Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50521/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
	NUMEES=0
	NGSIGN=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
	IF(VALUE(K).NE.'-'.AND.VALUE(K).NE.'+')GO TO 831
	NGSIGN=NGSIGN+1
	IF(NGSIGN.LE.2)GO TO 31
831	IF(VALUE(K).NE.'E')GO TO 832
	NUMEES=NUMEES+1
	IF(NUMEES.LE.1)GO TO 31
832   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)
34    FORMAT(' TWO DECIMAL 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 QUOTES'/)
      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
	NGSIGN=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
	IF(VALUE(K).NE.'-')GO TO 851
	NGSIGN=NGSIGN+1
	IF(NGSIGN.LE.1)GO TO 51
851   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