Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/bank.rte
There are 3 other files named bank.rte in the archive. Click here to see a list.
C
C WMU BANK ROUTINES
C
C WRITTEN TO ALLOW FORTRAN PROGRAMS TO MORE EASILY ACCESS
C DATA STORED IN BANK FILES. TEMPORARY STORAGE FOR USE BY
C THE BANK ROUTINES IS HELD IN A COMMON BLOCK /BKAREA/ WHICH MUST
C HAVE SIZE GREATER THAN OR EQUAL TO 11*(NSUB+NVTBR)+NVTBR+195
C WHERE: NSUB - IS TOTAL NUMBER OF SUBSETS REQUESTED
C NVTBR - IS TOTAL NUMBER OF VARIABLES TO BE ACCESSED
C
C NOTE: THE MORE COMMON AREA ALLOCATED, THE FASTER THE ROUTINES WILL
C BE (THIS IS TRUE UP TO THE POINT WHERE THE AMOUNT OF STORAGE
C ALLOCATED IS GREATER THAN 125*(NSUB+NVTBR)+NVTBR+195).
C
C THE SUBROUTINE PACKAGE IS COMPOSED OF SIX SUBROUTINES:
C
C NMBANK - INITIALIZATION ROUTINE, NAMES THE BANK TO BE USED AND
C SETS UP TEMPORARY STORAGE.
C
C GETDCT - GET THE NAME DESCRIPTION, AND MODE OF A
C VARIABLE IN THE BANK IF A NUMBER IS GIVEN. IF A NAME
C IS GIVEN GET THE NUMBER, DESCRIPTION AND MODE.
C
C SUBSET - USED TO SUBSET A BANK, THAT IS, PICK OFF ONLY THOSE
C OBSERVATIONS MEETING USER SPECIFIED CRITERIA. (SIMILIAR
C TO SELECT IN THE BANK). ONE SUBSET (SELECT) IS INDICATED
C FOR EACH CALL TO THE SUBROUTINE. A MAXIMUM OF 20 CALLS
C MAY BE MADE IN ANY ONE PASS.
C
C SETVAR - USED TO INDICATED A VARIABLE TO BE READ. ONE VARIABLE
C IS INDICATED FOR EACH CALL TO SETVAR.
C
C BNKRLS - RELEASE THE BANK FILE AND ALLOW DIFFERENT VARIABLES,
C SUBSETS, OR BANK FILES TO BE LOOKED AT IN ANY PROGRAM.
C
C GETOBS - READ ONE OBSERVATION PER CALL TO GETOBS. EACH TIME ALL
C THE VARIABLES INDICATED IN THE SETVAR CALLS WILL BE
C PLACED IN A VECTOR AND RETURNED TO THE MAIN LINE. ALSO
C THIS ROUTINE IS AVAILABLE FOR RANDOM ACCESS OF OBSERVATIONS
C
C
C ************************************************************
C
C
C SAMPLE PROGRAM TO ACCESS A BANK FILE
C
C C ROUTINE TO FIND MEANS AND VARIANCES OF FIRST 10 VARIABLES
C C IN A BANK FILE
C DIMENSION A(10),NAME(10),DESC(8),X(10),XX(10)
C COMMON /BKAREA/AREA(2000)
C CALL NMBANK(1,'TEST.BNK',"470,"470,IERR,2000)
C IF(IERR.NE.0) PAUSE 'ERROR ON NAMING BANK'
C DO 1 I=1,10
C C NOT NECESSARY TO GET NAMES BUT I'LL DO IT FOR THIS EXAMPLE
C CALL GETDCT(I,NAME(I),DESC,MODE,IERR)
C IF(IERR.NE.0) PAUSE 'ERROR ON NAME'
C CALL SETVAR(I,IERR)
C IF(IERR.NE.0) PAUSE 'ERROR ON SETTING A VARIABLE'
C 1 CONTINUE
C C FROM HERE TO THE END THE PROGRAM WILL BE SIMILIAR TO
C C THE STANDARD FORTRAN EXCEPT FOR
C C THE CALL TO GETOBS RATHER THAN A READ.
C IOBS=0
C 2 CALL GETOBS(A,IOBS,IERR)
C IF(IERR.EQ.1) GO TO 4
C IF(IERR.EQ.2) PAUSE 'PROBLEM IN FILE'
C DO 3 I=1,10
C X(I)=X(I)+A(I)
C XX(I)=XX(I)+A(I)**2
C 3 CONTINUE
C GO TO 2
C 4 TYPE 5
C 5 FORMAT('1NAME',5X,'MEAN',15X,'VARIANCE')
C N=IOBS-1
C DO 6 I=1,10
C VAR=(N*XX(I)-X(I)**2)/(N*(N-1.))
C XMEAN=X(I)/N
C TYPE 7,NAME(I),XMEAN,VAR
C 7 FORMAT(1X,A5,4X,G15.7,4X,G15.7)
C 6 CONTINUE
C CALL EXIT
C END
C
C
C WHILE THIS MAY APPEAR TO BE MUCH LONGER THAN NECESSARY FOR A
C SIMPLE PROGRAM IT IS MUCH FASTER THAN READING ASCII. FOR OUR
C TESTS (WITH A SAMPLE OF 150 OBSERVATIONS),
C IT WAS 3.5 TIMES FASTER THE THE EQUIVALENT NON-BANK PROGRAM
C SHOWN BELOW. RUN TIMES ON A KI10 WERE .68 SECONDS BANK AND
C 2.52 SECONDS NON-BANK.
C
C TO USE THE SUBSETTING FEATURE A SEPARATE CALL MUST BE MADE
C FOR EACH SELECT USED. THE BANK PROGRAM ABOVE WAS MODIFIED
C BY FOLLOWING THE 1 CONTINUE WITH THE STATEMENTS:
C CALL SUBSET(11,'<=',100000.,IERR)
C IF(IERR.NE.0) PAUSE 'ERROR ON SUBSET'
C THE TIME REQUIRED TO RUN THE PROGRAM WHICH GAVE THE SAME
C ANSWERS WAS .78 SECONDS.
C
C TO USE THE BANK ROUTINES AS A LIBRARY:
C .COMP BANK.RTE
C .EX PROG.F4,BANK/LIB
C
C
C
C ############################################################
C
C
C
C
C
C C EQUIVALENT FORTRAN PROGRAM TO THE BANK EXAMPLE ABOVE
C DIMENSION A(10),NAME(10),DESC(8),X(10),XX(10)
C DATA NAME/10*' '/
C OPEN(UNIT=1,FILE='OUT.DAT',ACCESS='SEQIN')
C IOBS=0
C 2 READ(1,1,END=4) A
C 1 FORMAT(8G15.7)
C DO 3 I=1,10
C X(I)=X(I)+A(I)
C XX(I)=XX(I)+A(I)**2
C 3 CONTINUE
C GO TO 2
C 4 TYPE 5
C 5 FORMAT('1NAME',5X,'MEAN',15X,'VARIANCE')
C N=IOBS-1
C DO 6 I=1,10
C VAR=(N*XX(I)-X(I)**2)/(N*(N-1.))
C XMEAN=X(I)/N
C TYPE 7,NAME(I),XMEAN,VAR
C 7 FORMAT(1X,A5,4X,G15.7,4X,G15.7)
C 6 CONTINUE
C CALL EXIT
C END
C
C
C
C
C
C **************************************************************
C ##############################################################
C **************************************************************
C
C
C
C
C WMU BANK SUBROUTINES RELEASE JAN 1975
C WRITTEN BY DICK HOUCHARD
C
C SUBROUTINES ARE COMPATIABLE WITH F10 OR F40 (IF
C OPENS ARE AVAILABLE).
C
C ONLY NON-DEC ROUTINE REQUIRED IS THE EXIST ROUTINE WHICH IS PART OF
C NORM GRANT'S SUBROUTINES.
C
C
C INDICATE BANK TO BE ACCESSED
C
C CALL NMBANK(IDEV,NAME,IPROJ,IPROG,IERR,ISIZE)
C
C IDEV - DEVICE TO BE USED IN ACCESSING THE BANK (MUST BE 1-10)
C NAME - ALPHANUMERIC 2 WORD QUANTITY CONTAINING THE NAME AND
C EXTENSION OF THE BANK TO BE ACCESSED
C IPROJ - PROJECT NUMBER WHERE BANK EXISTS (IF ZERO AREA BEING
C USED IS ASSUMED)
C IPROG - PROGRAMMER NUMBER WHERE BANK EXISTS (IF ZERO AREA
C BEING USED IS ASSUMED)
C IERR - ERROR RETURN
C 0 - NO ERROR
C 3 - NO CALL TO BNKRLS BEFOR CALLING SECOND BANK
C
C
SUBROUTINE NMBANK(ICHAN,NAME,IPROJ,IPROG,IERR,ISIZE)
COMMON /BKAREA/ NV,NC,IDEV,LSIZE,NSUB,IBASE,IV(20),SETUP
1,ICOND(20),VALUES(20),INPUT(125),IHOBS,ILOBS,NVBR,AR(1)
DIMENSION IPATH(3)
DOUBLE PRECISION NAME
IPATH(1)=IPROJ
IPATH(2)=IPROG
IPATH(3)=0
IERR=0
C IF IDEV IS POSITIVE THAN A CALL HAS BEEN MADE W/O RELEASING
IF(IDEV.EQ.0) GO TO 2
IERR=3
RETURN
2 CALL EXIST(NAME,LERR,IPROJ,IPROG)
IF(LERR.EQ.0) GO TO 1
IERR=LERR
RETURN
1 OPEN(UNIT=ICHAN,DEVICE='DSK',FILE=NAME,ACCESS='RANDIN',
1MODE='BINARY',RECORD SIZE=126,DIRECTORY=IPATH)
IDEV=ICHAN
LSIZE=ISIZE-195
C READ FIRST BLOCK OF BANK AND STORE # OF OBS, AND # OF VAR.
READ(IDEV#1) INPUT
NV=INPUT(1)
NC=INPUT(2)
NSUB=0
IBLOCK=(NC+124)/125
C CALCULATE BLOCK NUMBER OF FIRST DICTIONARY RECORD
IBASE=IBLOCK*NV+1
RETURN
END
C
C READ A DICTIONARY RECORD
C
C CALL GETDCT(IVAR,NAME,IDES,MODE,IERR)
C
C IVAR - VARIABLE NUMBER (IF ZERO NAME WILL BE USED TO
C LOCATE CORRECT RECORD - IF ZERO CORRECT NUMBER WILL
C BE RETURNED)
C NAME - ALPHANUMERIC 1 WORD QUANTITY NAME OF VARIABLE WILL BE
C RETURNED IF NOT ALREADY SUPPLIED. WILL BE CORRECTED
C IF IN ERROR.
C IDES - VECTOR AT LEAST 8 WORDS LONG RETURNS THE VARIABLE
C DESCRIPTION.
C MODE - MODE OF VARIABLE RETURNED.
C 0 - FLOATING
C 1 - ALPHANUMERIC
C 2 - FIXED (WILL BE SWITCHED TO FLOATING WHEN READING)
C IERR - ERROR RETURN
C 0 - NO ERROR
C 1 - BOTH IVAR AND NAME WERE ZERO
C 2 - VARIABLE NUMBER ENTERED WAS NOT IN RANGE OF
C VARIABLES.
C
C
C NOTE: EITHER THE VARIABLE NUMBER OR THE NAME MUST CONTAIN THE
C REFERENCE TO THE VARIBLE BEING SOUGHT.
C
C
SUBROUTINE GETDCT(IVAR,NAME,IDESPT,MODE,IERR)
COMMON /BKAREA/ NV,NC,IDEV,LSIZE,NSUB,IBASE,IV(20),SETUP
1,ICOND(20),VALUES(20),INPUT(125),IHOBS,ILOBS,NVBR,AR(1)
DIMENSION NNS(18,6),IDESPT(8)
EQUIVALENCE(INPUT,NNS)
IERR=0
C
C VAR NUMBER IS USED AS INDEX TO LOCATE DICTIONARY RECORD
C
IF(IVAR.EQ.0) GO TO 3
IF(IVAR.GT.NV) GO TO 9
IF(IVAR.GT.0) GO TO 1
9 IERR=2
RETURN
1 IBLK=(IVAR+5)/6+IBASE
IONE=IVAR-((IVAR-1)/6)*6
READ(IDEV#IBLK) INPUT
NAME=NNS(1,IONE)
8 DO 2 I=2,9
2 IDESPT(I-1)=NNS(I,IONE)
MODE=NNS(10,IONE)
RETURN
C
C NAME IS USED AS INDEX TO LOCATE DICTIONARY RECORD
C
3 IF(NAME.NE.0) GO TO 4
IERR=1
RETURN
4 K=(NV+5)/6
C LOOP THRU DICTIONARY RECORDS UNTIL GET A MATCH ON NAME
DO 5 I=1,K
L=6
IF((I*6).GT.NV) L=NV-(I-1)*6
READ(IDEV#(IBASE+I)) INPUT
DO 6 IONE=1,L
IF(NAME.EQ.NNS(1,IONE)) GO TO 7
6 CONTINUE
5 CONTINUE
IERR=3
RETURN
7 IVAR=(I-1)*6+IONE
GO TO 8
END
C
C INDICATE SUBSETS
C
C CALL SUBSET(IVAR,ICD,VAL,IERR)
C
C IVAR - VARIABLE NUMBER OF VARIABLE TO BE USED IN SUBSETTING
C ICD - CONDITION TO BE MET (ALPHANUMERIC VALUE ONLY)
C '=' - EQUAL
C '<' - LESS THAN
C '>' - GREATER THAN
C '<=' OR '=<' - LESS THAN OR EQUAL TO
C '>=' OR '=>' - GREATER THAN OR EQUAL TO
C '><' OR '<>' - NOT EQUAL
C VAL - VALUE TO BE COMPARED AGAINST (MUST BE FLOATING)
C IERR - ERROR RETURN
C 0 - NO ERROR
C 1 - VARIABLE NUMBER NOT IN RANGE OF VARIABLES
C 2 - NOT ENOUGH ROOM ALLOTED (COMMON STATEMENT)
C 3 - MORE THAN 20 SUBSETS
C
C
C NOTE: ROUTINE CALLED ONCE FOR EACH SUBSET TO BE PERFORMED. ALL
C SUBSETS MUST BE SATISFIED BEFOR AN OBSERVATION IS ACCEPTED.
C UP TO 20 SUBSETS MAY BE SPECIFIED AT ONE TIME.
C
C
SUBROUTINE SUBSET(IVAR,ICD,VAL,IERR)
COMMON /BKAREA/ NV,NC,IDEV,LSIZE,NSUB,IBASE,IV(20),SETUP
1,ICOND(20),VALUES(20),INPUT(125),IHOBS,ILOBS,NVBR,AR(1)
DIMENSION NNS(18,6)
EQUIVALENCE (NNS,INPUT)
IERR=0
C
C CHECK VARIABLE TO SEE IF IT EXISTS
C
IF(IVAR.GT.NV) GO TO 6
IF(IVAR.GT.0) GO TO 2
6 IERR=1
RETURN
C IS THERE ENOUGH ROOM ALLOCATED (COMMON STATEMENT)
2 IF(LSIZE.GE.((NSUB+NVTBR)*11+NVTBR)) GO TO 5
IERR=2
RETURN
C
C CHECK CONDITION FOR CORRECTNESS
C
5 IC=0
IF(ICD.EQ.'=') IC=1
IF(ICD.EQ.'<') IC=2
IF(ICD.EQ.'>') IC=4
IF(ICD.EQ.'><') IC=6
IF(ICD.EQ.'<>') IC=6
IF(ICD.EQ.'<=') IC=3
IF(ICD.EQ.'=<') IC=3
IF(ICD.EQ.'>=') IC=5
IF(ICD.EQ.'=>') IC=5
IF(IC.NE.0) GO TO 3
IERR=4
RETURN
3 IF(NSUB.LT.20) GO TO 4
IERR=3
RETURN
C
C EVERYTHING CORRECT MOVE IT OVER
C
4 NSUB=NSUB+1
IV(NSUB)=IVAR
ICOND(NSUB)=IC
VALUES(NSUB)=VAL
SETUP=0
RETURN
END
C
C INDICATE VARIABLES TO BE READ
C
C CALL SETVAR(IVAR,IERR)
C
C IVAR - VARIABLE NUMBER TO BE READ.
C IERR - ERROR RETURN
C 0 - NO ERROR
C 1 - VARIABLE NUMBER NOT IN RANGE OF VARIABLE.
C 2 - NOT ENOUGH ROOM ALLOCATED (COMMON STATEMENT)
C
C
C NOTE: THIS ROUTINE SHOULD BE CALLED ONCE FOR EACH VARIABLE
C TO BE READ. NUMBER OF VARIABLES READ IS ONLY LIMITED
C BY THE AVAILABLE STORAGE AS ALLOCTED IN THE COMMON
C STATEMENT.
C
C
SUBROUTINE SETVAR(IVAR,IERR)
COMMON /BKAREA/ NV,NC,IDEV,LSIZE,NSUB,IBASE,IV(20),SETUP
1,ICOND(20),VALUES(20),INPUT(125),IHOBS,ILOBS,NVBR,AR(1)
IERR=0
C IS THERE ENOUGH ROOM FOR ANOTHER VARIABLE
IF(LSIZE.GE.(11*(NVTBR+NSUB)+NVTBR)) GO TO 3
IERR=2
RETURN
C IS VARIABLE NUMBER OK?
3 IF(IVAR.GT.NV) GO TO 4
IF(IVAR.GT.0) GO TO 2
4 IERR=1
RETURN
2 NVBR=NVBR+1
AR(NVBR)=IVAR
SETUP=0
RETURN
END
C
C RELEASE BANK TO SETUP FOR A DIFFERENT READ
C
C CALL BNKRLS
C
C
C NOTE: PERFORMS A CALL RELEASE ON THE CHANNEL, REMOVES THE
C SUBSETS, AND RELEASE THE VARIABLES BEING READ.
C
C
SUBROUTINE BNKRLS
COMMON /BKAREA/ NV,NC,IDEV,LSIZE,NSUB,IBASE,IV(20),SETUP
1,ICOND(20),VALUES(20),INPUT(125),IHOBS,ILOBS,NVBR,AR(1)
NSUB=0
NVBR=0
IHOBS=0
ILOBS=0
CLOSE (UNIT=IDEV)
IDEV=0
SETUP=0
RETURN
END
C
C READ AN OBSERVATION
C
C CALL GETOBS(VALUE,IOBS,IERR)
C
C VALUE - VECTOR FOR VALUES TO BE RETURNED IN.
C IOBS - OBSERVATION NUMBER TO BE READ.
C - IF ZERO OR LESS 1 WILL BE SUBSTITUTED.
C - IF END OF FILE IT WILL CONTAIN 1 MORE THAN THE LAST
C OBSERVATION READ.
C - AT END OF EACH READ IT WILL CONTAIN NEXT OBSERVATION
C TO BE READ IF READ PROCEEDS SEQUENTIALLY.
C IERR - ERROR RETURN
C 0 - NO ERROR
C 1 - END OF FILE
C 2 - NO VARIABLES INDICATED BY CALLS TO SETVAR
C
C
C NOTE: FIXED POINT VARIABLES WILL BE CHANGED TO FLOATING POINT.
C MISSING DATA IS RETURNED AS THE OCTAL CONSTANT "400000000000
C
C
SUBROUTINE GETOBS(VALUE,IOBS,IERR)
COMMON /BKAREA/ NV,NC,IDEV,LSIZE,NSUB,IBASE,IV(20),SETUP
1,ICOND(20),VALUES(20),INPUT(125),IHOBS,ILOBS,NVBR,AR(1)
DIMENSION VALUE(1),XPUT(125),NNS(18,6)
EQUIVALENCE (XPUT,INPUT,NNS)
DATA MISS/"400000000000/
IERR=0
IF(SETUP.NE.0) GO TO 3
C
C SET UP FOR READING VARIABLES
C
C ONCE ONLY SECTION TO ESTABLISH CERTAIN VALUES
IF(NSUB.LE.0) GO TO 5
C MODES FOR SUBSETTING VARIABLES
DO 1 I=1,NSUB
M=IV(I)
L=(M+5)/6
IONE=M-(L-1)*6
READ(IDEV#(IBASE+L)) INPUT
1 AR(NVBR+I)=NNS(10,IONE)
5 IF(NVBR.GT.0) GO TO 4
IERR=2
RETURN
C MODES FOR VARIABLES BEING READ
4 DO 2 I=1,NVBR
M=AR(I)
L=(M+5)/6
IONE=M-(L-1)*6
READ(IDEV#(IBASE+L)) INPUT
2 AR(NVBR+NSUB+I)=NNS(10,IONE)
SETUP=1
C CALCULATION USED IN REMAINDER OF PROGRAM
C IBPV - NO OF BLOCKS IN BANK PER VARIABLE (DATA)
C IEXAR - ROOM FOR STORING MODES AND VARIABLES
C KL - ROOM ALLOCATED IN COMMON FOR STORING EACH VARIABLE.
IBPV=(NC+124)/125
IEXAR=NVBR*2+NSUB
KL=(LSIZE-IEXAR)/(NVBR+NSUB)
C
C
C
3 IF(IOBS.LE.0) IOBS=1
14 IF(IOBS.LE.NC) GO TO 6
IERR=1
RETURN
6 IF(IOBS.GT.IHOBS) GO TO 15
IF(IOBS.GE.ILOBS) GO TO 20
C
C IF OBS REQUIRED IS NOT IN RANGE OF OBSERV. IN CORE READ IT IN
C
15 KK=(IOBS+124)/125
JBEG=IOBS-(KK-1)*125
JEND=JBEG+KL-1
IF(JEND.GT.125) JEND=125
JMIN=JBEG-1
IF(NSUB.LE.0) GO TO 10
C READ IN SUBSETTING VARIABLES
DO 8 I=1,NSUB
M=IV(I)
IBLK=(IBPV*(M-1))+1+KK
READ(IDEV#IBLK) INPUT
JADD=IEXAR+(I-1)*KL-JMIN
JMODE=AR(NVBR+I)
DO 9 J=JBEG,JEND
IADD=JADD+J
IF(INPUT(J).EQ.MISS) GO TO 16
IF(JMODE.EQ.2) GO TO 7
16 AR(IADD)=XPUT(J)
GO TO 9
7 AR(IADD)=INPUT(J)
9 CONTINUE
8 CONTINUE
C READ VARIABLES TO BE SENT TO CALLING PROGRAM
10 DO 11 I=1,NVBR
M=AR(I)-1
IBLK=(IBPV*M)+1+KK
READ(IDEV#IBLK) INPUT
JADD=IEXAR+(I+NSUB-1)*KL-JMIN
JMODE=AR(NVBR+NSUB+I)
DO 12 J=JBEG,JEND
IADD=JADD+J
IF(INPUT(J).EQ.MISS) GO TO 17
IF(JMODE.EQ.2) GO TO 13
17 AR(IADD)=XPUT(J)
GO TO 12
13 AR(IADD)=INPUT(J)
12 CONTINUE
11 CONTINUE
C ILOBS IS LOWEST OBS NO. IN CORE, IHOBS IS HIGHEST
ILOBS=IOBS
IHOBS=IOBS+(JEND-JBEG)
C
C
C
20 L=IOBS-ILOBS+1
IF(NSUB.EQ.0) GO TO 40
IADD=IEXAR+L-KL
DO 21 I=1,NSUB
NADD=IADD+I*KL
C CHECK THE SUBSET, IF NOT ACCEPTABLE LOOK FOR FIRST VALID ONE
GO TO (31,32,33,34,35,36) ICOND(I)
31 IF(AR(NADD).EQ.VALUES(I)) GO TO 21
GO TO 37
32 IF(AR(NADD).LT.VALUES(I)) GO TO 21
GO TO 37
33 IF(AR(NADD).LE.VALUES(I)) GO TO 21
GO TO 37
34 IF(AR(NADD).GT.VALUES(I)) GO TO 21
GO TO 37
35 IF(AR(NADD).GE.VALUES(I)) GO TO 21
GO TO 37
36 IF(AR(NADD).NE.VALUES(I)) GO TO 21
37 IOBS=IOBS+1
GO TO 14
21 CONTINUE
C MOVE DATA TO USER AREA
40 IADD=IEXAR+(NSUB-1)*KL+L
DO 50 I=1,NVBR
50 VALUE(I)=AR(IADD+I*KL)
IOBS=IOBS+1
RETURN
END