Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/stp/stp13.for
There is 1 other file named stp13.for in the archive. Click here to see a list.
C *** STAT PACK ***
C SUBROUTINE USED TO PROVIDE USER WITH EASY METHOD OF TRANSFORMING
C DATA AND SORTING.
C CALLING SEQUENCE: CALL TRANS(NV,NC,MV,MC,DATA,VMN,STD,COR,NAMES,
C SP,IVIP)
C WHERE NV - NUMBER OF VARIABLES ACTUALLY USED
C NC - NUMBER OF OBSERVATIONS ACTUALLY USED
C MV - MAXIMUM NUMBER OF VARIABLES POSSIBLE
C MC - MAXIMUM NUMBER OF OBSERVATIONS POSSIBLE
C DATA - MATRIX CONTAINING DATA
C VMN - VECTOR CONTAINING VARIABLE MEANS
C STD - VECTOR CONTAINING VARIABLE STANDARD DEVIATIONS
C COR - CORRELATION MATRIX
C NAMES - VECTOR CONTAINING VARIABLE NAMES
C SP - EXTRA VECTOR AT LEAST MC LONG
C IVIP - EXTRA VECTOR AT LEAST NV LONG
C
C ROUTINE ORIGINALLY REQUESTED BY ULDIS SCHMIDIENS (TEACHER ED)
C BRAD HEITIMA (PSYCHOLOGY), AND MIKE KEENAN (MANAGEMENT).
C SORT WAS IN PARTICULAR REQUESTED BY MORTY WAGENFIELD (SOC.)
C CALLS ALSO THE ROUTINES: CALC,VARB,COMPD,AND SORT.
C NOTE: NO FIXED POINT VARIABLES CREATED.
C
SUBROUTINE TRANS (NV,NC,MV,MC,DATA,VMN,STD,COR,NAMES,SP,IVIP)
DIMENSION DATA(MC,MV), COR(MV,MV), VMN(1), STD(1), NAMES(1)
DIMENSION INST(25),IVAR1(25),IVAR2(25),CONST(25),SV(99),ITO(25),SP
1(1)
DIMENSION LINE(80),IVIP(1)
COMMON/DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/TRNF/ITYPES(9)
EQUIVALENCE (WORD,IWORD)
ITYPES(1)='('
ITYPES(2)=')'
ITYPES(3)=','
ITYPES(4)='='
ITYPES(5)='+'
ITYPES(6)='-'
ITYPES(7)='/'
ITYPES(8)='*'
ITYPES(9)=' '
1 IF(ICC.NE.2) WRITE (IDLG,2)
2 FORMAT (' ?',$)
READ (ICC,3,END=9999) LINE
3 FORMAT (80A1)
DO 5 I=80,1,-1
IF (LINE(I).NE.' ') GO TO 6
5 CONTINUE
GO TO 9999
6 IF ((LINE(1).EQ.'S').AND.(LINE(2).EQ.'T').AND.(LINE(3).EQ.'O')
1.AND.(LINE(4).EQ.'P')) GO TO 9999
N=I
I=0
7 I=I+1
8 IF (I.GT.N) GO TO 9001
IF (LINE(I).NE.' ') GO TO 7
DO 9 J=I+1,N
9 LINE(J-1)=LINE(J)
LINE(N)=' '
N=N-1
GO TO 8
9001 IF (LINE(1).EQ.'!') RETURN
L=1
N=1
K=1
4 IPAR=0
CALL COMPD (LINE,N,WORD,IDEF)
IF ((IDEF.EQ.9).AND.(WORD.EQ.'HELP')) GO TO 300
IF (IDEF.NE.1) GO TO 16
IPAR=1
IF (WORD.NE.'SORT') GO TO 10
WRITE(IDLG,24)
24 FORMAT(' PLEASE USE SORT COMMAND')
GO TO 1
10 IF (WORD.NE.'IFL') GO TO 11
INST(K)=22
GO TO 25
11 IF (WORD.NE.'IFE') GO TO 12
INST(K)=21
GO TO 25
12 IF (WORD.NE.'IFN') GO TO 13
INST(K)=26
GO TO 25
13 IF (WORD.NE.'IFG') GO TO 46
INST(K)=24
GO TO 25
46 IF(WORD.NE.'IF') GO TO 14
INST(K)=20
GO TO 25
14 WRITE(IDLG,15)
15 FORMAT ('+SORT MISSPELLED OR CONDITIONAL NOT CORRECT')
GO TO 1
16 IF (IDEF.NE.4) GO TO 22
INST(K)=4
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IV.LT.0) GO TO 22
IF (IERR.NE.0) GO TO 17
ITO(K)=IV
GO TO 25
17 IF ((IERR.NE.1).AND.(IERR.NE.3)) GO TO 22
IF ((NV+1).LE.MV) GO TO 19
WRITE (IDLG,18)
18 FORMAT ('+NO MORE ROOM FOR NEW VARIABLES IN DATA SET SPECIFIED')
GO TO 1
19 ITO(K)=NV+1
IF (IERR.EQ.3) GO TO 20
NAMES(NV+1)=IWORD
GO TO 25
20 ENCODE (5,21,NAMES(NV+1)) ITO(K)
21 FORMAT (I3,2X)
GO TO 25
22 WRITE (IDLG,23)
23 FORMAT ('+INSTRUCTION MUST HAVE FORM OF FORTRAN STATEMENT')
GO TO 1
C
C INSTRUCTION TYPE KNOWN, FIND INFORMATION NECESSARY
C
25 K=K+1
IF (K.LE.25) GO TO 50
26 WRITE (IDLG,27)
27 FORMAT ('+INSTRUCTION TOO LONG')
GO TO 1
37 IF(IERR.EQ.1) WRITE(IDLG,38)
IF(IERR.EQ.2) WRITE(IDLG,39)
IF(IERR.EQ.3) WRITE(IDLG,40)
38 FORMAT('+ONE OF THE VARIABLSE NAMES USED DOES NOT EXIST')
39 FORMAT('+# MUST BE FOLLOWED BY A VARIABLE')
40 FORMAT('+ONE OF THE VARIABLE NUMBERS USED DOES NOT EXIST')
GO TO 1
C
C CHECK FOR CONDITIONAL
C
50 IF ((INST(K-1).LT.20).OR.(INST(K-1).GT.26)) GO TO 80
M=N
51 M=M+1
IF (M.LT.80) GO TO 54
52 WRITE (IDLG,53)
53 FORMAT ('+UNBALANCED PARENTHESES')
GO TO 1
54 IF (LINE(M).NE.'(') GO TO 55
IPAR=IPAR+1
GO TO 51
55 IF (LINE(M).NE.')') GO TO 51
IPAR=IPAR-1
IF (IPAR.GT.0) GO TO 51
M=M-1
IF(INST(K-1).NE.20) GO TO 90
DO 91 II=N,M
IF(LINE(II).NE.'.') GO TO 91
IF((LINE(II+1).NE.'E').AND.(LINE(II+1).NE.'L').AND.
1(LINE(II+1).NE.'G').AND.(LINE(II+1).NE.'N')) GO TO 91
IF((LINE(II+2).NE.'Q').AND.(LINE(II+2).NE.'T').AND.
1(LINE(II+2).NE.'E')) GO TO 91
IF(LINE(II+3).NE.'.') GO TO 91
WORD=' '
ENCODE(4,3,WORD)(LINE(LLL),LLL=II,II+3)
LLL=0
IF(WORD.EQ.'.EQ.') LLL=21
IF(WORD.EQ.'.LT.') LLL=22
IF(WORD.EQ.'.LE.') LLL=23
IF(WORD.EQ.'.GT.') LLL=24
IF(WORD.EQ.'.GE.') LLL=25
IF(WORD.EQ.'.NE.') LLL=26
IF(LLL.EQ.0) GO TO 91
INST(K-1)=LLL
GO TO 93
91 CONTINUE
94 WRITE(IDLG,92)
92 FORMAT(' INCORRECT FORM OF IF STATEMENT')
GO TO 1
93 LINE(II)='-'
LINE(II+1)='('
IF((II+3).EQ.M) GO TO 94
DO 95 LLL=II+4,M
95 LINE(LLL-2)=LINE(LLL)
LINE(M-1)=')'
DO 96 LLL=M+1,80
96 LINE(LLL-1)=LINE(LLL)
LINE(80)=' '
M=M-1
90 CALL CALC (LINE,N,M,K,L,INST,IVAR1,IVAR2,ITO,CONST,SV,NV,NAMES,IER
1RC)
IF (IERRC.EQ.0) GO TO 70
56 IF (IERRC.EQ.1) WRITE (IDLG,53)
IF (IERRC.EQ.2) WRITE (IDLG,60)
60 FORMAT ('+PARENTHESES DO NOT ENCLOSE ANYTHING')
IF (IERRC.EQ.3) WRITE (IDLG,61)
61 FORMAT ('+POWER IS NOT A CONSTANT OR A VARIABLE')
IF (IERRC.EQ.4) WRITE (IDLG,38)
IF (IERRC.EQ.5) WRITE (IDLG,39)
IF (IERRC.EQ.6) WRITE (IDLG,40)
IF (IERRC.EQ.7) WRITE (IDLG,62)
62 FORMAT ('+TWO INSTRUCTIONS NOT SEPARATED BY A VARIABLE')
IF (IERRC.EQ.8) WRITE (IDLG,63)
63 FORMAT ('+ATTEMPT TO DIVIDE BY A CONSTANT VALUE OF ZERO')
IF (IERRC.EQ.9) WRITE (IDLG,27)
IF (IERRC.EQ.10) WRITE (IDLG,64),IERRC
64 FORMAT ('0SYSTEM PROBLEM-CONTACT DICK HOUCHARD',I4)
IF (IERRC.EQ.11) WRITE (IDLG,64),IERRC
IF (IERRC.EQ.12) WRITE (IDLG,64),IERRC
IF (IERRC.EQ.13) WRITE (IDLG,65)
65 FORMAT ('+TWO EXPRESSIONS NOT SEPARATED BY AN OPERATION')
IF (IERRC.EQ.14) WRITE (IDLG,66)
66 FORMAT ('+"," IS NOT A LEGAL OPERATION')
IF (IERRC.EQ.15) WRITE (IDLG,67)
67 FORMAT ('+"=" IS NOT A LEGAL OPERATION IN AN IF OR TWICE IN
1AN EQUATION')
IF (IERRC.EQ.16) WRITE (IDLG,64),IERRC
IF (IERRC.EQ.17) WRITE (IDLG,65)
IF (IERRC.EQ.18) WRITE (IDLG,68)
68 FORMAT ('+ILLEGAL OR MISSPELLED FUNCTION')
IF (IERRC.EQ.19) WRITE (IDLG,69)
69 FORMAT ('+ATTEMPT TO TAKE MEAN OR STANDARD DEVIATION OF CONSTANT')
GO TO 1
70 INST(K)=27
CALL COMPD (LINE,N,WORD,IDEF)
IF (IDEF.LE.9) GO TO 72
WRITE (IDLG,71)
71 FORMAT ('+IF ON A CONSTANT IS ILLEGAL')
GO TO 1
72 CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 17
ITO(K)=IV
K=K+1
IF(K.GT.25) GO TO 26
GO TO 4
C
C END OF CONDITIONAL
C
C
C CHECK FOR EQUALITY
C
80 M=N
81 M=M+1
IF (M.GT.80) GO TO 82
IF (LINE(M).NE.' ') GO TO 81
82 M=M-1
CALL CALC (LINE,N,M,K,L,INST,IVAR1,IVAR2,ITO,CONST,SV,NV,NAMES,IER
1RC)
IF (IERRC.NE.0) GO TO 56
CALL COMPD (LINE,N,WORD,IDEF)
IF ((IDEF.NE.9).AND.(IDEF.NE.19)) PAUSE 'BOAB'
INST(K)=9
IF (IDEF.EQ.19) GO TO 83
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 37
ITO(K)=IV
GO TO 100
83 ITO(K)=0
CONST(K)=WORD
GO TO 100
C
C ------------------------------------------------------------------
C
C CODING DONE NOW BEGIN WORK
C
C ------------------------------------------------------------------
C
100 ISDBZ=0
ISSQTN=0
KCODFN=0
DO 1100 I=1,K
IF(INST(I).NE.4) GO TO 1100
KCODFN=ITO(I)
GO TO 1101
1100 CONTINUE
1101 KNV=NV
IF(KCODFN.GT.KNV) KNV=KCODFN
DO 1102 I=1,KNV
1102 SP(I)=0
XM=0
DO 900 I=1,NC
N=1
103 KCODE=INST(N)
KCODTO=ITO(N)
106 N=N+1
IF (N.GT.K) PAUSE 'CODING PROB'
INSOP=INST(N)
INPUT=ITO(N)
IF (INSOP.EQ.99) GO TO 106
IF (INSOP.NE.9) GO TO 107
IF (INPUT.EQ.0) DATA(I,KCODTO)=CONST(N)
IF(INPUT.LT.0) DATA(I,KCODTO)=SV(-INPUT)
IF(INPUT.GT.0) DATA(I,KCODTO)=DATA(I,INPUT)
GO TO 800
107 GO TO (108,108,130,108,110,120,140,150,108,160,170,180,190,200,210
1,220,230,240,250,270,108,108,108,108,108,108,260,280,290) INSOP
108 WRITE (IDLG,109)
109 FORMAT (' SYSTEM PROB-CONTACT DICK HOUCHARD')
GO TO 1
C
C ADD
C
110 IF (IVAR1(N)) 111,112,113
111 WORD1=SV(-IVAR1(N))
GO TO 114
112 WORD1=CONST(N)
GO TO 114
113 WORD1=DATA(I,IVAR1(N))
114 IF (IVAR2(N)) 115,116,117
115 WORD2=SV(-IVAR2(N))
GO TO 118
116 WORD2=CONST(N)
GO TO 118
117 WORD2=DATA(I,IVAR2(N))
118 SV(INPUT)=WORD1+WORD2
GO TO 106
C
C SUBTRACT
C
120 IF (IVAR1(N)) 121,122,123
121 WORD1=SV(-IVAR1(N))
GO TO 124
122 WORD1=CONST(N)
GO TO 124
123 WORD1=DATA(I,IVAR1(N))
124 IF (IVAR2(N)) 125,126,127
125 WORD2=SV(-IVAR2(N))
GO TO 128
126 WORD2=CONST(N)
GO TO 128
127 WORD2=DATA(I,IVAR2(N))
128 SV(INPUT)=WORD1-WORD2
GO TO 106
C
C POWER
C
130 IF (IVAR1(N)) 131,132,133
131 WORD1=SV(-IVAR1(N))
GO TO 134
132 WORD1=CONST(N)
GO TO 134
133 WORD1=DATA(I,IVAR1(N))
134 IF (IVAR2(N)) 135,136,137
135 WORD2=SV(-IVAR2(N))
GO TO 138
136 WORD2=CONST(N)
GO TO 138
137 WORD2=DATA(I,IVAR2(N))
138 SV(INPUT)=WORD1**WORD2
GO TO 106
C
C DIVIDE
C
140 IF (IVAR1(N)) 141,142,143
141 WORD1=SV(-IVAR1(N))
GO TO 144
142 WORD1=CONST(N)
GO TO 144
143 WORD1=DATA(I,IVAR1(N))
144 IF (IVAR2(N)) 145,146,147
145 WORD2=SV(-IVAR2(N))
GO TO 148
146 WORD2=CONST(N)
GO TO 148
147 WORD2=DATA(I,IVAR2(N))
148 IF (WORD2.NE.0) GO TO 149
ISDBZ=1
SV(INPUT)=-9999E-20
GO TO 106
149 SV(INPUT)=WORD1/WORD2
GO TO 106
C
C MULTIPLY
C
150 IF (IVAR1(N)) 151,152,153
151 WORD1=SV(-IVAR1(N))
GO TO 154
152 WORD1=CONST(N)
GO TO 154
153 WORD1=DATA(I,IVAR1(N))
154 IF (IVAR2(N)) 155,156,157
155 WORD2=SV(-IVAR2(N))
GO TO 158
156 WORD2=CONST(N)
GO TO 158
157 WORD2=DATA(I,IVAR2(N))
158 SV(INPUT)=WORD1*WORD2
GO TO 106
C
C SQRT
C
160 IF (IVAR1(N)) 161,162,163
161 WORD1=SV(-IVAR1(N))
GO TO 164
162 WORD1=CONST(N)
GO TO 164
163 WORD1=DATA(I,IVAR1(N))
164 IF (WORD1.GE.0) GO TO 165
ISSQTN=1
WORD1=-WORD1
165 SV(INPUT)=SQRT(WORD1)
GO TO 106
C
C LN
C
170 IF (IVAR1(N)) 171,172,173
171 WORD1=SV(-IVAR1(N))
GO TO 174
172 WORD1=CONST(N)
GO TO 174
173 WORD1=DATA(I,IVAR1(N))
174 SV(INPUT)=ALOG(WORD1)
GO TO 106
C
C EXP
C
180 IF (IVAR1(N)) 181,182,183
181 WORD1=SV(-IVAR1(N))
GO TO 184
182 WORD1=CONST(N)
GO TO 184
183 WORD1=DATA(I,IVAR1(N))
184 SV(INPUT)=EXP(WORD1)
GO TO 106
C
C LOG10
C
190 IF (IVAR1(N)) 191,192,193
191 WORD1=SV(-IVAR1(N))
GO TO 194
192 WORD1=CONST(N)
GO TO 194
193 WORD1=DATA(I,IVAR1(N))
194 SV(INPUT)=ALOG10(WORD1)
GO TO 106
C
C SIN
C
200 IF (IVAR1(N)) 201,202,203
201 WORD1=SV(-IVAR1(N))
GO TO 204
202 WORD1=CONST(N)
GO TO 204
203 WORD1=DATA(I,IVAR1(N))
204 SV(INPUT)=SIN(WORD1)
GO TO 106
C
C COS
C
210 IF (IVAR1(N)) 211,212,213
211 WORD1=SV(-IVAR1(N))
GO TO 214
212 WORD1=CONST(N)
GO TO 214
213 WORD1=DATA(I,IVAR1(N))
214 SV(INPUT)=COS(WORD1)
GO TO 106
C
C MEAN
C
220 SV(INPUT)=VMN(IVAR1(N))
GO TO 106
C
C STD DEV
C
230 SV(INPUT)=STD(IVAR1(N))
GO TO 106
C
C ARC TANGENT
C
240 IF (IVAR1(N)) 241,242,243
241 WORD1=SV(-IVAR1(N))
GO TO 244
242 WORD1=CONST(N)
GO TO 244
243 WORD1=DATA(I,IVAR1(N))
244 SV(INPUT)=ATAN(WORD1)
GO TO 106
C
C ARC SIN
C
250 IF (IVAR1(N)) 251,252,253
251 WORD1=SV(-IVAR1(N))
GO TO 254
252 WORD1=CONST(N)
GO TO 254
253 WORD1=DATA(I,IVAR1(N))
254 SV(INPUT)=ASIN(WORD1)
GO TO 106
C
C ABSOLUTE VALUE
C
270 IF(IVAR1(N)) 271,272,273
271 WORD1=SV(-IVAR1(N))
GO TO 274
272 WORD1=CONST(N)
GO TO 274
273 WORD1=DATA(I,IVAR1(N))
274 SV(INPUT)=WORD1
IF(WORD1.LT.0) SV(INPUT)=-WORD1
GO TO 106
C
C RANDOM NUMBER
C
280 SV(INPUT)=RAN(RANNUM)
GO TO 106
C
C NORMAL RANDOM NUMBER
C
290 WORD1=0
DO 291 J=1,12
291 WORD1=WORD1+RAN(RANNUM)
SV(INPUT)=WORD1-6.
GO TO 106
C
C END OF IF
C
260 IF (INPUT) 261,261,262
261 WORD1=SV(-INPUT)
GO TO 263
262 WORD1=DATA(I,INPUT)
263 N=N+1
IF ((KCODE.EQ.21).AND.(WORD1.EQ.0)) GO TO 103
IF ((KCODE.EQ.22).AND.(WORD1.LT.0)) GO TO 103
IF ((KCODE.EQ.23).AND.(WORD1.LE.0)) GO TO 103
IF ((KCODE.EQ.24).AND.(WORD1.GT.0)) GO TO 103
IF((KCODE.EQ.25).AND.(WORD1.GE.0)) GO TO 103
IF((KCODE.EQ.26).AND.(WORD1.NE.0)) GO TO 103
IF(KCODFN.EQ.0) GO TO 900
IF(KCODFN.GT.NV) DATA(I,KCODFN)=-9999E-20
800 XM=XM+DATA(I,KCODFN)
DO 801 J=1,KNV
801 SP(J)=DATA(I,J)*DATA(I,KCODFN)+SP(J)
900 CONTINUE
IF(KCODFN.EQ.0) GO TO 1
IFF=0
IF (KCODFN.GT.NV) IFF=1
IF (KCODFN.GT.NV) NV=KCODFN
VMN(KCODFN)=XM/NC
STD(KCODFN)=SQRT((SP(KCODFN)-NC*VMN(KCODFN)**2)/(NC-1))
DO 904 J=1,NV
IF (J.EQ.KCODFN) GO TO 903
IF ((STD(J)*STD(KCODFN)).EQ.0) GO TO 902
COR(J,KCODFN)=(SP(J)-NC*VMN(J)*VMN(KCODFN))/((NC-1)*STD(KCODFN)
1*STD(J))
GO TO 904
902 COR (J,KCODFN)=0
GO TO 904
903 COR (J,KCODFN)=1.0
904 COR (KCODFN,J)=COR(J,KCODFN)
IF (IFF.NE.1) WRITE (IDLG,905) NAMES (KCODFN)
905 FORMAT (' VARIABLE: ',A5,' HAS BEEN TRANSFORMED')
IF (IFF.EQ.1) WRITE (IDLG,906) NAMES (KCODFN)
906 FORMAT (' VARIABLE: ',A5,' HAS BEEN CREATED')
IF (ISDBZ.EQ.1) WRITE (IDLG,907)
907 FORMAT (' ALL OCCURENCES OF DIVISION BY ZERO REPLACED BY -9999E-20
1')
IF (ISSQTN.EQ.1) WRITE (IDLG,908)
908 FORMAT (' ALL OCCURENCES OF SQRT OF NEG. NUMBER--ABS VAL OF NUMBER
1 USED')
GO TO 1
300 WRITE(IDLG,301)
301 FORMAT('0TRANSFORMATIONS ARE WRITTEN IN THE SAME MANNER AS',
1' FORTRAN'/' INSTRUCTIONS. THE VARIABLE TO BE MODIFIED OR',
2' CREATED IS'/' FOLLOWED BY AN "=" AND THEN BY THE EXPRESSION',
3' IT IS TO BE'/' SET EQUAL TO (THE EXPRESSION TO THE RIGHT OF',
4' THE "=" WILL BE'/' EVALUATED AND THE FINAL VALUE PLACED IN',
5' THE VARIABLE TO'/' THE LEFT OF THE EQUALS). HIERARCHY IS',
6' THE SAME AS FOR'/' FORTRAN: POWERS FIRST, MULTIPLICATION',
7' AND DIVISION NEXT,'/
8' AND FINALLY ADDITION AND SUBTRACTION. INSTRUCTIONS ARE'/
9' EVALUATED FROM LEFT TO RIGHT. PARENTHESES ARE EVALUATED'/
1' PRIOR TO REMAINING PORTIONS OF THE INSTRUCTION, ALWAYS'/
2' BEGINNING WITH THE INNERMOST PARENTHESES. FUNCTIONS'/
3' WHICH MAY BE USED ARE:'/
4' SQRT - SQUARE ROOT'/
5' LN - NATURAL LOG'/
6' EXP - EXPONENTIAL (E TO THE X)'/
7' LOG10 - LOG BASE 10'/
8' SIN - SIN'/
9' COS - COSINE'/
1' ABS - ABSOLUTE VALUE')
WRITE(IDLG,302)
302 FORMAT(' MEAN - MEAN OF VARIABLE'/
1' STD - STANDARD DEVIATION OF VARIABLE'/
2' ARCTN - ARC TANGENT'/
3' ARCSN - ARC SIN'/
4'0THE "TRANS" COMMAND CONTAINS FOUR CONDITIONAL CODES:'/
5' IFE - IF EQUAL TO ZERO'/
6' IFN - IF NOT EQUAL TO ZERO'/
7' IFL - IF LESS THAN ZERO'/
8' IFG - IF GREATER THAN ZERO'/
9'0THE CONDITIONAL CODE IS FOLLOWED BY AN EXPRESSION ENCLOSED'/
1' IN PARENTHESES FOR USE WITH THE CODE, AND FINALLY THE '/
2' TRANSFORMATION TO BE ACCOMPLISHED IF THE CONDITION IS'/
3' SATISFIED. FOR EACH OBSERVATION THE EXPRESSION FOLLOWING'/
4' THE CONDITIONAL CODE IS EVALUATED, IF THE FINAL VALUE'/
5' SATISFIES THE CONDITIONAL CODE THE TRANSFORMATION IS DONE'/
6' FOR THAT OBSERVATION. IF THE CONDITIONAL CODE IS NOT'/
7' SATISFIED, NO ACTION IS TAKEN ON THAT OBSERVATION AND THE'/
8' ROUTINE PROCEEDS TO THE NEXT OBSERVATION.')
WRITE(IDLG,303)
303 FORMAT('0VARIABLES MAY BE DEFINED BY NAMES OR IF VARIABLE'/
7' NUMBERS ARE USED, A "#" FOLLOWED BY THE VARIABLE'/
8' NUMBER. INSTRUCTION SIZE IS LIMITED TO 1 LINE'/
9' (72 CHARACTERS). TO END TRANSFROMATIONS TYPE A CARRIAGE RETURN'/
1' OR ^Z.')
WRITE(IDLG,304)
304 FORMAT('0EXAMPLES:'/
3'0IQ=MENTL/PHYSL CREATE OR MODIFY VARIABLE: IQ',
4' SETTING IT'/26X,'EQUAL TO VARIABLE: MENTL DIVIDED BY',
5' VARIABLE:'/26X,'PHYSL'/'0DIF=MEAS1-MEAS2',9X,
6' CREATE OR MODIFY VARIABLE: DIF SETTING IT'/
726X,'EQUAL TO VARIABLE: MEAS2 SUBTRACTED FROM'/
826X,'VARIABLE: MEAS2'/'0Z=(WT-MEAN(WT))/STD(WT) ',
9' CREATE OR MODIFY VARIABLE: Z BY SUBTRACTING'/
125X,' THE MEAN OF VARIABLE: WT FROM VARIABLE: WT'/
225X,' AND DIVIDING THAT BY THE STANDARD DEVIATION'/
325X,' FOR VARIABLE WT.'/
4'0IFG(#3-1)#3=LN(#3)'
57X,'IF THE QUANTITY VARIABLE NUMBER 3 MINUS 1 IS'/
626X,'GREATER THAN ZERO REPLACE VARIABLE NUMBER 3'/
726X,'WITH THE NATURAL LOGARITHM OF VARIABLE NUMBER'/
826X,'3'/'0CRIT=3.17+#4**(2+AGE*SQRT(7*#5))',
94X,'EXAMPLE OF COMPLEX TRANSFORMATION')
GO TO 1
9999 RETURN
END
C *** STAT PACK ***
C SUBROUTINE PART OF TRANS USED FOR CODEING EXPRESSIONS
C CALLING SEQUENCE: CALL CALC(LINE,N,M,K,L,INST,IVAR1,IVAR2,
C ITO,CONST,SV,NV,NAMES,IERRC)
C WHERE LINE - IS A VECTOR CONTAINING THE INSTRUCTION INPUT BY
C THE USER
C N - IS A POINTER INDICATING THE FIST POSITION IN LINE
C PREVIOUS TO THE EXPRESSION TO BE ANALYSED
C M - IS A POINTER INDICATING THE FIRST POSITION IN THE LINE
C AFTER THE EXPRESSION TO BE EVALUATED.
C K - IS A POINTER INDICATING WHERE CODING FOR THE NEXT
C INSTRUCTION IS TO BE PLACED IN INST.
C L - IS A POINTER INDICATING WHERE THE ANSWER FOR THE
C NEXT CALCULATION IS TO BE PLACED IN SV.
C INST - IS A VECTOR CONTAINING THE CALCULATIONS TO
C BE PERFORMED IN ORDER OF CALCULATION
C IVAR1 - IS A VECTOR CONTAINING ONE OF THE VARIABLES TO BE
C TO BE ACTED UPON BY THE CORRESPONDING INSTRUCTION
C IN INST. IF IVAR1 IS NEGATIVE ITS ABSOLUTE REFERS
C TO SV, IF ZERO TO THE CORRESPONDING CONST, IF
C POSITIVE TO A VARIABLE WITH THAT NUMBER.
C IVAR2 - IS A VECTOR CONTAINING ONE OF THE VARIABLES TO BE
C ACTED UPON BY THE CORRESPONDING INSTRUCTION IN
C INST. IF IVAR2 IS NEGATIVE ITS ABSOLUTE REFERS TO
C SV, IF ZERO TO THE CORRESPONDING CONST, IF POSITIVE
C TO THE VARIABLE WITH THAT NUMBER.
C ITO - IS A VECTOR CONTAINING THE ADDRESS OF SV WHERE EACH
C CORRESPONDING CALCULATION CALLED FOR IN INST ARE TO
C BE PLACED.
C CONST - IS A VECTOR CONTAINING THE CONSTANT VALUE
C (IF ONE WAS SPECIFIED) WHICH IS TO BE USED
C IN THE CALCULATION SPECIFIED IN THE CORRESPONDING
C INST. IF EITHER IVAR1 OR IVAR2 IS ZERO IT REFERS
C TO THE CONST.
C SV - IS A VECTOR WHERE SPECIAL VALUES ORE PLACED, OR RESULTS
C OF CERTAIN CALCULATIONS HELD. IT IS REFERED TO BY
C ITO; AND IVAR1 OR IVAR2 IF THEY ARE NEGATIVE
C NV - NUMBER OF VARIABLES ACTUALLY USED
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C IERRC - IS A WORD TO BE USED FOR RETURNING ERROR CODES
C
C HIERCHY IS THE SAME AS FORTRAN
C ROUTINE ALSO CALLS COMPD AND VARB
C
SUBROUTINE CALC (LINE,N,M,K,L,INST,IVAR1,IVAR2,ITO,CONST,SV,NV,NAM
1ES,IERRC)
DIMENSION LINE(1),INST(1),IVAR1(1),IVAR2(1),ITO(1),CONST(1),SV(1),
1NAMES(1)
DIMENSION IZ(2)
COMMON/TRNF/ITYPES(9)
EQUIVALENCE (IWORD,WORD)
1 IERRC=0
MA=0
MB=0
NA=N-1
2 NA=NA+1
IF (NA.GT.M) GO TO 4
IF (LINE(NA).EQ.'(') MA=NA+1
IF (LINE(NA).NE.')') GO TO 2
MB=NA-1
IF (MA.GT.0) GO TO 3
IERRC=1
RETURN
3 IF (MA.LE.MB) GO TO 4
IERRC=2
RETURN
4 KK=0
IF (MA.EQ.0) MA=N
IF (MB.EQ.0) MB=M
5 KK=KK+1
NZ=MA
GO TO (90,6,20,30,60) KK
90 NZ1=NZ
CALL COMPD (LINE,NZ,WORD,IDEF)
IF(IDEF.NE.-6) GO TO 5
INST(K)=6
IVAR1(K)=0
CONST(K)=0
CALL COMPD(LINE,NZ,WORD,IDEF)
IF(IDEF.LT.10) GO TO 91
SV(L)=-WORD
CONST(K)=SV(L)
INST(K)=99
GO TO 50
91 CALL VARB(IWORD,IERR,IV,NAMES,NV)
IF(IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
6 NZ1=NZ
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (NZ.GT.MB) GO TO 5
IF ((IDEF.NE.8).AND.(IDEF.NE.18)) GO TO 6
IF (LINE(NZ).NE.'*') GO TO 6
NZ=NZ+1
INST(K)=3
IF (IDEF.EQ.18) GO TO 12
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.EQ.0) GO TO 8
10 IERRC=IERR+3
RETURN
8 IVAR1(K)=IV
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.LE.0) GO TO 21
IF (IDEF.GT.9) GO TO 11
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
11 IVAR2(K)=0
CONST(K)=WORD
GO TO 50
12 CONST(K)=WORD
IVAR1(K)=0
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.LE.0) GO TO 21
IF (IDEF.GT.9) GO TO 14
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
14 INST(K)=99
SV(L)=CONST(K)**WORD
INST(K)=99
CONST(K)=SV(L)
GO TO 50
C
C DIVIDE MULTIPLY HIERACHY
C
20 NZ1=NZ
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (NZ.GT.MB) GO TO 5
IF ((IDEF.NE.8).AND.(IDEF.NE.18).AND.(IDEF.NE.7).AND.(IDEF.NE.17))
1GO TO 20
IF ((IDEF.EQ.8).OR.(IDEF.EQ.18)) INST(K)=8
IF ((IDEF.EQ.7).OR.(IDEF.EQ.17)) INST(K)=7
IF (IDEF.GT.9) GO TO 24
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR1(K)=IV
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.GT.0) GO TO 22
21 IERRC=7
RETURN
22 IF (IDEF.GT.9) GO TO 23
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
23 IVAR2(K)=0
CONST(K)=WORD
IF (WORD.NE.0) GO TO 50
IERRC=8
RETURN
24 CONST(K)=WORD
IVAR1(K)=0
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.LE.0) GO TO 21
IF (IDEF.GT.9) GO TO 25
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
25 IF (INST(K).EQ.8) SV(L)=CONST(K)*WORD
IF ((INST(K).NE.7).OR.(WORD.NE.0)) GO TO 26
IERRC=8
RETURN
26 IF (INST(K).EQ.7) SV(L)=CONST(K)/WORD
INST(K)=99
CONST(K)=SV(L)
GO TO 50
C
C ADD SUBTRACT HIERACHY
C
30 NZ1=NZ
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (NZ.GT.MB) GO TO 5
IF ((IDEF.NE.5).AND.(IDEF.NE.15).AND.(IDEF.NE.6).AND.(IDEF.NE.16))
1 GO TO 30
IF ((IDEF.EQ.5).OR.(IDEF.EQ.15)) INST(K)=5
IF ((IDEF.EQ.6).OR.(IDEF.EQ.16)) INST(K)=6
IF (IDEF.GT.9) GO TO 34
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR1(K)=IV
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.LE.0) GO TO 21
IF (IDEF.GT.9) GO TO 33
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
33 IVAR2(K)=0
CONST(K)=WORD
GO TO 50
34 CONST(K)=WORD
IVAR1(K)=0
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.LE.0) GO TO 21
IF (IDEF.GT.9) GO TO 35
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR2(K)=IV
GO TO 50
35 IF (INST(K).EQ.5) SV(L)=CONST(K)+WORD
IF (INST(K).EQ.6) SV(L)=CONST(K)-WORD
CONST(K)=SV(L)
INST(K)=99
GO TO 50
50 ITO(K)=L
ENCODE (2,51,IWORD) L
51 FORMAT (I2)
DECODE (2,52,WORD) IZ
52 FORMAT (2A1)
NZ2=NZ1
IDIF=0
IF(L.GT.9) IDIF=1
IDIF=NZ-NZ1-3-IDIF
IF(IDIF.EQ.0) GO TO 85
IF(IDIF.GT.0) GO TO 82
DO 81 I=80+IDIF,NZ-1,-1
81 LINE(I-IDIF)=LINE(I)
GO TO 85
82 DO 83 I=NZ-1,80
83 LINE(I-IDIF)=LINE(I)
DO 84 I=81-IDIF,80
84 LINE(I)=' '
GO TO 85
85 MB=MB-IDIF
M=M-IDIF
LINE (NZ1)="771004020100
NZ1=NZ1+1
IF (IZ(1).EQ.' ') GO TO 53
LINE (NZ1)=IZ(1)
NZ1=NZ1+1
53 LINE (NZ1)=IZ(2)
NZ1=NZ1+1
57 L=L+1
IF (L.GT.99) PAUSE 'PROBLEM'
NZ=NZ2
K=K+1
IF (K.LE.25) GO TO 56
IERRC=9
RETURN
56 GO TO (5,6,20,30) KK
60 NZ=MA
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (NZ.GT.MB) GO TO 62
61 IERRC=10
RETURN
62 IF ((MA.EQ.N).AND.(MB.EQ.M)) RETURN
IF ((IDEF.EQ.2).OR.(IDEF.EQ.12)) GO TO 63
IERRC=11
RETURN
63 IF ((LINE(NZ).EQ.'+').OR.(LINE(NZ).EQ.'-').OR.(LINE(NZ).EQ.'*').OR
1.(LINE(NZ).EQ.'/').OR.(LINE(NZ).EQ.' ').OR.(LINE(NZ).EQ.')'))
2 GO TO 64
IERRC=13
RETURN
64 MA=MA-1
IF (LINE(MA).EQ.'(') GO TO 65
IERRC=12
RETURN
65 MA=MA-1
DO 70 I=1,9
IF (LINE(MA).NE.ITYPES(I)) GO TO 70
IF (I.NE.3) GO TO 66
IERRC=14
RETURN
66 IF (I.NE.4) GO TO 58
IF(MA.LT.N) GO TO 58
IERRC=15
RETURN
58 IF(I.NE.2) GO TO 67
IERRC=13
RETURN
67 DO 68 J=MA+2,80
68 LINE (J-1)=LINE(J)
LINE (80)=' '
DO 69 J=NZ-1,80
69 LINE (J-1)=LINE(J)
LINE (80)=' '
M=M-2
GO TO 1
70 CONTINUE
71 MA=MA-1
IF (MA.GT.0) GO TO 72
IERRC=16
RETURN
72 DO 7 I=1,9
IF (LINE(MA).NE.ITYPES(I)) GO TO 7
IF ((I.GE.4).AND.(I.LE.8)) GO TO 73
IF(I.EQ.1) GO TO 73
IERRC=17
RETURN
7 CONTINUE
GO TO 71
73 NZ=MA+1
CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.NE.1) PAUSE 'NONONO'
INST(K)=0
IF (WORD.EQ.'SQRT') INST(K)=10
IF (WORD.EQ.'LN') INST(K)=11
IF (WORD.EQ.'EXP') INST(K)=12
IF (WORD.EQ.'LOG10') INST(K)=13
IF (WORD.EQ.'SIN') INST(K)=14
IF (WORD.EQ.'COS') INST(K)=15
IF (WORD.EQ.'MEAN') INST(K)=16
IF (WORD.EQ.'STD') INST(K)=17
IF (WORD.EQ.'ARCTN') INST(K)=18
IF (WORD.EQ.'ARCSN') INST(K)=19
IF(WORD.EQ.'ABS') INST(K)=20
IF(WORD.EQ.'RAN') INST(K)=28
IF(WORD.EQ.'NORM') INST(K)=29
IF (INST(K).NE.0) GO TO 74
IERRC=18
RETURN
74 CALL COMPD (LINE,NZ,WORD,IDEF)
IF (IDEF.EQ.12) GO TO 75
CALL VARB (IWORD,IERR,IV,NAMES,NV)
IF (IERR.NE.0) GO TO 10
IVAR1(K)=IV
IF ((INST(K).NE.16).AND.(INST(K).NE.17)) GO TO 77
IF (IVAR1(K).GT.0) GO TO 77
IERRC=19
RETURN
75 IF (INST(K).EQ.10) SV(L)=SQRT(WORD)
IF (INST(K).EQ.11) SV(L)=ALOG(WORD)
IF (INST(K).EQ.12) SV(L)=EXP(WORD)
IF (INST(K).EQ.13) SV(L)=ALOG10(WORD)
IF (INST(K).EQ.14) SV(L)=SIN(WORD)
IF (INST(K).EQ.15) SV(L)=COS(WORD)
IF ((INST(K).NE.16).AND.(INST(K).NE.17)) GO TO 76
IERRC=19
RETURN
76 IF (INST(K).EQ.18) SV(L)=ATAN(WORD)
IF (INST(K).EQ.19) SV(L)=ASIN(WORD)
IF((INST(K).EQ.20).AND.(WORD.GE.0)) SV(L)=WORD
IF((INST(K).EQ.20).AND.(WORD.LT.0)) SV(L)=-WORD
IF((INST(K).EQ.28).OR.(INST(K).EQ.29)) GO TO 77
INST(K)=99
CONST(K)=SV(L)
77 ITO(K)=L
ENCODE (2,51,WORD) L
DECODE (2,52,WORD) IZ
NZ1=MA+1
LINE (NZ1)="771004020100
NZ1=NZ1+1
IF (IZ(1).EQ.' ') GO TO 78
LINE (NZ1)=IZ(1)
NZ1=NZ1+1
78 LINE (NZ1)=IZ(2)
NZ1=NZ1+1
IDIF=NZ-NZ1
DO 79 I=NZ,80
79 LINE (I-IDIF)=LINE(I)
DO 80 I=81-IDIF,80
80 LINE (I)=' '
M=M-IDIF
L=L+1
IF (L.GT.99) PAUSE 'PROB1'
K=K+1
IF (K.LE.25) GO TO 1
IERRC=9
RETURN
END
C *** STAT PACK ***
C SUBROUTINE PART OF TRANS USED TO RETURN VARIABLE
C CALLING SEQUENCE: CALL VARB(IWORD,IERR,IV,NAMES,NV)
C WHERE IWORD - IS THE VARIBLE NAME SENT
C IERR - IS ZERO IF THE NAME EXISTS,OR IF ITS A LEGAL
C VARIABLE NUMBER (PRECEDED BY #), OR IF ITS A
C SPECIAL VALUE (PRECEDED BY OCTAL 771004020100)
C (IN WHICH CASE IV IS NEGATIVE WHEN RETURNED).
C IF WORD IS NOT LEGAL: NOT PRECEDED BY # OR OCTAL
C 771004020100 THEN ERROR IS SET TO 1. IF A # IS NOT
C FOLLOWED BY A NUMBER, IERR IS SET TO 2
C AND IF WORD IS A VARIABLE NUMBER OUTSIDE THE LEGAL
C RANGE ERR=3.
C IV - VARIABLE NUMBER IS RETURNED HERE. A NEGATIVE NUMBER
C INDICATES THE VARIABLE IS SPECIAL (SV)
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES.
C NV - NUMBER OF VARIABLES ACTUALLY USED.
C
SUBROUTINE VARB (IWORD,IERR,IV,NAMES,NV)
DIMENSION NAMES(1),TAKPT(5)
IERR=0
IV=0
DO 1 I=1,NV
IF (IWORD.NE.NAMES(I)) GO TO 1
IV=I
GO TO 13
1 CONTINUE
DO 100 I=1,5
100 TAKPT(I)=' '
DECODE (5,2,IWORD) TAKPT
2 FORMAT (5A1)
IF (TAKPT(1).NE.'#') GO TO 8
TAKPT(1)=' '
IF (TAKPT(2).NE.' ') GO TO 3
IERR=2
GO TO 13
3 IF (TAKPT(5).NE.' ') GO TO 5
DO 4 I=4,1,-1
4 TAKPT(I+1)=TAKPT(I)
GO TO 3
5 ENCODE (5,2,IWORD) TAKPT
DECODE (5,6,IWORD) IV
6 FORMAT (I5)
IF ((IV.GE.1).AND.(IV.LE.NV)) GO TO 13
IERR=3
GO TO 13
8 IF (TAKPT(1).NE."771004020100) GO TO 12
TAKPT(1)=' '
9 IF (TAKPT(5).NE.' ') GO TO 11
DO 10 I=4,1,-1
10 TAKPT(I+1)=TAKPT(I)
GO TO 9
11 ENCODE (5,2,IWORD) TAKPT
DECODE (5,6,IWORD) IV
IV=-IV
GO TO 13
12 IERR=1
13 RETURN
END
C *** STAT PACK ***
C SUBROUTINE PART OF TRANS USED TO RETURN NEXT VALUE AND OPERATION
C CALLING SEQUENCE: CALL COMPD(LINE,N,WORD,IDEF)
C WHERE LINE - IS A VECTOR CONTAINING THE INSTRUCTION TYPE IN
C BY THE USER.
C N - IS A POINTER POINTING TO NEXT CHARACTER IN LINE
C WORD - RETURN EITHER THE NEXT VARIABLE OR THE CONSTANT VALUE
C IDEF - RETURNS THE NEXT OPERATION. IF LESS THAN 10
C ITS AN OPERATION ON A VARIABLE, IF GREATER THAN 10
C ITS AN OPERATION ON A CONSTANT.
C
SUBROUTINE COMPD (LINE,N,WORD,IDEF)
DIMENSION LINE(1),ICHAR(15),COMP(3)
COMMON/TRNF/ITYPES(9)
DO 1 I=1,15
1 ICHAR(I)=' '
COMP(1)=0
L=1
NUM=0
IF(LINE(N).EQ.'.') NUM=1
IF ((LINE(N).LT.'0').OR.(LINE(N).GT.'9')) GO TO 2
NUM=1
GO TO 4
2 DO 3 I=1,9
IF (ITYPES(I).NE.LINE(N)) GO TO 3
IDEF=I
IF (NUM.EQ.1) IDEF=IDEF+10
GO TO 7
3 CONTINUE
4 IF (NUM.NE.1) GO TO 5
IF ((LINE(N).GE.'0').AND.(LINE(N).LE.'9')) GO TO 5
IF(LINE(N).EQ.'.') GO TO 5
IDEF=80
GO TO 7
5 IF (L.GT.15) GO TO 6
ICHAR(L)=LINE(N)
L=L+1
6 N=N+1
IF (N.LT.80) GO TO 2
IDEF=9
IF (NUM.EQ.1) IDEF=19
7 ENCODE (15,8,COMP) ICHAR
8 FORMAT (15A1)
IF (L.GT.1) GO TO 9
IDEF=-IDEF
WORD=0
GO TO 12
9 IF (NUM.NE.1) GO TO 11
DECODE (15,10,COMP) WORD
10 FORMAT (F)
GO TO 12
11 WORD=COMP(1)
12 N=N+1
RETURN
END