Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50520/stp18.stp
There are no other files named stp18.stp in the archive.
C **** STAT PACK ****
C SUBROUTINE FOR SHADE DIAGRAMS.
C CALLING SEQUENCE: CALL SHADE(NV,NC,MV,MC,DATA,IAV,IAH,NAMES)
C WHERE NV - NUMBER OF VARIABLES IN THE DATA
C NC - NUMBER OF OBSERVATIONS IN THE DATA
C MV - MAXIMUM NUMBER OF VARIABLES POSSIBLE
C MC - MAXIMUM NUMBER OF OBSERVATIONS POSSIBLE
C DATA - MATRIX CONTAINING DATA
C IAH - EXTRA VECTOR AT LEAST NC LONG
C IAV - EXTRA VECTOR AT LEAST NC LONG
C NAMES - VECTOR CONTAINING VARIABLE NAMES
C
C ROUTINE CREATES A SHADE DIAGRAM FROM DATA LOCATED IN A
C PLOTTING VARIABLE, WHOSE AXIS IS DETERMINED BY TWO OTHER VARIABLES
C THE DARKER THE SHADING, THE LARGER THE VALUE OF THE PLOTTING
C VARIABLE. UP TO 3 LINES OF OVERPRINT ARE NECESSARY FOR SOME PARTS
C OF THE GRAPH, THUS OUTPUT TO CRT'S IS NOT POSSIBLE. WHEN
C TWO OR MORE OBSERVATIONS REFERENCE THE SAME GRID THE VALUES OF
C THE DATA BEING PLOTTED IS AVERAGED. IF THE USER DESIRES THE DATA
C MAY BE SIMPLY ADDED AND PLOTTED. ZOOMX IS A METHOD FOR ZOOMING
C IN ON A PARTICULAR PORTION OF THE GRAPH. THE USER SPECIFIES THE
C COORDINATES TO BE USED AS THE CENTER OF THE GRAPH, AND THE INCREASE
C IN SIZE. ALL OTHER ENTRIES MUST REMAIN THE SAME, THAT IS IF A
C USER HAS ASKED FOR COORD BEFOR AND NOW WISHES TO BLOW UP A
C PORTION OF THAT GRAPH HE WILL AGAIN HAVE TO USE THE
C COORD OPTION. THIS ROUTINE SUGGESTED
C FOR INCLUSION IN STP BY RICK SACKS, FACULTY STAFF CONSULTANT
C (TOOK SAM ANEMA'S PLACE).
C
SUBROUTINE SHADE(NV,NC,MV,MC,DATA,IAV,IAH,NAMES)
DIMENSION COORD(2,2),ZCOOR(2),LEGND(5,3),VALLEG(5)
DIMENSION DATA(MC,MV),NAMES(1),OPTL(10),OPTR(5),METHD(2,2)
DIMENSION IV(50),IVAX(2),INPUT(50),IVAL(15),VAL1(3)
DIMENSION LOUT(81),XSUM(81),N(81),IAV(1),IAH(1)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON /EXTRA/ HEDR(70),NSZ
DATA LEGND/'.','+','O','X','B',2*' ','=','+','K',4*' ','*'/
DATA MINUS,PLUS/'-','+'/
DATA METHD/'(ADDI','TIVE)','(AVER','AGE)'/
1 DO 2 I=1,5
2 OPTR(I)=0
IF(ICC.NE.2) WRITE(IDLG,3)
3 FORMAT(' ENTER OPTIONS? ',$)
READ(ICC,4,END=9999) OPTL
4 FORMAT(10(A5,1X))
DO 5 I=1,5
IF(OPTL(I).EQ.'!') RETURN
IF(OPTL(I).EQ.' ') GO TO 20
IF(OPTL(I).NE.'HELP') GO TO 7
WRITE(IDLG,6)
6 FORMAT(' THE SHADE COMMAND CREATES A SHADED MAP GRAPH. THE'/
1' RANGE OF THE X AND Y COORDINATES TO APPEAR ON THE MAP WILL'/
1' NORMALLY BE CALCULATED FROM THE DATA. SHADING WILL ALSO BE'/
1' DETERMINED FROM THE DATA. WHERE MORE THAN 2 OBSERVATIONS'/
1' ADDRESS THE SAME GRID, THE RESULTS WILL BE AVERAGED.'/
1' OPTIONS AVAILABLE ARE:'/
1' COORD - USER SPECIFIED COORDINATES TO BE MAPPED'/
1' LEGND - USER SPECIFIED VALUES FOR DIFFERENT SHADINGS'/
1' ZOOMX - USER SPECIFIES COORDINATES TO BE USED AS THE CENTER'/
1' OF THE GRAPH, AND THE TIMES THE GRAPH IS TO BE'/
1' ENLARGED.'/
1' ADDED - RATHER THAN AVERAGE OBSERVATIONS ADDRESSING THE'/
1' SAME GRID, ADD THEM TOGETHER.'/
1'0ENTER OPTIONS DESIRED SEPARATED BY COMMAS. IF NO OPTIONS ARE'/
1' DESIRED TYPE A CARRIAGE RETURN.'/
1' NOTE: SHADE DIAGRAMS ARE NOT POSSIBLE ON CRT TYPE TERMINALS')
GO TO 1
7 IF(OPTL(I).NE.'COORD') GO TO 8
OPTR(1)=1
GO TO 5
8 IF(OPTL(I).NE.'LEGND') GO TO 9
OPTR(2)=1
GO TO 5
9 IF(OPTL(I).NE.'ZOOMX') GO TO 10
OPTR(3)=1
GO TO 5
10 IF(OPTL(I).NE.'ADDED') GO TO 11
OPTR(4)=1
GO TO 5
11 WRITE(IDLG,13) OPTL(I)
13 FORMAT(' OPTION "',A5,'" DOES NOT EXIST')
GO TO 1
5 CONTINUE
C
20 IF(ICC.NE.2) WRITE(IDLG,21)
21 FORMAT(' WHICH VARIABLE IS THE HORIZONTAL AXIS? ',$)
CALL ALPHA(IVAX(1),1,I,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 20
IF(I.NE.1) GO TO 20
IF(IHELP.NE.1) GO TO 23
WRITE(IDLG,22)
22 FORMAT(' ENTER THE VARIABLE TO BE USED AS THE X AXIS FOR THE'/
1' SHADE DIAGRAM. THE VARIABLE MAY BE SPECIFIED BY VARIABLE NAME'/
1' OR NUMBER. ONLY 1 VARIABLE MAY BE USED, AND * IS NOT VALID.')
GO TO 20
23 IF(ICC.NE.2) WRITE(IDLG,24)
24 FORMAT(' WHICH VARIABLE IS THE VERTICAL AXIS? ',$)
CALL ALPHA(IVAX(2),1,I,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 23
IF(IHELP.NE.1) GO TO 33
WRITE(IDLG,25)
25 FORMAT(' ENTER THE VARIABLE TO BE USED AS THE Y AXIS'/
1'FOR THE SHADE DIAGRAM. THE VARIABLE MAY BE SPECIFIED'/
1' BY VARIABLE NAME OR NUMBER. ONLY 1 VARIABLE MAY BE USED, AND'/
1' * IS NOT VALID.')
GO TO 23
33 IF(IVAX(1).NE.IVAX(2)) GO TO 26
WRITE(IDLG,34)
34 FORMAT(' THE SAME VARIABLE MAY NOT BE USED FOR BOTH AXIS'/)
GO TO 20
26 IF(ICC.NE.2) WRITE(IDLG,27)
27 FORMAT(' WHICH VARIABLES ARE TO BE PLOTTED? ',$)
CALL ALPHA(IV,NV,NIND,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 26
IF(IHELP.NE.1) GO TO 29
WRITE(IDLG,28)
28 FORMAT(' ENTER THE VARIABLES TO BE PLOTTED SEPARATED BY COMMAS.'/
1' VARIABLES MAY BE SPECIFIED BY VARIABLE NAME OR NUMBER.'/
1' RANGES OF VARIABLES MAY BE INDICATED BY ENTERING THE EXTREMES'/
1' OF THE RANGE SEPARATED BY A "-". IF A SHADE DIAGRAM IS TO BE'/
1' CREATED FOR EACH VARIABLE, A "*" OR "ALL" MAY BE USED.'/
1' NEITHER OF THE COORDINATE VARIABLES MAY BE USED AS A'/
1' VARIABLE TO BE PLOTTED, IF EITHER IS SPECIFIED IT WILL BE'/
1' ELIMINATED.')
GO TO 26
29 IALL=0
DO 30 I=1,NIND
IF(IV(I).LT.0) GO TO 31
30 CONTINUE
GO TO 40
31 IALL=1
NIND=NV
C
C COORDINATED FOR SYSTEM
C
40 IF(OPTR(1).NE.1) GO TO 100
DO 41 I=1,2
45 WRITE(IDLG,42) NAMES(IVAX(I))
42 FORMAT(' ENTER THE RANGE OF COORDINATES FOR ',A5,'? ',$)
READ(ICC,43,END=9999) INPUT
43 FORMAT(50A1)
IF(INPUT(1).EQ.'!') RETURN
IF((INPUT(1).NE.'H').OR.(INPUT(2).NE.'E').OR.(INPUT(3).NE.'L').
1OR.(INPUT(4).NE.'P')) GO TO 46
WRITE(IDLG,44)
44 FORMAT(' ENTER MAXIMUM AND MINIMUM COORDINATES SEPARATED BY A'/
1' COMMA.')
GO TO 45
46 LL=1
J=1
48 DO 47 K=1,15
47 IVAL(K)=' '
K=1
IEXP=0
IDP=0
49 IF(INPUT(J).EQ.' ') GO TO 65
IF(INPUT(J).EQ.'E') GO TO 55
IF(INPUT(J).EQ.'-') GO TO 57
IF(INPUT(J).EQ.',') GO TO 65
IF(INPUT(J).EQ.'.') GO TO 53
IF((INPUT(J).LE.'9').AND.(INPUT(J).GE.'0')) GO TO 51
WRITE(IDLG,50) INPUT(J)
50 FORMAT(' ILLEGAL CHARACTER "',A1,'" IN NUMBER')
GO TO 45
51 IF(K.GT.15) GO TO 69
IVAL(K)=INPUT(J)
K=K+1
J=J+1
GO TO 49
69 WRITE(IDLG,52)
52 FORMAT(' VALUE TOO LONG OR COMMA MISSING')
GO TO 45
53 IDP=IDP+1
IF(IDP.EQ.1) GO TO 51
WRITE(IDLG,54)
54 FORMAT(' ONLY 1 DECIMLE POINT PER NUMBER')
GO TO 45
55 IEXP=IEXP+1
IF(IEXP.EQ.1) GO TO 51
WRITE(IDLG,56)
56 FORMAT(' ONLY 1 EXPONENT PER NUMBER')
GO TO 45
57 IF((K.EQ.1).OR.(IVAL(K-1).EQ.'E')) GO TO 51
WRITE(IDLG,58)
58 FORMAT(' MINUS MUST BE FIRST CHARACTER OF NUMBER')
GO TO 45
65 IF(K.EQ.1) GO TO 64
59 IF(IVAL(15).NE.' ') GO TO 61
DO 60 K=15,2,-1
60 IVAL(K)=IVAL(K-1)
IVAL(1)=' '
GO TO 59
61 ENCODE(15,43,VAL1)IVAL
DECODE(15,62,VAL1) COORD(I,LL)
62 FORMAT(F15.0)
IF((INPUT(J).EQ.' ').AND.(LL.EQ.2)) GO TO 70
IF((INPUT(J).EQ.',').AND.(LL.EQ.1)) GO TO 68
IF(INPUT(J).NE.' ') GO TO 66
64 WRITE(IDLG,63)
63 FORMAT(' MINIMUM AND MAXIMUM MUST BE SEPARATED BY A COMMA')
GO TO 45
66 WRITE(IDLG,67)
67 FORMAT(' SECOND VALUE SHOULD BE ENDED WITH A RETURN')
GO TO 70
68 LL=2
J=J+1
GO TO 48
70 IF(COORD(I,1).LT.COORD(I,2)) GO TO 41
SAVE=COORD(I,1)
COORD(I,1)=COORD(I,2)
COORD(I,2)=SAVE
41 CONTINUE
C
C
C
100 IF(OPTR(3).NE.1) GO TO 150
IF(ICC.NE.2) WRITE(IDLG,101)
101 FORMAT(' ENTER X,Y COORDINATES FOR CENTER OF GRAPH? ',$)
READ(ICC,43,END=9999) INPUT
IF(INPUT(1).EQ.'!') RETURN
IF((INPUT(1).NE.'H').OR.(INPUT(2).NE.'E').OR.(INPUT(3).NE.'L').
1OR.(INPUT(4).NE.'P')) GO TO 103
WRITE(IDLG,102)
102 FORMAT(' ENTER X AND Y COORDINATEDS SEPARATED BY A COMMA.'/
1' THIS POINT WILL BE USED AS THE CENTER FOCAL POOINT FOR'/
1' ZOOMING IN.')
GO TO 100
103 LL=1
J=1
104 DO 105 K=1,15
105 IVAL(K)=' '
K=1
IEXP=0
IDP=0
106 IF(INPUT(J).EQ.' ') GO TO 112
IF(INPUT(J).EQ.'E') GO TO 110
IF(INPUT(J).EQ.'-') GO TO 111
IF(INPUT(J).EQ.',') GO TO 112
IF(INPUT(J).EQ.'.') GO TO 109
IF((INPUT(J).LE.'9').AND.(INPUT(J).GE.'0')) GO TO 107
WRITE(IDLG,50) INPUT(J)
GO TO 100
107 IF(K.GT.15) GO TO 108
IVAL(K)=INPUT(J)
K=K+1
J=J+1
GO TO 106
108 WRITE(IDLG,52)
GO TO 100
109 IDP=IDP+1
IF(IDP.EQ.1) GO TO 107
WRITE(IDLG,54)
GO TO 100
110 IEXP=IEXP+1
IF(IEXP.EQ.1) GO TO 107
WRITE(IDLG,56)
GO TO 100
111 IF((K.EQ.1).OR.(IVAL(K-1).EQ.'E')) GO TO 51
WRITE(IDLG,58)
GO TO 100
112 IF(K.EQ.1) GO TO 117
113 IF(IVAL(15).NE.' ') GO TO 115
DO 114 K=15,2,-1
114 IVAL(K)=IVAL(K-1)
IVAL(1)=' '
GO TO 113
115 ENCODE(15,43,VAL1) IVAL
DECODE(15,62,VAL1) ZCOOR(LL)
IF((INPUT(J).EQ.' ').AND.(LL.EQ.2)) GO TO 130
IF((INPUT(J).EQ.',').AND.(LL.EQ.1)) GO TO 119
IF(INPUT(J).NE.' ') GO TO 118
117 WRITE(IDLG,116)
116 FORMAT(' COORDINATES MUST BE SEPARATED BY A COMMA')
GO TO 100
118 WRITE(IDLG,67)
GO TO 130
119 LL=2
J=J+1
GO TO 104
C
130 IF(ICC.NE.2) WRITE(IDLG,131)
131 FORMAT(' HOW MANY TIMES INCREASE IN SIZE? ',$)
READ(ICC,43,END=9999) IVAL
IF(IVAL(1).EQ.'!') RETURN
IF((IVAL(1).NE.'H').OR.(IVAL(2).NE.'E').OR.(IVAL(3).NE.'L').
1OR.(IVAL(4).NE.'P')) GO TO 133
WRITE(IDLG,132)
132 FORMAT(' ENTER THE VALUE TO BE USED TO MULTIPLY THE SIZE OF THE'/
1' GRAPH BY. AS THE SIZE INCREASES SO WILL THE RESOLUTION.'/
1' ALL OTHER ENTRIES MUST REMAIN THE SAME TO ACHIVE A TRUE'/
1' INCREASE IN SIZE.')
GO TO 130
133 J=1
IEXP=0
IDP=0
134 IF(IVAL(J).EQ.' ') GO TO 140
IF(IVAL(J).EQ.'E') GO TO 136
IF(IVAL(J).EQ.'-') GO TO 138
IF(IVAL(J).EQ.'.') GO TO 137
IF((IVAL(J).LE.'9').AND.(IVAL(J).GE.'0')) GO TO 135
WRITE(IDLG,50) IVAL(J)
GO TO 130
135 J=J+1
IF(J.LE.15) GO TO 134
GO TO 140
136 IEXP=IEXP+1
IF(IEXP.EQ.1) GO TO 135
WRITE(IDLG,56)
GO TO 130
137 IDP=IDP+1
IF(IDP.EQ.1) GO TO 135
WRITE(IDLG,54)
GO TO 130
138 IF(IVAL(J-1).EQ.'E') GO TO 135
141 WRITE(IDLG,139)
139 FORMAT(' ZOOM FACTOR MUST BE POSITIVE')
GO TO 130
140 IF(J.EQ.1) GO TO 141
144 IF(IVAL(15).NE.' ') GO TO 142
DO 143 J=14,1,-1
143 IVAL(J+1)=IVAL(J)
IVAL(1)=' '
GO TO 144
142 ENCODE(15,43,VAL1) IVAL
DECODE(15,62,VAL1) ZOOMX
C
C LEGEND
C
150 IF(OPTR(2).NE.1) GO TO 200
IF(ICC.NE.2) WRITE(IDLG,161)
161 FORMAT(' ENTER MINIMUM VALUE FOR EACH LEGEND AFTER IT'/)
DO 162 I=1,5
180 IF(ICC.EQ.2) GO TO 167
J=1
163 IF(LEGND(I,J).EQ.' ') GO TO 165
WRITE(IDLG,164) LEGND(I,J)
164 FORMAT('+',A1)
J=J+1
GO TO 163
165 WRITE(IDLG,166)
166 FORMAT('+ ? ',$)
167 READ(ICC,43,END=9999) IVAL
IF(IVAL(1).EQ.'!') RETURN
IF((IVAL(1).NE.'H').OR.(IVAL(2).NE.'E').OR.(IVAL(3).NE.'L').
1OR.(IVAL(4).NE.'P')) GO TO 169
WRITE(IDLG,168)
168 FORMAT(' ENTER THE MINIMUM VALUE TO BE USED FOR EACH SYMBOL.')
GO TO 180
169 IEXP=0
IDP=0
DO 170 J=1,15
IF(IVAL(J).EQ.'E') GO TO 171
IF(IVAL(J).EQ.'-') GO TO 172
IF(IVAL(J).EQ.'.') GO TO 173
IF(IVAL(J).EQ.' ') GO TO 175
IF((IVAL(J).LE.'9').AND.(IVAL(J).GE.'0')) GO TO 170
WRITE(IDLG,50) IVAL(J)
GO TO 180
171 IEXP=IESP+1
IF(IESXP.EQ.1) GO TO 170
WRITE(IDLG,56)
GO TO 180
172 IF((J.EQ.1).OR.(IVAL(J-1).EQ.'E')) GO TO 170
WRITE(IDLG,58)
GO TO 180
173 IDP=IDP+1
IF(IDP.EQ.1) GO TO 170
WRITE(IDLG,54)
GO TO 180
170 CONTINUE
175 IF(J.EQ.1) GO TO 178
176 IF(IVAL(15).NE.' ') GO TO 178
DO 177 J=15,2,-1
177 IVAL(J)=IVAL(J-1)
IVAL(1)=' '
GO TO 176
178 ENCODE(15,43,VAL1) IVAL
DECODE(15,62,VAL1) VALLEG(I)
162 CONTINUE
C
C NOW BEGIN ANALYSIS
C
200 IHD=40
IVD=24
IDIV=4
IF(IOUT.NE.21) GO TO 201
IHD=80
IVD=48
IDIV=8
201 IF(OPTR(1).EQ.1) GO TO 203
C
C
C
COORD(1,1)=DATA(1,IVAX(1))
COORD(1,2)=DATA(1,IVAX(1))
COORD(2,1)=DATA(1,IVAX(2))
COORD(2,2)=DATA(1,IVAX(2))
DO 202 I=2,NC
DO 202 J=1,2
IF(DATA(I,IVAX(J)).LT.COORD(J,1)) COORD(J,1)=DATA(I,IVAX(J))
IF(DATA(I,IVAX(J)).GT.COORD(J,2)) COORD(J,2)=DATA(I,IVAX(J))
202 CONTINUE
203 DBD=(COORD(1,2)-COORD(1,1))/IDIV
DBDV=(COORD(2,2)-COORD(2,1))/IDIV
IF(DBDV.GT.DBD) DBD=DBDV
DINC=DBD
IF(OPTR(1).EQ.1) GO TO 207
C
Z=ALOG10(DBD)
M=Z
B=Z-M
IF(B.GE.0) GO TO 204
M=M-1
B=B+1
204 C=10.**B
IF(C.LE.10) DINC=10
IF(C.LE.5) DINC=5
IF(C.LE.2) DINC=2
IF(C.LE.1) DINC=1
DINC=DINC*10.**M
C
207 IF(OPTR(3).NE.1) GO TO 500
DINC=DINC/ZOOMX
X=IDIV/2.
COORD(1,1)=ZCOOR(1)-X*DINC
COORD(1,2)=ZCOOR(1)+DINC*X
COORD(2,1)=ZCOOR(2)-X*DINC
COORD(2,2)=ZCOOR(2)+X*DINC
C
500 IF(OPTR(1).EQ.1) GO TO 206
I=COORD(1,1)/DINC
IF(COORD(1,1).LT.0) I=I-1
XBG=I*DINC
IF(COORD(1,2).GT.(XBG+IDIV*DINC)) GO TO 205
COORD(1,1)=XBG
205 I=COORD(2,1)/DINC
IF(COORD(2,1).LT.0) I=I-1
YBG=I*DINC
IF(COORD(2,2).GT.(YBG+IDIV*DINC)) GO TO 206
COORD(2,1)=YBG
206 DINCH=DINC/10
DINCV=DINC/6
DO 210 I=1,NC
IAH(I)=(DATA(I,IVAX(1))-COORD(1,1))/DINCH+1.
IAV(I)=(DATA(I,IVAX(2))-COORD(2,1))/DINCV+1
210 CONTINUE
C
C NOW BEGIN CREATING THE GRAPH
C
DO 300 II=1,NIND
IVB=II
IF(IALL.EQ.0) IVB=IV(II)
IF(IOUT.EQ.21) CALL PRNTHD
IF(IOUT.NE.21) WRITE(IOUT,5566) (HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
I=OPTR(4)
IF(I.NE.1) I=2
WRITE(IOUT,301) NAMES(IVB),(METHD(J,I),J=1,2),NAMES(IVAX(1)),
1NAMES(IVAX(2))
301 FORMAT(11X,'****** SHADE DIAGRAM ******'/
1'0THE VARIABLE PLOTTED IS ',A5,1X,2A5/
1' HORIZONTAL AXIS IS ',A5,', AND VERTICAL AXIS IS ',A5/)
WRITE(IOUT,302) MINUS,PLUS,((MINUS,J=1,9),PLUS,I=1,IDIV),MINUS
302 FORMAT(2X,95A1)
LINES=9
DO 303 I=1,IVD+1
DO 304 J=1,IHD+1
XSUM(J)=0
304 N(J)=0
DO 305 J=1,NC
IF(IAV(J).NE.I) GO TO 305
LAH=IAH(J)
IF((LAH.LT.1).OR.(LAH.GT.(IHD+1))) GO TO 305
XSUM(LAH)=XSUM(LAH)+DATA(J,IVB)
N(LAH)=N(LAH)+1
305 CONTINUE
IF(OPTR(4).EQ.1) GO TO 307
DO 306 J=1,IHD+1
IF(N(J).EQ.0) GO TO 306
XSUM(J)=XSUM(J)/N(J)
306 CONTINUE
307 IF(I.NE.1) GO TO 308
VMAX=XSUM(1)
VMIN=XSUM(1)
308 DO 309 J=1,IHD+1
IF(N(J).EQ.0) GO TO 309
IF(VMAX.LT.XSUM(J)) VMAX=XSUM(J)
IF(VMIN.GT.XSUM(J)) VMIN=XSUM(J)
309 CONTINUE
303 CONTINUE
IF(OPTR(2).EQ.1) GO TO 342
RANGE=(VMAX-VMIN)/5
VALLEG(1)=VMIN
DO 341 I=2,5
341 VALLEG(I)=VALLEG(I-1)+RANGE
342 IF(VMAX.LT.VALLEG(5)) VMAX=VALLEG(5)
C
340 DO 310 I=IVD+1,1,-1
IF(I.EQ.40) WRITE(IOUT,400)
400 FORMAT('+',110X,'LEGEND')
IF(I.EQ.35) WRITE(IOUT,401),LEGND(1,1),VALLEG(1),VALLEG(2)
401 FORMAT('+',102X,A1,1X,G12.6,' - ',G12.6)
IF(I.EQ.36) WRITE(IOUT,402) LEGND(2,1),VALLEG(2),VALLEG(3)
402 FORMAT('+',102X,A1,1X,G12.6,' - ',G12.6)
IF(I.EQ.37) WRITE(IOUT,403) (LEGND(3,J),J=1,2),VALLEG(3),VALLEG(4)
403 FORMAT('+',102X,A1/'+',102X,A1,1X,G12.6,' - ',G12.6)
IF(I.EQ.38) WRITE(IOUT,404) (LEGND(4,J),J=1,2),VALLEG(4),VALLEG(5)
404 FORMAT('+',102X,A1/'+',102X,A1,1X,G12.6,' - ',G12.6)
IF(I.EQ.39) WRITE(IOUT,405)(LEGND(5,J),J=1,3),VALLEG(5),VMAX
405 FORMAT('+',102X,A1/'+',102X,A1/'+',102X,A1,1X,G12.6,' - ',G12.6)
DO 311 J=1,IHD+1
XSUM(J)=0
311 N(J)=0
DO 312 J=1,NC
IF(IAV(J).NE.I) GO TO 312
LAH=IAH(J)
IF((LAH.LT.1).OR.(LAH.GT.(IHD+1))) GO TO 312
XSUM(LAH)=XSUM(LAH)+DATA(J,IVB)
N(LAH)=N(LAH)+1
312 CONTINUE
IF(OPTR(4).EQ.1) GO TO 314
DO 313 J=1,IHD+1
IF(N(J).EQ.0) GO TO 313
XSUM(J)=XSUM(J)/N(J)
313 CONTINUE
314 DO 315 J=1,IHD+1
LOUT(J)=' '
DO 317 K=1,5
IF(N(J).EQ.0) GO TO 317
IF(XSUM(J).LT.VALLEG(K)) GO TO 317
LOUT(J)=LEGND(K,1)
317 CONTINUE
315 CONTINUE
IF((I-1).EQ.(((I-1)/6)*6)) GO TO 320
IF(IHD.EQ.40) WRITE(IOUT,318)(LOUT(J),J=1,IHD+1)
318 FORMAT(2X,'I',41A1,'I')
IF(IHD.EQ.80) WRITE(IOUT,319)(LOUT(J),J=1,IHD+1)
319 FORMAT(2X,'I',81A1,'I')
GO TO 323
320 J=I/6
VALUE=COORD(2,1)+J*DINC
IF(IHD.EQ.40) WRITE(IOUT,321)(LOUT(J),J=1,IHD+1),VALUE
321 FORMAT(2X,'+',41A1,'+',G15.7)
IF(IHD.EQ.80) WRITE(IOUT,322)(LOUT(J),J=1,IHD+1),VALUE
322 FORMAT(2X,'+',81A1,'+',G15.7)
323 DO 325 L=2,3
ISW=0
DO 326 J=1,IHD+1
LOUT(J)=' '
DO 327 K=1,5
IF(N(J).EQ.0) GO TO 327
IF(XSUM(J).LT.VALLEG(K)) GO TO 326
LOUT(J)=LEGND(K,L)
IF(LOUT(J).NE.' ') ISW=J
327 CONTINUE
326 CONTINUE
IF(ISW.EQ.0) GO TO 310
WRITE(IOUT,328)(LOUT(J),J=1,ISW)
328 FORMAT('+',2X,81A1)
325 CONTINUE
310 CONTINUE
WRITE(IOUT,302) MINUS,PLUS,((MINUS,J=1,9),PLUS,I=1,IDIV),MINUS
XSUM(1)=COORD(1,1)
DO 330 J=2,IDIV+1
330 XSUM(J)=XSUM(J-1)+DINC
WRITE(IOUT,331)(XSUM(J),J=1,IDIV+1,2)
331 FORMAT(1X,G13.7,4(7X,G13.7))
WRITE(IOUT,332)(XSUM(J),J=2,IDIV+1,2)
332 FORMAT(11X,G13.7,3(7X,G13.7))
IF(IOUT.NE.21) WRITE(IOUT,335)(LEGND(1,J),J=1,3),VALLEG(1),
1(VALLEG(I),(LEGND(I,J),J=1,3),VALLEG(I),I=2,5),VMAX
335 FORMAT('0LEGEND'/5(1X,A1/'+',A1/'+',A1,2X,G12.6,' - ',G12.6/))
300 CONTINUE
9999 RETURN
END
C*********TEST VERSION OF XTAB
SUBROUTINE XTAB(NV,NC,MV,MC,DATA,LM,AV,NAMES)
DIMENSION AV(1),LSTTAB(2,500),OPTLST(7),OPTIN(8)
DIMENSION LM(1),IL(16),IU(16),NAMES(1),DATA(MC,MV)
DIMENSION EXPCT(11),IFREQ(11),EXPEC(11),VALUE(11)
DIMENSION COLUMN(11),IHDRO(26)
COMMON /EXTRA/ HEDR(70),NSZ
COMMON /DEV/ ICC,IDATA,IOUT,IDLG
COMMON /PRNT/ LINPP
DASH='-----'
SPACE=' '
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' ENTER OPTIONS? ',$)
READ(ICC,3,END=9999) OPTIN
3 FORMAT(8(A5,1X))
IF(OPTIN(1).EQ.'!') RETURN
DO 4 I=1,7
4 OPTLST(I)=0
DO 5 I=1,8
IF(OPTIN(I).EQ.' ') GO TO 30
IF(OPTIN(I).NE.'HELP') GO TO 10
WRITE(IDLG,6)
6 FORMAT(' CROSS TABS WILL NORMALLY BE OUTPUT AS A TABLE'/
1' WITH NO PERCENTAGES. AVAILABLE OPTIONS ARE:'/
1'0PCNTR - PERCENTAGES CALCULATED BASED ON ROW TOTALS'/
1' PCNTC - PERCENTAGES CALCULATED BASED ON COLUMN TOTALS'/
1' PCNTT - PERCENTAGES CALCULATED BASED ON TOTAL OBSERVATIONS'/
1' EXPEC - EXPECTED VALUES IN EACH CELL CALCULATED'/
1' PAIRS - CROSS TAB OUTPUT AS ORDERED PAIRS'/
1' MARGN - MARGINALS (ROW AND COLUMN TOTALS)'/
1' CHISQ - CALCULATED CHISQ FOR TABLE'/
1' OUTPT - ALL ABOVE OPTIONS'/
1'0ENTER DESIRED OPTIONS SEPARATED BY COMMAS'/
1' IF NO OPTIONS ARE DESIRED TYPE A CARRIAGE RETURN')
GO TO 1
10 IF(OPTIN(I).NE.'PCNTR') GO TO 11
OPTLST(1)=1
GO TO 5
11 IF(OPTIN(I).NE.'PCNTC') GO TO 12
OPTLST(2)=1
GO TO 5
12 IF(OPTIN(I).NE.'PCNTT') GO TO 13
OPTLST(3)=1
GO TO 5
13 IF(OPTIN(I).NE.'EXPEC') GO TO 14
OPTLST(4)=1
GO TO 5
14 IF(OPTIN(I).NE.'PAIRS') GO TO 15
OPTLST(5)=1
GO TO 5
15 IF(OPTIN(I).NE.'MARGN') GO TO 16
OPTLST(6)=1
GO TO 5
16 IF(OPTIN(I).NE.'CHISQ') GO TO 17
OPTLST(7)=1
GO TO 5
17 IF(OPTIN(I).NE.'OUTPT') GO TO 20
DO 18 J=1,4
18 OPTLST(J)=1
DO 19 J=6,7
19 OPTLST(J)=1
GO TO 5
20 WRITE(IDLG,21) OPTIN(I)
21 FORMAT(' OPTION "',A5,'" DOES NOT EXIST')
GO TO 1
5 CONTINUE
30 IF(ICC.NE.2) WRITE(IDLG,31)
31 FORMAT(' ENTER CROSS TAB LIST'/)
CALL XALPHA(LSTTAB,1000,N,IRET,IHELP,IERR,NAMES,NV)
IF(IERR.EQ.1) GO TO 30
IF(IRET.EQ.1) RETURN
IF(IHELP.NE.1) GO TO 33
WRITE(IDLG,32)
32 FORMAT(' VARIABLES MAY BE SPECIFIED BY VARIABLE NAME OR'/
1' NUMBER. THE CROSSTAB LIST IS TO BE ENTERED IN THE'/
1' FOLLOWING MANNER:'/
1' A SEMICOLON (;) SEPARATES CROSSTABS,'/
1' AND A COMMA (,) IS USED TO SEPARATE THE VARIABLES WITHIN A'/
1'CROSS-TAB.'/
1'0IF RANGES OF VARIABLES ARE DESIRED THEN THE EXTREMES'/
1' OF THE RANGE ARE SEPARATED BY A MINUS (-). ASTERISK (*) MEANS'/
1' A RANGE OF ALL VARIABLES, THE WORD "ALL" MEANS *,*. EXAMPLES:'/
1' 2,3 PRODUCES 1 TAB: (2 VS 3),',/,
1' 2-3,4 PRODUCES 2 TABS: (2 VS 4) AND (3 VS 4),',/,
1' 3,* PRODUCES TABS OF ALL VARIABLES WITH 3,',/,
1' *,* PRODUCES ALL POSSIBLE COMBINATIONS OF CROSSTABS.'/
1'0THE MAXIMUM NUMBER OF CROSSTABS WHICH MAY BE SPECIFIED IN ONE'/
1' "XTAB" COMMAND IS 500.')
GO TO 30
33 NTABS=N/2
IF(NTABS.EQ.0)GO TO 30
DO 152 I=1,NTABS
IF(LSTTAB(1,I).LE.LSTTAB(2,I))GO TO 152
LST=LSTTAB(1,I)
LSTTAB(1,I)=LSTTAB(2,I)
LSTTAB(2,I)=LST
152 CONTINUE
DO 203 KK=2,1,-1
DO 202 J=NTABS-1,1,-1
DO 201 I=1,J
IF(LSTTAB(KK,I).LE.LSTTAB(KK,I+1))GO TO 201
DO 200 KL=1,2
LST=LSTTAB(KL,I)
LSTTAB(KL,I)=LSTTAB(KL,I+1)
LSTTAB(KL,I+1)=LST
200 CONTINUE
201 CONTINUE
202 CONTINUE
203 CONTINUE
KK=1
DO 300 J=1,NTABS
IF(LSTTAB(1,KK).EQ.LSTTAB(1,J).AND.LSTTAB(2,KK).EQ.LSTTAB(2,J))
#GO TO 300
KK=KK+1
IF(KK.EQ.J)GO TO 300
LSTTAB(1,KK)=LSTTAB(1,J)
LSTTAB(2,KK)=LSTTAB(2,J)
300 CONTINUE
NTABS=KK
COUNT=0
DO 36 I=1,4
IF(OPTLST(I).EQ.1) COUNT=COUNT+1
36 CONTINUE
IF(OPTLST(5).NE.1) GO TO 37
IF(IOUT.EQ.21) GO TO 39
LOUT=2
IF(COUNT.GT.0) LOUT=1
GO TO 38
39 LOUT=3
IF(COUNT.GT.1) LOUT=2
GO TO 38
37 LOUT=5
IF(IOUT.EQ.21) LOUT=11
38 DO 34 IM=1,NTABS
IX=LSTTAB(1,IM)
IY=LSTTAB(2,IM)
DO 35 J=1,NC
LM(J)=J
AV(J)=DATA(J,IY)
35 CONTINUE
C NOW SORT - SINGLETON SORT (ACM PARTITIONING)
M=1
II=1
J=NC
41 IF(II.GE.J) GO TO 48
42 K=II
IJ=(J+II)/2
T1=DATA(LM(IJ),IY)
T=DATA(LM(IJ),IX)
IF(DATA(LM(II),IX).LT.T) GO TO 43
IF(DATA(LM(II),IX).GT.T) GO TO 63
IF(DATA(LM(II),IY).LE.T1) GO TO 43
63 ISAV=LM(IJ)
LM(IJ)=LM(II)
LM(II)=ISAV
T=DATA(LM(IJ),IX)
T1=DATA(LM(IJ),IY)
43 LL=J
IF(DATA(LM(J),IX).GT.T) GO TO 45
IF(DATA(LM(J),IX).LT.T) GO TO 65
IF(DATA(LM(J),IY).GE.T1) GO TO 45
65 ISAV=LM(IJ)
LM(IJ)=LM(J)
LM(J)=ISAV
T=DATA(LM(IJ),IX)
T1=DATA(LM(IJ),IY)
IF(DATA(LM(II),IX).LT.T) GO TO 45
IF(DATA(LM(II),IX).GT.T) GO TO 64
IF(DATA(LM(II),IY).LE.T1) GO TO 45
64 ISAV=LM(IJ)
LM(IJ)=LM(II)
LM(II)=ISAV
T=DATA(LM(IJ),IX)
T1=DATA(LM(IJ),IY)
GO TO 45
44 ISAV=LM(LL)
LM(LL)=LM(K)
LM(K)=ISAV
45 LL=LL-1
IF(DATA(LM(LL),IX).GT.T) GO TO 45
IF(DATA(LM(LL),IX).LT.T) GO TO 46
IF(DATA(LM(LL),IY).GT.T1) GO TO 45
46 K=K+1
IF(DATA(LM(K),IX).LT.T) GO TO 46
IF(DATA(LM(K),IX).GT.T) GO TO 67
IF(DATA(LM(K),IY).LT.T1) GO TO 46
67 IF(K.LE.LL) GO TO 44
IF((LL-II).LE.(J-K)) GO TO 47
IL(M)=II
IU(M)=LL
II=K
M=M+1
GO TO 49
47 IL(M)=K
IU(M)=J
J=LL
M=M+1
GO TO 49
48 M=M-1
IF(M.EQ.0) GO TO 53
II=IL(M)
J=IU(M)
49 IF((J-II).GE.11) GO TO 42
IF(II.EQ.1) GO TO 41
II=II-1
50 II=II+1
IF(II.EQ.J) GO TO 48
NEXTRA=LM(II+1)
T=DATA(LM(II+1),IX)
T1=DATA(LM(II+1),IY)
IF(DATA(LM(II),IX).LT.T) GO TO 50
IF(DATA(LM(II),IX).GT.T) GO TO 68
IF(DATA(LM(II),IY).LE.T1) GO TO 50
68 K=II
51 LM(K+1)=LM(K)
K=K-1
IF(T.LT.DATA(LM(K),IX)) GO TO 51
IF(T.GT.DATA(LM(K),IX)) GO TO 69
IF(T1.LT.DATA(LM(K),IY)) GO TO 51
69 LM(K+1)=NEXTRA
GO TO 50
C
C END SORT
C
C NOW SORT AV VECTOR AGAIN USING THE SINGLETON SORT
53 M=1
II=1
J=NC
71 IF(II.GE.J) GO TO 78
72 K=II
IJ=(J+II)/2
T=AV(IJ)
IF(AV(II).LE.T) GO TO 73
AV(IJ)=AV(II)
AV(II)=T
T=AV(IJ)
73 LL=J
IF(AV(J).GE.T) GO TO 75
AV(IJ)=AV(J)
AV(J)=T
T=AV(IJ)
IF(AV(II).LE.T) GO TO 75
AV(IJ)=AV(II)
AV(II)=T
T=AV(IJ)
GO TO 75
74 AV(LL)=AV(K)
AV(K)=TT
75 LL=LL-1
IF(AV(LL).GT.T) GO TO 75
TT=AV(LL)
76 K=K+1
IF(AV(K).LT.T) GO TO 76
IF(K.LE.LL) GO TO 74
IF((LL-II).LE.(J-K)) GO TO 77
IL(M)=II
IU(M)=LL
II=K
M=M+1
GO TO 79
77 IL(M)=K
IU(M)=J
J=LL
M=M+1
GO TO 79
78 M=M-1
IF(M.EQ.0) GO TO 90
II=IL(M)
J=IU(M)
79 IF((J-II).GE.11) GO TO 72
IF(II.EQ.1) GO TO 71
II=II-1
80 II=II+1
IF(II.EQ.J) GO TO 78
T=AV(II+1)
IF(AV(II).LE.T) GO TO 80
K=II
81 AV(K+1)=AV(K)
K=K-1
IF(T.LT.AV(K)) GO TO 81
AV(K+1)=T
GO TO 80
C
C FIND NUMBER OF ROWS
C
90 NRTOT=1
XVAL=DATA(LM(1),IX)
DO 82 J=1,NC
IF(XVAL.EQ.DATA(LM(J),IX)) GO TO 82
NRTOT=NRTOT+1
XVAL=DATA(LM(J),IX)
82 CONTINUE
C
C FIND NUMBER OF COLUMNS
C
NCTOT=1
XVAL=AV(1)
DO 83 J=1,NC
IF(XVAL.EQ.AV(J)) GO TO 83
XVAL=AV(J)
NCTOT=NCTOT+1
83 CONTINUE
C
C MATRIX OUTPUT
C
IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(J),J=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,89)
89 FORMAT('0',25X,'*** CROSS TAB ***')
LINES=4
M=1
CHISQ=0
TOTN=NC
LAST=0
94 I=1
N=0
IF(M.GT.NC) GO TO 92
N=1
VALUE(N)=AV(M)
COLUMN(N)=1
91 M=M+1
IF(M.GT.NC) GO TO 92
IF(AV(M).NE.VALUE(N)) GO TO 95
COLUMN(N)=COLUMN(N)+1
GO TO 91
95 IF(N.GE.LOUT) GO TO 87
N=N+1
VALUE(N)=AV(M)
COLUMN(N)=1
NN=N
GO TO 91
92 NN=N
IF(OPTLST(6).NE.1) GO TO 93
IF(N.EQ.LOUT) GO TO 87
NN=NN+1
93 LAST=1
C
C COLUMN HEADERS AVAILABLE NOW
C
87 IF(IOUT.NE.21) GO TO 88
LINES=LINES+5
IF(LINES.LE.(LINPP-10)) GO TO 88
CALL PRNTHD
LINES=7
88 WRITE(IOUT,103) NAMES(IX),NAMES(IY)
103 FORMAT('0',A5,28X,A5)
WRITE(IOUT,108)(VALUE(J),J=1,N,2)
IF(N.GT.1) WRITE(IOUT,109)(VALUE(J),J=2,N,2)
WRITE(IOUT,111) DASH,(DASH,J=1,2*NN)
97 XVAL=DATA(LM(I),IX)
DO 100 J=1,N
100 IFREQ(J)=0
ROW=0
101 IF(DATA(LM(I),IX).NE.XVAL) GO TO 106
ROW=ROW+1
IF(DATA(LM(I),IY).GT.VALUE(N)) GO TO 107
DO 102 J=1,N
IF(DATA(LM(I),IY).EQ.VALUE(J)) IFREQ(J)=IFREQ(J)+1
102 CONTINUE
107 I=I+1
IF(I.LE.NC) GO TO 101
C OUTPUT NOW
106 IF(IOUT.NE.21) GO TO 115
NLINE=2
IF(OPTLST(1).EQ.1) NLINE=NLINE+1
IF(OPTLST(2).EQ.1) NLINE=NLINE+1
IF(OPTLST(3).EQ.1) NLINE=NLINE+1
IF(OPTLST(4).EQ.1) NLINE=NLINE+1
LINES=LINES+NLINE
IF(LINES.LE.LINPP) GO TO 115
CALL PRNTHD
JJ=10+20*N
ENCODE(JJ,108,IHDRO)(VALUE(J),J=1,N,2)
IF(LAST.EQ.1) IHDRO(1+4*NN)=' ROW'
JJ=2+4*NN
WRITE(IOUT,112)(IHDRO(J),J=1,JJ)
112 FORMAT(26A5)
108 FORMAT('0',9X,6(7X,G13.7))
IF((N.EQ.1).OR.((LAST.EQ.1).AND.(OPTLST(6).EQ.1))) GO TO 110
JJ=21+20*N
IF(N.GT.1) ENCODE(JJ,108,IHDRO)(VALUE(J),J=2,N,2)
IF(LAST.EQ.1) IHDRO(3+4*NN)='TOTAL'
JJ=4+4*NN
WRITE(IOUT,112)(IHDRO(J),J=1,JJ)
109 FORMAT(21X,5(7X,G13.7))
110 WRITE(IOUT,111) DASH,(DASH,J=1,2*NN)
111 FORMAT(15X,23A5)
LINES=6+NLINE
115 IF(NN.NE.N) IFREQ(NN)=ROW
WRITE(IOUT,116) XVAL,(IFREQ(J),J=1,NN)
116 FORMAT(15X,'I'/1X,G13.7,1X,'I',11(I6,4X))
IF((OPTLST(4).NE.1).AND.(OPTLST(7).NE.1)) GO TO 122
C
C EXPECTED VALUES CALCULATED
DO 120 J=1,N
EXPCT(J)=(ROW*COLUMN(J))/NC
CHISQ=CHISQ+(EXPCT(J)-IFREQ(J))**2/EXPCT(J)
120 CONTINUE
IF(NN.NE.N) EXPCT(NN)=TOTN/NRTOT
IF(OPTLST(4).EQ.1) WRITE(IOUT,121)(EXPCT(J),J=1,NN)
121 FORMAT(15X,'I',11(F8.1,'E '))
122 IF(OPTLST(3).NE.1) GO TO 132
C
C PERCENTAGES OF TOTAL
133 DO 130 J=1,N
130 EXPCT(J)=(IFREQ(J)/TOTN)*100.
IF(NN.NE.N) EXPCT(NN)=(ROW/TOTN)*100.
WRITE(IOUT,131)(EXPCT(J),J=1,NN)
131 FORMAT(15X,'I',11(2X,F6.1,'T%'))
132 IF(OPTLST(1).NE.1) GO TO 142
IF(N.EQ.0) GO TO 155
C
C ROW TOTAL PERCENTAGES
DO 140 J=1,N
140 EXPCT(J)=(IFREQ(J)/ROW)*100.
WRITE(IOUT,141)(EXPCT(J),J=1,N)
141 FORMAT(15X,'I',11(2X,F6.1,'R%'))
142 IF(OPTLST(2).NE.1) GO TO 155
C
C PERCENTAGES OF COLUMN
DO 150 J=1,N
150 EXPCT(J)=(IFREQ(J)/COLUMN(J))*100.
WRITE(IOUT,151)(EXPCT(J),J=1,N)
151 FORMAT(15X,'I',11(2X,F6.1,'C%'))
C
C
155 IF(I.LE.NC) GO TO 97
IF(OPTLST(6).NE.1) GO TO 160
DO 156 J=1,N
156 IFREQ(J)=COLUMN(J)
LINE=1
IF(OPTLST(3).EQ.1) LINE=LINE+1
IF(OPTLST(4).EQ.1) LINE=LINE+1
LINES=LINES+LINE
IF(LINES.LE.LINPP) GO TO 158
CALL PRNTHD
WRITE(IOUT,108)(VALUE(J),J=1,N,2)
IF(N.GT.1)WRITE(IOUT,109)(VALUE(J),J=2,N,2)
157 WRITE(IOUT,111) DASH,(DASH,J=1,2*NN)
LINES=LINE+6
158 IF(NN.NE.N) IFREQ(NN)=NC
WRITE(IOUT,159)(IFREQ(J),J=1,NN)
159 FORMAT(15X,'I'/1X,'COLUMN TOTALS',1X,'I',11(I6,4X))
IF(OPTLST(4).NE.1) GO TO 171
DO 170 J=1,N
170 EXPCT(J)=TOTN/NCTOT
WRITE(IOUT,121)(EXPCT(J),J=1,N)
171 IF(OPTLST(3).NE.1) GO TO 160
DO 172 J=1,N
172 EXPCT(J)=(IFREQ(J)/TOTN)*100.
WRITE(IOUT,131)(EXPCT(J),J=1,N)
160 IF(LAST.EQ.0) GO TO 94
IDF=(NRTOT-1)*(NCTOT-1)
IF(IDF.EQ.0) GO TO 34
IF(OPTLST(7).NE.1) GO TO 34
C**RRB/13OCT77
IERR=0
CALL CHIPRB(CHISQ,IDF,PROB)
IF(PROB.EQ.99)IERR=1
CONTG=SQRT(CHISQ/(NC+CHISQ))
IF(IOUT.NE.21) GO TO 165
LINES=LINES+5
IF(LINES.LE.LINPP) GO TO 165
CALL PRNTHD
LINES=7
165 WRITE(IOUT,166) CHISQ,IDF,PROB,CONTG
166 FORMAT('0CHI SQUARE =',G13.7,' WITH ',I6,' DEGREES OF FREEDOM'/
1' HAVING A PROBABILITY OF ',F7.4/'0CONTINGENCY COEFFICIENT =',
1G13.7)
GO TO 34
34 CONTINUE
9999 RETURN
END
SUBROUTINE XALPHA(IVECT,MAX,N,IRET,IHELP,IERR,NAMES,NV)
DIMENSION IVECT(2,MAX),NAMES(1),LINE(80)
COMMON/DEV/ICC,IDATA,IOUT,IDLG,IDSK
C
INUM=0
IALPH=0
IRET=0
IHELP=0
IERR=0
READ(ICC,1000,END=2000)LINE
1000 FORMAT(80A1)
DO 1002 MAXCHR=80,1,-1
1002 IF(LINE(MAXCHR).NE.' ')GO TO 1003
GO TO 2000
1003 IM=0
I=0
IST=0
1004 ICOL=0
ICOM=0
1008 IDASH=0
1012 I=I+1
IF(I.GT.MAXCHR)GO TO 1016
IF(LINE(I).GE.'A'.AND.LINE(I).LE.'Z')GO TO 1200
IF(LINE(I).GE.'0'.AND.LINE(I).LE.'9')GO TO 1100
IF(LINE(I).EQ.'!')GO TO 2010
IF(LINE(I).EQ.'*')GO TO 1200
1016 ISIZE=I-IST
IF(ISIZE.GT.5)GO TO 1020
ENCODE(5,1308,JVAR)(LINE(J),J=IST,I-1)
1308 FORMAT(5A1)
IF(JVAR.EQ.'ALL')GO TO 1712
IF(JVAR.EQ.'HELP')GO TO 2020
IF(JVAR.EQ.'EMPTY')GO TO 2030
IF(INUM.GT.0)GO TO 1300
IF(IALPH.GT.0)GO TO 1400
1020 TYPE 1024
1024 FORMAT(' ?SYNTAX ERROR')
1028 IERR=1
N=0
RETURN
1100 IF(IALPH.EQ.1)GO TO 1200
IF(INUM.EQ.0)IST=I
INUM=INUM+1
GO TO 1012
1200 IF(INUM.NE.0)GO TO 1020
IF(IALPH.EQ.0)IST=I
IALPH=IALPH+1
GO TO 1012
1300 DECODE(ISIZE,1312,JVAR)JNUM
1312 FORMAT(I)
INUM=0
GO TO 1500
1400 IALPH=0
IF(JVAR.EQ.'*')GO TO 1500
DO 1412 JNUM=1,NV
1412 IF(NAMES(JNUM).EQ.JVAR)GO TO 1500
TYPE 1416,JVAR
1416 FORMAT(' ?NAME - "',A5,'" DOESN''T EXIST')
GO TO 1028
1500 IF(I.GT.MAXCHR)GO TO 1700
IF(LINE(I).EQ.';')GO TO 1700
IF(LINE(I).EQ.',')GO TO 1600
IF(LINE(I).NE.'-')GO TO 1020
IF(JVAR.EQ.'*')GO TO 1020
C DASH
IF(IDASH.EQ.1)GO TO 1020
IDASH=1
IF(ICOM.EQ.1)GO TO 1512
IA=JNUM
GO TO 1012
1512 JA=JNUM
GO TO 1012
C COMMA
1600 IF(ICOM.EQ.1)GO TO 1020
ICOM=1
IF(JVAR.NE.'*')GO TO 1608
IF(IDASH.EQ.1)GO TO 1020
IA=1
IB=NV
GO TO 1008
1608 IF(IDASH.NE.1)IA=JNUM
IB=JNUM
GO TO 1008
C SEMI-COLON OR EOL
1700 IF(ICOL.EQ.1)GO TO 1020
ICOL=1
IF(JVAR.NE.'*')GO TO 1708
IF(IDASH.EQ.1)GO TO 1020
JA=1
JB=NV
GO TO 1716
1708 IF(ICOM.NE.1)GO TO 1020
IF(IDASH.NE.1)JA=JNUM
JB=JNUM
GO TO 1716
1712 IA=1
IB=NV
JA=1
JB=NV
1716 DO 1720 II=IA,IB
DO 1720 JJ=JA,JB
IM=IM+1
IF(IM.GT.MAX)GO TO 2040
IVECT(1,IM)=II
1720 IVECT(2,IM)=JJ
IF(I.LE.MAXCHR)GO TO 1004
C
2000 N=IM*2
RETURN
2010 IRET=1
RETURN
2020 IHELP=1
RETURN
2030 N=0
RETURN
2040 TYPE 2044,MAX
2044 FORMAT(' ?ERROR - MORE THAN ',I5,' CROSS-TABS')
IERR=1
RETURN
END