*
* $Id: hfnt2.F,v 1.4 1998/03/20 09:43:59 couet Exp $
*
* $Log: hfnt2.F,v $
* Revision 1.4 1998/03/20 09:43:59 couet
* - When filling a CWNtuple and using a 24bit packing of a real, for each entry
* equal to the maximum value XMAX the value actually stored into the CWN is
* XMIN. This only seems to happen with 24 to 30 bit packing. This error occured
* with the CERNLIB 98 and 96a on hpux and irix (at least).
*
* Revision 1.3 1997/07/07 09:34:43 couet
* - Error message changed in case of NaN filling to make it more clear.
*
* Revision 1.2 1996/07/11 15:44:14 couet
* - Bug fix from: Rainer Bartoldus <bartoldu@opalr6.physik.uni-bonn.de>
*
* The problem occurred with a job that reads in a list of CW ntuples,
* corrects some entries and writes out a list of new ntuples.
*
* After we observed problems with the output files, we discovered that
* even without any correction the output was different from the input.
*
* The symptom affected only signed integer variables. It looked as if
* their sign had been written randomly.
*
* However, this happened only after a certain number of input files
* depending on the size of the PAWC common block (The larger the common
* was the later the files were corrupted).
*
* Revision 1.1.1.1 1996/01/16 17:07:57 mclareni
* First import
*
*
#include "hbook/pilot.h"
*CMZ : 07/08/95 13.11.08 by Julian Bunn
*-- Author : Fons Rademakers 06/01/92
SUBROUTINE HFNT2
*.==========>
*.
*. Filling of a new (variable row length) n-tuple.
*. For the data-structure description see routine HBNT.
*.
*. This routine does the actual filling of the variables in block LBLOK.
*.
*. The first word of every physical record is, for the time being, only
*. used for the storage of intermadiate results of index variables.
*.
*..=========> ( A.A.Rademakers )
*
#include "hbook/hcntpar.inc"
#include "hbook/hcnt.inc"
#include "hbook/hcflag.inc"
#include "hbook/hcbook.inc"
*
CHARACTER*80 MSG
INTEGER ILOGIC
LOGICAL LOGIC, INDVAR, RANGE
CHARACTER*32 NAME
CHARACTER*96 MESS
EQUIVALENCE (LOGIC, ILOGIC)
*-* FMIN,FMAX must be saved on HP (compiler bug)
SAVE FMIN, FMAX
*
#include "hbook/jbyt.inc"
*
LNAME = LQ(LBLOK-1)
*
NDIM = IQ(LBLOK+ZNDIM)
*
*-- when this routine is called for the first time for a specific block
*-- create a reference link area in the LNAME bank that will contain
*-- pointers to the corresponding contents banks in the LBUF structure
*
IF (IQ(LBLOK+ZNOENT).EQ.0 .AND. IQ(LNAME-3).EQ.1) THEN
CALL MZPUSH(IHDIV, LNAME, NDIM, 0, ' ')
ENDIF
*
IQ(LBLOK+ZNOENT) = IQ(LBLOK+ZNOENT) + 1
*
IOFF = 0
*
DO 50 I = 1, NDIM
NSUB = JBYT(IQ(LNAME+IOFF+ZDESC), 18, 3)
ITYPE = JBYT(IQ(LNAME+IOFF+ZDESC), 14, 4)
ISIZE = JBYT(IQ(LNAME+IOFF+ZDESC), 8, 6)
NBITS = JBYT(IQ(LNAME+IOFF+ZDESC), 1, 7)
*
INDVAR = .FALSE.
IF (JBIT(IQ(LNAME+IOFF+ZDESC),28) .EQ. 1) INDVAR = .TRUE.
*
IF (IQ(LNAME+IOFF+ZNADDR) .EQ. 0) GOTO 40
*
*-- fix the NBITS for character variables (7 bits was not enough)
*
IF (ITYPE .EQ. 5) NBITS = IBIPB*ISIZE
*
*-- when a range has been specified enable range checking
*
RANGE = .FALSE.
LRAN = IQ(LNAME+IOFF+ZRANGE)
IF (LRAN .NE. 0) THEN
RANGE = .TRUE.
IF (ITYPE .EQ. 1) THEN
FMIN = Q(LREAL+LRAN)
FMAX = Q(LREAL+LRAN+1)
ELSEIF (ITYPE.EQ.2 .OR. ITYPE.EQ.3) THEN
IMIN = IQ(LINT+LRAN)
IMAX = IQ(LINT+LRAN+1)
ELSE
CALL HBUG('Type can not have range specification',
+ 'HFNT',ID)
GOTO 40
ENDIF
ENDIF
*
LCIND = IQ(LNAME+IOFF+ZLCONT)
IF (LQ(LNAME-I) .EQ. 0) THEN
LQ(LNAME-I) = LQ(LBUF-LCIND)
ENDIF
*
*-- make sure that LQ(LNAME-I) points to the right (i.e. last) bank
*-- when filling resumes (after, e.g., a call to HGNT)
*
IF (IQ(LNAME+IOFF+ZIBANK) .NE. IQ(LNAME+IOFF+ZNRZB)) THEN
CALL HNTRD(I, IOFF, IQ(LNAME+IOFF+ZNRZB), IER)
IF (IER .NE. 0) THEN
CALL HBUG('Error resuming filling','HFNT',ID)
GOTO 40
ENDIF
ENDIF
*
LR2 = LQ(LNAME-I)
IFIRST = IQ(LNAME+IOFF+ZIFCON)
NB = IQ(LNAME+IOFF+ZIFBIT) - 1
*
LRECL = IQ(LR2-1) - 1
NLEFT = LRECL - IFIRST + 2
NLEFT = NLEFT*IBIPW - NB
*
IELEM = 1
DO 10 J = 1, NSUB
LP = IQ(LINT+IQ(LNAME+IOFF+ZARIND)+(J-1))
IF (LP .LT. 0) THEN
IE = -LP
ELSE
IF (IQ(LNAME+LP-1+ZNADDR) .EQ. 0) THEN
CALL HBUG('Address of index variable not set',
+ 'HFNT',ID)
GOTO 40
ENDIF
IE = IQ(IQ(LNAME+LP-1+ZNADDR)+1)
ENDIF
IELEM = IELEM*IE
10 CONTINUE
*
DO 30 J = 1, IELEM
*
*-- if next item does not fit in the left over bits start with new word
*
*** IM = MOD(NB, IBIPW)
IM = IAND(NB, IBIPW-1)
IF (IM.NE.0 .AND. NBITS.GT.IBIPW-IM) THEN
NB = 0
NLEFT = NLEFT - IBIPW+IM
IFIRST = IFIRST + 1
ENDIF
*
*-- if next item does not fit in current buffer, write buffer
*
IF (NBITS .GT. NLEFT) THEN
IF (INDVAR) ISAVE = IQ(LR2+LRECL+1)
CALL HNTWRT(I, IOFF, IER)
IF (IER .NE. 0) GOTO 60
IF (INDVAR) IQ(LR2+1) = ISAVE
CALL SBIT1(IQ(LQ(LBUF-LCIND)),1)
NB = 0
NLEFT = LRECL*IBIPW
IFIRST = 2
ENDIF
*
*-- store REAL
*
IF (ITYPE .EQ. 1) THEN
IF (ISIZE .EQ. 4) THEN
IF (RANGE) THEN
QVAL = Q(IQ(LNAME+IOFF+ZNADDR)+J)
#if defined(CERNLIB_SUN)||defined(CERNLIB_SOLARIS)||defined(CERNLIB_SGI)||defined(CERNLIB_DECS)||defined(CERNLIB_ALPHA)||defined(CERNLIB_HPUX)||defined(CERNLIB_IBMRT)
* test the floating point
JX=IFPS(QVAL)
IF(JX .EQ. 0) THEN
WRITE(MSG,'(A,I10,A,I10)')
+ 'HFNT bad float in column:',IOFF/ZNADDR,' line:',J
CALL HFPBUG(QVAL,MSG,ID)
ENDIF
*
#endif
IF (QVAL .LT. FMIN .OR. QVAL .GT. FMAX) THEN
LL = IQ(LNAME+IOFF+ZLNAME)
LV = IQ(LNAME+IOFF+ZNAME)
CALL UHTOC(IQ(LCHAR+LV), 4, NAME, LL)
WRITE(MESS,1000) NAME(1:LL), IQ(LBLOK+ZNOENT),
+ QVAL
CALL HBUG(MESS,'HFNT',ID)
ENDIF
IF (QVAL .LT. FMIN) QVAL = FMIN
IF (QVAL .GT. FMAX) QVAL = FMAX
ENDIF
IF (NBITS .EQ. 32) THEN
#if defined(CERNLIB_NO_IEEE)
CALL IE3FOS(Q(IQ(LNAME+IOFF+ZNADDR)+J),
+ Q(LR2+IFIRST),1,K)
#endif
#if !defined(CERNLIB_NO_IEEE)
Q(LR2+IFIRST) = Q(IQ(LNAME+IOFF+ZNADDR)+J)
* test the floating point
JX=IFPS(Q(LR2+IFIRST))
IF(JX .EQ. 0) THEN
WRITE(MSG,'(A,I10,A,I10)')
+ 'HFNT bad float in column:',IOFF/ZNADDR,' line:',J
CALL HFPBUG(Q(LR2+IFIRST),MSG,ID)
ENDIF
*
#endif
ELSE
IBITF = ISHFT(1,NBITS)-1
IF (QVAL.EQ.FMAX) THEN
IPACK = IBITF
ELSE
IPACK = (QVAL-FMIN)/(FMAX-FMIN)*IBITF+0.5
ENDIF
CALL SBYT(IPACK, IQ(LR2+IFIRST), NB+1, NBITS)
ENDIF
ELSEIF (ISIZE .EQ. 8) THEN
IF (NBITS .EQ. 64) THEN
#if defined(CERNLIB_NO_IEEE)
CALL IE3FOD(Q(IQ(LNAME+IOFF+ZNADDR)+2*J-1),
+ Q(LR2+IFIRST),1,K)
#endif
#if !defined(CERNLIB_NO_IEEE)
Q(LR2+IFIRST) = Q(IQ(LNAME+IOFF+ZNADDR)+2*J-1)
Q(LR2+IFIRST+1) = Q(IQ(LNAME+IOFF+ZNADDR)+2*J)
* test the floating point
JX=IFPD(Q(LR2+IFIRST))
IF(JX .EQ. 0) THEN
WRITE(MSG,'(A,I10,A,I10)')
+ 'HFNT bad float in column:',IOFF/ZNADDR,' line:',2*J-1
CALL HFPBUG(Q(LR2+IFIRST),'HFNT',ID)
ENDIF
#endif
ELSE
*-- no double precision packed reals yet
ENDIF
ENDIF
*
*-- store INTEGER
*
ELSEIF (ITYPE .EQ. 2) THEN
IF (ISIZE .EQ. 2) THEN
ELSEIF (ISIZE .EQ. 4) THEN
IF (.NOT.RANGE .AND. NBITS.NE.32) THEN
*** IMAX = 2**(NBITS-1) - 1
IMAX = ISHFT(1,NBITS-1) - 1
IMIN = -IMAX
RANGE = .TRUE.
ENDIF
IF (RANGE) THEN
IVAL = IQ(IQ(LNAME+IOFF+ZNADDR)+J)
IF (IVAL .LT. IMIN .OR. IVAL .GT. IMAX) THEN
LL = IQ(LNAME+IOFF+ZLNAME)
LV = IQ(LNAME+IOFF+ZNAME)
CALL UHTOC(IQ(LCHAR+LV), 4, NAME, LL)
WRITE(MESS,1010) NAME(1:LL), IQ(LBLOK+ZNOENT),
+ IVAL
CALL HBUG(MESS,'HFNT',ID)
ENDIF
IF (IVAL .LT. IMIN) IVAL = IMIN
IF (IVAL .GT. IMAX) IVAL = IMAX
ENDIF
IF (INDVAR) THEN
IQ(LR2+IFIRST) = IQ(LR2+IFIRST-1) +
+ IQ(IQ(LNAME+IOFF+ZNADDR)+J)
ELSEIF (NBITS .EQ. 32) THEN
IQ(LR2+IFIRST) = IQ(IQ(LNAME+IOFF+ZNADDR)+J)
ELSE
IF (IVAL .LT. 0) THEN
CALL SBIT1(IQ(LR2+IFIRST), NB+NBITS)
CALL SBYT(-IVAL, IQ(LR2+IFIRST), NB+1, NBITS-1)
ELSE
CCC Mods from Rainer Bartoldus
CCC CALL SBYT(IVAL, IQ(LR2+IFIRST), NB+1, NBITS-1)
CALL SBYT(IVAL, IQ(LR2+IFIRST), NB+1, NBITS)
ENDIF
ENDIF
ELSEIF (ISIZE .EQ. 8) THEN
IF (NBITS .EQ. 64) THEN
IQ(LR2+IFIRST) =IQ(IQ(LNAME+IOFF+ZNADDR)+2*J-1)
IQ(LR2+IFIRST+1)=IQ(IQ(LNAME+IOFF+ZNADDR)+2*J)
ELSE
*-- no double precision packed integers yet
ENDIF
ENDIF
*
*-- store UNSIGNED INTEGER
*
ELSEIF (ITYPE .EQ. 3) THEN
IF (ISIZE .EQ. 2) THEN
ELSEIF (ISIZE .EQ. 4) THEN
IF (.NOT.RANGE .AND. NBITS.NE.32) THEN
*** IMAX = 2**(NBITS) - 1
IMAX = ISHFT(1,NBITS) - 1
IMIN = 0
RANGE = .TRUE.
ENDIF
IF (RANGE) THEN
IVAL = IQ(IQ(LNAME+IOFF+ZNADDR)+J)
IF (IVAL .LT. IMIN .OR. IVAL .GT. IMAX) THEN
LL = IQ(LNAME+IOFF+ZLNAME)
LV = IQ(LNAME+IOFF+ZNAME)
CALL UHTOC(IQ(LCHAR+LV), 4, NAME, LL)
WRITE(MESS,1010) NAME(1:LL), IQ(LBLOK+ZNOENT),
+ IVAL
CALL HBUG(MESS,'HFNT',ID)
ENDIF
IF (IVAL .LT. IMIN) IVAL = IMIN
IF (IVAL .GT. IMAX) IVAL = IMAX
ENDIF
IF (NBITS .EQ. 32) THEN
IQ(LR2+IFIRST) = IQ(IQ(LNAME+IOFF+ZNADDR)+J)
ELSE
CALL SBYT(IVAL, IQ(LR2+IFIRST), NB+1, NBITS)
ENDIF
ELSEIF (ISIZE .EQ. 8) THEN
IF (NBITS .EQ. 64) THEN
IQ(LR2+IFIRST) =IQ(IQ(LNAME+IOFF+ZNADDR)+2*J-1)
IQ(LR2+IFIRST+1)=IQ(IQ(LNAME+IOFF+ZNADDR)+2*J)
ELSE
*-- no double precision packed unsigned integers yet
ENDIF
ENDIF
*
*-- store LOGICAL
*
ELSEIF (ITYPE .EQ. 4) THEN
IF (ISIZE .EQ. 1) THEN
ELSEIF (ISIZE .EQ. 2) THEN
ELSEIF (ISIZE .EQ. 4) THEN
ILOGIC = IQ(IQ(LNAME+IOFF+ZNADDR)+J)
IF (LOGIC) THEN
CALL SBYT(1, IQ(LR2+IFIRST), NB+1, NBITS)
ELSE
CALL SBYT(0, IQ(LR2+IFIRST), NB+1, NBITS)
ENDIF
ENDIF
*
*-- store CHARACTER string
*
ELSEIF (ITYPE .EQ. 5) THEN
MXBY = ISHFT(ISIZE,-2)
DO 20 K = 1, MXBY
IQ(LR2+IFIRST+K-1) =
+ IQ(IQ(LNAME+IOFF+ZNADDR)+MXBY*(J-1)+K)
20 CONTINUE
#if defined(CERNLIB_IBM)||defined(CERNLIB_VAX)||defined(CERNLIB_DECS)||defined(CERNLIB_MSDOS)||defined(CERNLIB_LINUX)||defined(CERNLIB_WINNT)
CALL HRZTOA(IQ(LR2+IFIRST),MXBY)
#endif
ENDIF
*
NB = NB + NBITS
IF (ISHBIT .NE. 0) THEN
IFIRST = IFIRST + ISHFT(NB,-ISHBIT)
ELSE
IFIRST = IFIRST + NB/IBIPW
ENDIF
*** NB = MOD(NB, IBIPW)
NB = IAND(NB, IBIPW-1)
NLEFT = NLEFT - NBITS
IF (J .EQ. 1) CALL SBIT1(IQ(LQ(LBUF-LCIND)),1)
30 CONTINUE
*
*-- update pointers
*
IQ(LNAME+IOFF+ZIFCON) = IFIRST
IQ(LNAME+IOFF+ZIFBIT) = NB + 1
*
40 IOFF = IOFF + ZNADDR
50 CONTINUE
*
60 RETURN
*
1000 FORMAT(A,': Value out of range, event ',I10,' value ',G14.7)
1010 FORMAT(A,': Value out of range, event ',I10,' value ',I11)
*
END