* NTUPLES file SUBROUTINE ABUNIT(LUNA,LUNB) * * assignment of unit numbers and initialization (for negative args) * COMMON/ABTUPL/LUND(2) LOGICAL LUNDEF,OPENED,EXS,OPN SAVE /ABTUPL/,LUNDEF,OPENED DATA LUNDEF/.FALSE./,OPENED/.FALSE./ * ... C WRITE(*,*) LUNA,LUNB,' ARE LUNA AND LUNB IN ABUNIT' IF(.NOT.LUNDEF) THEN LUNDEF=.TRUE. LUND(1)=IABS(LUNA) LUND(2)=IABS(LUNB) END IF C IF(LUNA.GT.0) RETURN IF(OPENED) RETURN OPENED=.TRUE. DO ILUN=1,2 LUNIT=LUND(ILUN) IF(LUNIT.NE.0) THEN * inquire for given unit INQUIRE (UNIT=LUNIT,IOSTAT=IOS,EXIST=EXS,OPENED=OPN) IF(IOS.NE.0) THEN WRITE(*,*) 'Inquire failed for unit',LUNIT, + ' Error code=',IOS STOP END IF IF(.NOT.OPN) THEN * open sequential, unformattted scratch file OPEN (UNIT=LUNIT,STATUS='SCRATCH',ACCESS='SEQUENTIAL', + FORM='UNFORMATTED',IOSTAT=IOS) WRITE(*,*) 'OPEN UNIT =',LUNIT IF(IOS.NE.0) THEN WRITE(*,*) 'Open failed for unit',LUNIT, + ' Error code=',IOS STOP END IF END IF END IF END DO END SUBROUTINE UEVENT(NAME,NY,WT,X,Y) * write one event * CALL UVENT(NAME,NY,WT,X,Y) * * at end * CALL UEVENT('any ',-1,WT,X,Y) * * REAL Y(*) COMMON/UNCOMA/DUMMY,DUMMI,REC(102) CHARACTER*(*) NAME CHARACTER*4 CHA SAVE CHA,ID DATA CHA/' '/ * ... IF(NY.LT.0) THEN * write buffer CALL ASTORE(ID,REC,-1) ELSE * write array IF(NAME.NE.CHA) THEN CHA=NAME * convert from character to hollerith ID =((ICHAR(CHA(1:1))*256+ICHAR(CHA(2:2)))*256 + +ICHAR(CHA(3:3)))*256+ICHAR(CHA(4:4)) END IF IF(CHA.NE.' ') THEN MY=MIN(100,NY) REC(1)=WT REC(2)=X DO I=1,MY REC(2+I)=Y(I) END DO CALL ASTORE(ID,REC,2+MY) END IF END IF END SUBROUTINE ASTORE(ID,IARR,ND) * * store array (write) CALL ASTORE(ID,IARR,ND) * ID = identifier (integer) * IARR(1)...IARR(ND) = array * ND = 0 is allowed * ND < 0 means write buffer (at end) * * fetch array (read) CALL AFETCH(ID,IARR,ND) * ND = -1 means end-of-data * * * store after start means: write (previous data on the * data set is lost) * * store after fetch means: read until end-of-data, then * backspace, and write (previous data * on data set kept) * * fetch after store means: rewind data set, and read * * fetch after eod means: rewind data set, and read * * (BLKSIZE=4244) * INTEGER IARR(*) * IO-buffer for ntuples PARAMETER (NWDIM=1060) INTEGER IBUF(0:NWDIM) EQUIVALENCE (I,IBUF(0)) * common with unit numbers COMMON/ABTUPL/LUND(2) LOGICAL START SAVE /ABTUPL/,I,IBUF,ISTAT,NR,NARR,NREC,START,LUN,NRD DATA ISTAT/1/,NR/0/,NARR/0/,NREC/0/,START/.TRUE./,LUN/0/,NRD/0/ * ... IF(START) THEN * initialization START=.FALSE. CALL ABUNIT(-51,-52) * ... in this routine the first unit is used LUN=LUND(1) END IF * ISTAT * ----- ------------------ * 1 initial status * 2 status is read * 3 status is read/eof * 4 status is write IF(ND.LT.0) THEN * write buffer IF(ISTAT.EQ.4) THEN IF(I.NE.0) THEN WRITE(LUN) IBUF NREC=NREC+1 END IF WRITE(*,101) LUN,NARR,NREC END IF IF(ISTAT.NE.1) REWIND LUN ISTAT=1 NREC =0 NARR =0 GOTO 100 END IF IF(ISTAT.NE.4) THEN IF(ISTAT.EQ.1) THEN * initial status REWIND LUN ELSE * status is read or read/eof IF(ISTAT.EQ.2) THEN * status was read 11 READ(LUN,END=12) GOTO 11 END IF * status was read/eof 12 BACKSPACE LUN END IF * switch to status write ISTAT=4 I =0 END IF * status is write NARR=NARR+1 IBUF(I+1)=ID IBUF(I+2)=ND I=I+2 J=0 10 M=MIN(ND-J,NWDIM-I) DO K=1,M IBUF(I+K)=IARR(J+K) END DO J=J+M I=I+M IF(J.NE.ND.OR.I.GE.NWDIM-1) THEN WRITE(LUN) IBUF I=0 NREC=NREC+1 C WRITE(*,*) NREC,' is record number ' GOTO 10 END IF C IF(NARR.LE.100) WRITE(*,*)' A out',ID,ND,(IARR(LL),LL=1,ND) GOTO 100 * ENTRY AFETCH(ID,IARR,ND) IF(START) THEN START=.FALSE. CALL ABUNIT(-51,-52) LUN=LUND(1) END IF IF(ISTAT.NE.2) THEN IF(ISTAT.EQ.4) THEN * status was write - write buffer IF(I.NE.0) THEN WRITE(LUN) IBUF NREC=NREC+1 END IF WRITE(*,101) LUN,NARR,NREC END IF * switch to status read REWIND LUN NR=0 I =0 ISTAT=2 END IF * status is read IF(I.EQ.NR) THEN READ(LUN,END=50) IBUF NR=I I =0 END IF ID=IBUF(I+1) ND=IBUF(I+2) I=I+2 J=0 30 M=MIN(ND-J,NR-I) DO K=1,M IARR(J+K)=IBUF(I+K) END DO I=I+M J=J+M IF(J.NE.ND) THEN READ(LUN,END=50) IBUF NR=I I =0 GOTO 30 END IF NRD=NRD+1 C IF(NRD.LE.100) WRITE(*,*)' A in',ID,ND,(IARR(LL),LL=1,ND) GOTO 100 * status will become read/eof 50 ND=-1 ISTAT=3 100 RETURN 101 FORMAT(/' Ntuple-File A(',I2,') -',I8, + ' ntuples stored in',I8,' records'/) END SUBROUTINE BSTORE(ID,IARR,ND) * * store array (write) CALL ASTORE(ID,IARR,ND) * ID = identifier (integer) * IARR(1)...IARR(ND) = array * ND = 0 is allowed * ND < 0 means write buffer (at end) * * fetch array (read) CALL AFETCH(ID,IARR,ND) * ND = -1 means end-of-data * * * store after start means: write (previous data on the * data set is lost) * * store after fetch means: read until end-of-data, then * backspace, and write (previous data * on data set kept) * * fetch after store means: rewind data set, and read * * fetch after eod means: rewind data set, and read * * (BLKSIZE=4244) * INTEGER IARR(*) * IO-buffer for ntuples PARAMETER (NWDIM=1060) INTEGER IBUF(0:NWDIM) EQUIVALENCE (I,IBUF(0)) * common with unit numbers COMMON/ABTUPL/LUND(2) LOGICAL START SAVE /ABTUPL/,I,IBUF,ISTAT,NR,NARR,NREC,START,LUN DATA ISTAT/1/,NR/0/,NARR/0/,NREC/0/,START/.TRUE./,LUN/0/ * ... IF(START) THEN * initialization START=.FALSE. CALL ABUNIT(-51,-52) * ... in this routine the second unit is used LUN=LUND(2) END IF * ISTAT * ----- ------------------ * 1 initial status * 2 status is read * 3 status is read/eof * 4 status is write IF(ND.LT.0) THEN * write buffer IF(ISTAT.EQ.4) THEN IF(I.NE.0) THEN WRITE(LUN) IBUF NREC=NREC+1 END IF WRITE(*,101) LUN,NARR,NREC END IF IF(ISTAT.NE.1) REWIND LUN ISTAT=1 NREC =0 NARR =0 GOTO 100 END IF IF(ISTAT.NE.4) THEN IF(ISTAT.EQ.1) THEN * initial status REWIND LUN ELSE * status is read or read/eof IF(ISTAT.EQ.2) THEN * status was read 11 READ(LUN,END=12) GOTO 11 END IF * status was read/eof 12 BACKSPACE LUN END IF * switch to status write ISTAT=4 I =0 END IF * status is write NARR=NARR+1 IBUF(I+1)=ID IBUF(I+2)=ND I=I+2 J=0 10 M=MIN(ND-J,NWDIM-I) DO K=1,M IBUF(I+K)=IARR(J+K) END DO J=J+M I=I+M IF(J.NE.ND.OR.I.GE.NWDIM-1) THEN WRITE(LUN) IBUF I=0 NREC=NREC+1 GOTO 10 END IF GOTO 100 * ENTRY BFETCH(ID,IARR,ND) IF(START) THEN START=.FALSE. CALL ABUNIT(-51,-52) LUN=LUND(2) END IF IF(ISTAT.NE.2) THEN IF(ISTAT.EQ.4) THEN * status was write - write buffer IF(I.NE.0) THEN WRITE(LUN) IBUF NREC=NREC+1 END IF C WRITE(*,101) LUN,NARR,NREC END IF * switch to status read REWIND LUN NR=0 I =0 ISTAT=2 END IF * status is read IF(I.EQ.NR) THEN READ(LUN,END=50) IBUF NR=I I =0 END IF ID=IBUF(I+1) ND=IBUF(I+2) I=I+2 J=0 30 M=MIN(ND-J,NR-I) DO K=1,M IARR(J+K)=IBUF(I+K) END DO I=I+M J=J+M IF(J.NE.ND) THEN READ(LUN,END=50) IBUF NR=I I =0 GOTO 30 END IF GOTO 100 * status will become read/eof 50 ND=-1 ISTAT=3 100 RETURN 101 FORMAT(/' Ntuple-File B(',I2,') -',I8, + ' ntuples stored in',I8,' records'/) END