Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/bank/bnk1.ban
There are 3 other files named bnk1.ban in the archive. Click here to see a list.
C *** BANK ***
C
C THIS SUBROUTINE CONCERNED WITH THE CREATION OF A BANK FROM
C ASCII DATA. THE FILE IS CREATED IN TWO PARTS THE FIRST IS THE
C NAMES AND DESCRIPTIONS ENTERED INTO A FILE CALLED HEADR.TMP
C NEXT THE DATA IS STORED IN DZBA.TMP AS THE CORRECT
C BLOCKS BUT THE SEQUENCE IS OFF. FINALY THE FIRST BLOCK IS
C WRITTEN THE DATA IS READ FROM DZBA AND THEN THE HEADR FILE.
C
SUBROUTINE MABNK
COMMON /DEV/ IDLG,ICC,IBNK,IUPGR,ITMPRY,MPROG
COMMON /GEN/ IPROJA,IPROGA,NV,NO,BNKNM,DATCR,NPROJR,NPROGR
DIMENSION D(7000), NAMES(500), NAME(80), DATMIS(500,6), FMT(125)
DIMENSION Z(125),NNS(18,6),FMTT(600),KDSC(8,500),XX(9),ITYPE(500)
DIMENSION NAMDES(40),NAMV(5),MPLC(4),MDATA(20),FT(600),SAV(5)
DIMENSION DATED(2),NSAV(5),INPUT(80),MSAV(5),LSAV(5),IPATH(3)
EQUIVALENCE (D,FMTT),(D(650),FT,KDSC),(D(5000),ITYPE)
EQUIVALENCE (D(6000),NAMES),(Z,NNS),(SAV,NSAV),(INPUT,D(6700))
EQUIVALENCE (MISS,AMISS),(ILBKT,BKTLFT)
DOUBLE PRECISION BNKNM,DATCR,FILNAM,DEFNAM,FMTFIL,NDMFIL
DATA XX/'A','I','F','G','E','(',')','D','O'/
DATA DEFNAM/'INPUT.DAT'/
DATA ILBKT,IRBKT/"555004020100,"565004020100/
DATA MISS/"400000000000/
IUSER=2
WRITE(IDLG,3) BNKNM
3 FORMAT(' CREATING A NEW BANK TO BE NAMED - ',A10)
C
C CHECK FOR NAME
C
C
C INPUT DEVICE AND FILE NAME IF APLICABLE
C
900 WRITE(IDLG,901)
901 FORMAT('0INPUT? ',$)
READ(ICC,204,END=746) INPUT
IF(INPUT(1).EQ.'!') GO TO 746
DO 905 I=80,1,-1
IF(INPUT(I).NE.' ') GO TO 906
905 CONTINUE
IEND=0
GO TO 904
906 IEND=I
I=0
907 I=I+1
909 IF(I.EQ.IEND) GO TO 910
IF(INPUT(I).NE.' ') GO TO 907
DO 908 J=I+1,IEND
908 INPUT(J-1)=INPUT(J)
INPUT(IEND)=' '
IEND=IEND-1
GO TO 909
910 IF((INPUT(1).NE.'H').OR.(INPUT(2).NE.'E').
1OR.(INPUT(3).NE.'L').OR.(INPUT(4).NE.'P').OR.(INPUT(5).NE.' '))
2 GO TO 904
WRITE(IDLG,902)
902 FORMAT('0THIS ANSWER DEFINES WHERE THE INPUT DATA IS TO BE FOUND.'
1/'IT USUALLY CONSISTS OF A DEVICE, A FILENAME AND EXTENSION,'/
2' AND POSSIBLY A PROJECT PROGRAMMER NUMBER. POSSIBLE DEVICES ARE:'
3/' TTY: - TELETYPE'/' DSK: - DISK'/
3' CDR: - CARD READER'/
4' DTA#: - DECTAPE (MUST BE MOUNTED ALREADY'/
5' MTA#: - MAGTAPE (MUST BE MOUNTED AND POSITIONED)'/
6'0DEFALUTS:'/
7' IF NO INPUT DEVICE IS SPECIFIED, BUT A FILE NAME IS GIVEN,'/
8' THE DISK WILL BE USED AS THE DEVICE.'/
9'0 IF A DEVICE REQUIREING A FILE NAME IS GIVEN BUT NO FILE'/
1' NAME IS INDICATED, INPUT.DAT WILL BE ASSUMED.'/
2'0 IF NO RESPONSE IS GIVEN TTY: WILL BE USED.'/
3'0 IF DSK: IS SPECIFIED WITHOUT A PROJECT-PROGRAMMER NUMBER'/
4' THE USERS PROJECT PROGRAMMER NUMBER WILL BE ASSUMED.'/
5'0EXAMPLES:'/' TTY:'/' DSK:DATA.DAT'/)
GO TO 900
903 RETURN
904 DEV='TTY'
FILNAM=DEFNAM
IPATH(1)=0
IPATH(2)=0
IPATH(3)=0
IF(IEND.EQ.0) GO TO 970
C
C DEVICE
C
I=1
911 I=I+1
IF(I.GT.IEND) GO TO 914
IF(INPUT(I).EQ.':') GO TO 913
IF(INPUT(I).EQ.ILBKT) GO TO 914
GO TO 911
913 L=I-1
ENCODE(L,204,DEV)(INPUT(J),J=1,L)
L=I
GO TO 912
914 L=0
DEV='DSK'
C
C FILE NAME
C
912 DO 915 J=1,10
915 NAMDES(J)=' '
J=0
POINT=0
916 L=L+1
IF(L.GT.IEND) GO TO 920
IF(INPUT(L).EQ.'.') POINT=1
IF(INPUT(L).EQ.ILBKT) GO TO 920
IF(J.LT.10) GO TO 918
WRITE(IDLG,917)
917 FORMAT(' A COLON MUST FOLLOW THE DEVICE AND FILE NAME MAY BE'/
1' NO LONGER THAN 10 CHARACTERS')
GO TO 900
918 J=J+1
NAMDES(J)=INPUT(L)
GO TO 916
920 IF(POINT.EQ.1) GO TO 921
IF(J.GT.9) GO TO 921
J=J+1
NAMDES(J)='.'
921 ENCODE(10,204,FILNAM)(NAMDES(J),J=1,10)
C
C PROJECT NUMBER
C
IF(INPUT(L).NE.ILBKT) GO TO 970
DO 930 J=1,10
930 NAMDES(J)=' '
J=0
931 L=L+1
IF(L.GT.IEND) GO TO 935
IF(INPUT(L).EQ.IRBKT) GO TO 935
IF(INPUT(L).EQ.',') GO TO 940
IF((INPUT(L).GE.'0').AND.(INPUT(L).LE.'7')) GO TO 933
WRITE(IDLG,932)
932 FORMAT(' ILLEGAL CHARACTER IN PROJECT NUMBER')
GO TO 900
933 IF(J.LE.6) GO TO 936
935 WRITE(IDLG,934)
934 FORMAT(' MUST BE A COMMA BETWEEN PROJCT AND PROGRAMMER NUMBER')
GO TO 900
936 J=J+1
NAMDES(J)=INPUT(L)
GO TO 931
940 IF(J.GT.0) GO TO 941
IPATH(1)=0
GO TO 949
941 IF(NAMDES(10).NE.' ') GO TO 943
DO 942 K=9,1,-1
942 NAMDES(K+1)=NAMDES(K)
NAMDES(1)=' '
GO TO 941
943 ENCODE(10,204,DATED) (NAMDES(J),J=1,10)
DECODE(10,944,DATED) IPATH(1)
944 FORMAT(O10)
949 DO 950 J=1,10
950 NAMDES(J)=' '
J=0
951 L=L+1
IF(L.GT.IEND) GO TO 956
IF(INPUT(L).EQ.IRBKT) GO TO 956
IF((INPUT(L).GE.'0').AND.(INPUT(L).LE.'7')) GO TO 953
WRITE(IDLG,952)
952 FORMAT(' ILLEGAL CHARACTER IN PROGRAMMER NUMBER')
GO TO 900
953 IF(J.LE.6) GO TO 954
WRITE(IDLG,955)
955 FORMAT(' PROGRAMMER NUMBER TOO LONG')
GO TO 900
954 J=J+1
NAMDES(J)=INPUT(L)
GO TO 951
956 IF(J.GT.0) GO TO 957
IPATH(2)=0
GO TO 970
957 IF(NAMDES(10).NE.' ') GO TO 958
DO 959 K=9,1,-1
959 NAMDES(K+1)=NAMDES(K)
NAMDES(1)=' '
GO TO 957
958 ENCODE(10,204,DATED)(NAMDES(J),J=1,10)
DECODE(10,944,DATED) IPATH(2)
970 CALL EXISTS(DEV,FILNAM,IERR,IPATH(1),IPATH(2))
IF(IERR.EQ.0) GO TO 972
WRITE(IDLG,971)
971 FORMAT(' ? FILE DOES NOT EXIST')
GO TO 900
972 OPEN(UNIT=IUSER,DEVICE=DEV,ACCESS='SEQIN',FILE=FILNAM,
1 DIRECTORY=IPATH)
26 WRITE (IDLG,27)
27 FORMAT (' HOW MANY VARIABLES? ',$)
READ (ICC,28,END=25) NV
28 FORMAT (I)
IF (NV.LE.500) GO TO 30
WRITE (IDLG,29)
29 FORMAT (' THE MAXIMUM FOR THIS PROGRAM IS 500-FOR MORE SEE DICK
1HOUCHARD')
25 RETURN
30 WRITE (IDLG,330)
C
C FORMATTING FOR MABNK UP TO 400 CHARACTERS
C
330 FORMAT (' ENTER FORMAT ENCLOSED IN PARENTHESIS'/)
KOUNT=0
LFILE=0
ICARDS=1
L=1
DO 208 I=1,600
208 FMTT(I)=' '
200 K=L+79
IF(K.GT.600)K=600
IF(LFILE.EQ.1) READ(MPROG,204,END=25)(FMTT(I),I=L,K)
IF(LFILE.EQ.0)READ (ICC,204,END=25) (FMTT(I),I=L,K)
IF((L.EQ.1).AND.(FMTT(1).EQ.'!')) GO TO 746
IF((L.EQ.1).AND.(FMTT(1).EQ.'@')) GO TO 546
IF((L.EQ.1).AND.(FMTT(1).NE.'(')) GO TO 212
DO 201 N=K,L,-1
IF(FMTT(N).NE.' ') GO TO 202
201 CONTINUE
202 DO 203 J=L,N
IF(FMTT(J).EQ.'(') KOUNT=KOUNT+1
IF(FMTT(J).EQ.')') KOUNT=KOUNT-1
IF(FMTT(J).EQ.'/') ICARDS=ICARDS+1
203 CONTINUE
IF(N.LT.600) GO TO 209
WRITE(IDLG,210)
210 FORMAT(' FORMAT TOO LONG')
GO TO 30
212 WRITE(IDLG,213)
213 FORMAT(' FORMAT MUST BE ENCLOSED IN PARENTHESIS')
GO TO 30
546 DO 547 I=2,11
IF(FMTT(I).NE.BKTLFT) GO TO 547
WRITE(IDLG,548)
548 FORMAT(' NO BRACKETS WHEN SPECIFYING FILE FOR FORMAT')
GO TO 30
547 CONTINUE
ENCODE(10,204,FMTFIL)(FMTT(I),I=2,11)
CALL EXIST(FMTFIL,IERR,NPROJR,NPROGR)
IF(IERR.EQ.0) GO TO 550
WRITE(IDLG,549)
549 FORMAT(' FILE SPECIFIED FOR FORMAT NOT AVAILABLE')
GO TO 30
550 IF(LFILE.NE.1) GO TO 552
WRITE(IDLG,551)
551 FORMAT(' FORMAT FILE MAY NOT BE SPECIFIED IN A FORMAT FILE')
GO TO 30
552 LFILE=1
OPEN(UNIT=MPROG,DEVICE='DSK',FILE=FMTFIL,ACCESS='SEQIN')
GO TO 200
209 L=N+1
IF(KOUNT.GT.0) GO TO 200
IF(KOUNT.LT.0) WRITE(IDLG,206)
206 FORMAT(' UNBALANCED PARENTHESIS')
IF(KOUNT.LT.0) GO TO 30
ENCODE(600,204,FMT(1))FMTT
204 FORMAT(600A1)
C
C REMOVE ALL BUT IMPORTANT INFO FROM FORMAT
C
IF(LFILE.EQ.1) CLOSE(UNIT=MPROG)
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 PARENTHESIS
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.600) 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,204,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.600) 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.600) 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 PAUSE 'PROBLEM SEE DICK HOUCHARD'
RETURN
540 K=1
IF(NV.EQ.N) GO TO 543
WRITE(IDLG,544)
544 FORMAT(' CAUTION - NUMBER OF VARIABLES DOES NOT AGREE WITH FORMAT'
1)
543 IF(ICARDS.GT.1) WRITE(IDLG,545) ICARDS
545 FORMAT('0MULTIPLE RECORD FORMAT - ',I4,' RECORDS READ PER READ')
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
C
C NAME AND DESCRIPTION(AUTO MADE)
C
SAV(1)='V'
SAV(5)=' '
DO 400 I=1,NV
ENCODE(3,401,K) I
401 FORMAT(I3)
DECODE(3,204,K)(SAV(J),J=2,4)
402 IF(SAV(2).NE.' ') GO TO 405
DO 403 J=3,4
403 SAV(J-1)=SAV(J)
SAV(4)=' '
GO TO 402
405 ENCODE(5,204,NAMES(I)) SAV
DATMIS(I,1)=0
ENCODE(40,404,KDSC(1,I)) I,BNKNM
404 FORMAT('ORIGINAL VARIABLE NUMBER ',I3,' -',A10)
400 CONTINUE
C
C
C CHANCE TO CHANGE AUTOMATIC NAME AND DESCRIPTIONC
LFILE=0
C
WRITE(IDLG,409)
409 FORMAT('0ENTER NAMES, DESCRIPTIONS AND MISSING DATA'/)
440 IF(LFILE.EQ.0) WRITE(IDLG,441)
441 FORMAT('+? ',$)
IF(LFILE.EQ.1) READ(MPROG,204,END=570) INPUT
IF(LFILE.EQ.0) CALL GES(INPUT,80,ICHECK)
IF(ICHECK.EQ.2) GO TO 700
IF((INPUT(1).NE.'H').OR.(INPUT(2).NE.'E').OR.(INPUT(3).NE.'L').
1OR.(INPUT(4).NE.'P')) GO TO 406
WRITE(IDLG,407)
407 FORMAT(
1'0THE VARIABLES HAVE ALREADY BEEN GIVEN THE NAMES: V1, V2,'/
2' V3, V4, ...., AND DESCRIPTIONS: THIS IS THE ORIGINAL'/
3' VARIABE NO 1, ETC. NO MISSING DATA SYMBOLS HAVE BEEN'/
4' ASSUMED. TO CHANGE THESE, TYPE THE VARIABLE NO, AN EQUALS'/
5' SIGN, THE NAME OF THE VARIABLE (UP TO 5 CHARACTERS, FIRST'/
6' MUST BE A LETTER), A SEMICOLON, THE DESCRIPTION (UP TO 40'/
7' CHARACTERS), A SLASH AND A MISSING DATA SYMBOL. UP TO 5'/
8' MISSING DATA SMBOLS MAY BE SPECIFIED FOR ONE VARIABLE.'/
9' EXAMPLE:'/
1' 3=SEX ;SEX OF RESPONDANT/3/0/9'/
2' ANY PORTION (NAME,DESCRIPTION, OR MISSING DATA) WHIICH IS'/
3' NOT INCLUDED , WILL NOT BE CHANGED. THE NAME MUST BEGIN IN'/
4' THE FIRST POSITION FOLLOWING THE EQUALS, BUT NONE OF THE'/
5' OTHER PORTIONS REQUIRE SPECIAL POSITIONING. RANGES OF'/
6' VARIABLES MAY BE CHANGED WITH ONE COMMAND, BY INDICATING THE'/
7' LOWEST VARIABLE NUMBER OF THE RANGE, A MINUS, AND THE LARGEST'/
8' VARIABLE NUMBER OF THE RANGE. IF NAMES ARE TO BE CHANGED'/
9' FOR RANGES, A QUESTION MARK MUST BE IN THE NAME. THE')
WRITE(IDLG,408)
408 FORMAT(
1' QUESTION MARK IN THE VARIABLE WILL BE REPLACED WITH A'/
2' NUMBER, STARTING WITH ONE FOR THE FIRST VARIABLE IN THE'/
3' RANGE, TWO FOR THE SECOND, ETC. IF THERE ARE MORE THAN 9'/
4' VARIABLES IN THE RANGE, TWO QUESTION MARKS MUST BE IN THE'/
5' NAME. MISSING DATA MUST BE OF THE SAME TYPE AS VARIABLE'/
6' IT IS SPECIFIED FOR (ALPHA MISSING DATA SYMBOLS MUST BE'/
7' ENCLOSED IN QUOTES)'/
8'0WHEN ALL CHANGES HAVE BEEN MADE TYPE A CARRIAGE RETURN <CR>,'/
9' TO CONTINUE WITH PROGRAM'/)
GO TO 440
406 IF(INPUT(1).EQ.'!') GO TO 746
IF(INPUT(1).EQ.' ') GO TO 700
IF(INPUT(1).EQ."155004020100) GO TO 700
IF(INPUT(1).EQ.'@') GO TO 561
N=1
ISW=0
ISM=0
442 DO 443 I=1,3
443 NSAV(I)=' '
J=1
447 IF(INPUT(N).EQ.'-') GO TO 448
IF(INPUT(N).EQ.'=') GO TO 448
IF((INPUT(N).LE.'9').AND.(INPUT(N).GE.'0')) GO TO 446
444 WRITE(IDLG,445)
445 FORMAT(' ILLEGAL VARIABLE NUMBER'/)
GO TO 440
446 IF(J.GT.3) GO TO 444
NSAV(J)=INPUT(N)
J=J+1
N=N+1
GO TO 447
561 DO 562 I=2,11
IF(INPUT(I).NE.ILBKT) GO TO 562
WRITE(IDLG,563)
563 FORMAT(' NO BRACKETS ON VARIABLE DESCRIPTION FILE'/)
GO TO 440
562 CONTINUE
ENCODE(10,204,NDMFIL) (INPUT(I),I=2,11)
CALL EXIST(NDMFIL,IERR,NPROJR,NPROGR)
IF(IERR.EQ.0) GO TO 565
WRITE(IDLG,564)
564 FORMAT(' FILE FOR DESCRIPTION IS UNAVAILABLE'/)
GO TO 440
565 IF(LFILE.EQ.0) GO TO 567
WRITE(IDLG,566)
566 FORMAT(' DESCRIPTION FILE MAY NOT SPECIFY A DESCRIPTION FILE')
GO TO 440
567 LFILE=1
OPEN(UNIT=MPROG,DEVICE='DSK',FILE=NDMFIL,ACCESS='SEQIN')
GO TO 440
570 CLOSE(UNIT=MPROG)
LFILE=0
GO TO 440
C
448 IF(J.EQ.1) GO TO 444
449 IF(NSAV(3).NE.' ') GO TO 450
NSAV(3)=NSAV(2)
NSAV(2)=NSAV(1)
NSAV(1)=' '
GO TO 449
450 ENCODE(3,204,L) (NSAV(J),J=1,3)
DECODE(3,439,L) ITMP
439 FORMAT(I3)
IF((ITMP.LT.1).OR.(ITMP.GT.NV)) GO TO 444
IF(INPUT(N).EQ.'=') GO TO 455
IF(ISW.EQ.0) GO TO 452
WRITE(IDLG,451)
451 FORMAT(' 2 RANGES INDICATED FOR SINGLE LINE'/)
GO TO 440
452 ISW=1
IBG=ITMP
N=N+1
GO TO 442
455 IF(ISW.EQ.1) GO TO 456
IBG=ITMP
IEND=ITMP
GO TO 457
456 IEND=ITMP
IF(IBG.LE.IEND) GO TO 457
WRITE(IDLG,458)
458 FORMAT(' RANGE MUST BE SPECIFIED FROM LOW TO HIGH'/)
GO TO 440
457 NRN=IEND-IBG+1
N=N+1
C
C NAME FIRST
C
DO 460 I=1,5
460 NSAV(I)=' '
J=1
465 IF(INPUT(N).EQ.' ') GO TO 466
IF(INPUT(N).EQ.';') GO TO 466
IF(INPUT(N).EQ.'/') GO TO 466
IF(J.NE.1) GO TO 463
IF((INPUT(N).LE.'Z').AND.(INPUT(N).GE.'A')) GO TO 463
461 WRITE(IDLG,462)
462 FORMAT(' ILLEGAL NAME'/)
GO TO 440
463 IF(INPUT(N).EQ.'-') GO TO 461
IF(INPUT(N).EQ.',') GO TO 461
IF(INPUT(N).EQ.'(') GO TO 461
IF(INPUT(N).EQ.')') GO TO 461
IF(J.GT.5) GO TO 464
NSAV(J)=INPUT(N)
J=J+1
464 N=N+1
IF(N.LE.80) GO TO 465
466 IF(J.EQ.1) GO TO 600
NQ=0
DO 467 J=1,5
IF((NQ.GT.1).AND.(NSAV(J).NE.'?')) GO TO 468
IF(NSAV(J).NE.'?') GO TO 467
NQ=NQ+1
467 CONTINUE
468 IF(NRN.EQ.1) GO TO 470
IF((NRN.LT.10).AND.(NQ.GE.1)) GO TO 470
IF((NRN.LT.100).AND.(NQ.GE.2)) GO TO 470
IF(NQ.GE.3) GO TO 470
WRITE(IDLG,469)
469 FORMAT(' TOO MANY VARIABLES IN RANGE FOR NO. OF ?'/)
GO TO 440
470 DO 491 I=IBG,IEND
DO 472 J=1,5
472 MSAV(J)=NSAV(J)
IF(NQ.EQ.0) GO TO 490
J=I-IBG+1
ENCODE(5,471,L) J
471 FORMAT(I5)
DECODE(5,204,L) LSAV
DO 473 L=1,5
IF(LSAV(L).NE.' ') GO TO 474
473 CONTINUE
474 DO 475 M=1,5
IF(MSAV(M).EQ.'?') GO TO 476
475 CONTINUE
476 DO 477 J=L,5
MSAV(M)=LSAV(J)
M=M+1
477 CONTINUE
IF(M.GT.5) GO TO 490
478 IF(MSAV(M).NE.'?') GO TO 490
IF(M.EQ.5) GO TO 480
DO 479 J=M,4
479 MSAV(J)=MSAV(J+1)
480 MSAV(5)=' '
GO TO 478
490 ENCODE(5,204,NTMP) MSAV
IF(NTMP.EQ.'OBS') GO TO 492
IF(NTMP.EQ.'STOP') GO TO 492
IF(NTMP.EQ.'HELP') GO TO 492
IF(NTMP.EQ.'ALL') GO TO 492
IF(NTMP.EQ.'EMPTY') GO TO 492
GO TO 494
492 WRITE(IDLG,493) NTMP
493 FORMAT(' "',A5,'" IS A RESERVED NAME')
GO TO 491
494 DO 481 J=1,NV
IF(I.EQ.J) GO TO 481
IF(NAMES(J).NE.NTMP) GO TO 481
WRITE(IDLG,482) J,NTMP
482 FORMAT(' VARIABLE ',I3,' ALREADY HAS THE NAME ',A5/)
GO TO 491
481 CONTINUE
NAMES(I)=NTMP
491 CONTINUE
C
C
C
600 IF(INPUT(N).EQ.';') GO TO 601
IF(INPUT(N).EQ.'/') GO TO 620
N=N+1
IF(N.LE.80) GO TO 600
GO TO 440
C
C DESCRIPTION
C
601 DO 602 J=1,40
602 NAMDES(J)=' '
J=1
603 N=N+1
IF(N.LE.80) GO TO 604
GO TO 605
604 IF(INPUT(N).EQ.'/') GO TO 605
IF(J.GT.40) GO TO 603
NAMDES(J)=INPUT(N)
J=J+1
GO TO 603
605 DO 606 I=IBG,IEND
606 ENCODE(40,204,KDSC(1,I)) NAMDES
GO TO 600
C
C MISSING DATA
C
620 N=N+1
IF(ISM.EQ.1) GO TO 600
IF(NRN.LT.2) GO TO 623
DO 622 I=IBG,IEND
IF(ITYPE(I).EQ.ITYPE(IBG)) GO TO 622
WRITE(IDLG,621)
621 FORMAT(' THE SAME SYMBOLS FOR MISSING DATA CANNOT BE USED FOR'/
1' TWO DIFFERENT TYPE VARIABLES - NO MISSING DATA ACCEPTED THIS'/
2' STATEMENT'/)
ISM=1
GO TO 600
622 CONTINUE
623 ISR=0
IF((INPUT(N).NE.'V').OR.(INPUT(N+1).NE.'A').OR.(INPUT(N+2).
1NE.'L').OR.(INPUT(N+3).NE.'I').OR.(INPUT(N+4).NE.'D').OR.
2(INPUT(N+5).NE.':')) GO TO 624
N=N+6
ISR=1
IST=0
624 GO TO (630,680,800) (ITYPE(IBG)+1)
C
C FLOATING
C
630 DO 631 I=1,15
631 NAMDES(I)=' '
IPD=0
IEXP=0
J=1
632 IF(INPUT(N).EQ.' ') GO TO 660
IF(INPUT(N).EQ.'-') GO TO 634
IF(INPUT(N).EQ.'E') GO TO 640
IF(INPUT(N).EQ.'.') GO TO 636
IF(INPUT(N).EQ.'/') GO TO 660
IF(INPUT(N).EQ.';') GO TO 660
IF((INPUT(N).LE.'9').AND.(INPUT(N).GE.'0')) GO TO 643
WRITE(IDLG,645) INPUT(N)
645 FORMAT(' ILLEGAL CHARACTER "',A1,'" IN MISSING DATA SYMBOL'/)
GO TO 600
643 IF(J.GT.15) GO TO 633
639 NAMDES(J)=INPUT(N)
J=J+1
633 N=N+1
IF(N.LE.80) GO TO 632
GO TO 660
634 IF(J.EQ.1) GO TO 639
GO TO 653
C
636 IF(IPD.EQ.0) GO TO 638
WRITE(IDLG,637)
637 FORMAT(' ONLY 1 DECIMLE POINT PER MISSING VALUE'/)
GO TO 600
638 IPD=1
GO TO 639
C
640 IF(IEXP.EQ.0) GO TO 642
WRITE(IDLG,641)
641 FORMAT(' ONLY 1 E SIGN PER VALUE'/)
GO TO 600
642 IEXP=1
GO TO 639
C
653 N=N+1
IF(ISR.EQ.1) GO TO 647
WRITE(IDLG,646)
646 FORMAT(' VALID: WAS NOT INDICATED - RANGES MAY NOT BE USED'/)
GO TO 600
647 IF(IST.EQ.0) GO TO 649
WRITE(IDLG,648)
648 FORMAT(' TWO - CANNOT BE USED IN THE SAME STATEMENT'/)
GO TO 600
649 ENCODE(15,204,NAMDES(37))(NAMDES(J),J=1,15)
DECODE(15,650,NAMDES(37)) TMPB
650 FORMAT(G)
IST=1
GO TO 630
C
660 IF(ISR.EQ.1) GO TO 661
ENCODE(15,204,NAMDES(37)) (NAMDES(J),J=1,15)
DECODE(15,650,NAMDES(37)) TMPB
GO TO 670
661 IF(IST.EQ.1) GO TO 663
WRITE(IDLG,662)
662 FORMAT(' NO - FOR VALID RANGE'/)
GO TO 600
663 ENCODE(15,204,NAMDES(37))(NAMDES(J),J=1,15)
DECODE(15,650,NAMDES(37)) TMPE
IF(TMPB.LT.TMPE) GO TO 670
SAV(1)=TMPB
TMPB=TMPE
TMPE=SAV(1)
GO TO 670
C
C ALPHANUMERIC MISSING DATA SYMBOLS
C
680 DO 681 I=1,5
681 NAMDES(I)=' '
J=1
IF(INPUT(N).NE.1H') GO TO 683
N=N+1
682 IF(INPUT(N).EQ.' ') GO TO 693
IF(INPUT(N).EQ.'/') GO TO 683
IF(INPUT(N).EQ.';') GO TO 683
IF(INPUT(N).EQ.1H') GO TO 687
695 IF(J.GT.5) GO TO 685
NAMDES(J)=INPUT(N)
J=J+1
N=N+1
IF(N.LE.80) GO TO 682
683 WRITE(IDLG,684)
684 FORMAT(' ALPHA MISSING DATA SYMBOLS MUST BE ENCOLOSED IN QUOTES'/)
GO TO 600
685 WRITE(IDLG,686)
686 FORMAT(' MAXIMUM SIZE FOR ALPHA VARIABLE IS 6 CHARACTERS'/)
GO TO 600
687 N=N+1
IF(INPUT(N).EQ.'-') GO TO 690
IF(ISR.EQ.0) GO TO 689
IF(IST.EQ.1) GO TO 688
WRITE(IDLG,662)
GO TO 600
688 ENCODE(5,204,TMPE)(NAMDES(J),J=1,5)
IF(TMPB.LE.TMPE) GO TO 670
SAV(1)=TMPB
TMPB=TMPE
TMPE=SAV(1)
GO TO 670
689 ENCODE(5,204,TMPB)(NAMDES(J),J=1,5)
GO TO 670
690 IF(ISR.EQ.0) GO TO 692
IF(IST.EQ.1) GO TO 691
ENCODE(5,204,TMPB)(NAMDES(J),J=1,5)
IST=1
N=N+1
GO TO 680
691 WRITE(IDLG,648)
GO TO 600
692 WRITE(IDLG,646)
GO TO 600
693 DO 694 I=1,5
IF(INPUT(N+I).EQ.1H') GO TO 695
694 CONTINUE
GO TO 683
C
C FIXED
C
800 DO 801 I=1,15
801 NAMDES(I)=' '
J=1
802 IF(INPUT(N).EQ.' ') GO TO 812
IF(INPUT(N).EQ.'-') GO TO 806
IF(INPUT(N).EQ.'/') GO TO 812
IF(INPUT(N).EQ.';') GO TO 812
IF((INPUT(N).LE.'9').AND.(INPUT(N).GE.'0')) GO TO 803
WRITE(IDLG,645) INPUT(N)
GO TO 600
803 IF(J.GT.15) GO TO 805
804 NAMDES(J)=INPUT(N)
J=J+1
805 N=N+1
IF(N.LE.80) GO TO 802
GO TO 812
C
806 IF(J.EQ.1) GO TO 804
GO TO 807
C
807 N=N+1
IF(ISR.EQ.1) GO TO 809
WRITE(IDLG,646)
GO TO 600
809 IF(IST.EQ.0) GO TO 810
WRITE(IDLG,648)
GO TO 600
810 ENCODE(15,204,NAMDES(37))(NAMDES(J),J=1,15)
DECODE(15,811,NAMDES(37)) TMPB
811 FORMAT(I)
IST=1
GO TO 800
812 IF(ISR.EQ.1) GO TO 813
ENCODE(15,204,NAMDES(37))(NAMDES(J),J=1,15)
DECODE(15,811,NAMDES(37)) TMPB
GO TO 670
813 IF(IST.EQ.1) GO TO 814
WRITE(IDLG,662)
GO TO 600
814 ENCODE(15,204,NAMDES(37))(NAMDES(J),J=1,15)
DECODE(15,811,NAMDES(37)) TMPE
IF(TMPB.LE.TMPE) GO TO 670
SAV(1)=TMPB
TMPB=TMPE
TMPE=SAV(1)
GO TO 670
C
C PUT MISSING VALUES WHERE THEY BELONG
C
670 DO 679 I=IBG,IEND
IF(ISR.EQ.1) GO TO 672
J=DATMIS(I,1)
NN=J+1
IF(J.LT.0) NN=-J+1
IF(NN.LE.5) GO TO 678
WRITE(IDLG,671) I
671 FORMAT(' TOO MANY MISSING DATA FOR VARIABLE ',I3/)
GO TO 679
678 DATMIS(I,NN+1)=TMPB
IF(J.LT.0) DATMIS(I,1)=-NN
IF(J.GE.0) DATMIS(I,1)=NN
GO TO 679
672 IF(DATMIS(I,1).GE.0) GO TO 674
WRITE(IDLG,673) I
673 FORMAT(' 1 VALID RANGE ALREADY ACCEPTED FOR VARIABLE ',I3/)
GO TO 679
674 NN=DATMIS(I,1)
IF((NN+2).LE.5) GO TO 675
WRITE(IDLG,671) I
GO TO 679
675 IF(NN.EQ.0) GO TO 677
DO 676 J=2,NN
676 DATMIS(I,J+2)=DATMIS(I,J)
677 DATMIS(I,2)=TMPB
DATMIS(I,3)=TMPE
DATMIS(I,1)=-(DATMIS(I,1)+2)
679 CONTINUE
GO TO 600
C
C BEGIN WORK (DONE WITH QUESTIONS) FIRST CREATE TMP FILE OF HEADR
C
700 IF(LFILE.EQ.1) CLOSE (UNIT=MPROG)
OPEN (UNIT=ITMPRY,DEVICE='DSK',ACCESS='SEQOUT',FILE='HEADR.TMP',
1MODE='BINARY')
NNBL=(NV+5)/6
DO 701 I=1,NNBL
IVBG=(I-1)*6+1
IVEND=IVBG+5
IF(IVEND.GT.NV) IVEND=NV
DO 702 J=IVBG,IVEND
NNS(1,J-IVBG+1)=NAMES(J)
DO 703 K=1,8
703 NNS(K+1,J-IVBG+1)=KDSC(K,J)
NNS(10,J-IVBG+1)=ITYPE(J)
702 CONTINUE
WRITE(ITMPRY) Z
701 CONTINUE
CLOSE(UNIT=ITMPRY)
C
C BEGIN ANALYSIS OF DATA NOW
C
OPEN(UNIT=ITMPRY,DEVICE='DSK',ACCESS='RANDOM',MODE='BINARY',
1FILE='BANK.TMP',RECORD SIZE=126)
NPR=7000/NV
IF(NPR.GT.125) NPR=125
NERR=0
NO=0
NBKK=0
ATEND=0
IF(DEV.NE.'TTY') GO TO 705
WRITE(IDLG,714)
714 FORMAT('0ENTER DATA NOW, WHEN FINISHED TYPE A CONTROL Z (^Z)')
705 NIBLK=0
706 N=0
NFTR=NPR
IF((NIBLK+NFTR).GT.125) NFTR=125-NIBLK
707 IBG=N*NV+1
IEND=IBG+NV-1
READ(IUSER,FMT,END=731,ERR=739) (D(I),I=IBG,IEND)
NO=NO+1
713 N=N+1
IF(N.LT.NFTR) GO TO 707
C
C MISSING DATA REPLACED HERE
C
708 DO 750 I=1,NV
L=DATMIS(I,1)
IF(L.EQ.0) GO TO 750
IF(L.GT.0) GO TO 755
C RANGE
L=-L
DO 751 J=1,N
DATA=D((J-1)*NV+I)
IF((DATA.GE.DATMIS(I,2)).AND.(DATA.LE.DATMIS(I,3))) GO TO 752
D((J-1)*NV+I)=AMISS
GO TO 751
752 IF(L.LE.2) GO TO 751
DO 753 M=4,L+1
IF(DATA.NE.DATMIS(I,M)) GO TO 753
D((J-1)*NV+I)=AMISS
GO TO 751
753 CONTINUE
751 CONTINUE
GO TO 750
C INDIVIDUAL
755 DO 756 J=1,N
DATA=D((J-1)*NV+I)
DO 757 M=2,L+1
IF(DATA.NE.DATMIS(I,M)) GO TO 757
D((J-1)*NV+I)=AMISS
GO TO 756
757 CONTINUE
756 CONTINUE
750 CONTINUE
C
C
C
IF(NIBLK.NE.0) GO TO 720
IF(N.EQ.125) GO TO 710
DO 709 I=N,125
709 Z(I)=AMISS
710 DO 712 I=1,NV
DO 711 J=1,N
711 Z(J)=D((J-1)*NV+I)
KK=NBKK*NV+I
712 WRITE(ITMPRY#KK) Z
GO TO 730
720 DO 722 I=1,NV
KK=NBKK*NV+I
READ(ITMPRY#KK) Z
DO 721 J=1,N
721 Z(J+NIBLK)=D((J-1)*NV+I)
722 WRITE(ITMPRY#KK) Z
730 NIBLK=NIBLK+N
IF(ATEND.EQ.1) GO TO 735
IF(NIBLK.LT.125) GO TO 706
NBKK=NBKK+1
GO TO 705
739 NO=NO+1
NERR=NERR+1
IF(NERR.GT.5) GO TO 743
740 WRITE(IDLG,741) NO
741 FORMAT(' ERROR READING OBSERVATION ',I6)
DO 742 I=IBG,IEND
742 D(I)=AMISS
IF(DEV.NE.'TTY') GO TO 713
WRITE(IDLG,745)
745 FORMAT(' PLEASE REENTER THE ENTIRE OBSERVATION '/)
NO=NO-1
NERR=0
GO TO 707
743 IF((NERR/NO).GT.5) GO TO 740
WRITE(IDLG,744)
744 FORMAT(' MORE THAN 5 ERRORS PER HUNDRED OBSERVATIONS - BYE')
746 CLOSE(UNIT=IBNK,DISPOSE='DELETE')
RETURN
731 ATEND=1
IF(N.GT.0) GO TO 708
735 NAMANS=1
VERSON='V2'
CALL DATE(DATED)
WRITE(IBNK#1) NV,NO,NAMANS,DATED(1),DATED(2),NPROJR,
1NPROGR,VERSON,(K,I=1,117)
NBKK=(NO+124)/125
KK=2
DO 760 I=1,NV
DO 761 J=1,NBKK
NIBLK=(J-1)*NV+I
READ(ITMPRY#NIBLK)Z
WRITE(IBNK#KK)Z
KK=KK+1
761 CONTINUE
760 CONTINUE
CLOSE(UNIT=ITMPRY,DISPOSE='DELETE')
OPEN(UNIT=ITMPRY,DEVICE='DSK',ACCESS='SEQIN',MODE='BINARY',
1FILE='HEADR.TMP')
KK=NBKK*NV+1
736 READ(ITMPRY,END=737) Z
KK=KK+1
WRITE(IBNK#KK) Z
GO TO 736
737 CLOSE(UNIT=IBNK)
CLOSE(UNIT=IUSER)
CLOSE(UNIT=ITMPRY,DISPOSE='DELETE')
WRITE (IDLG,738) BNKNM,DATED,NV,NO
738 FORMAT('1BANK: ',A10,5X,'CREATED: ',2A5/' HAVING ',I3,
1' VARIABLES, AND ',I6,' OBSERVATIONS')
RETURN
END