*
* $Id: huwfun.F,v 1.5 1998/11/09 13:37:25 couet Exp $
*
* $Log: huwfun.F,v $
* Revision 1.5  1998/11/09 13:37:25  couet
* - mods for Y2K
*
* Revision 1.4  1996/09/25 09:27:29  couet
* - () was missing in the uwfunc generated function
*
* Revision 1.3  1996/05/13 10:11:14  couet
* - The XDUMMY parameter is not put in the generated function.
*
* Revision 1.2  1996/02/13 15:29:46  couet
* The VDINx variables (1 to 13) are now replaced by OBS(13).
*
* Revision 1.1.1.1  1996/01/16 17:07:59  mclareni
* First import
*
*
#include "hbook/pilot.h"
*CMZ :          11/10/95  17.51.26  by  Julian Bunn
*-- Author :    Fons Rademakers   22/05/92
      SUBROUTINE HUWFUN(LUN, ID1, RNAME1, ITRUN, CHOPT)
*.==========>
*.
*.           Write user function to access N-tuple ID1.
*.           The user function will get name RNAME.
*.           The file will be written using unit LUN.
*.           All variable names will be truncated to ITRUN
*.           characters (ITRUN=0 is no truncation). CHOPT can be 'B'
*.           to make a file for Batch usage (i.e. with HBNAME calls).
*.           Or 'P' to make a PAW selection function. Option 'B' is
*.           the default.
*.           If option 'I' generates only INCLUDE file
*.
*..=========> ( A.A.Rademakers )
*
#include "hbook/hcntpar.inc"
#include "hbook/hcflag.inc"
#include "hbook/hcbook.inc"
#include "hbook/hcbits.inc"
*
      COMMON /SLATE/ ISL(40)
*
      CHARACTER*(*) RNAME1, CHOPT
      CHARACTER*80  TITLE, RNAME
      CHARACTER*10  DATE
      CHARACTER*8   HOUR
      CHARACTER*5   SID
      LOGICAL       BATCH
*
      ID    = ID1
      IDPOS = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID)
      IF (IDPOS .LE. 0) THEN
         CALL HBUG('Unknown N-tuple','HUWFUN',ID1)
         RETURN
      ENDIF
      LCID  = LQ(LTAB-IDPOS)
      I4 = JBIT(IQ(LCID+KBITS),4)
      IF (I4 .EQ. 0) RETURN
      IF (IQ(LCID-2) .NE. ZLINK) THEN
         CALL HBUG('This routine does not work for old N-tuples',
     +             'HUWFUN',ID)
         RETURN
      ENDIF
*
      ITRUNC = ITRUN
      IF (ITRUNC .LE. 0) ITRUNC = 9999
      RNAME = RNAME1(1:MIN(LENOCC(RNAME1),ITRUNC))
*
      BATCH = .TRUE.
      IF (CHOPT(1:1) .EQ. 'B') BATCH = .TRUE.
      IF (CHOPT(1:1) .EQ. 'P') BATCH = .FALSE.
      IOPTI=INDEX(CHOPT,'I')
*
      TITLE = ' '
*
      LBLOK = LQ(LCID-1)
      LCHAR = LQ(LCID-2)
      LINT  = LQ(LCID-3)
      LREAL = LQ(LCID-4)
*
      ITIT1 = IQ(LCID+ZITIT1)
      NWTIT = IQ(LCID+ZNWTIT)
*
*-- write routine header
*
      CALL HITOC(ID1, SID, LL, IERR)
      CALL UHTOC(IQ(LCID+ITIT1), 4, TITLE, NWTIT*4)
*
      CALL DATIME(ID,IT)
      IYEAR  = ISL(1)
      IMONTH = ISL(2)
      IDAY   = ISL(3)
      IHOUR  = ISL(4)
      IMIN   = ISL(5)
      ISEC   = ISL(6)
      WRITE (DATE(1:2),'(I2.2)') IDAY
      DATE(3:3) = '/'
      WRITE (DATE(4:5),'(I2.2)') IMONTH
      DATE(6:6) = '/'
      WRITE (DATE(7:10),'(I4.4)') IYEAR
      WRITE (HOUR(1:2),'(I2.2)') IHOUR
      HOUR(3:3) = '.'
      WRITE (HOUR(4:5),'(I2.2)') IMIN
      HOUR(6:6) = '.'
      WRITE (HOUR(7:8),'(I2.2)') ISEC
*
      IF (BATCH) THEN
         IF(IOPTI.EQ.0)WRITE(LUN,1000) RNAME(1:LENOCC(RNAME))
         WRITE(LUN,1001) SID, TITLE(1:LENOCC(TITLE)),
     +                   DATE, HOUR
      ELSE
         IF(IOPTI.EQ.0)WRITE(LUN,1500) RNAME(1:LENOCC(RNAME))
         WRITE(LUN,1501) SID, TITLE(1:LENOCC(TITLE)),
     +                   DATE, HOUR
         WRITE(LUN,1600)
      ENDIF
*
*-- write declaration and common blocks
*
      IF (BATCH) THEN
         CALL HWDECL(LUN,ITRUNC)
      ELSE
         CALL HWPDCL(LUN,ITRUNC)
      ENDIF
*
*-- write HBNAME definitions
*
      IF(IOPTI.EQ.0) THEN
         IF (BATCH) THEN
            WRITE(LUN,2000) '*'
            CALL HWBNAM(LUN,ITRUNC)
         ENDIF
      ENDIF
*
*-- write trailer
*
      IF(IOPTI.EQ.0)THEN
         IF (BATCH) THEN
            WRITE(LUN,3000)
         ELSE
            WRITE(LUN,3500) RNAME(1:LENOCC(RNAME))
         ENDIF
      ENDIF
*
*-- formats
*
 1000 FORMAT('      SUBROUTINE ',A)
 1001 FORMAT(
     + '*********************************************************',/,
     + '*                                                       *',/,
     + '* This file was generated by HUWFUN.                    *',/,
     + '*                                                       *',/,
     + '*********************************************************',/,
     + '*',/,
     + '*     Ntuple Id:      ',A,/,
     + '*     Ntuple Title:   ',A,/,
     + '*     Creation:       ',A,' ',A,/,
     + '*',/,
     + '*********************************************************',/,
     + '*')
 1500 FORMAT('      REAL FUNCTION ',A,'()')
 1501 FORMAT(
     + '*********************************************************',/,
     + '*                                                       *',/,
     + '* This file was generated by HUWFUN.                    *',/,
     + '*                                                       *',/,
     + '*********************************************************',/,
     + '*',/,
     + '*     Ntuple Id:      ',A,/,
     + '*     Ntuple Title:   ',A,/,
     + '*     Creation:       ',A,' ',A,/,
     + '*',/,
     + '*********************************************************',/,
     + '*')
 1600 FORMAT(
     + '      LOGICAL         CHAIN',/,
     + '      CHARACTER*128   CFILE',/,
     + '      INTEGER         IDNEVT,NCHEVT,ICHEVT',/,
     + '      REAL            OBS(13)',/,
     + '*',/,
     + '      COMMON /PAWIDN/ IDNEVT,OBS',/,
     + '      COMMON /PAWCHN/ CHAIN, NCHEVT, ICHEVT',/,
     + '      COMMON /PAWCHC/ CFILE',/,
     + '*',/,
     + '*--   Ntuple Variable Declarations',/,
     + '*')
 2000 FORMAT(A)
 3000 FORMAT(
     + '*',/,
     + /,
     + '*',/,
     + '*--   Enter user code here',/,
     + '*',/,
     + /,
     + '*',/,
     + '      END')
 3500 FORMAT(
     + '*',/,
     + /,
     + '*',/,
     + '*--   Enter user code here',/,
     + '*',/,
     + /,
     + '      ',A,' = 1.',/,
     + '*',/,
     + '      END')
*
      RETURN
      END