Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50521/bnklib.for
There are 4 other files named bnklib.for in the archive. Click here to see a list.
	SUBROUTINE BNKNAM(ITYPE,NSIZE)
C
C	GET LIST OF VARIABLE TO BE USED FROM A BANK
C
	DIMENSION M(72),NNS(18,6),ISAVE(5),L1(2),MSAVE(5),NAME(800),
     1 NUM(800),MODE(800),IV(1000),IDUM(125),IT(0/2),NOGOOD(800),
     2 NOMAT(800)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	DOUBLE PRECISION NAMO,NAMI
	EQUIVALENCE (ITEMP,NOGOOD),(ITEMP(801),IV,NOMAT),(ITEMP(2601),
     1 NAME),(ITEMP(3401),NUM),(ITEMP(4201),MODE)
	EQUIVALENCE (IDUM,NNS)
	DATA IGRT/'$'/
	DATA IT/'F','A','I'/
	ISET=800
	NSET=1000
	IZ=(NOBNK+124)/125*NVBNK+1
	NT=(NVBNK+5)/6
1	ISIZE=0
	NSIZE=0
	NBAD=0
	DO 102 I=1,ISET
	NUM(I)=0
102	ITEMP(I)=0
	DO 103 J=1,NSET
103	IV(J)=0
10	WRITE(IDLG,100)
100	FORMAT(' WHICH VARIABLES FROM THE BANK?'/)
101	NPT=1
	CALL GES(M,72,IEND)
C
C	IEND=-1  IF ALTMODE IS ENCOUNTERED
C	    = 1  IF CARRIAGE RETURN IS ENCOUNTERED
C	    = 2  IF END OF FILE IS ENCOUNTERED
C
	IF (IEND.EQ.2) CALL EXIT
C
	IF ((M(1).EQ.'H').AND.(M(2).EQ.'E').AND.(M(3).EQ.'L').AND.
     1(M(4).EQ.'P')) GO TO 70
	DO 110 ILAST=72,1,-1
	IF (M(ILAST).NE.' ') GO TO 11
110	CONTINUE
	GO TO 301
11	IEND=-1
	IF(M(ILAST).EQ.',') IEND=1
	IF(ILAST.EQ.1)GO TO 2111
	IF((M(ILAST-1).EQ.',').AND.((M(ILAST).EQ.IALT)
     .	.OR.(M(ILAST).EQ.IGRT))) GOTO 2112
	GOTO 2111
2112	ILAST=ILAST-1
	M(ILAST)=IALT
2111	DO 12 I=1,5
12	ISAVE(I)=' '
	N=0
	DO 13 I=1,ILAST
	L=M(I)
	IF (L.EQ.' ') GO TO 13
	IF ((L.EQ.',').OR.(L.EQ.'-').OR.(L.EQ.IALT).OR.(L.EQ.IGRT))
     1 GO TO 14
	IF (N.GE.5) GO TO 13
	N=N+1
	ISAVE(N)=L
	GO TO 13
C
C	ISAVE CONTAINS 5(A1) NON-TERMINATOR CHARS & NO IMBEDDED SPACES
C
14	IF ((I.EQ.1).AND.((L.EQ.IALT).OR.(L.EQ.IGRT))) GO TO 301
	ISIZE=ISIZE+1
	ITEMP(ISIZE)=' '
	DO 777 KK=1,N
	IF ((ISAVE(KK).GT.'9').OR.(ISAVE(KK).LT.'0')) GO TO 15
777	CONTINUE
C
C	VARIABLE NUMBER FOUND, RIGHT JUSTIFY IN ISAVE
C
140	IF (ISAVE(5).NE.' ') GO TO 142
	DO 141 J=4,1,-1
141	ISAVE(J+1)=ISAVE(J)
	ISAVE(1)=' '
	GO TO 140
142	ENCODE(5,143,K) ISAVE
143	FORMAT(5A1)
	DECODE(5,144,K) IV(ISIZE)
144	FORMAT(I5)
	IF (L.EQ.'-')  GO TO 18
	GO TO (130,30), NPT
C
C	VARIABLE NAME FOUND
C
15	IV(ISIZE)=0
	ENCODE(5,143,ITEMP(ISIZE)) ISAVE
	IF ((ITEMP(ISIZE).EQ.'*').OR.(ITEMP(ISIZE).EQ.'ALL')) GO TO 20
16	IF (L.NE.'-') GO TO (130,30), NPT
C
C	'-'  RANGE OF VARIABLES
C
18	ISIZE=ISIZE+1
	ITEMP(ISIZE)='-'
	IV(ISIZE)=-2
	GO TO (130,30), NPT
C
130	N=0
	DO 131 J=1,5
131	ISAVE(J)=' '
13	CONTINUE
C
C	IF N > 0, STRING WAS TERMINATED BY LINE TERMINATOR
C	  SET NPT FLAG & JUMP INTO LOOP TO PROCESS STRING
C
	IF (N.LE.0) GO TO 30
	NPT=2
	GO TO 14
C
C	ALL OR *
C
20	IS=NVBNK
	IF (NVBNK.GT.ISET) IS=ISET
	NSIZE=0
	MATCH=0
	LEFT=6
	DO 21 I=1,NT
	I1=IZ+I
	READ(INP#I1) IDUM
	II=(I-1)*6
	IF (I.EQ.NT) LEFT=NVBNK-II
	DO 22 J=1,LEFT
	L=NNS(10,J)
	IF (ITYPE.GE.3) GO TO 200
	IF ((L.EQ.ITYPE).OR.((ITYPE.EQ.0).AND.(L.EQ.2))) GO TO 200
	MATCH=MATCH+1
	NOMAT(MATCH)=NNS(1,J)
	GO TO 22
200	IF (NSIZE.EQ.IS) GO TO 23
	NSIZE=NSIZE+1
	NAME(NSIZE)=NNS(1,J)
	MODE(NSIZE)=L
	NUM(NSIZE)=J+II
22	CONTINUE
21	CONTINUE
231	IF (MATCH-1) 65,63,64
C
23	IF (IS.NE.NVBNK) WRITE(IDLG,230) NVBNK,ISET
230	FORMAT('-ERROR:  There are',I7,' variables in the BANK and
     1 limit is set at',I7/9X,'Program proceeds, ignoring the excess'/)
	GO TO 231
C
C	END OF LINE FOUND
C
30	IF(IEND.EQ.1)GOTO 101
301	IF (ISIZE.LE.ISET) GO TO 31
	WRITE(IDLG,300)
300	FORMAT('-ERROR: Variable string too long, Contact computer
     1 center staff'/9X,'for help'/)
	CALL EXIT
C
31	IF (ISIZE.GT.0) GO TO 32
	WRITE(IDLG,310)
310	FORMAT('-ERROR:  Picking up 0 variables from the BANK, Try again
     .'/)
	IF (ICODE.GE.0) GO TO 10
311	CALL EXIT
C
C	CHECK FOR VALID VARIABLE NUMBER
C
32	DO 320 I=1,ISIZE
	IF (IV(I).NE.-2) GO TO 322
	IF ((IV(I-1).GE.0).AND.(IV(I+1).GE.0)) GO TO 320
	WRITE(IDLG,321) (ITEMP(J),J=I-1,I+1)
321	FORMAT('-ERROR:  Illegal entry for range    "',3A5,'",'/
     1 ' Re-enter the entire list')
3210	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
322	IF (IV(I).LE.NVBNK) GO TO 320
	WRITE(IDLG,323) IV(I)
323	FORMAT('-ERROR:  Variable number',I6,' does not exist, Try
     1 again'/)
	GO TO 3210
320	CONTINUE
C
	I1=IZ+1
	READ(INP#I1) IDUM
	I=1
	LEFT=6
	IF (NVBNK.LT.LEFT) LEFT=NVBNK
330	IF (IV(I).NE.0) GO TO 35
	L=ITEMP(I)
	DO 34 J=1,LEFT
	IF (L.NE.NNS(1,J)) GO TO 34
	NSIZE=NSIZE+1
	NAME(NSIZE)=L
	NUM(NSIZE)=J
	MODE(NSIZE)=NNS(10,J)
	GO TO 33
34	CONTINUE
	NSIZE=NSIZE+1
	NAME(NSIZE)=L
	NUM(NSIZE)=IV(I)
	GO TO 33
C
35	IF (IV(I).LT.0) GO TO 38
C
C	A POSITIVE # IN IV(I)
C
36	NSIZE=NSIZE+1
	NAME(NSIZE)=' '
	NUM(NSIZE)=IV(I)
	IF (IV(I).GT.LEFT) GO TO 33
	NAME(NSIZE)=NNS(1,IV(I))
	MODE(NSIZE)=NNS(10,IV(I))
	GO TO 33
C
C	-
C
38	LN=NUM(NSIZE)
	LIV=IV(I+1)
	IF ((LN.GE.1).AND.(LN.LT.LEFT)) GO TO 381
	IF (LIV.NE.0) GO TO 3803
	DO 3801 J=1,LEFT
	IF (ITEMP(J+1).EQ.NNS(1,J)) GO TO 3802
3801	CONTINUE
3800	NSIZE=NSIZE+1
	NAME(NSIZE)=' '
	NUM(NSIZE)=-2
	NSIZE=NSIZE+1
	I=I+1
	NAME(NSIZE)=ITEMP(I)
	NUM(NSIZE)=IV(I)
	GO TO 33
C
3802	IF ((LN.EQ.0).OR.(LN.GT.LEFT)) GO TO 486
	IST=LN+1
	LAST=LIV
	GO TO 3811
C
3803	IF (LIV.LE.LEFT) GO TO 486
	IF (LN-LIV) 3800,486,486
C
381	IST=LN+1
	IF (LIV.EQ.0) GO TO 385
	IF (LIV.GT.LEFT) GO TO 384
	LAST=LIV
3811	IF (LAST.LT.IST) GO TO 486
3810	NS=NSIZE
	NSIZE=NSIZE+LAST-IST+1
C
382	I=I+2
3820	DO 383 J1=IST,LAST
	NS=NS+1
	NAME(NS)=NNS(1,J1)
	MODE(NS)=NNS(10,J1)
383	NUM(NS)=J1
	GO TO 331
C
385	L=ITEMP(I+1)
	DO 386 J1=1,LEFT
	IF (L.NE.NNS(1,J1)) GO TO 386
	LAST=J1
	GO TO 3811
386	CONTINUE
C
384	LAST=LEFT
	NS=NSIZE
	NSIZE=NSIZE+LAST-IST+3
	NAME(NSIZE-1)=' '
	NUM(NSIZE-1)=-2
	NAME(NSIZE)=ITEMP(I+1)
	NUM(NSIZE)=IV(I+1)
	GO TO 382
C
33	I=I+1
331	IF (I.LE.ISIZE) GO TO 330
	IF (LEFT.EQ.NVBNK) GO TO 50
C
C
40	K2=6
	DO 41 K=2,NT
	I1=IZ+K
	READ(INP#I1) IDUM
	K1=K2
	K2=K*6
	IF (K2.GT.NVBNK) K2=NVBNK
	LEFT=K2-K1
	I=1
410	NI=NUM(I)
42	IF (NI) 47,44,43
43	IF ((NI.GT.K2).OR.(NI.LE.K1)) GO TO 46
	K3=NI-K1
	NAME(I)=NNS(1,K3)
	MODE(I)=NNS(10,K3)
	GO TO 46
C
44	L=NAME(I)
	DO 45 J=1,LEFT
	IF (L.NE.NNS(1,J)) GO TO 45
	NAME(I)=NNS(1,J)
	NUM(I)=K1+J
	MODE(I)=NNS(10,J)
	GO TO 46
45	CONTINUE
	GO TO 46
C
47	IF ((NUM(I-1).EQ.0).OR.(NUM(I-1).GE.K2)) GO TO 485
	NPT=1
	IST=NUM(I-1)+1-K1
	IF (NUM(I+1).EQ.0) GO TO 490
	IF (NUM(I+1).GT.K2) GO TO 49
	IF (NUM(I+1).LT.NUM(I-1)) GO TO 486
	LAST=NUM(I+1)-K1
483	J3=LAST-IST-1
	IF (J3.LT.0) GO TO 493
4830	I2=I+2
484	IF (I2.GT.NSIZE) GO TO 482
C
4800	DO 480 J=NSIZE,I2,-1
	NS=J+J3
	NAME(NS)=NAME(J)
	MODE(NS)=MODE(J)
480	NUM(NS)=NUM(J)
C
482	II=NUM(I-1)+1
	DO 481 J=IST,LAST
	NAME(I)=NNS(1,J)
	MODE(I)=NNS(10,J)
	NUM(I)=II
	II=II+1
481	I=I+1
	NSIZE=NSIZE+J3
	IF (NPT.EQ.2) I=I+2
	IF (I-NSIZE)410,41,41
C
485	IF ((NUM(I+1).EQ.0).OR.(NUM(I+1).GT.K2)) GO TO 46
486	WRITE(IDLG,487)
487	FORMAT('-ERROR:  Illegal range specification, Try again'/)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
C
490	L=NAME(I+1)
	DO 491 J=1,LEFT
	IF (L.EQ.NNS(1,J)) GO TO 492
491	CONTINUE
	IF (IST.LE.LEFT) GO TO 49
	I=I+2
	GO TO 460
C
49	LAST=LEFT
	J3=LAST-IST+1
	I2=I
	NPT=2
	GO TO 4800
C
492	LAST=J
	IF (LAST.LT.IST) GO TO 486
	NPT=1
	J3=LAST-IST-1
	IF (J3.GE.0) GO TO 4830
493	NAME(I)=NNS(1,LAST)
	MODE(I)=NNS(10,LAST)
	NUM(I)=K1+LAST
	NSIZE=NSIZE-1
	IF (I.GE.NSIZE) GO TO 41
	IJ=I
	DO 4860 J=I+2,NSIZE+1
	IJ=IJ+1
	NAME(IJ)=NAME(J)
	MODE(IJ)=MODE(J)
4860	NUM(IJ)=NUM(J)
C
46	I=I+1
460	IF (I.LE.NSIZE) GO TO 410
41	CONTINUE
C
C	CHECK FOR INVALID ENTRIES AND MODES
C
50	IF (NSIZE.GT.0) GO TO 500
5010	WRITE(IDLG,501)
501	FORMAT('-ERROR:  No variable selected from BANK, Try again'/
     1 )
	IF (ICODE) 311,1,1
C
C
500	NBAD=0
	MATCH=0
	IST=1
51	DO 52 I=IST,NSIZE
	L=NUM(I)
	IF (L.GT.0) GO TO (55,55,55,52,52),ITYPE+1
	IF (L.EQ.-2) GO TO 53
	NBAD=NBAD+1
	NOGOOD(NBAD)=NAME(I)
53	NSIZE=NSIZE-1
	IF (NSIZE.GT.0) GO TO 540
	WRITE(IDLG,600) NOGOOD(1)
	GO TO 5010
540	IF (I.GT.NSIZE) GO TO 6
	DO 54 J=I,NSIZE
	NAME(J)=NAME(J+1)
	MODE(J)=MODE(J+1)
54	NUM(J)=NUM(J+1)
	IST=I
	IF (NSIZE) 6,6,51
55	IF ((MODE(I).EQ.ITYPE).OR.((ITYPE.EQ.0).AND.(MODE(I).EQ.2)))
     1 GO TO 52
	MATCH=MATCH+1
	NOMAT(MATCH)=NAME(I)
	GO TO 53
52	CONTINUE
6	IF (NBAD-1) 62,60,61
60	WRITE(IDLG,600) NOGOOD(1)
600	FORMAT('-ERROR:  Variable "',A5,'" does not exist, program
     1 continues'/9X,'ignoring it'/)
	GO TO 62
61	WRITE(IDLG,610) NBAD,(NOGOOD(I),I=1,NBAD)
610	FORMAT('-ERROR:  The following',I6,' variable names do not
     1 exist,'/9X,'Program continues ignoring them:'/(10(1X,A5)))
	WRITE(IDLG,641)
C
62	IF (MATCH-1) 65,63,64
63	WRITE(IDLG,630) NOMAT(1),IT(ITYPE)
630	FORMAT('-ERROR:  Variable "',A5,'" is not of the required ',A1,
     1 '-Type,'/9X,'It will be excluded in all analysis'/)
	GO TO 650
64	WRITE(IDLG,640) IT(ITYPE),(NOMAT(I),I=1,MATCH)
640	FORMAT('-ERROR:  The following variables are not of the required
     1 ',A1,'-Type,'/9X,'They will be excluded in all analysis:'/
     2 (9X,10(A5,1X)))
650	WRITE(IDLG,641)
641	FORMAT(' ')
C
C	CHECK FOR DUPLICATE ENTRIES
C
65	IF (NSIZE.LE.1) RETURN
	IDUP=0
	LAST=NSIZE
	I=1
651	IST=I+1
6500	IF (IST.EQ.LAST) GO TO 654
	DO 6504 J=IST,LAST
	IF (NAME(I).EQ.NAME(J)) GO TO 652
6504	CONTINUE
6501	NSIZE=LAST
	IF (I.GE.NSIZE) GO TO 654
	I=I+1
	GO TO 651
C
652	IDUP=IDUP+1
	NOGOOD(IDUP)=NAME(I)
	IF (J.EQ.LAST) GO TO 6502
	LAST=LAST-1
	DO 653 K=J,LAST
	NAME(K)=NAME(K+1)
	NUM(K)=NUM(K+1)
653	MODE(K)=MODE(K+1)
	IST=J
	GO TO 6500
C
6502	LAST=LAST-1
	GO TO 6501
C
654	IF (IDUP-1) 68,66,67
66	WRITE(IDLG,660) NOGOOD(1)
660	FORMAT('-ERROR: Variable "',A5,'" is used more than once,'/
     1 9X,'Program proceeds ignoring the duplicate'/)
	GO TO 680
67	WRITE(IDLG,670) IDUP,(NOGOOD(I),I=1,IDUP)
670	FORMAT('-ERROR:  The following',I5,' variables appear more
     1 than once,'/9X,'Program proceeds ignoring the duplicates'/
     2 (9X,10(A5,1X)))
680	WRITE(IDLG,641)
68	RETURN
C
C	HELP
C
70	WRITE(IDLG,700)
700	FORMAT('-All or some of the variables located in a structured
     1 data BANK may be'/' used for the analysis.  A "ALL" or "*" may
     2 be entered if all of the'/' variables are to be used.  Otherwise,
     3 enter the variables by either'/' their NAMES (as previously
     4 defined in the data BANK) or by their'/' variable numbers
     5 separated by commas.  Ranges of variables may also'/' be
     6 specified by typing the extremes of the range separated
     7 by a "-".'/'-Multiple lines are available to enter the list
     8 provided the'/' last character in the line is a comma.'/'
     9 The list should be terminated by an altmode or a carriage
     1return.'//)
	GO TO 1
	END
	SUBROUTINE GTFORM(ISEL,NCHAR,IFMT)
C
C	ACCEPT FORMAT FOR READING DATA FILE
C
	DIMENSION IFMT(1),ITYPE(0/2),NAM(2),IN(80)
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SGETFR/ISTD,LTYPE
	DOUBLE PRECISION NAME
	EQUIVALENCE (NAME,NAM)
	DATA ITYPE/'F','A','I'/
C
C
99	IBEG=1
	ISTD=0
	NPT=0
	IPAREN=0
	IF(NCHAR.EQ.0)
     +    STOP 'PROGRAM ERROR: REPORT TO COMPUTER CENTER (GTFORM#99+4)'
C
C	WRITE HEADER
C
	IF((LTYPE.EQ.3).OR.(ISEL.EQ.1)) WRITE(IDLG,100)
100	FORMAT(' ENTER FORMAT ENCLOSED IN PARENTHESES'/)
	IF((LTYPE.LT.3).AND.(ISEL.EQ.0)) WRITE(IDLG,101) ITYPE(LTYPE)
101	FORMAT(' ENTER FORMAT ENCLOSED IN PARENTHESES: (',A1,
     .	'-TYPE ONLY)'/)
98	IF(NPT.LT.2) CALL GES(IN,80,IERR)
	IF(NPT.EQ.2) READ(29,102) IN
C
C	FIND # OF CHARACTERS
C
	DO 10 I=80,1,-1
	IF(IN(I).NE.' ') GOTO 20
10	CONTINUE
	ISTD=1
	RETURN
C
C	STANDARD FORMAT REQUESTED; RETURN
C
20	LAST=I
C
C	GET RID OF EXTRA SPACES
C
	I=0
25	I=I+1
	IF(I.GT.LAST) GOTO 30
	IF(IN(I).NE.' ') GOTO 25
	DO 15 J=I,LAST
15	IN(J)=IN(J+1)
	LAST=LAST-1
	GOTO 25
C
C
30	IF(NPT.NE.0) GOTO 300
	IF(IN(1).EQ.'H'.AND.IN(2).EQ.'E'.AND.IN(3).EQ.'L'.AND.IN(4)
     .	.EQ.'P') GOTO 999
	IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M'.AND.IN(4).EQ.
     .	'E') RETURN
	IF((IN(1).NE.'(').AND.(IN(1).NE."401004020100)) GOTO 9999
	NPT=1
	DO 35 I=1,NCHAR
35	IFMT(I)=' '
	IF(IN(1).EQ.'(') GOTO 300
C
C	COMMAND FILE
C
	NPT=2
	DO 40 I=2,LAST
	IF(IN(I).EQ.'.') GOTO 45
40	CONTINUE
	LAST=LAST+1
	IN(LAST)='.'
45	J=LAST-1
	ENCODE(J,102,NAM(1)) (IN(I),I=2,LAST)
102	FORMAT(80A1)
	CLOSE(UNIT=29)
	OPEN(UNIT=29,DEVICE='DSK',FILE=NAME,ACCESS='SEQIN')
	GOTO 98
C
C	READ FORMAT
C
300	DO 50 I=1,LAST
	IF(IN(I).EQ.'(') IPAREN=IPAREN+1
	IF(IN(I).EQ.')') IPAREN=IPAREN-1
50	CONTINUE
	IF(IBEG+((LAST+4)/5).GT.NCHAR) GOTO 9999
	ENCODE (LAST,102,IFMT(IBEG)) (IN(I),I=1,LAST)
	IBEG=IBEG+(LAST+4)/5
	IF(IPAREN.LT.1) GOTO (200,201),NPT
	GOTO 98
C
C	RETURN
C
201	CLOSE (UNIT=29)
200	RETURN
C
C	ERROR AND HELP
C
9999	WRITE(IDLG,103)
103	FORMAT('-ERROR:  Format incorrectly specified'/)
	GOTO 99
999	I=NCHAR*5
	WRITE(IDLG,104) I
104	FORMAT(' Any FORMAT specification must comply with the FORTRAN-1
     .0 Format'/' requirement. The FORMAT must also be enclosed
     .in parentheses'/' and be no more than ',I3,' characters in length'
     .	//' Example:  ENTER FORMAT ENCLOSED IN PARENTHESES'
     .	/11X,'(I2,F3.0,1X,F2.0,I1)'/)
	GOTO 99
	END
	SUBROUTINE GTID
C
C	THIS SUBROUTINE WAS WRITTEN BY BERENICE HOUCHARD ON 1974
C	TO BE USED BY SOME OF THE PROGRAMS IN THE BANK SYSTEM.  IT
C	ACCEPTS A 80 COLUMN INPUT FROM THE USER TO BE USED AS A HEADER
C	FOR OUTPUT PURPOSES.
C
C	THE HEADER INFORMATION IS STORED IN VECTOR ID SITUATED
C	IN THE COMMON BLOCK SID.
C
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SID/ID(16),ISTOP
	DOUBLE PRECISION NAMO,NAMI
C
C
	WRITE(IDLG,10)
10	FORMAT(' ENTER HEADER')
	READ(ICC,11) ID
11	FORMAT(16A5)
	DO 12 ISTOP=16,1,-1
	IF (ID(ISTOP).NE.' ') RETURN
12	CONTINUE
	RETURN
	END
	SUBROUTINE GTMODE(NV,NF,NOTF)
C
C	THIS IS A MODIFICATION OF DICK HOUCHARD'S PROGRAM IN WHICH
C	THE MODE OF EACH VARIABLE IS EXTRACTED FROM THE FORMAT SUBMITTED
C	BY THE USER.  THIS MODIFICATION WAS DONE ON 1974 BY BERENICE
C	HOUCHARD.
C
C
C	NV-----NUMBER OF VARIABLES
C	NF-----5*DIMENSION OF NOTF
C	NOTF---VECTOR CONTAINING THE FORMAT IN A5
C	ITYPE--VECTOR TO CONTAIN THE MODE OF EACH VARIABLE
C
	DIMENSION NOTF(1),ITYPE(800),FMTT(400),FT(400),XX(9),SAV(5)
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	EQUIVALENCE (ITEMP(1),FMTT),(ITEMP(401),FT),(ITEMP(801),SAV),
     1 (ITEMP(4201),ITYPE)
	DATA XX/'A','I','F','G','E','(',')','D','O'/
	DECODE(NF,2,NOTF) (FMTT(I),I=1,NF)
2	FORMAT(400A1)
	DO 20 N=NF,1,-1
	IF (FMTT(N).NE.' ')GO TO 21
20	CONTINUE
	STOP 'PROGRAM ERROR: REPORT TO COMPUTER CENTER (GTMODE#20+1)'
21      I=0
500   I=I+1
508   IF(I.GT.N) GO TO 512
      DO 501 J=1,9
      IF(FMTT(I).EQ.XX(J)) GO TO 500
501   CONTINUE
      IF((FMTT(I).LT.'0').OR.(FMTT(I).GT.'9')) GO TO 504
      DO 502 K=1,4
      IF((K+I).GT.N) GO TO 504
      DO 503 J=1,9
      IF(FMTT(K+I).NE.XX(J)) GO TO 503
      IF(J.EQ.7) GO TO 504
      GO TO 500
503   CONTINUE
      IF((FMTT(K+I).LT.'0').OR.(FMTT(K+I).GT.'9')) GO TO 504
502   CONTINUE
C     GET RID OF CHARACTER
504   DO 505 J=I+1,N
505   FMTT(J-1)=FMTT(J)
      N=N-1
      GO TO 508
C
C     GET RID OF PARANTHESES
512   ISW=0
      I=0
      M=1
513   I=I+1
      IF(I.GT.N) GO TO 530
      IF(FMTT(I).EQ.XX(6)) GO TO 513
      IF(FMTT(I).EQ.XX(7)) GO TO 513
      IF((FMTT(I).GE.'0').AND.(FMTT(I).LE.'9')) GO TO 514
      FT(M)=FMTT(I)
      M=M+1
      IF(M.LT.NF) GO TO 513
      GO TO 541
514   ISW=1
      DO 515 K=1,5
515   SAV(K)=' '
      J=1
516   SAV(J)=FMTT(I)
      I=I+1
      J=J+1
      IF((FMTT(I).GE.'0').AND.(FMTT(I).LE.'9')) GO TO 516
517   IF(SAV(5).NE.' ') GO TO 519
      DO 518   J=4,1,-1
518   SAV(J+1)=SAV(J)
      SAV(1)=' '
      GO TO 517
519   ENCODE(5,2,WORD) SAV
      DECODE (5,520,WORD) LOOP
520   FORMAT(I5)
      IF(FMTT(I).EQ.XX(6)) GO TO 525
      DO 521 J=1,LOOP
      FT(M)=FMTT(I)
      M=M+1
      IF(M.GT.NF) GO TO 541
521   CONTINUE
      GO TO 513
525   L=I+1
      KOUNT=1
526   IF(FMTT(L).EQ.XX(6)) KOUNT=KOUNT+1
      IF(FMTT(L).EQ.XX(7)) KOUNT=KOUNT-1
      IF(KOUNT.EQ.0) GO TO 527
      L=L+1
      GO TO 526
527   IF((I+1).GT.(L-1)) GO TO 532
      DO 528 J=1,LOOP
      DO 529 K=I+1,L-1
      FT(M)=FMTT(K)
      M=M+1
      IF(M.GT.NF) GO TO 541
529   CONTINUE
528   CONTINUE
532   I=L
      GO TO 513
530   N=M-1
      IF(ISW.EQ.0) GO TO 540
      DO 531 I=1,N
531   FMTT(I)=FT(I)
      GO TO 512
541	STOP 'PROGRAM ERROR: REPORT TO COMPUTER CENTER (GTMODE#541)'
540   K=1
      DO 542 I=1,NV
      ITYPE(I)=0
      IF(FT(K).EQ.'A') ITYPE(I)=1
      IF(FT(K).EQ.'O') ITYPE(I)=2
      IF(FT(K).EQ.'I') ITYPE(I)=2
      K=K+1
      IF(K.GT.N) K=1
C
C     FORMAT BROKEN DOWN
C
542   CONTINUE
	RETURN
	END
	SUBROUTINE INFO(N)
C
C	WRITE HEADER PAGE FOR NON-TTY: OUTPUT DEVICES
C
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/FMT/NOTF(80)	!MSL: CHANGED FROM 48, 11-1-76
	COMMON/SID/ID(16),ISTOP
	COMMON/SINFO/CALNAM,PROG(12)
	COMMON/SINFO1/ITIME,IDATE(2)
C
C
	DOUBLE PRECISION NAMO,NAMI
C
C
	CALL DATE(IDATE)
	CALL TIME(ITIME)
	WRITE(IOUT,11) PROG,CALNAM,ITIME,IDATE,ID,NOTF
11	FORMAT('1'/'-'/'-',29X,'WESTERN  MICHIGAN  UNIVERSITY'//
     1 30X,12A5///30X,'CALLING NAME:  ',A5/30X,'TIME-DATE   :  ',A5,2X
     2 2A5/30X,'TITLE',7X,':  ',16A5/30X,'FORMAT',6X,':  ',16A5/
     3 4(43X,16A5/))
C
C
	IF (IBNK.NE.1) GO TO 300
	WRITE(IOUT,20) NAMI,NDBNK,LFBR,NPBNK,IRTBR,NVBNK,NOBNK
20	FORMAT(30X,'DATA FILE   :  ',A10/30X,'CREATED ON  :  ',2A5/
     1 30X,'BY PROJ-PROG:  ',A1,O6,',',O6,A1/30X,'NUMBER OF VARIABLES IN
     2 THE BANK.',5(' .'),I7/30X,'NUMBER OF OBSERVATIONS IN THE BANK',
     3 4(' .'),I7)
	IF (N.NE.0) WRITE(IOUT,21) N
21	FORMAT(30X,'NUMBER OF VARIABLES USED',9(' .'),I7)
300	IF ((IDEVI.EQ.'DSK').AND.(IBNK.NE.1)) WRITE(IOUT,30) NAMI,LFBR,
     1 IPROJ,IPROG,IRTBR
30	FORMAT('-',29X,'DATA FILE   :  ',A10,A1,O6,',',O6,A1)
	RETURN
	END
	SUBROUTINE PAGE
*********************************************************************
*
*	THIS SUBROUTINE OUTPUTS HEADER AT TOP OF PAGE FOR NON-TTY DEVICE
*	IF OUTPUT DEVICE IS 'TTY' PROGRAM RETURNS
*
*	SINFO1 IS IN COMMON WITH SUBROUTINE "INFO" WHICH OBTAINS DATE
*	SINFO IS IN COMMON WITH MAIN WHICH OBTAINS PROGRAM TITLE
*
*	IPAGE COUNTS LINES IN EACH PAGE
*	IPAGCT IS PAGE COUNTER BOTH A ZERO IN MAINLINE
*
************************************************************************
	COMMON /IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SINFO/CALNAM,PROG(12)
	COMMON/SINFO1/ITIME,IDATE(2)
	COMMON /SID/ID(16),ISTOP
	DOUBLE PRECISION NAMO,NAMI
	IF(IDEVO.EQ.'TTY') RETURN
	IPAGE=2
	CALL TIME(ITIME)
	IPAGCT=IPAGCT+1
	IF(ISTOP.EQ.0) GOTO 1
	WRITE(IOUT,100) CALNAM,IDATE,ID,ITIME,IPAGCT
100	FORMAT('1',A5,'  W.M.U.   ',2A5,4X,16A5,3X,A5,4X,'PAGE:',I4/)
	RETURN
1	WRITE(IOUT,101) CALNAM,IDATE,PROG,ITIME,IPAGCT
101	FORMAT('1',A5,'  W.M.U.   ',2A5,9X,12A5,18X,A5,4X,'PAGE:',I4/)
	RETURN
	END
	FUNCTION RNORM(XMEAN,STDEV)
C
C	THIS ROUTINE FINDS A RANDOM NORMAL NUMBER
C	WITH A GIVEN MEAN AND ST. DEVIATION
C
	RNORM=0.
	DO 1 I=1,12
1	RNORM=RNORM+RAN(X)
	RNORM=RNORM-6.
	RNORM=RNORM*STDEV+XMEAN
	RETURN
	END
	SUBROUTINE SELECT(M)
C
C	ARGUMENT FROM THE CALLING PROGRAM:
C
C	M------NUMBER OF VARIABLES
C
C
C	ARGUMENTS RETURN TO THE CALLING PROGRAM
C
C	N------TOTAL NUMBER OF CONDITIONS, BOTH 'AND'S AND 'OR'S
C	NVAR---VARIABLE NUMBER ASSOCIATED WITH THE ITH SELECT
C	NCON---CONDITION ASSOCIATED WITH THE ITH SELECT
C		"=" IS 1, ">" IS 2, ">=" IS 3, "<" IS 4, "<=" IS 5, "<>" IS 6
C	VALUE--VALUES ASSOCIATED WITH ITH SELECT
C	NVAL---NUMBER OF VALUES AFTER THE CONDITION SYMBOL
C	NOR----LINE NUMBER OF THE ITH SELECT, ILLEGAL LINES NOT COUNTED
C		'OR' CONDITIONS HAVE THE SAME LINE NUMBERS
C		'AND' CONDITIONS HAVE DIFFERENT LINE NUMBERS
C
	DIMENSION NAME(800),NUM(800),MODE(800),IDUM(72),ISYM(3),ICON(3),
     1 DUM(72),IVEC(125),NNS(18,6),V(15),IV(15),WORD(3),
     2 IVALUE(20,20),ISAVE(5)
C
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SELEC/N,NVAR(20),NCON(20),VALUE(20,20),NVAL(20),NOR(20)
C
	DOUBLE PRECISION NAMO,NAMI
	EQUIVALENCE (ITEMP(1),IDUM,DUM), (ITEMP(73),IV,V),
     1 (ITEMP(88),IVEC,NNS), (ITEMP(2601),NAME),(ITEMP(3401),NUM),
     2 (ITEMP(4201),MODE), (IVALUE,VALUE)
C
	DATA ISYM/'=','>','<'/
	DATA ICON/1,2,4/
C
	IF (IDEVO.NE.'TTY') WRITE(IOUT,101)
101	FORMAT('-',29X,'SELECT OPTION:'/)
1000	WRITE(IDLG,10)
10	FORMAT('  SELECT OPTION:'/'  ?',$)
	READ(ICC,11,END=8)IDUM
11	FORMAT(72A1)
	IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
     1 .AND.(IDUM(4).EQ.'P')) GO TO 90
	IF ((IDUM(1).EQ.'S').AND.(IDUM(2).EQ.'A').AND.(IDUM(3).EQ.'M')
     1.AND.(IDUM(4).EQ.'E')) GO TO 95
	N=0
	LINE=0
122	LINE=LINE+1
	NR=0
	DO 12 LAST=72,1,-1
	IF (IDUM(LAST).NE.' ') GO TO 201
12	CONTINUE
	GO TO 8
C
C	BUILD VARIABLE NAME OR NUMBER
C
201	I=1
2	DO 20 J=1,5
20	ISAVE(J)=' '
	DO 210 J=1,15
210	IV(J)=' '
	ICOND=0
	IS=0
200	L=IDUM(I)
	IF (L.EQ.' ') GO TO 22
	DO 21 JJ=1,3
	IF (L.EQ.ISYM(JJ)) GO TO 25
21	CONTINUE
	IS=IS+1
	IF (IS.LE.5) ISAVE(IS)=L
22	I=I+1
	IF (I.LE.LAST) GO TO 200
230	WRITE(IDLG,23)
23	FORMAT('-ERROR:  Invalid entry, Re-enter the line'//)
231	IF (ICODE.LT.0) CALL EXIT
232	LINE=LINE-1
	N=N-NR
240	WRITE(IDLG,24)
24	FORMAT('+ ?',$)
	READ(ICC,11,END=8) IDUM
	GO TO 122
C
C	IF VARIABLE NAME, CHECK IF IT WAS DEFINED
C
25	ISTORE=' '
	DO 251 J=1,5
	IF((ISAVE(J).LT.'0'.OR.ISAVE(J).GT.'9').AND.
     1   ISAVE(J).NE.' ')GO TO 252
251	CONTINUE
	GO TO 28
252	ENCODE(5,11,ISTORE)ISAVE
	DO 26 J=1,M
	IF (ISTORE.EQ.NAME(J)) GO TO 40
26	CONTINUE
	IF (IBNK.EQ.1) GO TO 41
270	WRITE(IDLG,27) ISTORE
27	FORMAT('-ERROR:  Variable "',A5,'" does not exist, Re-enter
     1 the line'//)
	IF (ICODE.GE.0) GO TO 232
	CALL EXIT
C
C	IF VARIABLE NUMBER, JUSTIFY AND RANGE CHECK
C
28	IF (ISAVE(5).NE.' ') GO TO 30
	DO 29 J=4,1,-1
29	ISAVE(J+1)=ISAVE(J)
	ISAVE(1)=' '
	GO TO 28
30	NSTORE=' '
	ENCODE(5,11,NSTORE) ISAVE
	DECODE(5,31,NSTORE) ISTORE
31	FORMAT(I5)
	IF (ISTORE.LE.0) GO TO 230
	IF (N.GE.20) GO TO 80
	IF (IBNK.NE.0) GO TO 32
C
C	GET MODE OF VARIABLE;  0 = FLOAT, 1 = ALPHA, 2 = FIX
C
C		VARIABLE #, NON-DATABANK
C
	IF (ISTORE.LE.M) GO TO 311
	ISTORE=NSTORE
	GO TO 270
311	N=N+1
	NVAR(N)=ISTORE
	MO=MODE(ISTORE)
	GO TO 5
C
C		VARIABLE #, DATABANK

C
32	IF (ISTORE.LE.NVBNK) GO TO 321
	ISTORE=NSTORE
	GO TO 270
321	I1=(ISTORE+5)/6
	I2=I1+1+(NOBNK+124)/125*NVBNK
	READ(INP#I2) IVEC
	N=N+1
	NVAR(N)=ISTORE
	I1=ISTORE-(I1-1)*6
	MO=NNS(10,I1)
	GO TO 5
C
C		VARIABLE NAME, NON-DATABANK
C
40	IF (N.GE.20) GO TO 80
	N=N+1
	NVAR(N)=NUM(J)
	MO=MODE(J)
	GO TO 5
C
C		VARIABLE NAME, DATABANK
C
41	I1=(NOBNK+124)/125*NVBNK+1
	NT=(NVBNK+5)/6
	DO 42 J=1,NT
	I2=I1+J
	READ(INP#I2) IVEC
	DO 42 J1=1,6
	IF (ISTORE.EQ.NNS(1,J1)) GO TO 43
42	CONTINUE
	GO TO 270
C
43	IF (N.GE.20) GO TO 80
	N=N+1
	NVAR(N)=(J-1)*6+J1
	MO=NNS(10,J1)
C
C	CHECK FOR VALID CONDITION
C	JJ = CONDITION INDEX INTO ISYM, ICON;  I = CHAR POS IN INPUT LINE
C	ICNDCT = COUNT OF CONDITIONAL SYMBOLS, NEVER MORE THAN 2
C
5	NOR(N)=LINE
	NR=NR+1
	NV=0
	ICNDCT=0
50	IF(ICOND.EQ.ICON(JJ))GO TO 230
	ICOND=ICOND+ICON(JJ)
	ICNDCT=ICNDCT+1
	IF(ICNDCT.GT.2)GO TO 230
51	I=I+1
	IF (I.GT.LAST) GO TO 230
	IF(IDUM(I).EQ.' ')GO TO 51
	DO 53 JJ=1,3
	IF (IDUM(I).EQ.ISYM(JJ)) GO TO 50
53	CONTINUE
C
C	BUILD VALUE AND CHECK ITS VALIDITY
C
	NCON(N)=ICOND
602	IS=0
	L=IDUM(I)
	IF(L.NE.' ')GO TO 603
	I=I+1
	IF(I.GT.LAST)GO TO 230
	GO TO 602
603	IF (MO.NE.1) GO TO 60
	IF (L.EQ.1H') GO TO 6
601	WRITE(IDLG,600)
600	FORMAT('-ERROR:  Missing '' in an A-type variable'/9X,'Re-enter
     1 the line'//)
	GO TO 231
6	I=I+1
	IF(I.GT.LAST)GO TO 230
	L=IDUM(I)
	GO TO 61
C
C	MAX # CHAR IN VARIABLE STRING IS 15
C
60	IF ((L.LT.'0'.OR.L.GT.'9').AND.(L.NE.'-'.AND.L.NE.'.')) GO TO 230
61	IS=IS+1
	IF (IS.LE.15) IV(IS)=L
	I=I+1
	IF (I.GT.LAST) GO TO 62
	L=IDUM(I)
	IF ((L.NE.';').AND.(L.NE.','))GO TO (60,61,60),MO+1
62	NV=NV+1
	IF (NV.LE.20) GO TO 621
	WRITE(IDLG,620)
620	FORMAT('-ERROR:  Too many values in the string (max=20)'
     1  /9X,'Re-enter the line'//)
	GO TO 231
C
C	CHECK FOR COMMAS SEPARATING MULTIPLE VALUES (= ONLY)
C
621	IF ((L.NE.',').OR.((L.EQ.',').AND.(ICOND.EQ.1))) GO TO
     1 (66,63,66), MO+1
	WRITE(IDLG,623)
623	FORMAT('-ERROR:  Multiple values can only be performed on a
     1 ''EQUAL'' CONDITION'/9X,'Re-enter the line'//)
	GO TO 231
C
C	PROCESS A-TYPE VALUE
C
63	IF (IS.LE.6) GO TO 65
	WRITE(IDLG,64) IV
64	FORMAT('-ERROR:  ',15A1,' Is too long for A-type variable ',
     1 '(max=5 char),'/9X,'Re-enter the line'//)
	GO TO 231
65	IF (IV(IS).NE.1H') GO TO 601
	IS=IS-1
	IVALUE(NV,N)=' '
	ENCODE(IS,11,IVALUE(NV,N)) (IV(J),J=1,IS)
C
C
652	NVAL(N)=NV
	I=I+1
	IF (I.GT.LAST) GO TO 651
	IF (L.EQ.';') GO TO 2
	IF (L.EQ.',') GO TO 602
651	IF (IDEVO.NE.'TTY') WRITE(IOUT,650) IDUM
650	FORMAT(37X,72A1)
	GO TO 240
C
C	PROCESS F-TYPE AND I-TYPE VALUES
C
66	IDSHCT=0
	IPERCT=0
	DO 67 J=1,IS
	IF (IV(J).EQ.'.')IPERCT=IPERCT+1
	IF (IV(J).EQ.'-')IDSHCT=IDSHCT+1
67	CONTINUE
	IF(IPERCT.GT.1)GO TO 230
	IF(IDSHCT.GT.1.OR.(IDSHCT.EQ.1.AND.IV(1).NE.'-'))GO TO 230
	IF(IPERCT.EQ.1.AND.MO.EQ.2)GO TO 693
C
C		RIGHT JUSTIFY NUMBER IN WORK VECTOR IV
C
670	I1=16
	DO 68 J=IS,1,-1
	I1=I1-1
68	IV(I1)=IV(J)
	DO 69 J=1,IS
69	IV(J)=' '
	DO 6900 J=1,3
6900	WORD(J)=' '
	ENCODE(15,11,WORD) IV
	IF (MO.EQ.2) GO TO 691
	DECODE(15,690,WORD) VALUE(NV,N)
690	FORMAT(G15.0)
	GO TO 652
C
691	DECODE(15,692,WORD) IVALUE(NV,N)
692	FORMAT(I15)
	GO TO 652
C
693	WRITE(IDLG,694)
694	FORMAT('-ERROR:  Cannot have a decimal point in a I-type
     1 variable'/9X,'Re-enter the line'//)
	GO TO 231
C
8	IF (N.GT.0) RETURN
	WRITE(IDLG,81)
81	FORMAT('-ERROR:  No qualifier accepted, Try again'//)
	IF (ICODE.GE.0) GO TO 1000
	CALL EXIT
C
80	WRITE(IDLG,83)
83	FORMAT('-ERROR:  Too many qualifiers requested (max=20)'
     1 /9X,'Program will ignore the last SELECT statement'//)
	N=N-NR
	RETURN
C
90	WRITE(IDLG,91)
91	FORMAT('-SELECT option allows the program to consider only those
     1 observations'/' meeting user specified criteria.  Instructions to
     2 the SELECT option'/' (QUALIFIERS) are entered on a line or on
     3 separate lines.  Each'/' QUALIFIER contains 3 basic parts:
     4  VARIABLE, CONDITION, and VALUE or'/' VALUES to be compared
     5 against.  The variable may be specified by'/' either the variable
     6 NAME (if previously defined), or the variable'/' number (in the
     7 case of data BANK file, this is the number associated'/' with the
     8 BANK).  The CONDITION may be one of the following:'//6X,
     9 'CONDITION',5X,'MEANING'/6X,9('-'),5X,7('-')/9X,'=',10X,'equal
     1 to'/9X,'<',10X,'less than'/9X,'>',10X,'greater than'/6X,'<= or =<
     2',6X,'less than or equal to'/6X,'>= or =>',6X,'greater than or
     3 equal to'/6X,'<> or ><',6X,'not equal'//)
	WRITE(IDLG,92)
92	FORMAT(' The value to be compared against must be of the same
     1 type as the'/' variable it is compared with.'//' Enter each
     2 QUALIFIER immediately after the ? is typed out by the program'/
     3 ' Several QUALIFIERS may be ''OR'' together by entering the
     4 QUALIFIERS on'/' a line separated by semi-colons (;).  Enter a
     5 ^Z, a carriage return or'/' a blank line immediately after the ?
     6 to signify the end of all'/' QUALIFIERS.  Up to 20 Qualifiers may
     7 be specified.'//' EXAMPLE: To consider all those observations in
     8 which variable 3 is'/11X,'not ZERO, and variable 5 is less than 4
     9 or greater than 8.'//11X,'SELECT OPTION:'/11X,'?3<>0'/11X,
     1'?5<4;5>8'/11X,'?^Z'//)
	GO TO 1000
C
C	SAME OPTION
C
95	IF (IDEVO.NE.'TTY') WRITE(IOUT,950)
950	FORMAT(37X,'SAME AS THE PRECEEDING RUN'/)
	RETURN
	END
	SUBROUTINE VARLST(NSIZE)
C
C	THIS SUBROUTINE WAS WRITTEN BY BERENICE HOUCHARD ON 1974 FOR
C	SOME OF THE PROGRAMS IN THE BANK SYSTEM, SPECIFICALLY, FREQ.FRE,
C	CORL.COR,TAB.TAB AND REGR.REG.
C
C	THE SUBROUTINE ACCEPTS EITHER THE TOTAL NUMBER OF VARIABLES IN
C	THE ANALYSIS OR A STRING OF VARIABLE NAMES TO BE ASSIGNED TO
C	THE VARIABLES AND HENCE IMPLICITLY DETERMINE THE TOTAL NUMBER OF
C	VARIABLES IN THE ANALYSIS.
C
C	A VARIABLE NAME CONSISTS OF ONE TO FIVE ALPHANUMERIC CHARACTERS
C	THE FIRST BEING NON-NUMERIC.  IT MAY NOT CONTAIN ANY OF THE
C	FOLLOWING SYMBOLS:
C
C		*  ?  -  /  ,  +  '  .  BLANK
C
C	SEVERAL RESERVED WORDS MAY NOT BE USED AS VARIABLE NAMES, THEY
C	ARE:  ALL  HELP  EMPTY  STOP  OBS
C
C
	DIMENSION NAME(800),NUM(800),IDUM(72),ISAVE(5),IRSYM(9),IRWRD(5)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
C
	DOUBLE PRECISION NAMO,NAMI
	EQUIVALENCE (ITEMP(1),ISAVE),(ITEMP(6),IDUM),(ITEMP(2601),NAME),
     1 (ITEMP(3401),NUM)
C
	DATA IRSYM/' ','-','.','*','/','?','"','+',';'/
	DATA IRWRD/'ALL','HELP','EMPTY','STOP','OBS'/
	DATA IGRT/'$'/
C
1	WRITE(IDLG,10)
10	FORMAT(' ENTER # OF VARIABLES OR VARIABLE NAMES'/)
	NSIZE=0
11	DO 110 I=1,5
110	ISAVE(I)=' '
	CALL GES(IDUM,72,IEND)
	NPT=1
	IF (IEND.NE.2) GO TO 111
112	IF (ICODE) 1,1,901
111	IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
     1 .AND.(IDUM(4).EQ.'P')) GO TO 90
C
C	# OF VARIABLES ENTERED
C
	DO 1230 I=10,1,-1
	IF (IDUM(I).NE.' ') GO TO 124
1230	CONTINUE
124	J=I
	IF((IDUM(J).EQ.IALT).OR.(IDUM(J).EQ.IDOL)) J=J-1
C
C	CHECK IF VALID NUMBER
C
	DO 777 I=1,J
	IF((IDUM(I).LT.'0').OR.(IDUM(I).GT.'9')) GOTO 20
777	CONTINUE
C
C
	DO 123 I=1,J
123	ISAVE(I)=IDUM(I)
12	IF (ISAVE(5).NE.' ') GO TO 121
	DO 120 I=4,1,-1
120	ISAVE(I+1)=ISAVE(I)
	ISAVE(1)=' '
	GO TO 12
121	ENCODE(5,151,L) ISAVE
	DECODE(5,122,L) NSIZE
122	FORMAT(I5)
C
C	GENERATE VARIABLE NUMBERS
C
	IF (NSIZE.LE.0) GO TO 19
	IF (NSIZE.GT.800) GO TO 191
	DO 13 I=1,NSIZE
	DO 14 J=1,5
14	ISAVE(J)=' '
	ENCODE(5,150,NAME(I)) I
150	FORMAT(I5)
	DECODE(5,151,NAME(I)) ISAVE
151	FORMAT(5A1)
16	IF (ISAVE(1).NE.' ')  GO TO 18
	DO 17 K=1,4
17	ISAVE(K)=ISAVE(K+1)
	ISAVE(5)=' '
	GO TO 16
18	ENCODE(5,151,NAME(I)) ISAVE
	NUM(I)=I
13	CONTINUE
	RETURN
C
19	WRITE(IDLG,190) NSIZE
190	FORMAT('-ERROR:  Number of variables ',I6,' outside allowable
     1 range,'/9X,'Try again'/)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
191	WRITE(IDLG,192)
192	FORMAT('-ERROR:  Variable name list too long, contact computer
     1 center staff'/9X,'for help'/)
	CALL EXIT
C
C	VARIABLE NAMES ENTERED
C
20	DO 200 LAST=72,1,-1
	IF (IDUM(LAST).NE.' ') GO TO 201
200	CONTINUE
	GO TO 40
201	IF((IDUM(LAST-1).NE.',').OR.(IDUM(LAST).NE.IALT).OR.(IDUM(LAST)
     .	.OR.IGRT)) GOTO 2201
	LAST=LAST-1
	IDUM(LAST)=IALT
2201	ISUB=0
	N=0
	DO 21 K=1,LAST
	L=IDUM(K)
	IF ((L.EQ.',').OR.(L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 30
	IF (L.EQ.' ') GO TO 21
	DO 22 I=2,9
	IF (L.EQ.IRSYM(I)) GO TO 23
22	CONTINUE
	IF (N.GE.5) GO TO 21
	N=N+1
	ISAVE(N)=L
	GO TO 21
C
23	WRITE(IDLG,230) L
230	FORMAT('-ERROR:  Reserved character "',A1,'" in variable name'/)
	GO TO 25
24	WRITE(IDLG,240) NAME(NSIZE)
240	FORMAT('-ERROR:  Variable name "',A5,'" is reserved'/)
25	IF (ICODE.LT.0) CALL EXIT
	WRITE(IDLG,250)
250	FORMAT('+Re-enter the line'/)
	NSIZE=NSIZE-ISUB
	GO TO 11
C
30	IF ((K.EQ.1).AND.((L.EQ.IALT).OR.(L.EQ.IGRT))) GO TO 40
	IF (N.LE.0) GO TO 21
301	IF ((ISAVE(1).LT.'0').OR.(ISAVE(1).GT.'9')) GO TO 31
	WRITE(IDLG,300) ISAVE
300	FORMAT('-ERROR:  Variable name "',5A1,'" starts with a number'/)
	GO TO 25
C
31	NSIZE=NSIZE+1
	IF (NSIZE.GT.800) GO TO 191
	ISUB=ISUB+1
	NAME(NSIZE)=0
	ENCODE(5,151,NAME(NSIZE)) ISAVE
	DO 32 I=1,5
	IF (NAME(NSIZE).EQ.IRWRD(I)) GO TO 24
32	CONTINUE
	NUM(NSIZE)=NSIZE
	IF(NPT.EQ.2) GOTO 40
330	N=0
	DO 33 I=1,5
33	ISAVE(I)=' '
	IF ((L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 40
21	CONTINUE
	IF(L.EQ.',') GOTO 11
	IF (N.LE.0) GO TO 40
	NPT=2
	GO TO 301
C
40	IF (NSIZE-1) 19,411,410
410	DO 41 I=1,NSIZE-1
	DO 41 J=I+1,NSIZE
	IF (NAME(I).EQ.NAME(J)) GO TO 42
41	CONTINUE
411	RETURN
C
42	WRITE(IDLG,420) NAME(I),I,J
420	FORMAT('-ERROR:  Variable name "',A5,'" is used in variables ',
     1 I5,' and ',I5)
	IF (ICODE.LT.0) CALL EXIT
	WRITE(IDLG,421)
421	FORMAT('-Enter correction in the order:  VARIABLE #, COMMA,
     1 VARIABLE NAME OR A - TO DELETE'/)
	READ(ICC,422) I,L
422	FORMAT(I,A5)
	IF (L.EQ.'-    ') GO TO 43
	NAME(I)=L
	NUM(I)=I
	GO TO 40
43	DO 44 J=I+1,NSIZE
	NAME(J-1)=NAME(J)
44	NUM(J-1)=NUM(J)
	NSIZE=NSIZE-1
	GO TO 40
C
C	HELP
C
90	WRITE(IDLG,900)
900	FORMAT('-This line defines directly and indirectly the number of
     1 variables to'/' be used in the analysis.  If a number is entered,
     2 it is assumed to be'/' the number of variables and variable name
     3 option is not selected.'/' If a variable name list is entered,
     4 the number of variables is'/' counted from the list.  Variable
     5 name list should conform to the'/' following rules:'//
     6 ' (1)  The list is composed of 1 or more lines.  If more than
     7 1 line'/6X,'is needed the last character in the line must
     . be a comma.'/6x,'The list must be terminated with a
     . carriage return or an altmode.'//
     8' (2)  Variable name is made of 1 to 5
     9 alphanumeric characters, the'/6x,'first being non-numeric.'//6x,
     1 'The names may not contain any of the following symbols:'// 6x,
     2 '*      ?      -      /      ,      +      ''      .      BLANK'/
     4/ 6X,'Nor may be any of the reserved words:'//
     5 6X,'ALL    HELP   EMPTY  STOP   OBS'/)
	IF (ICODE.GE.0) GO TO 1
901	CALL EXIT
	END