*
* $Id$
*
* $Log$
* Revision 1.8  1999/03/23 14:34:23  couet
* - With some CWNs containing REAL*8, an error message saying that
*   the number was invalid (NaN) was displayed. This was a side
*   effect of the word swapping problem fixed previously.
*
* Revision 1.7  1999/03/05 15:42:32  couet
* - Bug fixed to handle properly the word swapping of REAL*8 machines on little
* endian machines
*
* Revision 1.6  1998/12/02 09:05:30  couet
* - clean up
*
* Revision 1.5  1998/09/25 09:28:34  mclareni
* Modifications for the Mklinux port flagged by CERNLIB_PPC
*
* 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
      INTEGER LRAN, LCIND, LP, LRECL
      SAVE LRAN, LCIND, LP, LRECL
*
#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)
#if defined(CERNLIB_VAX)||defined(CERNLIB_DECS)||(defined(CERNLIB_LINUX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
                     Q(LR2+IFIRST)   = Q(IQ(LNAME+IOFF+ZNADDR)+2*J)
                     Q(LR2+IFIRST+1) = Q(IQ(LNAME+IOFF+ZNADDR)+2*J-1)
                     JX=IFPD(Q(LR2+IFIRST+1))
#else
                     Q(LR2+IFIRST)   = Q(IQ(LNAME+IOFF+ZNADDR)+2*J-1)
                     Q(LR2+IFIRST+1) = Q(IQ(LNAME+IOFF+ZNADDR)+2*J)
                     JX=IFPD(Q(LR2+IFIRST))
#endif
 
*     test the floating point
                     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
*
*   Mods from Rainer Bartoldus
*   The previous version was:
*                          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_PPC))||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
