*-- Author : John V. Morris
SUBROUTINE FLK2HB(NHISTS,IERR)
PARAMETER( MAXL=300 )
CHARACTER*30 TL1, TL4
CHARACTER*4 DTP
COMMON/FFARML/ NLK, NSQ(MAXL), DTP(MAXL), TL1(MAXL), TL4(MAXL),
& NBX(MAXL), NBY(MAXL),
& XBA(MAXL), XBB(MAXL), YBA(MAXL), YBB(MAXL),
& NHB(MAXL), LHB(MAXL)
PARAMETER( MAXH=300) ! number of FTD histograms
PARAMETER( MAXH4=MAXH*4 )
COMMON/FLKSTA/ NENT(MAXH), NIN(MAXH), SUMW(MAXH), RNEFF(MAXH),
& XSTAT(MAXH4), YSTAT(MAXH4)
PARAMETER(LENST=66)
COMMON/FTOTST/ ISTSUM(LENST)
LOGICAL PLANAR,RADIAL
COMMON /FTQRUN/ NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
DATA LKOFF/19500/ ! farm <-> LOOK offset ????
CHARACTER*30 TITLE
DIMENSION STORE(4800) ! for contents transfer ?
DIMENSION STOR2(60,80)
EQUIVALENCE( STORE(1),STOR2(1,1) )
IERR = 0
NHISTS = 0
IF( NLK.LE.0 )THEN
IERR = -1
GOTO 2000
ENDIF
DO 1000 JL=1,NLK
IDH = LHB(JL) ! ID of referenced HBOOK hist
IDL = NSQ(JL) ! farm hist sequence number
LFG = IDL + LKOFF ! careful !!??
INR = 0
CALL GTEXT(LFG,4,NCHAR,TITLE)
IF( TITLE.NE.TL1(JL) )THEN ! mis-match
IERR = -2
WRITE(6,'('' FLK2HB ** -2 ,JL,IDH,IDL,LFG '',4I6)')
& JL,IDH,IDL,LFG
GOTO 2000
ENDIF
CALL GHBINS(DTP(JL),LFG,INR,NX,XA,XB,NY,YA,YB)
IF( NX.NE.NBX(JL) .OR. NY.NE.NBY(JL) )THEN ! mis-match
WRITE(6,'('' FLK2HB ** -3 JL, NX, NY, NBX, NBY '',8I6)')
& JL,IDH,IDL,LFG,NX,NY,NBX(JL),NBY(JL)
IERR = -3
GOTO 2000
ENDIF
CALL GHSTAT(DTP(JL),LFG,INR,NENT(JL),SUMW(JL),RNEFF(JL),
& XSTAT(JL*4-3),YSTAT(JL*4-3))
IF(NENT(JL).EQ.0) THEN
WRITE(6,'('' FLK2HB ** -5 ,JL,IDH,IDL,LFG '',4I6)')
& JL,IDH,IDL,LFG
IERR = -5
GO TO 2000
ENDIF
IF( NY.EQ.0 .AND. NX.GT.0 )THEN ! 1-D
LEN = NX
IF(DTP(JL).EQ.'HSW') LEN = LEN*2
CALL FDATA(DTP(JL),LFG,INR,0,NR,STORE,LEN)
IF(DTP(JL).EQ.'HSW') THEN
DO 100 IBIN = 2 , NX
100 STORE(IBIN) = STORE(IBIN*2 - 1)
ENDIF
CALL HPAK(IDH,STORE)
NHISTS = NHISTS+1
IF( IDL.EQ.26 )THEN ! copy to ISTSUM
DO 1002 JX=1,LENST
1002 ISTSUM(JX) = NINT(STORE(JX))
CALL FQEND
ENDIF
ELSE IF( NX*NY.GT.0 )THEN ! 2-D
LENX = NX
IF(DTP(JL).EQ.'HDW') LENX = LENX*2
LEN = LENX*NY
IF( NHB(JL).EQ.1 )THEN ! straight copy
CALL FDATA(DTP(JL),LFG,INR,0,NR,STORE,LEN)
IF(DTP(JL).EQ.'HDW') THEN
DO 101 JY=1,NY
LOC = (JY-1)*LENX
LOCN= (JY-1)*LENX/2
DO 101 IBIN = 2 , LENX
101 STORE(LOCN+ IBIN) = STORE(LOC + IBIN*2 - 1)
ENDIF
CALL HPAK(IDH,STOR2) ! ... I hope! ..?
NHISTS = NHISTS+1
ELSE IF( NHB(JL).GT.1 )THEN ! copy slice-by-slice
IF( NHB(JL).NE.NY )THEN ! mis-match
IERR = -4
GOTO 2000
ENDIF
CALL FDATA(DTP(JL),LFG,INR,0,NR,STORE,LEN)
DO 1001 JY=1,NY
LOC = (JY-1)*LENX
IF(DTP(JL).EQ.'HDW') THEN
DO 102 IBIN = 2 , LENX
102 STORE(LOC + IBIN) = STORE(LOC + IBIN*2 - 1)
ENDIF
NHISTS = NHISTS+1
IDSTO = IDH+JY-1
IF(IDL.EQ.8 .OR. IDL.EQ.23) THEN
IDSTO = IDH + INT((JY-1)/13)*1000 +
& JY - INT((JY-1)/13)*13 - 1
ENDIF
1001 CALL HPAK(IDSTO,STORE(LOC+1))
ENDIF
ENDIF
1000 CONTINUE
2000 CONTINUE ! error messages are printed by FTDEOR
RETURN
END
*