Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/bnk11.ban
There are 3 other files named bnk11.ban in the archive. Click here to see a list.
C *** BANK ***
C
C SUBROUTINE TO ADD OBSERVATIONS TO THE BANK. WHEN ENTERED
C THE ROUTINE FIRST CREATES THE PLACES FOR THE NEW OBSERVATIONS
C FILLED WITH MISSING DATA. THEN ONE AT A TIME IT QUIZES THE USER
C FOR THE NEW DATA TO BE PLACED IN IT. THIS IS A HANDY
C WAY TO CREATE A RANDOM DATA SET OF A SPECIFIED NUMBER OF
C OBSERVATIONS
C
SUBROUTINE CREATE
DIMENSION ITYPE(1000),NAME(1000),SAMPL(125),ISAMPL(125)
DIMENSION NNS(18,6),VALUE(15),COMPD(3)
EQUIVALENCE (SAMPL,ISAMPL,NNS),(MISS,AMISS)
COMMON /DEV/IDLG,ICC,IBNK
COMMON /GEN/ IPROJA,IPROGA,NV,NO,BNKNM,DATCR,NPROJR,NPROGR
COMMON /OBS/ LICOB,NHO,IO(2,30)
COMMON /SET/ NHVSET,IVSET(2,30), NHOSET,IOSET(2,30)
DOUBLE PRECISION BNKNM,DATCR
DATA MISS/"400000000000/
MAX=IO(1,1)
DO 1 I=1,NHO
IF(MAX.LT.IO(2,I)) MAX=IO(2,I)
1 CONTINUE
DO 3 I=NO+1,MAX
DO 4 J=1,NHO
IF((I.LE.IO(2,J)).AND.(I.GE.IO(1,J))) GO TO 3
4 CONTINUE
WRITE(IDLG,5) I
5 FORMAT(' THE OBSERVATION TO BE ADDED MUST BE COMPLETE -'I4,
1' WAS MISSING')
RETURN
3 CONTINUE
NOBASE=(NO+124)/125
NOMIN=(NOBASE-1)*125
IF(((MAX+124)/125).NE.NOBASE) GO TO 83
DO 81 I=1,NV
IREC=I*NOBASE+1
READ (IBNK#IREC) SAMPL
DO 82 J=(NO+1-NOMIN),(MAX-NOMIN)
82 SAMPL(J)=AMISS
81 WRITE(IBNK#IREC) SAMPL
GO TO 84
83 IDIFF=((MAX+124)/125)-NOBASE
NHB=(NV+5)/6
IBASE=NOBASE*NV+1
DO 72 I=1,NHB
IREC=IBASE+I
READ(IBNK#IREC) SAMPL
IREC=IREC+IDIFF*NV
72 WRITE(IBNK#IREC) SAMPL
DO 73 I=NV,2,-1
IBASE=(I-1)*NOBASE+1
DO 74 J=NOBASE,1,-1
IREC=IBASE+J
READ(IBNK#IREC) SAMPL
IF(J.NE.NOBASE) GO TO 76
IF((NO-NOMIN).EQ.125) GO TO 76
DO 75 K=(NO-NOMIN+1),125
75 SAMPL(K)=AMISS
76 IREC=IREC+(I-1)*IDIFF
74 WRITE(IBNK#IREC) SAMPL
DO 78 K=1,125
78 SAMPL(K)=AMISS
IREC=IBASE+NOBASE+(I-1)*IDIFF
DO 77 J=1,IDIFF
IREC=IREC+1
77 WRITE(IBNK#IREC) SAMPL
73 CONTINUE
IREC=1+NOBASE
DO 79 J=1,IDIFF
IREC=IREC+1
79 WRITE(IBNK#IREC) SAMPL
84 READ(IBNK#1) SAMPL
ISAMPL(2)=MAX
WRITE(IBNK#1) SAMPL
NOUSED=NO
NO=MAX
NOSET=1
IOSET(1,1)=1
IOSET(2,1)=NO
NOBASE=(NO+124)/125
NBLK=((NO-1)/125)*NV+1
DO 6 J=1,(NV+5)/6
READ(IBNK#(NBLK+J+NV)) SAMPL
IBEG=(J-1)*6+1
IEND=IBEG+5
IF(IEND.GT.NV) IEND=NV
DO 7 I=IBEG,IEND
ITYPE(I)=NNS(10,I-IBEG+1)
NAME(I)=NNS(1,I-IBEG+1)
7 CONTINUE
6 CONTINUE
IF(NV.LT.4) WRITE(IDLG,8)
8 FORMAT('0OBS. VAR. VALUE'/)
DO 2 I=NOUSED+1,MAX
NBL=(I+124)/125
NONE=I-(NBL-1)*125
20 IF(NV.GE.4) WRITE(IDLG,21) I
21 FORMAT(' OBS:',I5/)
DO 22 J=1,NV
IREC=(J-1)*NOBASE+NBL+1
READ(IBNK#IREC) SAMPL
28 IF(NV.LT.4) GO TO 24
WRITE(IDLG,23) NAME(J)
23 FORMAT('+ ',A5,'? ',$)
GO TO 26
24 WRITE(IDLG,25) I,NAME(J)
25 FORMAT('+',I5,2X,A5,'? ',$)
26 READ(ICC,27,END=70) VALUE
27 FORMAT(15A1)
IF((VALUE(1).EQ.'M').AND.(VALUE(2).EQ.'I').AND.
1(VALUE(3).EQ.'S').AND.(VALUE(4).EQ.'S')) GO TO 56
IF(VALUE(1).EQ.'!') GO TO 70
GO TO (30,40,50)(ITYPE(J)+1)
C
C FLOATING TYPE FORMAT
C
30 IDP=0
IOK=0
DO 31 K=1,15
IF(VALUE(K).EQ.' ') GO TO 31
IOK=1
IF(VALUE(K).EQ.'.') GO TO 33
IF((VALUE(K).LE.'9').AND.(VALUE(K).GE.'0')) GO TO 31
WRITE(IDLG,32) VALUE(K)
32 FORMAT(' ILLEGAL CHARACTER "',A1,'" FOR FLOATING VALUE'/)
GO TO 28
33 IDP=IDP+1
IF(IDP.EQ.1) GO TO 31
WRITE(IDLG,34) VALUE(K)
34 FORMAT(' TWO DECIMLE POINTS FOR VALUE'/)
GO TO 28
31 CONTINUE
IF(IOK.NE.1) GO TO 56
ENCODE(15,35,COMPD) VALUE
35 FORMAT(15A1)
DECODE(15,36,COMPD) SAMPL(NONE)
36 FORMAT(G)
GO TO 60
C
C ALPHA TYPE FORMAT(MUST BE ENCLOSED IN QUOTES)
C
40 IF((VALUE(1).EQ.' ').AND.(VALUE(2).EQ.' ').AND.(VALUE(3).EQ.' ')
1.AND.(VALUE(4).EQ.' ').AND.(VALUE(5).EQ.' ')) GO TO 56
IF(VALUE(1).EQ.1H') GO TO 42
WRITE(IDLG,41)
41 FORMAT(' ALPHA VALUE MUST BE ENCLOSED IN QUOUTES'/)
GO TO 28
42 K=2
43 IF(VALUE(K).EQ.1H') GO TO 45
K=K+1
IF(K.LE.7) GO TO 43
WRITE(IDLG,44)
44 FORMAT(' 5 CHARACTER MAXIMUM FOR ALPHA VALUE'/)
GO TO 28
45 DO 46 L=K,7
46 VALUE(K)=' '
ENCODE(5,47,SAMPL(NONE)) (VALUE(K),K=2,6)
47 FORMAT(5A1)
GO TO 60
C
C FIXED TYPE FORMAT
C
50 IOK=0
DO 51 K=1,15
IF(VALUE(K).EQ.' ') GO TO 51
IOK=1
IF((VALUE(K).LE.'9').AND.(VALUE(K).GE.'0')) GO TO 51
WRITE(IDLG,52) VALUE(K)
52 FORMAT(' ILLEGAL CHARACTER "',A1,'" FOR FIXED VALUE'/)
GO TO 28
51 CONTINUE
IF(IOK.EQ.0) GO TO 56
54 IF(VALUE(15).NE.' ') GO TO 55
DO 53 K=15,2,-1
53 VALUE(K)=VALUE(K-1)
VALUE(1)=' '
GO TO 54
55 ENCODE(15,35,COMPD) VALUE
DECODE(15,57,COMPD) ISAMPL(NONE)
57 FORMAT(I15)
GO TO 60
56 SAMPL(NONE)=AMISS
C
C
C
60 WRITE(IBNK#IREC) SAMPL
22 CONTINUE
2 CONTINUE
70 RETURN
END