* * $Id: fzorec.F,v 1.3 1999/06/18 13:29:39 couet Exp $ * * $Log: fzorec.F,v $ * Revision 1.3 1999/06/18 13:29:39 couet * - qcardl.inc was empty: It is now removed and not used. * Comment END CDE removed. * * Revision 1.2 1996/04/18 16:10:49 mclareni * Incorporate changes from J.Zoll for version 3.77 * * Revision 1.1.1.1 1996/03/06 10:47:14 mclareni * Zebra * * #include "zebra/pilot.h" SUBROUTINE FZOREC C- Record controls, exchange file format C- service routine to FZOUT C- Controlling parameter : IDX(2) C- C- IDX(2) > 0 start new logical record, C- IDX(1) = length C- IDX(2) = type : 1 start/end of run C- 2 new d/s of new event C- 3 new d/s of same event C- 9 write emergency stop C- C- = 0 up-date buffer parameters from L4CURX C- write PhR if buffer completed : C- either : buffer full and LR continues C- or : LR ended on fast block C- C- = -1 flush the buffer C- = -2 End-of-File C- = -3 End-of-Data C- Note : for each LR there is a final call with IDX(2)=0 C- to save the buffer parameters; at this moment the buffer C- is flushed if the record is fast or almost full #include "zebra/zmach.inc" #include "zebra/zunit.inc" #include "zebra/mqsys.inc" #include "zebra/eqlqf.inc" #include "zebra/fzcx.inc" * #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M)) DIMENSION NAMESR(2) DATA NAMESR / 4HFZOT, 4HRX / #endif #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M)) DATA NAMESR / 6HFZOREC / #endif #if !defined(CERNLIB_QTRHOLL) CHARACTER NAMESR*8 PARAMETER (NAMESR = 'FZOREC ') #endif #include "zebra/q_or.inc" #include "zebra/q_jbit.inc" #include "zebra/q_sbit1.inc" #include "zebra/qtrace.inc" C- buffer parameters : C- -6 JFAST = 0 : current buffer is steering rec C- .NE. 0 : current buffer is fast record C- -5 NFASTX, # of fast records still to be written C- -4 C- -3 N4RESX, # of words in LR still to be done C- -2 N4DONX, # of words stored in buffer C- -1 C- LBPARX +0 maximum size of buffer C- +1 size of PhR, local machine words C- +2 INCBUF : step to buffer C- +3 (off-set for reading) C- +4 off-set for writing C- ( =0 normal, =128 ALFA) C- -1 free to allow packing C- L4STOX +0 start of buffer C- L4STAX +0 start of buffer accumulation LBPARX = LQFX + INCBPX JFAST = IQ(KQSP+LBPARX-6) NFASTX = IQ(KQSP+LBPARX-5) #if defined(CERNLIB_QDEVZE) IF (LOGLVX.GE.3) WRITE (IQLOG,9701) IDX(2),JFAST,NFASTX 9701 FORMAT (' FZOREC- entered with IDX(2)=',I3, F' JFAST,NFASTX=',2I4) #endif IF (IDX(2).EQ.0) GO TO 41 N4RESX = IQ(KQSP+LBPARX-3) N4DONX = IQ(KQSP+LBPARX-2) INCBUF = IQ(KQSP+LBPARX+2) JOFFSO = IQ(KQSP+LBPARX+4) L4STOX = KQSP+8 + LBPARX + INCBUF L4STAX = L4STOX + JOFFSO L4ENDX = L4STAX + MAXREX #if defined(CERNLIB_QDEVZE) IF (LOGLVX.GE.3) WRITE (IQLOG,9703) N4RESX,N4DONX 9703 FORMAT (12X,'N4RESX,N4DONX=',2I7) #endif IF (IDX(2).LT.0) GO TO 51 IF (IDX(2).EQ.9) GO TO 30 C----------------------------------------------------------- C------ IDX(2) > 0 : start new logical record C----------------------------------------------------------- IQ(KQSP+LQFX+21) = IQ(KQSP+LQFX+21) + 1 #if defined(CERNLIB_FZMEMORY) IF (IFIFOX.EQ.3) GO TO 23 #endif IF (N4RESX.NE.0) GO TO 31 IF (N4DONX.NE.0) GO TO 24 C-- LR starts new physical record 23 LQ(L4STAX+4) = MAXREX IF (MEDIUX.LT.4) THEN LQ(L4STAX+5) = IQ(KQSP+LQFX+23) ELSE LQ(L4STAX+5) = 0 ENDIF LQ(L4STAX+6) = 8 IQ(KQSP+LBPARX-6)= 0 IQ(KQSP+LBPARX-5)= 0 N4DONX = 8 GO TO 25 24 IF (LQ(L4STAX+6).EQ.0) LQ(L4STAX+6)=N4DONX 25 IQ(KQSP+LQFX+31) = IQ(KQSP+LQFX+33) + 1 IQ(KQSP+LQFX+32) = N4DONX N4DONX = N4DONX + 2 L4CURX = L4STAX + N4DONX LQ(L4CURX-2) = IDX(1) LQ(L4CURX-1) = IDX(2) ISTENX = 1 IF (IDX(2).EQ.1) THEN LQ(L4STAX+4) = MSBIT1(LQ(L4STAX+4),31-JRUNX) LQ(L4STAX+5) = 0 ENDIF IQ(KQSP+LBPARX-3) = IDX(1) IQ(KQSP+LBPARX-2) = N4DONX NWOVFL = N4DONX + IDX(1) - MAXREX IF (NWOVFL.LE.0) GO TO 991 NFASTX = (NWOVFL-1)/MAXREX + 1 IF (JBIT(MSTATX,15).EQ.0) THEN NWUNUS = NFASTX*MAXREX - NWOVFL IF (NWUNUS .GE. 12) NFASTX=NFASTX-1 ENDIF IQ(KQSP+LBPARX-5) = NFASTX GO TO 991 C---- EMERGENCY STOP 30 IDX(2) = 0 31 IF (JFAST.NE.0) GO TO 36 IF (NFASTX.NE.0) GO TO 33 IF (N4RESX+N4DONX.GT.MAXREX) GO TO 33 NWTOLR = LQ(L4STAX+6) IF (NWTOLR.EQ.0) GO TO 36 LQ(L4STAX+NWTOLR) = MAXREX - NWTOLR 33 NWCL = MAXREX - N4DONX IF (NWCL.GT.0) CALL VZERO (LQ(L4STAX+N4DONX),NWCL) CALL FZOPHR 36 LQ(L4STAX+4) = MAXREX IF (MEDIUX.LT.4) THEN LQ(L4STAX+5) = IQ(KQSP+LQFX+23) ELSE LQ(L4STAX+5) = 0 ENDIF LQ(L4STAX+6) = 8 LQ(L4STAX+4) = MSBIT1 (LQ(L4STAX+4),32) IQ(KQSP+LBPARX-6)= 0 IQ(KQSP+LBPARX-5)= 0 IQ(KQSP+LBPARX-3)= 0 IQ(KQSP+LBPARX-2)= 0 NWCL = MAXREX - 10 LQ(L4STAX+8) = NWCL LQ(L4STAX+9) = 5 CALL VZERO (LQ(L4STAX+10),NWCL) CALL FZOPHR IF (IDX(2).GT.0) GO TO 23 GO TO 991 C----------------------------------------------------------- C------ IDX(2) = 0 : up-date buffer parameters C-- write the buffer if complete C----------------------------------------------------------- C- Note : L4CURX=L4ENDX+1 if a double-precision number spans C- two physical records, giving NWFREE = -1 41 N4DONX = L4CURX - L4STAX NWNEW = N4DONX - IQ(KQSP+LBPARX-2) N4RESX = IQ(KQSP+LBPARX-3) - NWNEW IQ(KQSP+LBPARX-3) = N4RESX IQ(KQSP+LBPARX-2) = N4DONX 42 NWFREE = L4ENDX - L4CURX #if defined(CERNLIB_QDEVZE) IF (LOGLVX.GE.3) WRITE (IQLOG,9743) N4RESX,N4DONX,NWFREE 9743 FORMAT (12X,'N4RESX,N4DONX,NWFREE=',3I7) #endif IF (NWFREE.LT.0) GO TO 55 IF (N4RESX.NE.0) THEN IF (NWFREE.EQ.0) GO TO 55 GO TO 999 ENDIF C-- End of LR reached IF (N4DONX.EQ.0) GO TO 999 ISTENX = IOR(ISTENX,2) IF (NWFREE.LT.4) GO TO 54 IF (JFAST.NE.0) GO TO 54 IF (JBIT(MSTATX,15).NE.0) GO TO 54 GO TO 999 C----------------------------------------------------------- C------ IDX(2) = -1 : flush the buffer C----------------------------------------------------------- 51 IF (IDX(2).LT.-1) GO TO 71 IF (N4RESX.NE.0) GO TO 31 IF (N4DONX.EQ.0) GO TO 991 ISTENX = IOR(ISTENX,2) NWFREE = MAXREX - N4DONX C-- construct dummy LR to complete the buffer 54 IF (NWFREE.LE.0) GO TO 55 IF (JFAST.EQ.0) THEN IF (LQ(L4STAX+6).EQ.0) LQ(L4STAX+6)=N4DONX ENDIF L4CURX = L4STAX + N4DONX LQ(L4CURX) = NWFREE - 1 IF (NWFREE.LT.2) GO TO 55 LQ(L4CURX+1) = 5 NWFILX = NWFREE - 2 IF (NWFILX.EQ.0) GO TO 55 #if !defined(CERNLIB_FZMEMORY) CALL VZERO (LQ(L4CURX+2),NWFILX) #endif #if defined(CERNLIB_FZMEMORY) IF (IFIFOX.NE.3) CALL VZERO (LQ(L4CURX+2),NWFILX) #endif C-- Write the physical record 55 MWOVSV = LQ(L4ENDX) CALL FZOPHR C-- Ready buffer for next physical record ISTENX = 0 IF (N4RESX.GT.0) GO TO 57 IF (NWFREE.LT.0) GO TO 57 C-- no pending data for current logical record IQ(KQSP+LBPARX-2) = 0 L4CURX = L4STAX GO TO 991 C-- current logical record continues 57 IF (IQ(KQSP+LBPARX-6).EQ.0) THEN LQ(L4STAX+4) = MAXREX IF (MEDIUX.LT.4) THEN LQ(L4STAX+5) = IQ(KQSP+LQFX+23) ELSE LQ(L4STAX+5) = 0 ENDIF LQ(L4STAX+6) = 0 N4DONX = 8 ELSE N4DONX = 0 ENDIF L4CURX = L4STAX + N4DONX IQ(KQSP+LBPARX-2) = N4DONX IF (NWFREE.GE.0) GO TO 991 C-- double-precision number spannning the physical records LQ(L4CURX) = MWOVSV N4DONX = N4DONX + 1 L4CURX = L4CURX + 1 IQ(KQSP+LBPARX-2) = N4DONX IF (N4RESX.GT.0) GO TO 991 GO TO 42 C----------------------------------------------------------- C------ IDX(2) < -1 : ENDFILE C----------------------------------------------------------- 71 CALL FZOPHR 991 IDX(2) = 0 #include "zebra/qtrace99.inc" RETURN END