home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d1xx
/
d144
/
analyticalc.lha
/
AnalytiCalc
/
AnalySources.Arc
/
AnalyNS.Ftn
< prev
next >
Wrap
Text File
|
1988-04-10
|
83KB
|
3,076 lines
c -h- nextel.fms Tue Sep 2 10:58:55 1986
SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
C THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
C BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
C NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
C
C RETCD = 1 IF OPERAND (VALUE IN RETVAL(100)
C 2 IF OPERATOR (VALUE IN RETTYP)
C 3 NO MORE ELEMENTS
C 4 IF ERROR
C
C RETVAL HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
C A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
C
C RETTYP IS THE TYPE CODE
C NEXTEL CALLS
C
C ERRMSG PRINTS OUT ERROR MESSAGES
C FLIP REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
C GETNNB GETS THE NEXT NON-BLANK FROM LINE(80)
C
C NEXTEL IS CALLED BY INPOST
C
C
C VARIABLE USE
C --------- ----------------------------------
C
C ALPHA(27) HOLDS LEGAL VARIABLE NAMES.
C
C ARROW '^'
C
C B10 SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
C DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
C
C B16 SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
C DIGIT A, B, C, D, E, OR F WAS FOUND.
C
C BASE HOLDS BASE OF CONSTANT.
C
C CHAR1 HOLDS A SINGLE CHARACTER FROM LINE.
C
C DEFBAS THE DEFAULT BASE SPECIFIED.
C
C DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
C 8, 10, AND 16.
C
C DOT '.'
C
C EQ '='
C
C EXCODE CODE FOR EXPONENTIATION.
C
C FCNT NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
C
C FUNCT (NAME,INDXX) HOLDS FUNCTION NAMES.
C
C FUNVAL(I,J)
C IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
C FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
C IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
C FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
C
C
C I,J,K,L HOLDS TEMPORARY VALUES
C
C I1,I2 HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
C
C IALPHA INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
C
C IHOLD HOLDS TEMPORARY VALUES
C
C INT PICKS UP INTEGER*4 VALUES.
C
C IPT POINTER TO ELEMENTS IN LINE(80).
C
C IPT2 POINTER TO ELEMENTS IN LINE(80).
C
C LASTOP USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
C CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
C
C MINUS '-'
C
C OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
C
C PLUS '+'
C
C QUOTE "'"
C
C RB HOLDS NEGATIVE POWERS OF 10.(BASE 10)
C
C REAL PICKS UP REAL*8 CONSTANTS.
C
C RETCD RETURN CODE:
C 1 IF OPERAND (VALUE IN RETVAL(100))
C 2 IF OPERATOR (VALUE IN RETTYP)
C 3 NO MORE ELEMENTS.
C 4 IF ERROR.
C
C RETCD2 RETURN CODE WHEN CALLING GETNNB.
C
C RETPT INDEXES DIGITS PICKED UP FOR A CONSTANT.
C
C RETTYP THE TYPE CODE OF THE RETURNED ELEMENT.
C
C TYPE TYPE CODE FOR EACH VARIABLE.
C
C VBLS HOLDS VALUE OF VARIABLES.
C
C VLEN GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
C
C LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION
C
C
REAL*8 REAL,RB,ACX,XAC
INTEGER*4 INT
EXTERNAL INDX,DFLOAT
REAL*8 DFLOAT
InTeGer*4 INDXX
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 LASTOP
InTeGer*4 VIEWSW,BASED,VLEN(9),DEFBAS
InTeGer*4 TYPE(1,1)
InTeGer*4 RETCD,RETCD2,RETTYP,EXCODE
InTeGer*4 B10,B16,RETPT,BASE
InTeGer*4 FCNT,AHOLD
InTeGer*4 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
C
CHARACTER*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
CHARACTER*1 RETVAL(20)
C REAL*8 RVLF
C EQUIVALENCE (FVLF,RETVAL(1))
CHARACTER*1 FUNCT(10,40)
InTeGer*4 FUNVAL(2,40)
CHARACTER*1 AVBLS(20,27)
EQUIVALENCE(XAC,AVBLS(1,27))
CHARACTER*1 VBLS(8,1,1)
CHARACTER*1 OPER(9),DIGITS(16,3)
CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
CHARACTER*1 FOUR(4),EIGHT(8)
C
COMMON /V/ TYPE,AVBLS,VBLS,VLEN
COMMON /DIGV/ DIGITS
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C ***<<< KLSTO COMMON START >>>***
InTeGer*4 DLFG
C COMMON/DLFG/DLFG
InTeGer*4 KDRW,KDCL
C COMMON/DOT/KDRW,KDCL
InTeGer*4 DTRENA
C COMMON/DTRCMN/DTRENA
REAL*8 EP,PV,FV
DIMENSION EP(20)
INTEGER*4 KIRR
C COMMON/ERNPER/EP,PV,FV,KIRR
c InTeGer*4 LASTOP
C COMMON/ERROR/LASTOP
CHARACTER*1 FMTDAT(9,76)
C COMMON/FMTBFR/FMTDAT
CHARACTER*1 EDNAM(16)
C COMMON/EDNAM/EDNAM
InTeGer*4 MFID(2),MFMOD(2)
C COMMON/FRM/MFID,MFMOD
InTeGer*4 JMVFG,JMVOLD
C COMMON/FUBAR/JMVFG,JMVOLD
COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
1 LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC COMMON /ERROR/ LASTOP
C
EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
C
DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
DATA MINUS/'-'/,PLUS/'+'/
DATA OPER/'(','-','!','*','/','+','-',')','='/
C
C NUMBER OF FUNCTIONS
DATA FCNT/30/
C
DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
1 'D','A','B','S',' ',' ',' ',' ',' ',' ',
2 'I','A','B','S',' ',' ',' ',' ',' ',' ',
3 'F','L','O','A','T',5*' ','I','F','I','X',6*' ',
5 'A','I','N','T',6*' ','I','N','T',7*' ',
7 'I','D','I','N','T',5*' ','E','X','P',7*' ',
9 'D','E','X','P',6*' ','A','L','O','G','1','0',4*' ',
2 'D','L','O','G','1','0',4*' ','A','L','O','G',6*' ',
4 'D','L','O','G',6*' ','S','Q','R','T',6*' ',
6 'D','S','Q','R','T',5*' ','S','I','N',7*' ',
8 'D','S','I','N',6*' ','C','O','S',7*' ',
1 'D','C','O','S',6*' ','T','A','N','H',6*' ',
2 'D','T','A','N','H',5*' ','A','T','A','N',6*' ',
3 'D','A','T','A','N',5*' ',
1 'A','S','I','N',6*' ','D','A','S','I','N',5*' ',
2 'A','C','O','S',6*' ','D','A','C','O','S',5*' ',
3 'T','A','N',' ',6*' ','D','T','A','N',106*' '/
DATA EXCODE/112/
DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
1 6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
2 4,44,5,44,4,45,5,45,4,46,5,46,3,47,4,47,20*0/
C
10 CONTINUE
CALL GETNNB(IPT,RETCD2)
IF (RETCD2.EQ.1) GOTO 50
C
C NO MORE ELEMENTS
LASTOP=0
RETCD=3
RETURN
C
C
C INITIALIZE VARIABLES
50 CONTINUE
B10=0
B16=0
RETTYP=0
RETPT=0
REAL=0.D0
RETCD=1
DEFBAS=BASED
C RVLF=0.0D0
C COMMENT OUT DO LOOP OVER 20 BYTES FOR SPEED.
C (INSTEAD JUST ZERO 8 BYTES WE WILL LIKELY USE)
DO 60 I=1,8
C DO 60 I=1,20
60 RETVAL(I)=0
C
70 CHAR1=LINE(IPT)
NONBLK=IPT
C
C
C SEE IF ALPHABETIC OR %
C SHORTCUT IF IT'S A CELL NAME .. GO JUST EVALUATE IT.
C ALSO WORKS FOR ENCODED FUNCT NAMES.
IF(ICHAR(CHAR1).GE.255)GOTO 12000
C SEPARATE OUT FUNCTION CALLS FOR FASTER EXECUTION...SKIP TRYING FUNCT. NAME
C FIRST AS VARIABLE NAME (WHICH CAN TAKE LONG TIME TO CONVERT BEFORE WE DISCOVER
C IT ISN'T NEEDED...)
C
IF(ICHAR(CHAR1).GE.230)GOTO 13201
C ADD COUPLE MORE SHORTCUTS... DON'T JUST LOOP TO SEE IF WE HAVE
C AN ALPHA CHARACTER...
IF(CHAR1.NE.ALPHA(27))GOTO 78
I=27
GOTO 10000
78 CONTINUE
IF(CHAR1.LT.'A'.OR.CHAR1.GT.'Z')GOTO 79
C TRY TO AVOID LOTS OF EXTRA FUNCTION CALLS...
C COMPARE CHARS AS CHARACTER VALUES... SHOULD STILL BE OK.
CCC IF(ICHAR(CHAR1).LT.ICHAR(ALPHA(1))
CCC 1 .OR.ICHAR(CHAR1).GT.ICHAR(ALPHA(26)))GOTO 79
C USE FACT THAT ASCII CHARACTER CODES ARE IN A CONTINUOUS RANGE
CCC I=ICHAR(CHAR1)-ICHAR(ALPHA(1))
I=ICHAR(CHAR1)-65
C 65 IS ASCII VALUE FOR 'A' CHARACTER.
C (HARDCODE FOR SPEED...)
GOTO 10000
79 CONTINUE
C DELETE 3 LINES FOLLOWING:
C DO 80 I=1,27
C IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
C80 CONTINUE
C
C
C NOT ALPHA SO SEE IF AN OPERATOR
DO 100 I=1,9
IF (CHAR1.EQ.OPER(I)) GOTO 20000
100 CONTINUE
C
C
C SEE IF AN OPERAND
C *** EVIDENTLY SHORT LOOP RUNS AS FAST AS A COUPLE DECISIONS AND SOME
C MATH; LEAVE IN.
140 DO 150 I=1,16
IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
150 CONTINUE
C
C
C
IF (CHAR1.EQ.DOT) GOTO 40000
C
C
C
IF (CHAR1.EQ.ARROW) GOTO 300
C
C
C
IF (CHAR1.EQ.QUOTE) GOTO 200
C
C
C ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
C
C
C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
190 CALL ERRMSG (20)
GOTO 99000
C
C
C
C
C **************************************
C ****** ASCII CONSTANT SPECIFIED ******
C **************************************
200 CONTINUE
NONBLK=NONBLK+1
RETVAL(1)=ICHAR(LINE(NONBLK))
RETTYP=1
GOTO 35100
C
C
C
C
C **************************************
C ****** IMMEDIATE BASE SPECIFIED ******
C **************************************
300 CALL GETNNB(IPT,RETCD2)
IF (RETCD2.EQ.1) GOTO 320
C
C
C *** ERROR *** ILLEGAL BASE SPECIFICATION
310 CALL ERRMSG(19)
GOTO 99000
C
C
C IMMEDIATE BASE SPECIFICATION
320 CHAR1=LINE(IPT)
NONBLK=IPT
IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
C
C
C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
CALL GETNNB (IPT,RETCD2)
IF (RETCD2.EQ.2) GOTO 310
CHAR1=LINE(IPT)
NONBLK=IPT
IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
C
C
C IMMEDIATE BASE IS 16
DEFBAS=16
GOTO 370
C
C
C IMMEDIATE BASE IS 8
360 DEFBAS=8
GOTO 370
C
C
C IMMEDIATE BASE IS 10
365 DEFBAS=10
C
C
C
370 CALL GETNNB(IPT,RETCD2)
IF (RETCD2.EQ.2) GOTO 310
CHAR1=LINE(IPT)
NONBLK=IPT
C
C
C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
GOTO 140
C
C
C
C
C ****************************************************
C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
C ****************************************************
10000 CONTINUE
IALPHA=I
IHOLD=NONBLK
C
C
C SCAN EACH OF THE FUNCTION NAMES.
DO 10060 I=1,FCNT
C
C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
K=FUNVAL(1,I)
IPT2=IHOLD
NONBLK=IHOLD
IF (K.EQ.0) GOTO 10060
C
C
C SCAN EACH LETTER OF THE FUNCTION'S NAME
DO 10050 J=1,K
IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
IF (J.EQ.K) GOTO 10100
CALL GETNNB (IPT2,RETCD2)
IF (RETCD2.EQ.2) GOTO 10060
NONBLK=IPT2
10050 CONTINUE
STOP 10050
C
10060 CONTINUE
10070 NONBLK=IHOLD
GOTO 12000
C
C
C FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
10100 CONTINUE
C
C
C
C
C **********************************
C ****** UNARY FUNCTION FOUND ******
C **********************************
RETTYP=ICHAR(CHAR(FUNVAL(2,I)))
LASTOP=RETTYP
RETCD=2
GOTO 99099
C
C
C
C
C
C ********************************
C ****** VARIABLE SPECIFIED ******
C ********************************
12000 CONTINUE
C
C
C IALPHA HOLDS INDEX INTO ALPHA OF NAME
C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
C CALL GETNNB (IPT,RETCD2)
C IF (RETCD2.EQ.2) GOTO 12060
CC
CC
CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
C DO 12050 I=1,27
C IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
C12050 CONTINUE
C *****&&&&& ...ENDING HERE
C ADD BELOW...
LLB=IPT
LRB=LEND
CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
C IF(IVALID.EQ.0)GOTO 12200
C IPT=LSTCHR
IF(IVALID.NE.0.AND.ID2.LE.1.AND.ID1.GT.60)GOTO 13201
IF(IVALID.NE.0)GOTO 12201
C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
C
C COME HERE DIRECT FOR FUNCTIONS ENCODED...
13201 CONTINUE
I=IPT+9
CALL FNAME(LINE(IPT),I,INDEXF)
IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 12202
C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
LLAST=LEND-IPT+1
I=INDX(LINE(IPT),ICHAR(']'))
IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
LRB=I
LLB=INDX(LINE(IPT),ICHAR('['))
IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
XAC=ACX
TYPE(1,1)=2
CALL TYPSET(1,27,TYPE(1,1))
C TYPE(27,1)=2
ID1=27
ID2=1
LSTCHR=LRB+IPT
C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
C RETURN ITS VALUE.
GOTO 12201
C IF NOT VALID FUNCTION REPORT AN ERROR.
12202 GOTO 12200
12201 IPT=LSTCHR
IF(LSTCHR.LT.LEND)IPT=IPT-1
NONBLK=IPT
C RESET NONBLK ALST SO WE RESET GETNNB TOO...
C WAS IPT=LSTCHR+1
C IPT POINTS AFTER VARIABLE NAME...
C ENSURE NON ALPHA AFTER VARIABLE NAME
CALL GETNNB(IPT,RETCD2)
IF(RETCD2.EQ.2) GOTO 12060
C
C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
C OF RETVAL.
IF (LINE(IPT).EQ.EQ) GOTO 12100
C
C
C ************************************************
C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
C ************************************************
12060 CALL TYPGET(ID1,ID2,RETTYP)
C12060 RETTYP=TYPE(ID1,ID2)
C *****&&&&&
C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
IF (RETTYP.EQ.5)RETTYP=4
IF (RETTYP.EQ.6)RETTYP=8
IF (RETTYP.EQ.7)RETTYP=3
12061 CONTINUE
IF(RETTYP.LE.0)GO TO 12080
K=VLEN(RETTYP)
DO 12070 I=1,K
IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12068
C TRY AND CALL XVBLGT HERE TO GET VALUE ALL AT ONCE
C TO AVOID MULTIPLE ARBITRATION...
IF(I.EQ.K)CALL XVBLGT(ID1,ID2,RETVAL)
C CALL VBLGET(I,ID1,ID2,RETVAL(I))
C RETVAL(I)=VBLS(I,ID1,ID2)
GOTO 12070
12068 RETVAL(I)=AVBLS(I,ID1)
12070 CONTINUE
C
12080 LASTOP=RETTYP
GOTO 99099
C
C
C
C *******************************************************
C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
C *******************************************************
12100 CONTINUE
C RETVAL(1)=IALPHA
C RETTYP=TYPE(IALPHA)
CALL TYPGET(ID1,ID2,TYPE(1,1))
CALL RVBOO(RETVAL,ID1,ID2)
C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
C AS 2 INTEGERS.
RETTYP=TYPE(1,1)
GOTO 12080
C
C
C
C *** ERROR *** UNIDENTIFIED FUNCTION
12200 CALL ERRMSG(18)
GOTO 99000
C
C
C
C
C
C **********************
C ****** OPERATOR ******
C **********************
C
C I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
20000 CONTINUE
RETCD=2
IF(I.NE.4)GO TO 20050
C
C
C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
CALL GETNNB (IPT,RETCD2)
IF(RETCD2.NE.1)GO TO 99000
IF (LINE(IPT).NE.STAR) GOTO 20050
C
C
C '**' SPECIFIED (EXPONENTIATION)
RETTYP=EXCODE
NONBLK=IPT
GO TO 12080
C
C
C
C SET DEFAULT RETTYP FOR OPERATORS
20050 RETTYP=109+I
C
C
C CHECK OUT POSSIBLE UNARY OPERATOR "-"
IF (RETTYP.NE.111) GOTO 20080
C
C
C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
C IS UNARY.
IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
; LASTOP.EQ.200) GOTO 20090
C
C
C BINARY SUBTRACTION OPERATOR
RETTYP=116
GOTO 12080
C
C
C
C SEE IF A '+' SIGN
20080 IF(RETTYP.NE.115)GO TO 20085
C
C
C DETERMINE IF IT IS A UNARY PLUS
IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
C
C
C SEE IF LAST OPERATOR WAS ')'
IF(LASTOP.EQ.117)GO TO 20085
C
C
C UNARY '+' FOUND.
RETCD=1
GO TO 10
C
C
C
C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
C IF RETTYP IS FOR =, SET TO PROPER CODE
20085 IF(RETTYP.EQ.110)GO TO 20090
IF(RETTYP.EQ.118)RETTYP=200
GO TO 12080
C
C
C UNARY -
20090 CONTINUE
GOTO 99097
C
C
C
C
C
C
C *************************
C ****** NON-DECIMAL ******
C *************************
C
30000 RETPT=RETPT+1
IF (RETPT.LE.19) GOTO 30020
C
C
C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 19 DIGITS
C (ACTUALLY, NO LONGER PRESENT...)
CALL ERRMSG(22)
GOTO 99000
C
C
C I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
C SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
30020 IF (I.NE.16) GOTO 30030
I=0
GOTO 30050
30030 IF (I.EQ.8.OR.I.EQ.9) B10=1
IF(I.GT.9) B16=1
30050 RETVAL(RETPT)=CHAR(I)
C
C
C GET NEXT CHARACTER
CALL GETNNB (IPT,RETCD2)
IF (RETCD2.NE.1) GOTO 30100
NONBLK=IPT
CHAR1=LINE(IPT)
DO 30070 I=1,16
IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
30070 CONTINUE
IF (CHAR1.EQ.DOT) GOTO 40000
NONBLK=NONBLK-1
30100 CONTINUE
C
IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
C
c add code here to check for non -calc mode and goto 40000 if so
c if defbas.ne.8 and if we're working on a floating number
C
C *****************************
C ****** BASE 8 CONSTANT ******
C *****************************
BASE=8
C
C
C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
IF (RETPT.GT.10) GOTO 30170
RETTYP=8
C
C
C CONVERT TO OCTAL, HEX OR INTEGER
30110 INT=0
30130 DO 30132 L=1,7
IF (ICHAR(RETVAL(L)).NE.0) GOTO 30140
30132 CONTINUE
30140 DO 30150 I=L,RETPT
INT=INT*BASE+ICHAR(RETVAL(I))
RETVAL(I)=0
30150 CONTINUE
RETVAL(20)=0
30155 DO 30160 I=1,4
30160 RETVAL(I)=FOUR(I)
GOTO 35100
C
C
C ************************************************
C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
C ************************************************
30170 RETTYP=6
30180 CALL FLIP (RETVAL,8,RETPT)
c was 20 above, not 8 but we shortened stack arrays so shorten this
GOTO 35100
C
C
C
C *********************
C ****** BASE 16 ******
C *********************
30200 BASE=16
C
C
C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
IF (RETPT.GT.7) GOTO 30270
C
C
C
C HEXADECIMAL
RETTYP=3
GOTO 30110
C
C
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 16 ******
C ****************************************
30270 RETTYP=7
GOTO 30180
C
C
C *********************
C ****** BASE 10 ******
C *********************
30300 BASE=10
C
C
C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
IF (RETPT.GT.9) GOTO 30370
C
C
C INTEGER
RETTYP=4
GOTO 30110
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 10 ******
C ****************************************
30370 RETTYP=5
GOTO 30180
C
C
C
C
C
C SET LASTOP AND EXIT
35100 LASTOP=RETTYP
GOTO 99099
C
C
C *****************************
C ****** REAL OR DECIMAL ******
C *****************************
40000 IF (B16.NE.1) GOTO 40020
C
C
C *** ERROR *** '.' MAY ONLY BE USED WITH BASE 10
CALL ERRMSG(21)
GOTO 99000
C
C
C
40020 IF (RETPT.EQ.0) GOTO 40200
C
C
C IGNORE LEADING ZEROES
DO 40022 L=1,19
IF (ICHAR(RETVAL(L)).NE.0) GOTO 40030
40022 CONTINUE
C
C IF ALL ZEROES THE LAST ONE COUNTS!
L=19
C
C
C CONVERT TO A REAL*8 NUMBER
40030 CONTINUE
REAL=0.D0
DO 40060 I=L,RETPT
REAL=REAL*10.D0+ICHAR(RETVAL(I))
RETVAL(I)=0
40060 CONTINUE
C
C
C PICK UP FRACTIONAL PART OF REAL (DECIMAL)
40200 CONTINUE
RB=1.0D0
RETTYP=2
40205 CALL GETNNB (IPT,RETCD2)
IF (RETCD2.EQ.1) GOTO 40300
C
C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
GOTO 40537
C
C
C
40300 NONBLK=IPT
CHAR1=LINE(IPT)
DO 40320 I=1,10
IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
40320 CONTINUE
GOTO 40350
40330 IF (I.EQ.10) I=0
RB=0.1D0*RB
REAL=REAL+DFLOAT(I)*RB
GOTO 40205
C
C
C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
40350 IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
NONBLK=NONBLK-1
GO TO 40537
C
C
C *********************************************
C ****** E AND D EXPONENT SPECIFICATIONS ******
C *********************************************
40360 CONTINUE
CALL GETNNB(IPT,RETCD2)
IF (RETCD2.EQ.1) GOTO 40370
C
C
C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
40365 CALL ERRMSG (24)
GOTO 99000
C
C
40370 CHAR1=LINE(IPT)
IF (CHAR1.EQ.MINUS) GOTO 40380
RB=10.D0
IF (CHAR1.NE.PLUS) GOTO 40400
GOTO 40390
40380 RB=0.1D0
C
C
C
40390 NONBLK=IPT
CALL GETNNB (IPT,RETCD2)
40400 IF (RETCD2.GE.2) GOTO 40365
NONBLK=IPT
CHAR1=LINE(IPT)
DO 40450 I=1,10
IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
40450 CONTINUE
GOTO 40365
40480 IF (I.EQ.10) I=0
C
C
C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
I1=I
CALL GETNNB (IPT,RETCD2)
IF (RETCD2.GE.2) GOTO 40550
CHAR1=LINE(IPT)
NONBLK=IPT
DO 40500 I=1,10
IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
40500 CONTINUE
NONBLK=NONBLK-1
GOTO 40550
C
C
C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
40520 IF (I.EQ.10) I=0
I2=I
C
C
40530 RETTYP=9
REAL=REAL*RB**(I1*10+I2)
C
C
C
C ***************************************************
C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
C ***************************************************
40537 DO 40540 I=1,8
40540 RETVAL(I)=EIGHT(I)
GOTO 35100
C
C
C
40550 I2=I1
I1=0
GOTO 40530
C
C
C
C ********************************
C ******* ERROR PROCESSING *******
C ********************************
99000 CONTINUE
IV=LEND-NONBLK+1
CALL VWRT(LINE(NONBLK),IV)
C WRITE (0,99010) (LINE(I),I=NONBLK,LEND)
C99010 FORMAT (1X,80(A1,\))
RETCD=4
99097 LASTOP=0
99099 RETURN
END
c -h- pget.for Tue Sep 2 10:58:55 1986
SUBROUTINE PGET(CMDLIN,ICODE,IRTN)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
CHARACTER*1 FORM,FVLD,CMDLIN(132)
INTEGER*4 VNLT
CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
COMMON/NMSH/NMSH
REAL*8 XVBLS(1,1)
INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC InTeGer*4 IOLVL
INTEGER*4 JVBLS(2,1,1)
CCC COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
DIMENSION FORM(128),FVLD(1,1)
CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
CHARACTER*1 LETA
CCC InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC InTeGer*4 LLCMD,LLDSP
CCC COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
DIMENSION NRDSP(20,75),NCDSP(20,75)
COMMON/D2R/NRDSP,NCDSP
InTeGer*4 TYPE(1,1),VLEN(9)
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
REAL*8 XAC,ZAC
EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
REAL*8 XXAC,XYAC
EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 IPS1,IPS2,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC CHARACTER*1 ARGSTR(52,4)
CCC COMMON/ARGSTR/ARGSTR
C EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
INTEGER*4 IIRO,IICO,INUMEM
C NEED SOME BIG VARIABLES FOR SAVING THE MAPPINGS
EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC COMMON/KLVL/KLVL
CHARACTER*1 DEFVB(12)
COMMON/DEFVBX/DEFVB
CCC InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
REAL*8 DVS(20,75)
INTEGER*4 LDVS(2,20,75)
EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
CHARACTER*76 CFORM
EQUIVALENCE(CFORM(1:1),FORM(1))
COMMON /FVLDC/FVLD
C CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
COMMON/DSPCMN/DVS,CWIDS
C ***<<< NULETC COMMON START >>>***
InTeGer*4 ICREF,IRREF
C COMMON/MIRROR/ICREF,IRREF
InTeGer*4 MODPUB,LIMODE
C COMMON/MODPUB/MODPUB,LIMODE
InTeGer*4 KLKC,KLKR
REAL*8 AACP,AACQ
C COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
InTeGer*4 NCEL,NXINI
C COMMON/NCEL/NCEL,NXINI
CHARACTER*1 NAMARY(20,301)
C COMMON/NMNMNM/NAMARY
InTeGer*4 NULAST,LFVD
C COMMON/NULXXX/NULAST,LFVD
COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
1 KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC InTeGer*4 ICREF,IRREF
CCC COMMON/MIRROR/ICREF,IRREF
C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
C
C PUT NUMBERS OUT TO FILE
C USES RELATIVE FORMS TO CURRENT POS.
C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
C ONLY WRITES PHYSICALLY PRESENT DATA.
C P/D RRR,CCC,FORMULA,VALID,FORMAT
C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
ICODE=1
CLOSE(4)
7954 CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
C ASK FOR FILE NAME
CALL VWRT('Enter Filename>',15)
III=IOLVL
C IF(III.EQ.5)III=0
READ(III,7953,END=510,ERR=510)FORM2
c7952 FORMAT(' Enter filename>\')
7953 FORMAT(128A1)
DO 6940 II=1,128
ILN=129-II
IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
FORM2(ILN)=0
6940 CONTINUE
6941 CONTINUE
C ILN IS LENGTH OFLINE NOW.
ILN=MIN0(ILN,127)
FORM2(ILN+1)=0
CALL WASSIG(4,FORM2)
C NOW ENCODE COL WIDTHS AND ICREF/IRREF
C SO SAVE/RESTORE OF EXTENDED SHEETS DOESN'T GET
C MESSED UP.
WRITE(CFORM(1:76),8850,ERR=8851)ICREF,IRREF,(CWIDS(III),
1 III=1,20),DRWV,DCLV
8850 FORMAT(24I3)
DO 8855 III=1,80
II=ICHAR(NMSH(III))
IF(II.LT.32)II=32
8855 NMSH(III)=CHAR(II)
8851 CONTINUE
WRITE(4,6951)NMSH,(FORM(II),II=1,76)
6951 FORMAT(80A1,76A1)
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT('Enter max. displ down to save or 0 for all>',43)
III=IOLVL
C IF(III.EQ.5)III=0
READ(III,7978,END=510,ERR=510)LDXM
6950 FORMAT(80A1)
7978 FORMAT(I7)
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT('Enter max. displcmt right to save or 0 for all>',47)
III=IOLVL
C IF(III.EQ.5)III=0
READ(III,7978,END=510,ERR=510)MDXM
IF(MDXM.LE.0)MDXM=12000
IF(LDXM.LE.0)LDXM=12000
C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID
C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN
C INTEGER THOUGH.
IF(CMDLIN(2).NE.'P'.and.CMDLIN(2).GT.' ')GOTO 7950
C TREAT "P" BY ITSELF AS A SAVE PP TYPE COMMAND (PUT PHYS)
DO 7951 ICO=PCOL,301
DO 7951 IRO=PROW,60
C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY.
C IRX=(ICO-1)*60+IRO
CALL REFLEC(ICO,IRO,IRX)
IDRO=IRO-PROW+1
IDCL=ICO-PCOL+1
IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951
C FORM DISPLACEMENT LOCATORS
CALL FVLDGT(IRO,ICO,FVLD(1,1))
IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7951
CALL WRKFIL(IRX,FORM,0)
CALL CE2A(FORM,FORM2)
IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
CALL TYPGET(IRO,ICO,TYPE(1,1))
IF(CMDLIN(3).NE.'N')GOTO 5402
IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5402
C ALWAYS WRITE TEXT OUT EVEN IF SAVING NUMERICALLY
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
C INTERNAL PROC TO PRINT NUMERIC VALUES AT 6400
LETR='P'
ASSIGN 5405 TO INUMEM
C GOTO 6400
6400 CONTINUE
C ASSUME LETR IS SET TO GOOD PREFIX LETTER ASCII VALUE
CALL XVBLGT(IRO,ICO,XVBLS(1,1))
IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL,
1 JVBLS(1,1,1)
5403 FORMAT(1A1,I5,',',I5,',',I15)
IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL,
1 XVBLS(1,1)
5404 FORMAT(1A1,I5,',',I5,',',D30.19)
GOTO INUMEM,(5405,6406)
5402 CONTINUE
C FIND END OF TEXT IN ARRAY
DO 4330 IV=2,110
IVVV=113-IV
IF(ICHAR(FORM2(IVVV)).GT.32)GOTO 4331
4330 CONTINUE
4331 CONTINUE
C SAVE ON PPX IN EFFICIENT FORM.
C DON'T WRITE OUT TRAILING NULLS.
C ENSURE FORMAT HAS NO NULLS IN IT.
DO 358 IV=120,128
358 IF(ICHAR(FORM2(IV)).LT.32)FORM2(IV)=Char(32)
IF(CMDLIN(3).EQ.'F')GOTO 6404
C PPF WILL SAVE FORMULAS ONLY
C PPA WILL SAVE FORMULAS AND VALUES (AS WILL PPc WHERE c IS
C ANY CHARACTER EXCEPT N.
LETR='p'
C FLAG NUMERIC SAVE VIA LOWERCASE P HERE
ASSIGN 6406 TO INUMEM
C GO WRITE FIRST LINE NUMERICALLY
GOTO 6400
6406 CONTINUE
C NOW HAVE NUMERIC LINE WRITTEN. WRITE THE SECOND LINE OF THE
C GROUP TO, SO AS NOT TO CONFUSE GRAPHICS PROGRAMS AND THE
C LIKE.
III=JCHAR(FORM2(119))
WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
6404 CONTINUE
C NOW WRITE OUT FORMULA RECORD.
WRITE(4,7955)IDRO,IDCL,(FORM2(IV),IV=1,IVVV)
5405 CONTINUE
C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII.
7955 FORMAT('P',I5,',',I5,',',128A1)
C NOTE LONG RECORDS.
III=JCHAR(FORM2(119))
WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7956 FORMAT(I3,',',9A1,',',I5)
7951 CONTINUE
2751 CONTINUE
C
C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO
C ONLY SAVE MAPPINGS IF 4TH COMMAND CHARACTER IS "M".
C ... THEY TAKE A LOT OF ROOM.
IF (CMDLIN(4).NE.'M') GOTO 6541
DO 6540 IRO=DROW,20
DO 6540 ICO=DCOL,75
IIRO=64000
IICO=IIRO
IIRO=IIRO+IRO
IICO=IICO+ICO
C NOTE WE MAKE THESE NUMBERS LARGE SO GRAPHING PROGRAMS WON'T TRY
C TO READ THEM.
6955 FORMAT('M',I5,',',I5,',',2I7)
WRITE(4,6955,ERR=6541)IIRO,IICO,NRDSP(IRO,ICO),
1 NCDSP(IRO,ICO)
C WRITE A SPECIAL RECORD, FLAGGED BY 'M', TO SAVE A MAPPING CELL
C NEED A 2ND RECORD TOO; JUST SEND LAST ONE AGAIN.
WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
6540 CONTINUE
6541 CONTINUE
CLOSE(4)
GOTO 9990
7950 IF(CMDLIN(2).NE.'D')GOTO 9990
DO 7957 ICO=DCOL,75
DO 7957 IRO=DROW,20
IDRO=IRO-DROW+1
IDCL=ICO-DCOL+1
IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957
NR=NRDSP(IRO,ICO)
NC=NCDSP(IRO,ICO)
C IRX=(NC-1)*60+NR
CALL REFLEC(NC,NR,IRX)
CALL FVLDGT(NR,NC,FVLD(1,1))
IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7957
CALL WRKFIL(IRX,FORM,0)
CALL CE2A(FORM,FORM2)
IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
IF(CMDLIN(3).NE.'N')GOTO 5412
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5412
C WRITE LABELS EVEN IF NUMERIC SAVE
CALL TYPGET(NR,NC,TYPE(1,1))
CALL XVBLGT(NR,NC,XVBLS(1,1))
IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1)
5413 FORMAT('P',I5,',',I5,',',I15)
IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1)
5414 FORMAT('P',I5,',',I5,',',D30.19)
GOTO 5415
5412 CONTINUE
WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110)
5415 CONTINUE
7958 FORMAT('D',I5,',',I5,',',128A1)
DO 359 IV=120,128
359 IF(FORM2(IV).LT.' ')FORM2(IV)=Char(32)
III=JCHAR(FORM2(119))
WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7957 CONTINUE
C ALLOW SAVE AS NEEDED OF MAPPING
GOTO 2751
C CLOSE(4)
9990 RETURN
510 CONTINUE
IRTN=1
CLOSE(IOLVL)
CLOSE(11)
OPEN(11,FILE='CON:0/0/100/100/Analy Command')
RETURN
END
c -h- pgget.for Tue Sep 2 10:58:55 1986
SUBROUTINE PGGET(CMDLIN,ICODE,IRTN)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
CHARACTER*1 FORM,FVLD,CMDLIN(132)
INTEGER*4 VNLT
CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
COMMON/NMSH/NMSH
REAL*8 XVBLS(1,1)
INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC InTeGer*4 IOLVL
INTEGER*4 JVBLS(2,1,1)
REAL*8 R8WK
CCC COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
DIMENSION FORM(128),FVLD(1,1)
INTEGER*4 IRRW,ICCL
C USE BIG NUMBERS SO WE CAN SUBTRACT 64000 AND STILL NOT GET WRAPAROUND.
C (FOR SAVE/RESTORE OF MAP)
CHARACTER*76 CFORM
CHARACTER*35 CFORM2
EQUIVALENCE(CFORM2(1:1),FORM2(1))
EQUIVALENCE(CFORM(1:1),FORM(1))
InTeGer*4 NDUM(24)
C ***<<< NULETC COMMON START >>>***
InTeGer*4 ICREF,IRREF
C COMMON/MIRROR/ICREF,IRREF
InTeGer*4 MODPUB,LIMODE
C COMMON/MODPUB/MODPUB,LIMODE
InTeGer*4 KLKC,KLKR
REAL*8 AACP,AACQ
C COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
InTeGer*4 NCEL,NXINI
C COMMON/NCEL/NCEL,NXINI
CHARACTER*1 NAMARY(20,301)
C COMMON/NMNMNM/NAMARY
InTeGer*4 NULAST,LFVD
C COMMON/NULXXX/NULAST,LFVD
COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
1 KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC COMMON/MIRROR/ICREF,IRREF
CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
CCC InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC InTeGer*4 LLCMD,LLDSP
CCC COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
DIMENSION NRDSP(20,75),NCDSP(20,75)
EXTERNAL INDX
COMMON/D2R/NRDSP,NCDSP
InTeGer*4 TYPE(1,1),VLEN(9)
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
REAL*8 XAC,ZAC
EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
REAL*8 XXAC,XYAC
EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 IPS1,IPS2,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC CHARACTER*1 ARGSTR(52,4)
CCC COMMON/ARGSTR/ARGSTR
C EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC COMMON/KLVL/KLVL
CHARACTER*1 DEFVB(12)
COMMON/DEFVBX/DEFVB
CCC InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
REAL*8 DVS(20,75)
INTEGER*4 LDVS(2,20,75)
EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
COMMON /FVLDC/FVLD
CCC InTeGer*4 NCEL,NXINI
CCC COMMON/NCEL/NCEL,NXINI
C CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
COMMON/DSPCMN/DVS,CWIDS
C
c7952 FORMAT(' Enter filename>\')
7953 FORMAT(128A1)
6950 FORMAT(80A1)
7978 FORMAT(I7)
7956 FORMAT(I3,1X,9A1,1X,I5)
CLOSE(4)
7960 CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
C GET FILE NAME
call Vwrt('Enter Filename>',15)
III=IOLVL
C IF(III.EQ.5)III=0
READ(III,7953,END=510,ERR=510)FORM2
DO 6940 II=1,128
ILN=129-II
IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
FORM2(ILN)=Char(0)
6940 CONTINUE
6941 CONTINUE
C ILN IS LENGTH OFLINE NOW.
ILN=MIN0(127,ILN)
FORM2(ILN+1)=Char(0)
C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS...
NXINI=1
LDXM=INDX(FORM2,ICHAR('/'))
C IF FILE IS FILENAME/M WE WON'T DO IT FAST...
IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400
FORM2(LDXM)=Char(0)
C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN
NXINI=0
8400 CONTINUE
CALL RASSIG(4,FORM2)
READ(4,6951,END=7964,ERR=7964)NMSH,FORM
6951 FORMAT(80A1,76A1,56A1)
6952 FORMAT(24I3)
C TRY TO DECODE ICREF,IRREF, CWIDS, AND DRWV,DCLV
READ(CFORM(1:76),6952,ERR=6953)NDUM
C IF HERE, THE READ WAS OK (APPARENTLY)
C FILL IN DEFAULTS IF NOTHING BUT ZEROES REALLY WAS SEEN
C (OR JUST ALL SPACES)
ICREF=NDUM(1)
IF(ICREF.LE.0.OR.ICREF.GT.60)ICREF=10
IRREF=NDUM(2)
IF(IRREF.LE.0.OR.IRREF.GT.300)IRREF=50
C SET UP CWIDS BUT DEFAULT TO 10 IF NO REAL INFO THERE
DO 6954 III=1,20
IIVV=NDUM(III+2)
IF(IIVV.LT.1.OR.IIVV.GT.100)IIVV=10
CWIDS(III)=IIVV
6954 CONTINUE
C RESTORE NUMBER ROWS AND COLS BEING DISPLAYED
C NOTE WE DO NOT RESTORE THE COMPLETE DISPLAY
C MAPPING; JUST THE WIDTHS AND NUMBERS OF DISPLAY
C COLUMNS, AND WE RESTORE THE EXTENDED MAP SO THAT
C SAVED SHEETS WILL NORMALLY GET BACK THE SAME EXTENDED
C ADDRESSING THAT HAD BEEN SET UP.
DRWV=NDUM(23)
IF(DRWV.LT.1.OR.DRWV.GT.20)DRWV=7
DCLV=NDUM(24)
IF(DCLV.LT.1.OR.DCLV.GT.75)DCLV=20
6953 CONTINUE
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT('Enter max. displc. down to restore or 0 for all>',48)
III=IOLVL
C IF(III.EQ.5)III=0
READ(III,7978,END=510,ERR=510)MDXM
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT('Enter max. displc. right to restore or 0 for all>',
1 49)
READ(III,7978,END=510,ERR=510)LDXM
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT('Enter min. displ. down (1 or more)>',35)
READ(III,7978,END=510,ERR=510)MMDXM
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT('Enter min displ. right (1 or more)>',35)
READ(III,7978,END=510,ERR=510)LLDXM
IF(MDXM.LE.0)MDXM=12000
LLDXM=MAX0(1,LLDXM)
MMDXM=MAX0(1,MMDXM)
IF(LDXM.LE.0)LDXM=12000
IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1
C ENTER RECALC MANUAL MODE IF ADDING NUMBERS OR SUBT.
C FROM SAVED SHEET
C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER.
7961 CONTINUE
READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV),
1 IV=1,110)
7962 FORMAT(A1,I5,1X,I5,1X,128A1)
DO 4497 IV=1,110
IVV=111-IV
IF(FORM2(IVV).GT.' ')GOTO 4496
FORM2(IVV)=Char(0)
4497 CONTINUE
4496 CONTINUE
C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE
C ZEROED ON READIN.
READ(4,7956,END=7964,ERR=7964)III,(FORM2(IV),IV=120,128),
1 KKTYP
FORM2(119)=Char(III)
IF(LET1.EQ.'M')GOTO 6500
C M CODE MEANS WE'RE READING THE DISPLAY-TO-PHYSICAL MAP.
C GO HANDLE IT SPECIALLY, THEN RETURN. FLAGS RECORDS BY
C ADDING 64000 TO ROW AND COL NUMBERS TO AVOID GETTING
C GRAPHICS PROGRAMS MESSED UP.
C NOTE THAT SAVING THE MAP WAS OPTIONAL AND IS NOT THE
C DO-NOTHING DEFAULT.
IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
IF(JCHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990
IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961
IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961
C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES
C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR).
C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY.
NR=IRRW+PROW-LLDXM
NC=ICCL+PCOL-MMDXM
IF(CMDLIN(2).NE.'D'.AND.LET1.NE.68)GOTO 7963
IF(CMDLIN(2).EQ.'P')GOTO 7963
C GET DISPLAY VERSION...
LRR=IRRW+DROW-LLDXM
LCC=ICCL+DCOL-MMDXM
LRR=MAX0(1,LRR)
LCC=MAX0(1,LCC)
IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961
NR=NRDSP(LRR,LCC)
NC=NCDSP(LRR,LCC)
7963 CONTINUE
C LET1='p'WILL COME HERE TOO. HANDLE IT SINCE IT'S NUMERIC STUFF.
C IRX=(NC-1)*60+NR
CALL REFLEC(NC,NR,IRX)
IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961
FORM2(118)=CHAR(15)
DO 7113 IVV=1,128
7113 FORM(IVV)=FORM2(IVV)
INRW=PROW
INCL=PCOL
JOUTR=1
JOUTC=2
C A1 = OUT LOCATION FOR INPUT CELL NAMES
JRTR=1
JRTC=1
IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC,
1 INRW,INCL,JRTR,JRTC)
C ALLOW RELOCATION ON LOADING SAVED SHEET IF DESIRED.
CALL FVLDST(NR,NC,FORM2(119))
C FVLD(NR,NC)=FORM2(119)
CALL TYPSET(NR,NC,KKTYP)
C TYPE(NR,NC)=KKTYP
CALL CA2E(FORM2,FORM)
IF(LET1.NE.'p')CALL WRKFIL(IRX,FORM,1)
C WRITE(7'IRX)FORM2
IF(LET1.NE.'p')GOTO 7961
C HAVE LOWERCASE 'p' NOW AS NUMERIC SAVE FLAG FOR THIS RECORD.
READ(CFORM2(1:35),6408,ERR=7961)XVBLS(1,1)
6408 FORMAT(BN,D30.19)
CALL XVBLGT(NR,NC,R8WK)
IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK
IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1)
C IMPLEMENT ADDING AND SUBTRACTING SAVED SHEETS FROM CURRENT.
C GOES TO RECALC MANUAL MODE SINCE RECALC WOULD MESS UP
C VALUES; FORMULAS GET UPDATED FROM LAST-READ SHEET NORMALLY.
CALL XVBLST(NR,NC,XVBLS(1,1))
GOTO 7961
6500 CONTINUE
C HERE READ MAPPINGS
IRRW=IRRW-64000
ICCL=ICCL-64000
C RESTORE OFFSETS TO NORMAL RANGE
READ(CFORM2(1:35),6501,ERR=7961)II,III
6501 FORMAT(2I7)
NRDSP(IRRW,ICCL)=II
NCDSP(IRRW,ICCL)=III
C GO BACK FOR MORE. INEFFICIENT STORAGE OF MAP BUT IT'S COMPACT
C CODE...
GOTO 7961
7964 CONTINUE
CLOSE(4)
9990 NXINI=0
RETURN
510 CONTINUE
IRTN=1
NXINI=0
CLOSE(IOLVL)
CLOSE(11)
OPEN(5,FILE='CON:0/0/100/100/Analy Command')
RETURN
END
c -h- pmtx2.for Tue Sep 2 10:58:55 1986
SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
1 IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
CHARACTER*1 LINE(80)
CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
1 ID2B,RETCD)
C GET LOC OF MATRIX A (MUST BE SQUARE)
IBGN=LSTCHR+1
IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
IF(LINE(LSTCHR).NE.',')GOTO 300
CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
1 IDYB,RETCD)
C GET LOC OF MATRIX X (RESULT).
IBGN=LSTCHR+1
IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
IF(LINE(LSTCHR).NE.',')GOTO 300
CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
1 IDCB,RETCD)
IBGN=LSTCHR+1
C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
C FOR ERROR...
1000 RETURN
300 CONTINUE
RETCD=3
RETURN
END
c -h- postvl.for Tue Sep 2 10:58:55 1986
SUBROUTINE POSTVL (RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C * *
C * SUBROUTINE POSTVL (RETCD) *
C * *
C **************************************************
C
C
C CONVERTS POSTFIX EXPRESSIONS IN STACK 1 TO A VALUE
C
C
C RETCD MEANING
C
C 1 O.K.
C 2 ERROR
C
C POSTVL CALLS
C
C CALBIN CALCULATES BINARY OPERATIONS
C CALUN CALCULATES UNARY OPERATIONS
C ERRMSG PRINTS OUT ERROR MESSAGES
C VAROUT OUTPUTS THE VALUE OF A VARIABLE
C
C
C
C
C POSTVL IS CALLED BY CALC
C
C
C
C
C VARIABLE USE
C _________ ___________________________
C
C I,K TEMPORARY VALUES
C
C PT1 POINTS TO TOP ELEMENT IN STACK1
C
C RETCD RETURN CODE: 1=O.K., 2=ERROR
C
C RETCD2 USED TO HOLD RETURN CODE WHEN CALLS TO
C OTHER ROUTINES ARE MADE.
C
C ST1PT STACK 1 POINTER.
C
C ST2PT STACK 2 POINTER.
C
C ST1TYP VECTOR OF TYPES FOR EACH ELEMENT IN STACK 1
C
C ST2TYP VECTOR OF TYPES FOR EACH ELEMENT IN STACK 2
C
C STACK1 HOLDS ORIGINAL POSTFIX EXPRESSION.
C
C STACK2 USED TO EVALUATE EXPRESSION IN STACK1.
C
C TYPE(27) HOLDS THE DATA TYPE FOR EACH OF THE VARIABLES.
C
C AVBLS(100,27) HOLDS VALUES OF VARIABLES.
C VBLS(8,60,301) HOLDS VALUE OF COMPLEXLY-NAMED VARIABLES. 1ST 27 ELEMENTS
C ARE PLACE HOLDERS FOR AVBLS; ROUTINES THAT GENERATE DIMENSIONS ID1,ID2
C FOR VBLS RETURN DIMENSIONS 1-27,1 FOR A-Z,%. THESE RESULT IN AVBLS
C ARRAY BEING USED. VBLS ARRAY (MAX LENGTH 8 BYTES/VARIABLE) IS USED
C FOR OTHER VARIABLES WHOSE NAMES ARE <ALPHA><ALPHA><NUM><NUM>
C (WITH OPTION FOR ANY REASONABLE # OF ALPHAS AND NUMERICS BUT CLAMPED
C AT 60,301 VALUES TO WORK CORRECTLY.)
C
C VIEWSW VIEW SWITCH:
C 0 = OFF
C 1 = DISPLAY COMMANDS
C 2 = DISPLAY VALUE OF EXPRESSIONS
C 3 = DISPLAY ALL
C
C
C
C SUBROUTINE POSTVL (RETCD)
C
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 PT1
InTeGer*4 VIEWSW,BASED
InTeGer*4 RETCD,RETCD2,VLEN(9)
InTeGer*4 TYPE(1,1)
InTeGer*4 ST1TYP(40),ST2TYP(40)
InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
InTeGer*4 I,K
C
CHARACTER*1 LINE(80)
CHARACTER*1 STACK1(8,40), STACK2(8,40),AVBLS(20,27)
CHARACTER*1 VBLS(8,1,1)
C
COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
; ST1LIM,ST2LIM
COMMON /V/ TYPE,AVBLS,VBLS,VLEN
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
C
RETCD=1
C
C
C IF THERE IS ONE ELEMENT IN STACK1 AND IT IS NOT
C A NUMBER, THE EXPRESSION IS ILLEGAL (GO TO 95).
IF(ST1PT.EQ.2.AND.ST1TYP(1).GT.30)GO TO 95
C
C
10 IF (ST1PT.GT.2) GOTO 40
IF (ST1PT.EQ.1) GOTO 95
C
C
C ***************************************
C ****** ONLY 1 ELEMENT ON STACK 1 ******
C ***************************************
K=VLEN(ST1TYP(ST1PT-1))
C
C
C COPY INTO VARIABLE %
DO 20 I=1,K
20 AVBLS(I,27)=STACK1(I,1)
CALL TYPSET(27,1,ST1TYP(1))
C TYPE(27,1)=ST1TYP(1)
C
C
C OUTPUT VALUE OF %
IF (VIEWSW.GT.1) CALL VAROUT(27,1)
RETURN
C
C
C MORE THAN ONE ELEMENT ON STACK1
40 CONTINUE
IF (ST1TYP(ST1PT-1).LE.30) GOTO 90
IF (ST2PT.LE.ST2LIM) GOTO 45
C
C
C *** ERROR *** STACK 2 OVERFLOW
CALL ERRMSG(9)
43 RETCD=2
RETURN
C
C
C
C
C ****************************************
C ****** OPERATOR SO PUT ON STACK 2 ******
C ****************************************
45 ST2TYP(ST2PT)=ST1TYP(ST1PT-1)
ST2PT=ST2PT+1
ST1PT=ST1PT-1
IF(ST1PT.EQ.1)GO TO 95
GOTO 40
C
C
C
C
C
C *********************
C ****** OPERAND ******
C *********************
C
C FIRST BE SURE THAT THERE IS AN OPERATOR INVOLVED ON STACK 2
C (IF ONLY ONE ELEMENT IN STACK 1 YOU SHOULD NOT BE HERE).
90 IF(ST2PT.NE.1)GO TO 110
C
C
C *** ERROR *** ILLLEGAL EXPRESSION
95 CALL ERRMSG(8)
GO TO 43
C
C
C
C
C ENTER HERE AFTER APPLYING AN OPERATOR TO A NUMBER
100 IF (ST2PT.EQ.1) GOTO 10
110 K=ST2TYP(ST2PT-1)
C
C IF A UNARY OPERATOR, GO TO 190
IF ((K.GT.30.AND.K.LE.47).OR.K.EQ.111) GOTO 190
C
C
C IF A BINARY OPERATOR, GO TO 170
IF (K.GE.110.AND.K.LE.117) GOTO 170
IF(K.EQ.200)GO TO 170
C
C IF ELEMENT ON STACK2 AT ST2PT-1 IS AN OPERAND, APPLY CALBIN AGAIN
IF(K.LE.30) GO TO 180
STOP 110
C
C
C
C
C ***************************************************************
C ****** CALBIN CALCULATES THE BINARY VALUE OF AN OPERATOR ******
C ***************************************************************
C UPON ENTRANCE:
C OPERAND 1 IS IN STACK 1
C OPERAND 2 IS IN STACK 2
C OPERATOR IS BELOW OPERAND 2
C UPON EXIT RESULT IS ON STACK 1
C
C RETURN CODE MEANING
C
C 1 O.K.
C 2 OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C 3 ERROR ENCOUNTERED
C
C
170 CONTINUE
C
C
C FIRST PUT OPERAND 2 ONTO STACK 2
PT1=ST1PT-1
ST2TYP(ST2PT)=ST1TYP(PT1)
K=VLEN(ST2TYP(ST2PT))
DO 175 I=1,K
175 STACK2(I,ST2PT)=STACK1(I,PT1)
ST1PT=ST1PT-1
IF(ST1PT.EQ.1)GO TO 95
ST2PT=ST2PT+1
C
C
C IF OPERAND 1 IS AN OPERATOR, PUT IT ON STACK 2 (GO TO 45)
IF(ST1TYP(ST1PT-1).GT.30) GO TO 45
180 CALL CALBIN (RETCD2)
GOTO (100,1000,43), RETCD2
STOP 180
C
C
C
C
C
C ********************************************************************
C ****** CALL CALUN TO CALCULATE THE VALUE OF A UNARY OPERATION ******
C ********************************************************************
C OPERATOR IS IN STACK 2
C OPERAND IS IN STACK 1
C UPON EXIT, OPERATOR IS POPPED OFF STACK 2
C
C RETURN CODE MEANING
C
C 1 O.K.
C 2 OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C 3 ERROR ENCOUNTERED
C
C
190 CALL CALUN (RETCD2)
GOTO(100,43),RETCD2
STOP 190
C
C
1000 RETURN
END
c -h- prtcon.for Tue Sep 2 10:58:55 1986
C **********************************
C * *
C * INTERNAL FUNCTION PRTCON *
C * *
C **********************************
C CALLED BY MOUT ONLY
C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
FUNCTION PRTCON(L1,IBASE)
InTeGer*4 BASE(3)
InTeGer*4 IBASE,K
CHARACTER*1 L1,PRTCON,DIGITS(16,3)
COMMON /DIGV/ DIGITS
DATA BASE /10,8,16/
PRTCON=L1
IF(L1.EQ.0)PRTCON=CHAR(BASE(IBASE))
K=ICHAR(PRTCON)
PRTCON=DIGITS(K,IBASE)
RETURN
END
c -h- rassig.for Tue Sep 2 10:58:55 1986
SUBROUTINE RASSIG(IUNIT,NAME)
C
C
CHARACTER*1 NAME(50)
InTeGer*4 IUNIT
C &&&& MS FTN 3.2
LOGICAL LEXIST
C &&&&
CHARACTER*20 WK
CHARACTER*1 WK1(20)
EQUIVALENCE(WK(1:1),WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
DO 1 N=1,20
WK1(N)=' '
1 CONTINUE
DO 2 N=1,20
II=ICHAR(NAME(N))
IF(II.LT.32)GOTO 3
WK1(N)=CHAR(II)
C1 CONTINUE
2 CONTINUE
3 CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
INQUIRE(FILE=WK(1:20),EXIST=LEXIST)
IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
c CALL UVT100(1,1,1)
c CALL SWRT('File not found. Attempting to create.',37)
c OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
c 1 FORM='FORMATTED')
c CLOSE(IUNIT)
c
c On failure to open a file, create a window instead which
c can be its surrogate...
c
Open(Iunit,file='CON:200/100/400/60/RdErr ' // wk,
1 Access='Sequential',form='Formatted')
C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
C WILL GET EOF ON START, BUT THAT'S TOO BAD...
Goto 77
100 CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
1 FORM='FORMATTED')
77 CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
RETURN
END
c -h- recalc.f40 Tue Sep 2 10:58:55 1986
SUBROUTINE RECALC
C COPYRIGHT (C) 1983,1984,1985,1986 GLENN EVERHART
C ALL RIGHTS RESERVED
C RECALCULATE COMMAND
C RECOMPUTE ALL ELEMENTS OF SPREADSHEET WHERE VALID.
C PARAMETER 18060=60*301
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
CHARACTER*1 FORM,FVLD,CMDLIN(132)
INTEGER*4 VNLT
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 IPS1,IPS2,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCCC InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC 1 IRCE1,IRCE2
CCCC COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC 1 IRCE1,IRCE2
C ***<<< KLSTO COMMON START >>>***
InTeGer*4 DLFG
C COMMON/DLFG/DLFG
InTeGer*4 KDRW,KDCL
C COMMON/DOT/KDRW,KDCL
InTeGer*4 DTRENA
C COMMON/DTRCMN/DTRENA
REAL*8 EP,PV,FV
DIMENSION EP(20)
INTEGER*4 KIRR
C COMMON/ERNPER/EP,PV,FV,KIRR
InTeGer*4 LASTOP
C COMMON/ERROR/LASTOP
CHARACTER*1 FMTDAT(9,76)
C COMMON/FMTBFR/FMTDAT
CHARACTER*1 EDNAM(16)
C COMMON/EDNAM/EDNAM
InTeGer*4 MFID(2),MFMOD(2)
C COMMON/FRM/MFID,MFMOD
InTeGer*4 JMVFG,JMVOLD
C COMMON/FUBAR/JMVFG,JMVOLD
COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
1 LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC InTeGer*4 DLFG
CCC COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS HAVE BEEN SEEN, ELSE 0
DIMENSION FORM(128),FVLD(1,1)
COMMON/FVLDC/FVLD
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=-2 OR -3 = DISPLAY FORMULA
C FVLD=3 NUMERIC, COMPUTE ONCE THEN SET FVLD TO 2
C FVLD=2 NUMERIC CONSTANT, ALREADY COMPUTED... DO NOT RECOMPUTE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
DIMENSION NRDSP(20,75),NCDSP(20,75)
COMMON/D2R/NRDSP,NCDSP
InTeGer*4 TYPE(1,1),VLEN(9)
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
CCC InTeGer*4 RRWACT,RCLACT
CCC COMMON/RCLACT/RRWACT,RCLACT
CCC InTeGer*4 KDRW,KDCL
CCC COMMON /DOT/KDRW,KDCL
COMMON/V/TYPE,AVBLS,VBLS,VLEN
InTeGer*4 PRS,PCS,DRS,DCS
PRS=PROW
PCS=PCOL
DRS=DROW
DCS=DCOL
IF(RCMODE.EQ.2)GOTO 5500
C THE FOLLOWING 2 LOOPS DEFINE ORDER OF CALCULATION.
C HERE THIS IS: OUTER LOOP ON ROWS (ACROSS), INNER LOOP ON COLUMNS (DOWN).
C NOTE THAT N2 DEFINES THE SHEET. SINCE 1 IS THE ACCUMULATORS, JUST GO THRU
C FOR THE SHEET, NOT THE AC'S.
DO 1 N2=2,RCLACT
N1=1
220 CONTINUE
C DO 2 N1=1,60
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
C
CCCC COMMENT 2 LINES OUT WHEN FAST FVLDGT IS IN TO SPEED UP MORE...
CCCC EXTRA LOGIC IN FVPEEK DOESN'T USUALLY PAY FOR ITSELF...
CCC CALL FVPEEK(N1,N2,NN1)
CCC N1=NN1
CALL FVLDGT(N1,N2,FVLD(1,1))
IIFV=JCHAR(FVLD(1,1))
IF (IIFV.LE.0) GOTO 2
IRRX=(N2-1)*60+N1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 2
KDRW=N1
KDCL=N2
PROW=N1
PCOL=N2
C SEE IF THIS PHYS COL HAS A DISPLAY COL. AND IF SO SET THAT UP.
C ONLY SET TO DISPLAYED LOCS HERE TO MINIMIZE SEARCH TIME.
C NEED THIS TO HANDLE D## FORMS...
IF (DLFG.EQ.0)GOTO 95
C IF NEVER HAD A D## FORM FORGET LOOKING FOR DISPLAY LOCS.
DO 20 M2=1,DCLV
DO 10 M1=1,DRWV
M1X=M1
M2X=M2
C LOOK FOR DISPLAY COORDS EVEN IF IN HYPERSPACE
C WE FIND ONE IF INDEX FROM REFLECT IS SAME AS WHAT
C WE'RE LOOKING FOR...
IF(NRDSP(M1,M2).EQ.N1.AND.NCDSP(M1,M2).EQ.N2)GOTO 9
10 CONTINUE
20 CONTINUE
95 CONTINUE
C HERE IF CELL NOT DISPLAYED... SEE IF NEEDS DOING IN RI, RE MODES
IF(RCMODE.LE.0)GOTO 9
IF(PROW.NE.IRCE1.OR.PCOL.NE.IRCE2)GOTO 2
C SKIP UNLESS ENTER CELL.
9 CONTINUE
C IF NO DISPLAY ROW, LEAVE AT LOW RIGHT...
C USE SAVED VALUES SO WE DON'T RELY ON DO LOOP INDEX AFTER LOOP END.
DROW=M1X
DCOL=M2X
CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
DO 56 N=1,109
LLST=111-N
IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 57
FORM(LLST)=Char(0)
56 CONTINUE
57 CONTINUE
FORM(LLST)=Char(0)
FORM(111)=Char(0)
C IF(ICHAR(FORM(118)).NE.15)GOTO 2
CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
C CALL FVLDGT(N1,N2,FVLD(1,1))
IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
2 CONTINUE
N1=N1+1
IF(N1.LE.RRWACT)GOTO 220
1 CONTINUE
GOTO 5600
5500 CONTINUE
C RCMODE=2 AND NOT RM MODE
C (IN RM MODE, RECALC IS NOT CALLED...)
DO 1701 M2=1,DCLV
DO 1702 M1=1,DRWV
C TO HANDLE DISPLAY WHEREVER IT MAY BE, FIND ID OF PHYS CELL AND
C CONVERT TO PHYS ROW, COL AGAIN REGARDLESS OF ALIAS...
C (NOTE CALC ORDER IS THEREFORE DISPLAY ORDER, NOT SHEET ORDER...)
K=NRDSP(M1,M2)
KK=NCDSP(M1,M2)
CALL REFLECT(KK,K,IV1)
NRC=IV1-1
N1=MOD(NRC,60)+1
N2=((NRC-N1+1)/60)+1
C COMPUTE PHYS ROW, COL FROM DISPLAY COORDINATES.
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
CALL FVLDGT(N1,N2,FVLD(1,1))
IIFV=JCHAR(FVLD(1,1))
IF (IIFV.LE.0) GOTO 1702
C FORGET THIS CELL IF NOT A COMPUTABLE ONE...
IRRX=IV1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 1702
KDRW=N1
KDCL=N2
PROW=N1
PCOL=N2
DROW=M1
DCOL=M2
CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
C (ALSO GUARANTEE WE HAVE LOTS OF NULLS AT END TO TERMINATE INDEX ROUTINES)
DO 756 N=1,109
LLST=111-N
IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 757
FORM(LLST)=Char(0)
756 CONTINUE
757 CONTINUE
FORM(LLST)=Char(0)
FORM(111)=Char(0)
C CALL DOENTR TO DO THE ACTUAL COMPUTATION WORK...
CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
1702 CONTINUE
1701 CONTINUE
C END OF COMPUTATION OVER DISPLAYS
C GOTO 5600
5600 CONTINUE
PROW=PRS
PCOL=PCS
DROW=DRS
DCOL=DCOL
C FORCE FUNCTION WORKS ONCE ONLY.
RCONE=0
RCMODE=IABS(RCMODE)
C SET FOR TEMP. RECALC-ALL MODES TO RETURN TO NORMAL.
IRCE1=0
IRCE2=0
RETURN
END
c -h- reflect.f40 Tue Sep 2 10:58:55 1986
SUBROUTINE REFLEC(ID1,ID2,ID)
C FORM ID OUT OF ID1,ID2 BUT USING REFLECTED VALUES SO THAT
C RESULT ID IS ALWAYS IN PRIME AREA.
InTeGer*4 ID,ID1,ID2,IDD1,IDD2
C ***<<< NULETC COMMON START >>>***
InTeGer*4 ICREF,IRREF
C COMMON/MIRROR/ICREF,IRREF
InTeGer*4 MODPUB,LIMODE
C COMMON/MODPUB/MODPUB,LIMODE
InTeGer*4 KLKC,KLKR
REAL*8 AACP,AACQ
C COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
InTeGer*4 NCEL,NXINI
C COMMON/NCEL/NCEL,NXINI
CHARACTER*1 NAMARY(20,301)
C COMMON/NMNMNM/NAMARY
InTeGer*4 NULAST,LFVD
C COMMON/NULXXX/NULAST,LFVD
COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
1 KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC COMMON/MIRROR/ICREF,IRREF
C IN RECALC WE MOVE OVER PRIME AREA ONLY AND SEARCH FOR CELLS IN
C DISPLAY AREA THERE. THIS IMPLIES THAT WE DON'T FIND DISPLAY
C COORDS OF CELLS IN EXTENDED AREAS THERE. THEREFORE THE RI AND RE
C MODES FAIL COMPLETELY THERE. SINCE WE WANT THE SYSTEM TO WORK IN
C A PREDICTABLE WAY, FORCE RECALC MODE (I.E., R OR RM MODES) THERE TO
C ALLOW CELLS TO BE COMPUTED.
C NOTE THAT IF WE ARE IN THE PRIME AREA AND ISSUE AN RE OR RI COMMAND,
C THAT MODE SHOULD STAY SET SO LONG AS WE STAY THERE SINCE THE RE OR
C RI MODES WILL INHIBIT COMPUTING OUTSIDE THAT AREA (AS LONG AS NOTHING
C REFLECTS INTO IT) SO THERE WILL BE NO REASON FOR THIS TO BE CALLED
C TO REFLECT SOMETHING BACK TO PRIME AREA UNTIL A R COMMAND IS GIVEN
C OR THE DISPLAY MOVES OFF THE EDGE OF THE PRIME 60 BY 301 AREA.
C
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 IPS1,IPS2,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE
CCC InTeGer*4 IRCE1,IRCE2
CCC COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,IRCE2
IDD1=MAX0(ID1,1)
IDD2=ID2
C ACCEPT TRICK CALLS WITH ID1=0 AS FROM GMSUBS, MTXEQU,
C AND MDST
IF(ID1.LT.1)GOTO 2000
4000 CONTINUE
IF(IDD2.LE.60)GOTO 1000
IDD2=IDD2-60
IDD1=IDD1+IRREF
c RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
GOTO 4000
1000 CONTINUE
IF(IDD1.LE.301)GOTO 2000
IDD1=IDD1-300
IDD2=IDD2+ICREF
c RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
GOTO 4000
2000 CONTINUE
ID=(IDD1-1)*60+IDD2
RETURN
END
c -h- relvbl.for Tue Sep 2 10:58:55 1986
SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC)
C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN
C PARAMETER CUP=1,ED=11,EL=12
CHARACTER*1 NAME(4),NUMBER(6)
CHARACTER*1 LNIN,LNOUT
CHARACTER*6 NUMBR6
EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
DIMENSION LNIN(128),LNOUT(128)
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
C LOGICAL*2 L63,L192,L255,L127,L128
LOGICAL*4 L1,L2
C InTeGer*4 I63,I192,I255,I127,I128
InTeGer*4 I63,I192,I127
InTeGer*4 I1,I2
C EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
EQUIVALENCE (I1,L1),(I2,L2)
C EQUIVALENCE (L127,I127),(L128,I128)
C DATA I63/63/,I192/192/,I255/255/,I127/127/,I128/128/
DATA I63/63/,I192/192/,I127/127/
LI=1
LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100 CONTINUE
C IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200
LCC=ICHAR(LNIN(LI))
C IF WE HAVE 255,CODE,CODE THEN RELOCATE IN BINARY...
IF(LCC.EQ.255)GOTO 500
IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
IL1=LI
LE=110
LSTC=LE
CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
C AVOID MESSING UP FUNCTION NAMES
IF(ID2.EQ.1)IVLD=0
C IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0
IF(IVLD.EQ.0)GOTO 200
C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT.
C FIRST DON'T RELOCATE P## AND D## FORMS.
IF(LNIN(LI+1).EQ.'#')GOTO 250
C RELOCATE NORMAL VARIABLE HERE.
C
C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS
C ID1.GT.JRTR AND ID2.GT.JRTC
IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210
IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210
C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL.
C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH
C AND CLAMP TO VALID DIMENSIONS.
IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
906 ID1=MAX0(ID1,1)
ID2=MAX0(ID2,1)
C CAN UNPACK THIS STUFF ALL RIGHT IN EXTENDED WAYS.
ID1=MIN0(18060,ID1)
ID2=MIN0(18060,ID2)
210 CONTINUE
CALL IN2AS(ID1,NAME)
C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
IL2=ID2-1
WRITE(NUMBR6(1:6),1000)IL2
C ENCODE(6,1000,NUMBER)IL2
1000 FORMAT(I6)
C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
C THROW OUT SPACES AND COPY THE REST.
LI=LSTC
DO 202 N=1,4
IF(Ichar(NAME(N)).LE.32)GOTO 202
LNOUT(LO)=NAME(N)
LO=LO+1
IF(LO.GT.110)GOTO 300
202 CONTINUE
IF(IDOL1.GT.0)LNOUT(LO)=36
IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1
DO 203 N=1,6
IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
C IF 32 ISN'T SPACE, LOSE
LNOUT(LO)=NUMBER(N)
LO=LO+1
IF(LO.GT.110)GOTO 300
203 CONTINUE
IF(IDOL2.EQ.0)GOTO 300
LNOUT(LO)=CHAR(36)
IF(LO.LE.109)LO=LO+1
GOTO 300
250 CONTINUE
C JUST COPY DISPLAY FORMS.
IL1=LSTC-1
DO 251 N=LI,IL1
LNOUT(LO)=LNIN(N)
LO=LO+1
IF(LO.GT.110)GOTO 300
251 CONTINUE
LI=LSTC
C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
GOTO 300
200 LNOUT(LO)=LNIN(LI)
LO=LO+1
LI=LI+1
300 IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
LO=MIN0(LO,110)
DO 400 N=LO,110
400 LNOUT(N)=0
DO 1 N=111,128
1 LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
RETURN
500 CONTINUE
C DECODE BY HAND...
LNOUT(LO)=LNIN(LI)
I1=ICHAR(LNIN(LI+1))
I2=IMASK(I1,I192)
C L2=L1.AND.L192
I1=IMASK(I1,I63)
C L1=L1.AND.L63
C DO MASKING TO GET BINARY COORDS
ID1=I1
I1=ICHAR(LNIN(LI+2))
I1=IMASK(I1,I127)
C L1=L1.AND.L127
ID2=I2*2+I1
C NOW RELOCATE AND PUT BACK
IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 510
IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 510
IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
C CLAMP RESULT TO MAX RANGES
ID1=MAX0(ID1,1)
ID2=MAX0(ID2,1)
C DO GENERAL REPACK IF ID1 OR ID2 ARE EXTENDED RANGE.
IF(ID1.GT.60.OR.ID2.GT.301)GOTO 905
C ID1=MIN0(60,ID1)
C ID2=MIN0(301,ID2)
510 CONTINUE
C RELOCATED, NOW REPACK AS NEW BINARY PATTERNS
I1=ID1
C L1=L1.AND.L63
I1=IMASK(I1,I63)
I2=ID2/2
I2=IMASK(I2,I192)
C L2=L2.AND.L192
C L1=L1.OR.L2
I1=I1+I2
LNOUT(LO+1)=CHAR(I1)
I2=ID2
I2=IMASK(I2,I127)+128
C L2=L2.AND.L127
C L2=L2.OR.L128
C BE SURE AT LEAST 1 BIT IS SET
LNOUT(LO+2)=CHAR(I2)
LI=MIN0(109,LI+3)
LO=MIN0(109,LO+3)
C GO LOOK FOR MORE TO DECODE
GOTO 300
905 CONTINUE
C HERE SET UP FOR REENTRY INTO "NORMAL" DECODE
LSTC=MIN0(109,LI+3)
GOTO 906
END
c -h- rnd.for Tue Sep 2 10:58:55 1986
FUNCTION RND(DUM)
C GENERATE RANDOM NUMBER BY LINEAR CONGRUENCE IN BIG
C INTEGERS.
REAL*4 R
INTEGER*4 DUM
INTEGER*4 I,II
LOGICAL*4 L,LMSK
REAL*8 XX
EQUIVALENCE(I,L),(II,LMSK)
I=DUM
XX=I
XX=XX*214013.0D0+2531011.0D0
IF(XX.LT.0.)XX=1.0D0-XX
XX=DMOD(XX,16777216.0D0)
I=IDINT(XX)
C I=I*214013+2531011
C USE MASKING TO ZOT THIS INTO NORMAL RANGE
C JUST USE MODULO...
IF(I.LT.0)I=1-I
IF(I.LT.0)I=0
I=MOD(I,16777215)
DUM=I
C RETURN RANDOM BETWEEN 0 AND 1.0
C PERIOD OF 2**24 MAX
XX=I
XX=XX/16777216.0
R=SNGL(XX)
RND=R
RETURN
END
c -h- rvboo.for Tue Sep 2 10:58:55 1986
SUBROUTINE RVBOO(RETV,ID1,ID2)
C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
C ACCESS VARIABLE LOCATION LATER.
InTeGer*4 RETV,ID1,ID2
DIMENSION RETV(2)
RETV(1)=ID1
RETV(2)=ID2
RETURN
END
c -h- scmp.for Tue Sep 2 10:58:55 1986
SUBROUTINE SCMP(LINA,LINB,LENM,ICODE)
DIMENSION LINA(1),LINB(1)
CHARACTER*1 LINA,LINB
ICODE=1
DO 1 N=1,LENM
IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
C ALLOW _ TO BE A WILDCARD.
IF(LINA(N).EQ.'_'.OR.LINB(N).EQ.'_')GOTO 1
IF(LINA(N).NE.LINB(N))ICODE=0
IF(ICODE.NE.1)GOTO 2
1 CONTINUE
2 CONTINUE
RETURN
END
c -h- sed.for Tue Sep 2 10:58:55 1986
SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH)
CHARACTER*1 LIN(1),LWRK(1),ARGSTR(52,4)
CHARACTER*1 LCMD(1),LSU(10)
EXTERNAL INDX
CHARACTER*10 LSU10
EQUIVALENCE (LSU10(1:10),LSU(1))
INTEGER*4 III
REAL*8 XAC
C
C OPERATION:
C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT
C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH
C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT.
C
C EDITS:
C CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST
C INTERVAL BETWEEN DELIMITERS WITH SECOND.
C HOWEVER:
C &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4)
C
C &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND
C PRINTED.
C &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND
C INSERTED.
C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH
C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %).
C WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER
C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER.
DO 335 IV=1,80
335 LWRK(IV)=0
IDELIM=ICHAR(LCMD(1))
ID2=INDX(LCMD(2),IDELIM)
IF(ID2.GE.LENGTH)GOTO 100
C NOW HAVE 1ST STRING, OF NONZERO LENGTH
C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT
C BOTH MUST BE DEFINED BY A DELIMITER.
ID3=INDX(LCMD(2+ID2),IDELIM)
IF(ID3.GE.LENGTH)GOTO 100
C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN.
C (NOTE WE WANT TO FILL ALL OF LENGTH)
INLIN=1
INWRK=1
IVV=ID3+ID2+2
DO 336 IV=IVV,LENGTH
336 LCMD(IV)=0
LSA=ID2-1
LSB=ID3-1
LSSB=2+ID2
LZR=0
DO 1 N=1,LENGTH
IF(LSA.GT.0)GOTO 350
C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO
C EXISTING STRING AT THE END.
C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.)
IF(LIN(N).EQ.0)GOTO 351
C JUST COPY THE INPUT FIRST AND GO OFF
GOTO 2
351 CONTINUE
C HERE WE HAVE THE TERMINAL NULL
LZR=LZR+1
C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH
IF(LZR.EQ.1)GOTO 222
GOTO 1
350 CONTINUE
IF(LIN(INLIN).EQ.0)GOTO 1
CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD)
IF(ICOD.EQ.0)GOTO 2
C HERE HAVE TO SUBSTITUTE
C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST.
222 CONTINUE
INLIN=INLIN+LSA
C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER
IF(LSB.LE.0)GOTO 1
C DO 6 M=1,LSB
M=1
106 CONTINUE
IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7
8 CONTINUE
C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE.
LWRK(INWRK)=LCMD(LSSB+M-1)
IF(INWRK.LT.LENGTH)INWRK=INWRK+1
GOTO 6
7 CONTINUE
C HANDLE & FORMS
IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8
C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE.
M=M+1
IF(LCMD(LSSB+M-1).GT.'4')GOTO 10
C HERE JUST HANDLE ARGSTR SUBSTITUTIONS.
II=ICHAR(LCMD(LSSB+M-1))
II=II-48
C II IS NOW THE INDEX.
DO 11 MM=1,52
LWRK(INWRK)=ARGSTR(MM,II)
IF(INWRK.LT.LENGTH)INWRK=INWRK+1
IF(ARGSTR(MM,II).EQ.0)GOTO 12
11 CONTINUE
12 CONTINUE
M=M+1
C PASS THE NUMBER OF THE &NUMBER FORM
GOTO 6
10 CONTINUE
C HANDLE ZAC FORMS
M=M+1
C PASS THE DIGIT
IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14
C FILL IN ZAC AS AN INTEGER
II=32
IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC
C ONLY HANDLE CONVERSION IF LEGAL
LWRK(INWRK)=CHAR(II)
IF(INWRK.LT.LENGTH)INWRK=INWRK+1
GOTO 6
14 CONTINUE
C HANDLE NUMERIC CONVERSION HERE
LSU(1)=0
III=0
IF(DABS(XAC).LT.9999999.)III=IDINT(XAC)
WRITE(LSU10(1:10),15,ERR=22)III
C ENCODE(10,15,LSU,ERR=22)III
15 FORMAT(I9)
22 DO 16 MK=1,10
IF(LSU(MK).EQ.0)GOTO 6
IF(LSU(MK).EQ.' ')GOTO 16
LWRK(INWRK)=LSU(MK)
IF(INWRK.LT.LENGTH)INWRK=INWRK+1
16 CONTINUE
6 CONTINUE
M=M+1
IF(M.LE.LSB)GOTO 106
GOTO 1
2 CONTINUE
C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE.
LWRK(INWRK)=LIN(INLIN)
IF(INLIN.LT.LENGTH)INLIN=INLIN+1
IF(INWRK.LT.LENGTH)INWRK=INWRK+1
1 CONTINUE
C COPY BACK OUT TO CMDLIN AFTER FIXUP
IF(INWRK.GE.LENGTH)GOTO 3
DO 4 N=INWRK,LENGTH
4 LWRK(N)=0
3 CONTINUE
C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW.
DO 5 N=1,LENGTH
5 LCMD(N)=LWRK(N)
100 CONTINUE
RETURN
END
c -h- sign.for Tue Sep 2 10:58:55 1986
REAL *8 FUNCTION SIGN(VAR)
REAL*8 VAR
C ALWAYS RETURN 1. OR -1. FOR THIS PROGRAM ... NEVER 0.
SIGN=1.
IF(VAR.LT.0.)SIGN=-1.
RETURN
END
c -h- slend.for Tue Sep 2 10:58:55 1986
SUBROUTINE SLEND(RETCD)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C * *
C * SUBROUTINE SLEND(RETCD) *
C * *
C **************************************************
C
C
C
C SETS VALUE OF LEND, POINTER TO LAST NON-BLANK CHARACTER
C IN LINE(80)
C
C
C
C
C RETCD VALUE MEANING
C
C 1 NORMAL RETURN
C 2 ALL BLANKS
C
C
C
C SLEND IS CALLED BY CALC
C
C VARIABLE USE
C
C BLANK ' '
C I INDEXES CHARACTERS IN LINE(80).
C LEND UPON EXIT, POINTS TO THE LAST NON-
C BLANK IN LINE(80).
C LINE(80) HOLDS COMMAND LINE.
C RETCD RETURN CODE. 1=NORMAL, 2=ALL BLANKS
C
C
C
C SUBROUTINE SLEND(RETCD)
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 VIEWSW,BASED,RETCD
C
CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
CHARACTER*1 LINE(80)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
C
C
C
RETCD=1
DO 100 I=1,80
IF(LINE(81-I).NE.BLANK)GO TO 200
100 CONTINUE
RETCD=2
RETURN
200 LEND=81-I
RETURN
END
c -h- sscmp.for Tue Sep 2 10:58:55 1986
SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE)
DIMENSION LINA(1),LINB(1)
CHARACTER*1 LINA,LINB
ICODE=1
DO 1 N=1,LENM
c IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
IF(ICHAR(LINA(N)).NE.ICHAR(LINB(N)))ICODE=0
IF(ICODE.NE.1)GOTO 2
1 CONTINUE
2 CONTINUE
RETURN
END
c -h- sstr.for Tue Sep 2 10:58:55 1986
SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM)
CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
InTeGer*4 LA,N,LE
InTeGer*4 VLEN(9),TYPE(1,1)
CHARACTER*1 AVBLS(20,27)
REAL*8 XVBLS(1,1),XX,VP,TMP
COMMON/V/TYPE,AVBLS,XVBLS,VLEN
NI=N
N=N+2
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
LAA=N
LEE=LE
CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
IF(IVLD.LE.0)GOTO 990
C XX=XVBLS(I1,I2)
CALL XVBLGT(I1,I2,XX)
VP=128.D0**7
DO 1 NN=1,8
TMP=DINT(XX/VP)
NBF(NN)=CHAR(IDINT(TMP))
VP=VP/128.D0
XX=XX-(128.D0*TMP)
1 CONTINUE
C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED
C STRING. COPY TO FORM.
NL=NI
DO 2 NN=1,8
FORM(NL)=NBF(NN)
IF(NN.GE.1)NL=NL+1
2 CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
N=NL
LE=LE-LSTC+NL
DO 401 M=N,LE
CMDLIN(M)=CMDLIN(M+LSTC-NL)
401 CONTINUE
C HOPE ALL'S WELL NOW...
RETURN
990 FORM(N)=CMDLIN(N)
RETURN
END
c -h- strcmp.for Tue Sep 2 10:58:55 1986
SUBROUTINE STRCMP(NAME,LENGTH,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C * *
C * SUBROUTINE STRCMP(NAME,LENGTH,RETCD) *
C * *
C **************************************************
C
C
C STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH)
C THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE:
C
C 1=MATCH
C 2=FAILURE
C
C UPON EXIT, COMMON VARIABLE NONBLK
C IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED
C FOR MATCH
C IF FAILURE, UNCHANGED
C
C
C
C MODIFICATION CLASSES: M2
C
C
C
C STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80)
C
C STRCMP IS CALLED BY CMND
C
C
C
C
C VARIABLE USE
C
C I2 INDEXES NAME(LENGTH).
C IS HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS
C AND IT IS NECESSARY TO RESTORE THE VALUE.
C LENGTH HOLDS THE LENGTH OF VECTOR NAME.
C NONBLK POINTER FOR COMMAND LINE HELD BY LINE(80).
C RETCD HOLDS RETURN CODE. 1=MATCH, 2=FAILURE
C
C
C
C
C SUBROUTINE STRCMP(NAME,LENGTH,RETCD)
InTeGer*4 LENGTH
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 RETCD,VIEWSW,BASED
C
CHARACTER*1 LINE(80),NAME(LENGTH)
CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER
C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER
C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER
C IN THE COMMAND NAME (AFTER THE ASTERISK).
IS=NONBLK
CALL GETNNB(IPT,RETCD)
GO TO (10,999),RETCD
C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME
C
C
10 DO 100 I2=1,LENGTH
CALL GETNNB(IPT,RETCD)
GO TO (20,999),RETCD
STOP 20
20 NONBLK=IPT
IF(NAME(I2).NE.LINE(NONBLK))GOTO 999
100 CONTINUE
RETCD=1
RETURN
C
C
C NO MATCH
999 RETCD=2
C IF ERROR, RESTORE VALUE OF NONBLK
NONBLK=IS
RETURN
END
c -h- svbl.for Tue Sep 2 10:58:55 1986
SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM)
InTeGer*4 VLEN(9),TYPE(1,1)
CHARACTER*1 AVBLS(20,27)
REAL*8 XVBLS(1,1)
COMMON/V/TYPE,AVBLS,XVBLS,VLEN
CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
CHARACTER*3 NBF3
EQUIVALENCE(NBF3(1:1),NBF(5))
InTeGer*4 LA,N,LE
NI=N
N=N+2
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
LAA=N
LEE=LE
CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
IF(IVLD.LE.0)GOTO 990
LAA=LSTC+1
C ACCEPT ANY DELIMITER
LEE=LE
CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD)
IF(IVLD.LE.0)GOTO 990
C XX=XVBLS(I1,I2)
CALL XVBLGT(I1,I2,XX)
C XX IS COL #
C XY=XVBLS(J1,J2)-1.0
CALL XVBLGT(J1,J2,XY)
IF(XX.LE..99.OR.XX.GT.DFLOAT(RRW))GOTO 990
IF(XY.LE..99.OR.XY.GT.DFLOAT(RCL))GOTO 990
IC=XX
CALL IN2AS(IC,NBF)
IR=XY
WRITE(NBF3(1:3),300)IR
C ENCODE(3,300,NBF(5))IR
300 FORMAT(BZ,I3)
NL=NI
C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES.
DO 400 NN=1,7
FORM(NL)=NBF(NN)
IF(FORM(NL).GT.64)NL=NL+1
400 CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
N=NL
LE=LE-LSTC+NL
DO 401 M=N,LE
CMDLIN(M)=CMDLIN(M+LSTC-NL)
401 CONTINUE
C HOPE ALL'S WELL NOW...
RETURN
990 CONTINUE
FORM(N)=CMDLIN(N)
RETURN
END
c -h- swrt.for Tue Sep 2 10:58:55 1986
C
C SWRT - WRITE VARIABLE LENGTH STRING TO SCREEN WITHOUT
C RECORD TERMINATION.
C COPYRIGHT GLENN C EVERHART 1984
C ALL RIGHTS RESERVED
C *** Don't use for normal Amiga stuff, but have available in case
C *** it should be handy someplace...
C
C
ccc SUBROUTINE SWRT(STRING,LENGTH)
ccc CHARACTER*1 STRING(127)
ccc INTEGER LENGTH
cccC DUMP OUT ALL WE CAN..
ccc CHARACTER*9 SFM
ccc CHARACTER*1 SFMX(9)
ccc CHARACTER*3 SNM
ccc EQUIVALENCE(SNM,SFMX(2))
ccc EQUIVALENCE (SFMX(1),SFM)
cccC HERE ARE THE BUILT IN FORMATS. NOTE WE FILL IN THE
cccC REPEAT COUNT AT RUNTIME FOR THE TEXT TO BE WRITTEN.
cccC NOTE ALSO THAT THE 1ST CHAR IS A # SIGN TO SHOW UP PROBLEMS.
cccC FORMATS ARE (nnnA1,\)
cccC COMPRISING 13 CHARACTERS IN ALL.
ccc DATA SFM/'(001A1,\)'/
cccC NOTE WE JUST FILL IN THE LENGTH AND WRITE TO SCREEN USING
cccC SFM AS A RUNTIME FORMAT.
cccC
ccc IF(LENGTH.LE.0)RETURN
ccc WRITE(SNM,1)LENGTH
ccc1 FORMAT(BZ,I3)
cccC WRITE ON UNIT 6 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
cccC (VIA EXPLICIT OPEN IN MAIN PROGRAM)
ccc WRITE(11,SFM)(STRING(II),II=1,LENGTH)
ccc RETURN
ccc END
SUBROUTINE VWRT(STRING,LENGTH)
C VWRT is like SWRT but writes to lun 11 window instead.
CHARACTER*1 STRING(127)
INTEGER LENGTH
C DUMP OUT ALL WE CAN..
IF(LENGTH.LE.0)RETURN
C WRITE ON UNIT 11 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
C (VIA EXPLICIT OPEN IN MAIN PROGRAM)
REWIND 11
WRITE(11,777)(STRING(II),II=1,LENGTH)
REWIND 11
777 format(1X,127A1)
RETURN
END