Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50520/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