SUBROUTINE FOPENS(FNAME,IBUF) C FNAME is the name of the file to be opened C IBUF is the buffer chosen 1 or 2. c LOGICAL*1 BUFF(1024,2),BUF1(1024),BUF2(1024),NAMES(2,16) INTEGER LLUN(2),LLOCKS(2),IBLK(2,2) EQUIVALENCE (BUF1(1),BUFF(1,1)) EQUIVALENCE (BUF2(1),BUFF(1,2)) COMMON /RW/BUFF,LLUN,LLOCKS,IBLK,NAMES LOGICAL*1 FNAME(16) INTEGER CH OPEN(UNIT=IBUF,NAME=FNAME,TYPE='OLD',ERR=1500) LLUN(IBUF)=ILUN(IBUF) CH=ILUN(IBUF) C This statement declares the file shared updated. C IERR=IDCLSF(CH,5) LLOCKS(IBUF)=0 IF(IERR.NE.0)WRITE(5,100)IERR 100 FORMAT(' FILE IS NOT PROPERLY DECLARED',I1) C SAVES INFO OF LAST ACCESS DO 20 I=1,16 NAMES(IBUF,I)=FNAME(I) 20 CONTINUE IBLK(IBUF,1)=-1 IBLK(IBUF,2)=-1 RETURN 1500 WRITE(5,300)(FNAME(I),I=1,14) 300 FORMAT(' *** ERROR *** UNABLE TO OPEN FILE :',14A1,$) STOP RETURN END C SUBROUTINE REDREC(IBUF,IREC,LOCKON,LENREC,CAREC) C IBUF is chosen buffer,1 or 2. C IREC is the number of the record wanted. C LENREC is the length of records in the fixed length file. C CAREC will contain the data from the wanted record. C LOCKON is the choice to lock(1) or not to lock (0). LOGICAL*1 BUFF(1024,2),BUF1(1024),BUF2(1024),NAMES(2,16) INTEGER LLUN(2),LLOCKS(2),IBLK(2,2) EQUIVALENCE (BUF1(1),BUFF(1,1)) EQUIVALENCE (BUF2(1),BUFF(1,2)) COMMON /RW/BUFF,LLUN,LLOCKS,IBLK,NAMES COMMON /RI/ISB,IPOS,TWO LOGICAL*1 CAREC(LENREC) INTEGER LOCKON,TWO,TEST,LCK,FORIT DOUBLE PRECISION DISB,DIREC,DLEN DIREC=IREC DLEN=LENREC C ISB is the block number the record starts in. ISB=((DIREC-1)*DLEN)/512 DISB=ISB C IPOS is the starting position of the record relative to the C block the record is in. IPOS=(1+(DIREC-1)*DLEN)-DISB*512 C TWO means two blocks are needed to get the record. TWO=(IPOS+LENREC).GT.513 C LCK means the block(s) in the buffer are locked. LCK=LLOCKS(IBUF).EQ.1 C TEST one means locked and first buffer half contains needed block C with needed record. TEST=(LCK.AND.ISB.EQ.IBLK(IBUF,1)) C If TEST one is true and only one block needed, C then skip around reading in new block. IF(TEST.AND..NOT.TWO)GO TO 200 C TEST two asks if TEST one is true and 2 blocks needed C and buffer second half has right block. TEST=TEST.AND.TWO.AND.(ISB+1).EQ.IBLK(IBUF,2) C If TEST two is true, then skip around reading in new block. IF(TEST) GO TO 200 C TEST three asks if only one block needed and locked,but C the block is in second buffer half. TEST=(.NOT.TWO).AND.LCK.AND.ISB.EQ.IBLK(IBUF,2) C Since block is in second buffer half, increase IPOS by 512. IF(TEST)IPOS=IPOS+512 IF(TEST)GO TO 200 C Need to put new blocks in. C UNLOCK OLD BLOCKS IF(LLOCKS(IBUF).EQ.1)CALL UNLOCK(IBUF) IF(LOCKON.EQ.0)GO TO 50 C When LOCKON is not zero, then lock the blocks. CALL LKBLKW(LLUN(IBUF),ISB) IF(TWO)CALL LKBLKW(LLUN(IBUF),(ISB+1)) LLOCKS(IBUF)=1 C READ IN THE DATA 50 NUMRED=256 IF(TWO)NUMRED=512 IF(IBUF.EQ.1)CALL IREADW(NUMRED,BUF1,ISB,LLUN(IBUF)) IF(IBUF.EQ.2)CALL IREADW(NUMRED,BUF2,ISB,LLUN(IBUF)) 3000 FORMAT(' IN REDREC',100A1) C Store block numbers of data read in. IBLK(IBUF,1)=ISB IBLK(IBUF,2)=-1 IF(TWO)IBLK(IBUF,2)=ISB+1 C NEEDED BLOCKS IN MEMORY 200 IF(TEST.AND.LOCKON.EQ.0.AND.LLOCKS(IBUF).EQ.1)CALL UNLOCK(IBUF) C Take out record from buffer and put into carec. DO 250 I=1,LENREC CAREC(I)=BUFF((IPOS-1+I),IBUF) 250 CONTINUE C LOCKON set to 3 means called from RITREC RETURN END SUBROUTINE UNLOCK(IBUF) C This subroutine unlocks the blocks in the buffer. C IBUF is the chosen buffer 1 or 2. LOGICAL*1 BUFF(1024,2),BUF1(1024),BUF2(1024),NAMES(2,16) INTEGER LLUN(2),LLOCKS(2),IBLK(2,2) EQUIVALENCE (BUF1(1),BUFF(1,1)) EQUIVALENCE (BUF2(1),BUFF(1,2)) COMMON /RW/BUFF,LLUN,LLOCKS,IBLK,NAMES CALL IUSPBK(LLUN(IBUF),IBLK(IBUF,1)) IF(IBLK(IBUF,2).GE.0)CALL IUSPBK(LLUN(IBUF),IBLK(IBUF,2)) C Sets the flag that says the blocks in buffer are unlocked. LLOCKS(IBUF)=0 RETURN END SUBROUTINE RITREC(IBUF,IREC,LOCKON,LENREC,CAREC) C IBUF same as in REDREC C LENREC same as in REDREC C CAREC contains the new data in record that will be written out. C LOCKON same as in REDREC LOGICAL*1 BUFF(1024,2),BUF1(1024),BUF2(1024),NAMES(2,16) LOGICAL*1 BUF12(512),BUF22(512) INTEGER LLUN(2),LLOCKS(2),IBLK(2,2) EQUIVALENCE (BUF1(1),BUFF(1,1)) EQUIVALENCE (BUFF(513,1),BUF12(1)) EQUIVALENCE (BUFF(513,2),BUF22(1)) EQUIVALENCE (BUF2(1),BUFF(1,2)) COMMON /RW/BUFF,LLUN,LLOCKS,IBLK,NAMES COMMON /RI/ISB,IPOS,TWO LOGICAL*1 CAREC(LENREC) LOGICAL*1 DCAREC(512) INTEGER TWO C Save arguments since special call of REDREC C will change values. CALL REDREC(IBUF,IREC,3,LENREC,DCAREC) C ISB,IPOS,TWO are same as in REDREC. C Put new record data in correct location of buffer. DO 250 I=1,LENREC BUFF((IPOS-1+I),IBUF)=CAREC(I) 250 CONTINUE 3000 FORMAT(' INRITREC',100A1) NUMRED=256 IF(IPOS.GT.512)GO TO 300 IF(TWO) NUMRED=512 C Write out updated record. IF(IBUF.EQ.1)CALL IWRITW(NUMRED,BUF1,ISB,LLUN(IBUF)) IF(IBUF.EQ.2)CALL IWRITW(NUMRED,BUF2,ISB,LLUN(IBUF)) 300 IF(IPOS.LE.512) GO TO 400 IF(IBUF.EQ.1)CALL IWRITW(256,BUF12,ISB,LLUN(IBUF)) IF(IBUF.EQ.2)CALL IWRITW(256,BUF22,ISB,LLUN(IBUF)) 400 IF(LOCKON.EQ.0)CALL UNLOCK(IBUF) RETURN END SUBROUTINE FCLOSE(IBUF) C This unlocks any blocks in the buffer. C This closes the file. C This blanks the name of the file. LOGICAL*1 BUFF(1024,2),BUF1(1024),BUF2(1024),NAMES(2,16) INTEGER LLUN(2),LLOCKS(2),IBLK(2,2) EQUIVALENCE (BUF1(1),BUFF(1,1)) EQUIVALENCE (BUF2(1),BUFF(1,2)) COMMON /RW/BUFF,LLUN,LLOCKS,IBLK,NAMES C Unlock blocks in buffer. IF(IBLK(IBUF,1).GE.0)CALL IUSPBK(LLUN(IBUF),IBLK(IBUF,1)) IF(IBLK(IBUF,2).GE.0)CALL IUSPBK(LLUN(IBUF),IBLK(IBUF,2)) C Close the file. CLOSE(UNIT=IBUF) C Blank the name of the file being closed. DO 50 I=1,16 NAMES(IBUF,I)=' ' 50 CONTINUE C Turn off the flags. LLUN(IBUF)=-1 LLOCKS(IBUF)=0 IBLK(IBUF,1)=-1 IBLK(IBUF,2)=-1 RETURN END