C****************************************************************************** C C Neither First Chicago Corporation, the First National Bank of Chicago, C nor any of its employees makes any warranty, either expressed or implied, C assumes any legal liability, nor any responsibility for the accuracy, C completeness or usefulness of any information, product or process disclosed. C Neither does First Chicago Corportion, the First National Bank of Chicago,nor C any of its employees represent that use of this material would not infringe C privately owned rights. C C****************************************************************************** C C C c MAPPER.FOR MAIN PROGRAM FOR MAPPING LARGE FSA FILES c C ***************************************************************************** c ****************************************************************************** c c WRITTEN BY: Russell Seward, Douglas Bohrer c Personnel Department, The First National Bank of Chicago c 1 First National Plaza, 22nd Floor c Chicago, Illinois 60670 c c DATE: 14-SEP-81 c C PURPOSE: This program rearranges the fields of any fortran sequential ascii 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 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 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=(1+(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)) 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 FORIT=LOCKON.EQ.3 IF(FORIT)IBUF=ISB IF(FORIT)IREC=IPOS IF(FORIT)LENREC=TWO 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) 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 CAREC(LENREC) LOGICAL*1 DCAREC(512) INTEGER TWO C Save arguments since special call of REDREC C will change values. IIBUF=IBUF IIREC=IREC LLENRE=LENREC DO 100 I=1,LENREC DCAREC(I)=CAREC(I) 100 CONTINUE CALL REDREC(IBUF,IREC,3,LENREC,CAREC) C ISB,IPOS,TWO are same as in REDREC. ISB=IBUF IPOS=IREC TWO=LENREC IBUF=IIBUF IREC=IIREC LENREC=LLENRE C Put new record data in correct location of buffer. DO 250 I=1,LLENRE BUFF((IPOS-1+I),IIBUF)=DCAREC(I) 250 CONTINUE NUMRED=256 IF(TWO)NUMRED=512 C Write out updated record. IF(IIBUF.EQ.1)CALL IWRITW(NUMRED,BUF1,ISB,LLUN(IIBUF)) IF(IIBUF.EQ.2)CALL IWRITW(NUMRED,BUF2,ISB,LLUN(IIBUF)) IF(LOCKON.EQ.0)CALL UNLOCK(IIBUF) 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