Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/stp9.stp
There is 1 other file named stp9.stp in the archive. Click here to see a list.
C *** STAT PACK ***
C SUBROUTINE FOR INPUTTING DATA FROM A PRE-CREATED DATA BANK
C CALLING SEQUENCE: CALL ABANK(NV,NC,MV,MC,DATA,VMN,COR,STD,INV,NAMES)
C WHERE NV - IS THE NUMBER OV COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN.
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN.
C DATA - STORAGE FOR DATA, DIMENSIONED FOR MAXIMUM MATRIX.
C VMN - IS A VECTOR CONTAINING VARIABLE MEANS.
C COR - IS A MATRIX CONTAINING CORRELATIONS.
C STD - IS A VECTOR CONTAINING VARIABLE STANDARD DEVIATIONS.
C INV - IS A VECTOR AT LEAST MV LONG.
C NAMES - S A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM IS UPDATE OF ONE ORIGINALLY WRITTEN FOR MANAGEMENT
C DEPARTMENT TO ACCESS STORED DATA BANKS. STRUCTURE IS SET SUCH
C THAT AS MANY VARIABLES AS ARE NECESSARY MAY BE USED AND AS
C MANY OBSERVATIONS AS ARE NECESSARY MAY BE USED. ALL VARIABLES
C RECOVERED ARE FORCED TO BE FLOATING POINT RATHER THEY WERE ORIGINALLY
C FIXED OR FLOATING. ALPHA VARIABLES ARE COMPLETELY OUT OF BOUNDS
C AND ANY ATTEMPT TO USE THEM WILL BE THROWN OUT OF THE REQUEST.
C ALPHA VARIABLES MAY BE USED IN SELECT STATEMENTS HOWEVER.
C MISSING DATA IS REPRESENTED AS OCTAL 400000000000 IN THE
C BANK. WHEN READ INTO STP THEY ARE REPLACED WITH -9999E-20.
C THE DATA BANK STORES DATA IN A BINARY FILE, EACH BLOCK CONTAINING
C 125 OBSERVATIONS. THE BLOCK STRUCTURE IS AS FOLLOWS:
C BLOCK 1 - VARIABLE 1 OBSERVATIONS 1-125
C BLOCK 2 - VARIABLE 1 OBSERVATIONS 126-250
C BLOCK 3 - VARIABLE 1 OBSERVATIONS 251-375
C .
C .
C .
C .
C BLOCK N - VARIABLE 1 OBSERVATION (N-1)*125-LAST OBSERVATION IN BANK
C BLOCK N+1 - VARIABLE 2 OBSERVATION 1-125
C BLOCK N+2 - VARIABLE 2 OBSERVATION 126-250
C BLOCK N+3 - VARIABLE 2 OBSERVATION 251-375
C .
C .
C .
C BLOCK 2*N - VARIABLE 2 OBSERVATION (N-1)*125+1-LAST OBSERVATION
C .
C .
C .
C .
C BLOCK NV*N - VARIABLE NV(LAST VARIABLE) OBSERVATION THROUGH LAST
C AS PICKED UP ALL DATA MAINTAINS A PLACE
C RELATIONSHIP, THAT IS: VAR 1 OBSERVATIONS 17 COMES FROM THE
C SAME OBSERVATION ON THE DATA BANK THAT VAR 14 OBSERVATION
C 17 CAME FROM. MAKING CORRELATIONS BETWEEN DATA FOR HEIGHTS
C AND WEIGHTS MEANINGFUL. THIS COMMAND IS, HOWEVER, CAPABLE
C OF RECOVERING DATA LIKE: THE IQ OF ALL BOYS AS VAR 1, AND THE
C IQ OF ALL GIRLS AS VARIABLE 2. THE ONLY RESTRICTION HERE IS
C OF COURSE, THE SAMPLE NEEDS THE SAME NUMBER OF OBSERVATIONS
C FOR ALL VARIABLES. IF THEY HAVE DIFFERENT SIZES, THE LARGER
C IS SIMPLY TRIMMED. IN ADDITION STARTING POINTS CAN BE GIVEN.
C IF A COMMAND WERE GIVEN TO START AT OBSERVATION 73 THE PROGRAM
C WOULD GATHER ALL POSSIBLE DATA, REJECTING ANY WITH MISSING
C DATA OBSERVATIONS, MAKING ONE COMPLETE PASS THROUGH THE BANK. THIS
C COMMAND ALSO HAS A POWERFUL SUBSETTING PACKAGE ALLOWING THE
C USER TO LOOK AT SOMETHING LIKE: THE IQ'S OF BOYS 21 YEARS OLD,
C WITH A GPA OF 3.0 OR HIGHER. THE "ACBNK" STATEMENT ALSO
C ALLOWS RECOVERY OF MISSING DATA, BY THE SIMPLE SETTING OF A
C SWITCH. NAMES MAY BE USED TO ACCESS THE BANK. 6 NAME DESCRIPTIONS
C WILL BE STORED PER RECORD; EACH DESCRIPTION IS MADE UP OF 1 WORD
C NAME(5 CHARACTERS), A 9 WORD (45 CHARACTER) VARIABLE DESCRIPTION,
C AND A 1 WORD MODE(0-FLOAT, 1-ALPHA, 2-FIXED).
C
SUBROUTINE ABANK(NV,NC,MV,MC,DATA,VMN,COR,STD,INV,ICOND,NAMES)
DIMENSION VMN(1),DATA(MC,MV),COR(MV,MV),STD(1)
DIMENSION INV(1),ICOND(1),NAMES(1),PATH(3)
DIMENSION INPUT(80),D(1500),ID(1500),NAME(10),IO(125),NNS(18,6)
DIMENSION IVSL(20),ISLCOD(20),VALUE(20),IWTBP(20),MODE(20)
EQUIVALENCE (ID,D),(MISS,AMISS),(IO,NNS)
EQUIVALENCE(PATH(1),IPJ),(PATH(2),IPG)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
DOUBLE PRECISION BNKNM,XTRA
C NBL IS LEFT HAND BRACKET NBR IS RIGHT HAND BRACKET
NBL="555004020100
NBR="565004020100
PATH(3)=0
MISS="400000000000
SWM=0
SWQ=0
SWS=0
SWI=0
IPJ=0
IPG=0
IROOM=1500
NV=0
ISTART=1
IBNK=1
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT('0BANK AND SWITCHES? ',$)
READ(ICC,3,END=440)INPUT
3 FORMAT(80A1)
IF(INPUT(1).EQ.'!') GO TO 440
IF(INPUT(1).EQ.' ') GO TO 440
C
C ..............................................................
C IF HELP IS NEEDED
C ...............................................................
C
IF((INPUT(1).NE.'H').OR.(INPUT(2).NE.'E').OR.(INPUT(3).NE.'L').OR.
1(INPUT(4).NE.'P')) GO TO 7
WRITE (IDLG,4)
WRITE(IDLG,5)
WRITE (IDLG,6) NBL,NBR
4 FORMAT('0THIS PACKAGE WAS WRITTEN TO ACCESS STORED BINARY DATA'/
1' BANKS. IT ALLOWS FOR SUBSETTING OF DATA, REJECTION OF'/
2' OBSERVATIONS CONTAINING MISSING DATA, AND RECOVERY OF'/
3' INDEPENDENT SAMPLES. WHEN THE PROGRAM CALLS FOR THE NAME'/
4' OF THE FILE, TYPE IN THE NAME WITHOUT THE EXTENSION. TO'/
5' ACCESS THE BANK IT WILL HAVE BEEN NECESSARY TO CREATE'/
6' IT IN THE PROGRAM MABNK, THUS IT WILL ALREADY HAVE THE'/
7' EXTENSION "BNK". DIRECTLY ADJOINING THIS WILL BE THE'/
8' PROJECT-PROGRAMMER NUMBER IN BRACKETS (IF OTHER THAN YOUR OWN).'
9/' NEXT WILL BE ANY SWITCHES YOU WISH TO SET, ENCLOSED IN'/
1' PARANTHESES. SWITCHES AVAILABLE ARE:'/
2' Q-SPECIFY QUALIFYING FIELDS.'/' I-INDEPENDENT SAMPLES.'/
3' S-SPECIFY STARTING OBSERVATION NUMBER OTHER THAN 1.'/
4' M-ALLOW RECOVERY OF OBSERVATIONS WITH MISSING DATA.*'/
5' VARIABLES ARE ENTERED BY THEIR CORRESPONDING BANK CODES'/
6' OR NAMES, IF NAMES HAVE BEEN DEFINED FOR THE BANK.'/
6'ALL VARIABLES ENTERED AT ONE TIME WILL MAINTAIN'/
7' A PLACE RELATIONSHIP. IT IS POSSIBLE TO SUBSET THE DATA BY'/
8' USE OF THE Q SWITCH.'/)
5 FORMAT(' QUALIFYING VARIABLES ARE ENTERED BY A BANK CODE OR NAME,'/
1/' A RELATIONSHIP CODE, AND A VALUE FOR GROUPING.'/
2' THESE ARE TYPED ON THE SAME LINE WITH NO SPACES (1 QUALIFIER'/
1' PER LINE). THE RELATIONSHIP CODES ARE:'/
5' ",EQ," OR "=" - EQUAL'/
5' ",LT," OR "<" - LESS THAN'/
5' ",GT," OR ">" - GREATER THAN'/
5' ",NE," OR "<>" OR "><" - NOT EQUAL TO'/
5' ",LE," OR "<=" OR "=<" - LESS THAN OR EQUAL TO'/
5' ",GE," OR ">=" OR "=>" - GREATER THAN OR EQUAL TO'/
7' AN INSTRUCTION TO KEEP ONLY THOSE OBSERVATIONS WHERE VARIABLE '/
8' 1 IS LESS THAN 10 MIGHT LOOK LIKE THIS:'/' 1,LT,10'/
9' TO STOP INSERTION OF QUALIFYING FIELDS TYPE A <CR>,'/
1' ^Z(CONTROL Z), OR "STOP"'/)
6 FORMAT(' A TYPICAL RUN MIGHT LOOK LIKE THIS:'/
1' .............'/' WHAT BANK NAME AND SWITCHES? ',
2'DATA',A1,'420,420',A1,'(QS)'/' WHAT STARTING POSITION? 170'/
3' LIST BANK CODES SEPERATED BY COMMAS'/' 1,2,4'/
4' LIST QUALIFYING FIELDS IN FOLLOWING MANNER'/
5' 1 PER LINE: BANK CODE, RELATIONSHIP, VALUE AT POINT'/
6' 3,LT,17'/' AGE=9'/' 4>=3'/' STOP'/' .............'/
7' DATA BANK WAS LOCATED IN AREA 420,420. IT WAS RECOVERED'/
8' LISTING A STARTING POINT OF 170; AND 3 QUALIFYING FIELDS,'/
9' SUBSETTING THE DATA SO THAT EVERY OBSERVATION USED FOR DATA'/
1' HAS BANK CODE 3 LESS THAN 17, AGE EQUAL TO 9, AND'/
2' BANK CODE 4 GREATER THAN OR EQUAL TO 3.'//
3' * MISSING DATA IS REPRESENTED BY THE NUMBER -9999E-20')
GO TO 1
C
C .............................................................
C
C USED TO DETERMINE NAME OF FILE TO BE FOUND
C
C ............................................................
C
7 DO 8 I=1,10
8 NAME(I)=' '
I=1
11 IF(INPUT(I).EQ.NBL) GO TO 14
IF(INPUT(I).EQ.'(') GO TO 14
IF(INPUT(I).EQ.' ') GO TO 14
IF(INPUT(I).EQ.'/') GO TO 14
IF(INPUT(I).NE.'.') GO TO 10
WRITE(IDLG,9)
9 FORMAT(' NO EXTENSION NECESSARY ".BNK" WILL BE ADDED')
GO TO 14
10 IF(I.LE.6) GO TO 13
WRITE(IDLG,12)
12 FORMAT(' BANK NAME TOO LONG')
GO TO 1
13 NAME(I)=INPUT(I)
I=I+1
GO TO 11
14 IF(I.EQ.1) RETURN
NAME(I)='.'
NAME(I+1)='B'
NAME(I+2)='N'
NAME(I+3)='K'
ENCODE(10,3,BNKNM) NAME
IF(INPUT(I).NE.NBL) GO TO 35
C
C PROJECT NUMBER
C
DO 15 J=1,10
15 NAME(J)=' '
J=1
21 I=I+1
IF(INPUT(I).EQ.',') GO TO 22
IF(INPUT(I).EQ.' ') GO TO 20
IF(INPUT(I).NE.NBR) GO TO 17
20 WRITE(IDLG,16)
16 FORMAT(' NO COMMA BETWEEN PROJECT AND PROGRAMMER NUMBER')
GO TO 1
17 IF((INPUT(I).LE.'7').AND.(INPUT(I).GE.'0')) GO TO 19
WRITE(IDLG,18) INPUT(I)
18 FORMAT(' THE CHARACTER "',A1,'" IS ILLEGAL FOR PROJECT NUMBER')
GO TO 1
19 IF(J.GT.6) GO TO 20
NAME(J)=INPUT(I)
J=J+1
GO TO 21
22 IF(NAME(6).NE.' ') GO TO 24
DO 23 J=6,2,-1
23 NAME(J)=NAME(J-1)
NAME(1)=' '
GO TO 22
24 ENCODE(10,3,XTRA) NAME
DECODE(6,34,XTRA) IPJ
C
C PROGRAMMER NUMBER
C
DO 25 J=1,10
25 NAME(J)=' '
J=1
I=I+1
30 IF(INPUT(I).EQ.NBR) GO TO 31
IF(INPUT(I).EQ.' ') GO TO 31
IF((INPUT(I).LE.'7').AND.(INPUT(I).GE.'0')) GO TO 27
WRITE(IDLG,26) INPUT(I)
26 FORMAT(' THE CHARACTER "',A1,'" IS ILLEGAL FOR PROGRAMMER NUMBER')
GO TO 1
27 IF(J.LE.6) GO TO 29
WRITE(IDLG,28)
28 FORMAT(' PROGRAMMER NUMBER TOO LONG')
GO TO 1
29 NAME(J)=INPUT(I)
J=J+1
I=I+1
GO TO 30
31 IF(NAME(6).NE.' ') GO TO 33
DO 32 J=6,2,-1
32 NAME(J)=NAME(J-1)
NAME(1)=' '
GO TO 31
33 ENCODE(10,3,XTRA) NAME
DECODE(6,34,XTRA) IPG
34 FORMAT(O6)
I=I+1
C
C
C
35 CALL EXIST(BNKNM,IERR,IPJ,IPG)
IF(IERR.EQ.0) GO TO 39
WRITE(IDLG,38)
38 FORMAT(' BANK NOT AVIALABLE')
GO TO 1
C
C SWITCH IF SET MUST BE ENCLOSED IN PARANTHESIS OR PRECEDED BY A /
C
39 OPEN(UNIT=IBNK,FILE=BNKNM,ACCESS='RANDIN',MODE='BINARY',
1RECORD SIZE=126,DIRECTORY=PATH)
READ(IBNK#1) NVB,NOB,(J,K=3,7),VERSON,(J,K=9,125)
IF(VERSON.EQ.'V2') GO TO 37
WRITE(IDLG,36)
36 FORMAT(' THIS BANK CREATED WITH AN EXPERIMENTAL VERSION'/
1' TO UPDATE THE BANK RUN BANKUP FROM AREA 220,220. IF YOU'/
2' ARE NOT RESPONSIBLE FOR THE BANK CONTACT THE OWNER')
RETURN
37 NOBASE=(NOB+124)/125
IBASE=NOBASE*NVB+1
LBASE=(NVB+5)/6
GO TO 55
40 I=I+1
55 IF(INPUT(I).EQ.' ') GO TO 60
IF(INPUT(I).EQ.'/') GO TO 42
IF(INPUT(I).EQ.'(') GO TO 51
WRITE(IDLG,41)
41 FORMAT(' SWITCHES MUST BE PRECEDED BY A / OR ENCLOSED IN ',
1'PARANTHESES')
GO TO 1
C
C SWITCHES PRECEDED BY A /
C
42 I=I+1
IF(INPUT(I).NE.'Q') GO TO 46
IF(SWQ.NE.1) GO TO 45
43 WRITE(IDLG,44) INPUT(I)
44 FORMAT(' SWITCH ',A1,' SPECIFIED TWICE IN STRING OF SWITCHES')
GO TO 1
45 SWQ=1
GO TO 40
46 IF(INPUT(I).NE.'I') GO TO 47
IF(SWI.EQ.1) GO TO 43
SWI=1
GO TO 40
47 IF(INPUT(I).NE.'S') GO TO 48
IF(SWS.EQ.1) GO TO 43
SWS=1
GO TO 40
48 IF(INPUT(I).NE.'M') GO TO 49
IF(SWM.EQ.1) GO TO 43
SWM=1
GO TO 40
49 WRITE(IDLG,50) INPUT(I)
50 FORMAT(' SWITCH "',A1,'" DOES NOT EXIST')
GO TO 1
C
C SWITCHES ENCLOSED IN PARANTHESIS
C
51 I=I+1
IF(INPUT(I).EQ.')') GO TO 40
IF(INPUT(I).NE.'Q') GO TO 52
IF(SWQ.EQ.1) GO TO 43
SWQ=1
GO TO 51
52 IF(INPUT(I).NE.'I') GO TO 53
IF(SWI.EQ.1) GO TO 43
SWI=1
GO TO 51
53 IF(INPUT(I).NE.'S') GO TO 54
IF(SWS.EQ.1) GO TO 43
SWS=1
GO TO 51
54 IF(INPUT(I).NE.'M') GO TO 49
IF(SWM.EQ.1) GO TO 43
SWM=1
GO TO 51
C
C IF STARTING SWITCH WAS USED GET STARTING POSITION
C
60 IF(SWS.EQ.0) GO TO 514
502 IF(ICC.NE.2) WRITE(IDLG,500)
500 FORMAT(' WHAT IS THE STARTING ADRESS? ',$)
READ(ICC,3,END=432) INPUT
IF(INPUT(1).EQ.'!') GO TO 432
IF(INPUT(1).EQ.' ') GO TO 514
IF((INPUT(1).NE.'H').AND.(INPUT(2).NE.'E').AND.(INPUT(3).NE.'L').
1AND.(INPUT(4).NE.'P')) GO TO 503
WRITE(IDLG,501)
501 FORMAT(' ENTER THE OBSERVATION NUMBER OF THE BANK WHERE YOU'/
1' WOULD LIKE TO BEGIN SELECTING DATA FROM')
GO TO 502
503 DO 504 J=1,10
504 NAME(J)=' '
J=1
I=1
508 IF(INPUT(I).EQ.' ') GO TO 509
IF((INPUT(I).LE.'9').AND.(INPUT(I).GE.'0')) GO TO 506
WRITE(IDLG,505)
505 FORMAT(' INDICATE STARTING POSITION BY OBSERVATION NUMBER ONLY')
GO TO 502
506 IF(J.GT.10) GO TO 507
NAME(J)=INPUT(I)
J=J+1
507 I=I+1
IF(I.LE.80) GO TO 508
509 IF(NAME(10).NE.' ') GO TO 511
DO 510 J=9,1,-1
510 NAME(J+1)=NAME(J)
NAME(1)=' '
GO TO 509
511 ENCODE(10,3,XTRA) NAME
DECODE(10,515,XTRA) I
515 FORMAT(I10)
IF((I.LE.NOB).AND.(I.GT.0)) GO TO 513
WRITE(IDLG,512)
512 FORMAT(' STARTING POSITION NOT IN RANGE OF OBSERVATIONS IN BANK')
GO TO 502
513 ISTART=I
514 NVSF=0
NOSF=MC
IF(SWI.EQ.0) GO TO 62
IF(ICC.NE.2) WRITE(IDLG,61)
61 FORMAT('0INDEPENDENT SAMPLES WILL BE TAKEN ON SUCCESSIVE'/
1' "LIST VARIABLES". WHEN ALL INDEPENDENT SAMPLES HAVE BEEN'/
2' GIVEN TYPE A ^Z(CONTROL Z) OR A <CR>')
ISAMP=0
62 ISAMP=ISAMP+1
59 IF((SWI.EQ.1).AND.(ICC.NE.2)) WRITE(IDLG,63) ISAMP
63 FORMAT(' INDEPENDENT SAMPLE ',I2/)
147 IF(ICC.NE.2) WRITE(IDLG,64)
64 FORMAT(' ENTER VARIABLES SEPARATED BY COMMAS'/)
READ(ICC,3,END=400) INPUT
IF(INPUT(1).EQ.'*') GO TO 600
IF((INPUT(1).NE.'H').OR.(INPUT(2).NE.'E').OR.(INPUT(3).NE.'L').
1 OR.(INPUT(4).NE.'P').OR.(INPUT(5).NE.' ')) GO TO 131
WRITE(IDLG,130)
130 FORMAT(' ENTER THE VARIABLES TO BE RECOVERED FROM THE BANK.'/
1' EITHER VARIABLE NAMES OR NUMBERS MAY BE USED. RANGES MAY'/
2' BE ENTERED BY LISTING THE EXTREMES OF THE RANGE SEPARATED'/
3' BY A -'/)
GO TO 147
131 IF(INPUT(1).EQ.'!') GO TO 432
IF(INPUT(1).EQ.' ') GO TO 400
NVTBR=0
I=1
65 DO 66 J=1,5
66 NAME(J)=' '
J=1
NUM=0
67 IF(INPUT(I).EQ.',') GO TO 72
IF(INPUT(I).EQ.'-') GO TO 72
IF(INPUT(I).EQ.' ') GO TO 72
IF(J.NE.1) GO TO 68
IF((INPUT(I).GT.'9').OR.(INPUT(I).LT.'0')) GO TO 70
NUM=1
GO TO 70
68 IF(NUM.EQ.0) GO TO 70
IF((INPUT(I).LE.'9').AND.(INPUT(I).GE.'0')) GO TO 70
WRITE(IDLG,69)
69 FORMAT(' COMMA MISSING BETWEEN VARIABLE NUMBER AND NAME'/)
GO TO 147
70 IF(J.GT.5) GO TO 71
NAME(J)=INPUT(I)
J=J+1
71 I=I+1
IF(I.LE.80) GO TO 67
72 IF(J.GT.1) GO TO 148
WRITE(IDLG,73)
73 FORMAT(' WHERE A NAME OR VARIABLE NUMBER SHOULD HAVE OCCURRED ',
1' NONE DID')
GO TO 147
148 NVTBR=NVTBR+1
IF((NVSF+NVTBR).LE.MV) GO TO 75
93 WRITE(IDLG,74)
74 FORMAT(' MORE VARIABLES THAN ROOM ALLOCATED'/)
GO TO 147
75 STD(NVTBR)=NUM
IF(NUM.EQ.0) GO TO 79
C
C VARIABLE IS INDICATED BY NUMBERS
C
77 IF(NAME(5).NE.' ') GO TO 78
DO 76 J=5,2,-1
76 NAME(J)=NAME(J-1)
NAME(1)=' '
GO TO 77
78 ENCODE(5,3,NAMCP) (NAME(J),J=1,5)
DECODE(5,149,NAMCP) INV(NVTBR)
149 FORMAT(I5)
IF((INV(NVTBR).LE.NVB).AND.(INV(NVTBR).GT.0)) GO TO 80
WRITE(IDLG,119) INV(NVTBR)
119 FORMAT(' VARIABLE ',I5,' DOES NOT EXIST')
GO TO 147
C
C VARIABLE IS INDICATED BY NAME
C
79 ENCODE(5,3,NAMCP)(NAME(J),J=1,5)
IF(NAMCP.EQ.'STOP') GO TO 400
IF(NAMCP.EQ.'ALL') GO TO 600
NAMES(NVSF+NVTBR)=NAMCP
IF(NAMES(NVSF+NVTBR).NE.'OBS') GO TO 80
NAMES(NVSF+NVTBR)='OBSER'
INV(NVTBR)=0
STD(NVTBR)=2
ICOND(NVTBR)=0
80 IF(INPUT(I).NE.',') GO TO 81
I=I+1
VMN(NVTBR)=1
GO TO 65
81 IF(INPUT(I).NE.'-') GO TO 82
I=I+1
VMN(NVTBR)=2
GO TO 65
82 VMN(NVTBR)=3
C
C FILL IN NAMES AND MODES FOR NUMBERS, AND MODES AND NUMBERS FOR NAMES
C
DO 83 I=1,LBASE
IREC=IBASE+I
READ(IBNK#IREC) IO
IREDY=(I-1)*6
IEND=6
IF((I*6).GT.NVB) IEND=NVB-IREDY
DO 84 J=1,IEND
DO 85 K=1,NVTBR
M=STD(K)+1
GO TO (87,86,85),M
86 IF(INV(K).NE.(IREDY+J)) GO TO 85
NAMES(NVSF+K)=NNS(1,J)
ICOND(K)=NNS(10,J)
STD(K)=2
GO TO 85
87 IF(NAMES(NVSF+K).NE.NNS(1,J)) GO TO 85
INV(K)=IREDY+J
ICOND(K)=NNS(10,J)
STD(K)=2
85 CONTINUE
84 CONTINUE
83 CONTINUE
C
C CHECK FOR NAMES THAT DIDN'T EXIST AND ALPHA VARIABLES
C
DO 90 I=1,NVTBR
IF(STD(I).NE.0) GO TO 92
WRITE(IDLG,91) NAMES(NVSF+I)
91 FORMAT(' VARIABLE ',A5,' NOT USED IN THIS BANK')
GO TO 147
92 IF(ICOND(I).NE.1) GO TO 90
WRITE(IDLG,94) NAMES(NVSF+I)
94 FORMAT(' VARIABLE ',A5,' IS ALPHA - NO ALPHAS IN STP!')
GO TO 147
90 CONTINUE
C
C TAKE CARE OF RANGES
C
KREC=0
I=1
100 IF(VMN(I).EQ.1) GO TO 105
IF(VMN(I).EQ.3) GO TO 110
IBEG=INV(I)
IEND=INV(I+1)
INCRE=1
IF(IBEG.GT.IEND) INCRE=-1
IDIFF=(IEND-IBEG)*INCRE-1
IF((IDIFF+NVTBR).GT.MV) GO TO 93
IF(IDIFF.LT.1) GO TO 105
DO 101 J=NVTBR,I+1,-1
INV(IDIFF+J)=INV(J)
ICOND(IDIFF+J)=ICOND(J)
NAMES(NVSF+IDIFF+J)=NAMES(NVSF+J)
VMN(IDIFF+J)=VMN(J)
101 CONTINUE
DO 102 J=1,IDIFF
INV(I+J)=INV(I+J-1)+INCRE
IREC=(INV(I+J)+5)/6
IF(IREC.EQ.KREC) GO TO 103
KREC=IREC
READ(IBNK#(KREC+IBASE)) IO
103 IONE=INV(I+J)-(KREC-1)*6
IF(NNS(10,IONE).EQ.1) GO TO 93
ICOND(I+J)=NNS(10,IONE)
NAMES(NVSF+I+J)=NNS(1,IONE)
102 CONTINUE
NVTBR=NVTBR+IDIFF
I=I+IDIFF
105 I=I+1
GO TO 100
C
C ILLIMINATE DUPLICATES
C
110 I=2
IF(NVTBR.LT.2) GO TO 118
116 DO 111 J=1,I-1
IF(INV(J).EQ.INV(I)) GO TO 112
111 CONTINUE
GO TO 114
112 IF(I.EQ.NVTBR) GO TO 117
DO 113 J=I+1,NVTBR
INV(J-1)=INV(J)
ICOND(J-1)=ICOND(J)
NAMES(NVSF+J-1)=NAMES(NVSF+J)
113 CONTINUE
117 NVTBR=NVTBR-1
GO TO 115
114 I=I+1
115 IF(I.LE.NVTBR) GO TO 116
118 IF(NVTBR.GT.0) GO TO 122
WRITE(IDLG,123)
123 FORMAT(' NO VARIABLES TO BE READ'/)
GO TO 147
600 NVTBR=0
DO 601 I=1,LBASE
IREC=IBASE+I
READ(IBNK#IREC) IO
IREDY=(I-1)*6
IEND=6
IF((I*6).GT.NVB) IEND=NVB-IREDY
DO 602 J=1,IEND
IF(NNS(10,J).EQ.1) GO TO 602
NVTBR=NVTBR+1
IF(NVTBR.LE.MV)GO TO 604
WRITE(IDLG,603)
603 FORMAT(' MORE VARIABLES IN BANK THAN ROOM ALLOCATED')
GO TO 147
604 INV(NVTBR)=IREDY+J
ICOND(NVTBR)=NNS(10,J)
NAMES(NVSF+NVTBR)=NNS(1,J)
602 CONTINUE
601 CONTINUE
C
C SELECTION PORTION
C
122 NUSED=NVTBR
ISL=1
IF(SWQ.EQ.0) GO TO 299
IF(ICC.NE.2) WRITE(IDLG,605)
605 FORMAT('0ENTER QUALIFIERS'/)
150 IF(ICC.NE.2) WRITE(IDLG,146)
146 FORMAT('+? ',$)
READ(ICC,3,END=299) INPUT
IF(INPUT(1).EQ.'!') GO TO 432
IF(INPUT(1).EQ.' ') GO TO 299
I=1
151 DO 152 J=1,5
152 NAME(J)=' '
J=1
NUM=0
153 IF(INPUT(I).EQ.'.') GO TO 158
IF(INPUT(I).EQ.',') GO TO 158
IF(INPUT(I).EQ.'<') GO TO 158
IF(INPUT(I).EQ.'>') GO TO 158
IF(INPUT(I).EQ.'=') GO TO 158
IF(INPUT(I).EQ.' ') GO TO 158
IF(J.NE.1) GO TO 154
IF((INPUT(I).LT.'0').OR.(INPUT(I).GT.'9')) GO TO 156
NUM=1
GO TO 156
154 IF(NUM.EQ.0) GO TO 156
IF((INPUT(I).LE.'9').AND.(INPUT(I).GE.'0')) GO TO 156
WRITE(IDLG,155)
155 FORMAT('0VARIABLE NUMBER INCORRECT'/)
GO TO 150
156 IF(J.GT.5) GO TO 157
NAME(J)=INPUT(I)
J=J+1
157 I=I+1
GO TO 153
158 IF(NUM.EQ.1) GO TO 165
C
C SELECT VARIABLE IS A NAME
C
ENCODE(5,3,NAMCP) (NAME(J),J=1,5)
DO 159 J=1,NUSED
IF(NAMCP.NE.NAMES(NVSF+J)) GO TO 159
IVSL(ISL)=-J
MODE(ISL)=0
IWTBP(ISL)=J
GO TO 180
159 CONTINUE
IF(NAMCP.NE.'HELP') GO TO 173
WRITE(IDLG,174)
174 FORMAT('0UP TO 20 QUALIFIERS MAY BE ENTERED, 1 PER LINE'/
1' IN RESPONSE TO A QUESTION MARK. WHEN THE LAST QUALIFIER HAS'/
2' BEEN ENTERED, TYPE A ^Z, BLANK LINE, OR STOP. QUALIFIERS'/
3' ARE COMPRISED OF A VARIABLE (SPECIFIED BY NAME OR NUMBER)'/
4' A CONDITION (MAY BE SPECIFIED BY A COMBINATION OF THESE'/
5' SYMBOLS: <>=, OR THE STANDARD FORTRAN NOTATION: NE,EQ,'/
6' ETC.), AND THE VALUE TO BE COMPARED AGAINST (IF THE VARIABLE'/
7' BEING CHECKED IS ALPHANUMERIC THEN THE VALUE MUST BE ENCLOSED'/
8' IN QUOTES.'/)
GO TO 150
173 IF(NAMCP.EQ.'STOP') GO TO 299
IF(NAMCP.NE.'ALL') GO TO 171
WRITE(IDLG,172)
172 FORMAT(' ALL MAY NOT BE USED IN A SELECT'/)
GO TO 150
171 IF(NAMCP.EQ.'OBS') GO TO 163
DO 160 J=1,LBASE
READ(IBNK#(IBASE+J)) IO
IEND=6
IF((J*6).GT.NVB) IEND=NVB-J*6+6
DO 160 K=1,IEND
IF(NAMCP.EQ.NNS(1,K)) GO TO 161
160 CONTINUE
WRITE(IDLG,162) NAMCP
162 FORMAT('0VARIABLE "',A5,'" DOES NOT EXIST'/)
GO TO 150
161 IVSL(ISL)=(J-1)*6+K
MODE(ISL)=NNS(10,K)
GO TO 164
163 IVSL(ISL)=0
MODE(ISL)=0
164 NVTBR=NVTBR+1
IWTBP(ISL)=NVTBR
GO TO 180
C
C SELECT VARIABLE IS A NUMBER
C
165 IF(NAME(5).NE.' ') GO TO 167
DO 166 J=5,2,-1
166 NAME(J)=NAME(J-1)
NAME(1)=' '
GO TO 165
167 ENCODE(5,3,NAMCP)(NAME(J),J=1,5)
DECODE(5,149,NAMCP) IVSL(ISL)
IF((IVSL(ISL).LE.NVB).AND.(IVSL(ISL).GE.1)) GO TO 169
WRITE(IDLG,168) IVSL(ISL)
168 FORMAT('0VARIABLE NO ',I5,' DOES NOT EXIST'/)
GO TO 150
169 DO 170 J=1,NUSED
IF(INV(J).NE.IVSL(ISL)) GO TO 170
IVSL(ISL)=-J
MODE(ISL)=0
IWTBP(ISL)=J
GO TO 180
170 CONTINUE
J=(IVSL(ISL)+5)/6
IONE=IVSL(ISL)-(J-1)*6
READ(IBNK#(IBASE+J)) IO
MODE(ISL)=NNS(10,IONE)
NVTBR=NVTBR+1
IWTBP(ISL)=NVTBR
GO TO 180
C
C SELECT CONDITION
C
180 IF((INPUT(I).EQ.'.').OR.(INPUT(I).EQ.',')) GO TO 190
C
C SIGNS USED (<>=)
C
IE=0
IG=0
IL=0
181 IF(INPUT(I).NE.'=') GO TO 182
IF(IE.EQ.1) GO TO 184
IE=1
GO TO 186
182 IF(INPUT(I).NE.'<') GO TO 183
IF(IL.EQ.1) GO TO 184
IL=1
GO TO 186
183 IF(INPUT(I).NE.'>') GO TO 187
IF(IG.EQ.1) GO TO 184
IG=1
GO TO 186
184 WRITE(IDLG,185) INPUT(I)
185 FORMAT('0CONDITION "',A1,'" SEPCIFIED TWICE'/)
GO TO 150
186 I=I+1
GO TO 181
187 ISLCOD(ISL)=IE*1+IL*2+IG*4
IF((ISLCOD(ISL).GE.1).AND.(ISLCOD(ISL).LT.7)) GO TO 200
189 WRITE(IDLG,188)
188 FORMAT('0ILLEGAL CONDITION'/)
GO TO 150
C
C FOR SELECT 2 CHARACTER CODES WERE USED
C
190 IF(INPUT(I+3).NE.INPUT(I)) GO TO 189
NAMCP=' '
ENCODE(2,3,NAMCP) INPUT(I+1),INPUT(I+2)
I=I+4
ISLCOD(ISL)=0
IF(NAMCP.EQ.'EQ') ISLCOD(ISL)=1
IF(NAMCP.EQ.'LT') ISLCOD(ISL)=2
IF(NAMCP.EQ.'LE') ISLCOD(ISL)=3
IF(NAMCP.EQ.'GT') ISLCOD(ISL)=4
IF(NAMCP.EQ.'GE') ISLCOD(ISL)=5
IF(NAMCP.EQ.'NE') ISLCOD(ISL)=6
IF(ISLCOD(ISL).EQ.0) GO TO 189
C
C NOW VALUES TO BE COMPARED AGAINST
C
200 IF((INPUT(I).EQ.'M').AND.(INPUT(I+1).EQ.'I').AND.
1(INPUT(I+2).EQ.'S').AND.(INPUT(I+3).EQ.'S')) GO TO 217
IF(MODE(ISL).EQ.1) GO TO 210
C
C VALUE IS NUMERIC
C
DO 201 J=1,10
201 NAME(J)=' '
J=1
202 IF((INPUT(I).EQ.'-').AND.(J.EQ.1)) GO TO 206
IF(INPUT(I).EQ.'.') GO TO 206
IF(INPUT(I).EQ.'E') GO TO 206
IF(INPUT(I).EQ.' ') GO TO 205
IF((INPUT(I).LE.'9').AND.(INPUT(I).GE.'0')) GO TO 206
WRITE(IDLG,203)
203 FORMAT('0VALUE TO BE COMPARED AGAINST MUST BE NUMERIC'/)
GO TO 150
206 IF(J.GT.10) GO TO 204
NAME(J)=INPUT(I)
J=J+1
204 I=I+1
IF(I.LT.80) GO TO 202
205 IF(J.EQ.1) GO TO 208
IF(NAME(10).NE.' ') GO TO 208
DO 207 J=10,2,-1
207 NAME(J)=NAME(J-1)
NAME(1)=' '
GO TO 205
208 ENCODE(10,3,XTRA) NAME
DECODE(10,209,XTRA) VALUE(ISL)
209 FORMAT(F10.0)
GO TO 220
217 VALUE(ISL)=AMISS
GO TO 220
C
C VALUE TO BE COMPARED AGAINST IS ALPHA
C
210 IF(INPUT(I).EQ.1H') GO TO 213
211 WRITE(IDLG,212)
212 FORMAT('0ALPHA VALUES MUST BE ENCLOSED IN QUOTES'/)
GO TO 150
213 DO 214 J=1,5
214 NAME(J)=' '
J=1
I=I+1
215 IF(INPUT(I).EQ.1H') GO TO 216
IF(J.GT.5) GO TO 216
NAME(J)=INPUT(I)
J=J+1
I=I+1
GO TO 215
216 ENCODE(5,3,VALUE(ISL)) (NAME(J),J=1,5)
220 ISL=ISL+1
IF(ISL.LE.20) GO TO 150
C
C NOW RECOVER DATA
C
299 ISL=ISL-1
ISIZPV=IROOM/NVTBR
IF(ISIZPV.GT.125) ISIZPV=125
ONESW=0
IBPOS=ISTART
NC=1
GO TO 303
302 IBPOS=IEPOS+1
IF(IBPOS.GT.NOB) IBPOS=1
IF((ONESW.EQ.1).AND.(IBPOS.EQ.ISTART)) GO TO 380
303 IBLO=(IBPOS+124)/125
IEPOS=IBPOS+ISIZPV-1
IF(IEPOS.GT.(IBLO*125)) IEPOS=IBLO*125
IF(IEPOS.GT.NOB) IEPOS=NOB
IF((ONESW.EQ.1).AND.(IEPOS.GT.ISTART)) IEPOS=ISTART-1
JSUB=(IBLO-1)*125
JADD=IBPOS-JSUB-1
JEND=IEPOS-IBPOS+1
DO 304 I=1,NUSED
ISET=(I-1)*ISIZPV
IF(INV(I).EQ.0) GO TO 308
IREC=(INV(I)-1)*NOBASE+IBLO+1
READ(IBNK#IREC) IO
IF(ICOND(I).EQ.2) GO TO 306
DO 305 J=1,JEND
305 ID(ISET+J)=IO(J+JADD)
GO TO 304
306 DO 307 J=1,JEND
D(ISET+J)=IO(J+JADD)
IF(IO(J+JADD).EQ.MISS) ID(ISET+J)=IO(J+JADD)
307 CONTINUE
GO TO 304
308 DO 309 J=1,JEND
309 D(ISET+J)=IBPOS+J-1
304 CONTINUE
IF(ISL.LT.1) GO TO 350
N=NUSED+1
DO 320 I=1,ISL
IF(IVSL(I).LT.0) GO TO 320
ISET=(N-1)*ISIZPV
IF(IVSL(I).GT.0) GO TO 335
DO 330 J=1,JEND
330 D(ISET+J)=IBPOS+J-1
GO TO 340
335 IREC=(IVSL(I)-1)*NOBASE+IBLO+1
READ(IBNK#IREC) IO
IF(MODE(I).EQ.2) GO TO 336
DO 337 J=1,JEND
337 ID(ISET+J)=IO(J+JADD)
GO TO 340
336 DO 338 J=1,JEND
D(ISET+J)=IO(J+JADD)
IF(IO(J+JADD).EQ.MISS) ID(ISET+J)=IO(J+JADD)
338 CONTINUE
340 N=N+1
320 CONTINUE
IF(N.NE.(NVTBR+1)) PAUSE 'DONT EQUAL'
C
C CHECK IT OVER AND MOVE
C
350 DO 351 J=1,JEND
IF(ISL.LT.1) GO TO 370
DO 352 I=1,ISL
L=(IWTBP(I)-1)*ISIZPV+J
IF((VALUE(I).EQ.AMISS).AND.(ISLCOD(I).EQ.1)) GO TO 353
IF(D(L).EQ.AMISS) GO TO 351
353 GO TO (361,362,363,364,365,366) ISLCOD(I)
361 IF(D(L).EQ.VALUE(I)) GO TO 352
GO TO 351
362 IF(D(L).LT.VALUE(I)) GO TO 352
GO TO 351
363 IF(D(L).LE.VALUE(I)) GO TO 352
GO TO 351
364 IF(D(L).GT.VALUE(I)) GO TO 352
GO TO 351
365 IF(D(L).GE.VALUE(I)) GO TO 352
GO TO 351
366 IF(D(L).NE.VALUE(I)) GO TO 352
GO TO 351
352 CONTINUE
370 IF(SWM.EQ.1) GO TO 372
DO 371 I=1,NUSED
L=(I-1)*ISIZPV+J
IF(D(L).EQ.AMISS) GO TO 351
DATA(NC,I+NVSF)=D(L)
371 CONTINUE
NC=NC+1
IF(NC.LE.NOSF) GO TO 351
GO TO 380
372 DO 373 I=1,NUSED
L=(I-1)*ISIZPV+J
IF(D(L).EQ.AMISS) D(L)=-9999E-20
373 DATA(NC,I+NVSF)=D(L)
NC=NC+1
IF(NC.GT.NOSF) GO TO 380
351 CONTINUE
IF(IEPOS.EQ.NOB) ONESW=1
GO TO 302
380 NVSF=NVSF+NUSED
NC=NC-1
IF(NC.LT.NOSF) NOSF=NC
IF(NOSF.LT.1) GO TO 430
IF(SWI.EQ.1) GO TO 62
C
C WRAP IT UP
C
400 NV=NVSF
NC=NOSF
IF((NV*NC).LT.1) GO TO 430
DO 401 I=1,NV
VMN(I)=0
DO 406 K=1,NV
406 COR(K,I)=0
401 CONTINUE
DO 410 I=1,NC
DO 411 J=1,NV
VMN(J)=VMN(J)+DATA(I,J)
DO 411 K=1,J
411 COR(K,J)=COR(K,J)+DATA(I,J)*DATA(I,K)
410 CONTINUE
DO 405 I=1,NV
DO 405 J=1,NV
405 COR(J,I)=NC*COR(I,J)-VMN(J)*VMN(I)
DO 416 I=1,NV
STD(I)=0
IF(NC.GT.1) STD(I)=SQRT(COR(I,I)/(NC*(NC-1.)))
416 VMN(I)=VMN(I)/NC
DO 417 I=1,NV
DO 417 J=I,NV
IF(I.EQ.J) GO TO 417
IF((COR(I,I)*COR(J,J)).EQ.0) GO TO 417
COR(I,J)=COR(J,I)/SQRT(COR(I,I)*COR(J,J))
COR(J,I)=COR(I,J)
GO TO 417
418 COR(I,J)=0
COR(J,I)=0
417 CONTINUE
DO 419 I=1,NV
419 COR(I,I)=1.
GO TO 433
430 WRITE(IDLG,431)
431 FORMAT(' NO OBSERVATIONS IN DATA REQUESTED')
432 NV=0
NC=0
433 CALL RELEAS(IBNK)
440 RETURN
END