#include "HepTuple/hbook/pawsize.h" subroutine hbfinit() C Initialize the PAWC common block to a known size and tell HBook C about it. Used by the HBookFile class. I would do this in C++, but C I don''t know how to create the correct style storage for the C common block. C C Paul Rensing July 1994 C Liz Sexton-Kennedy June 1997 implicit none integer lpaw, pawc, inkeys(3) logical match parameter (lpaw = LQPAW) common /pawc/ pawc(lpaw) integer nqstor,nqofft,nqoffs,nqallo,nqiam,lqatab,lqasto,lqbtis +, lqwktb,nqwktb,lqwkfz,mqkeys,nqinit,nqtsys,nqm99,nqperm +, nqfata,nqcase,nqtrac,mqtrac,kqsp common /mzca/ nqstor,nqofft(16),nqoffs(16),nqallo(16),nqiam +, lqatab,lqasto,lqbtis,lqwktb,nqwktb,lqwkfz +, mqkeys(3),nqinit,nqtsys,nqm99,nqperm,nqfata,nqcase +, nqtrac,mqtrac(48) equivalence (kqsp,nqoffs(1)) * data inkeys / 4HEBRA, 4HINIT, 4HDONE / * * Check that Zebra hasn''t been initialized already by somebody (like * Geant). It it has, don''t do it again. That would lead to a host of * mysterious and wrong behaviours that we don''t need. * * If Zebra has already been initialized, go ahead and establish the /PAWC/ * store but do NOT initialize Zebra again. We accomplish that by setting * the argument to Hlimit negative. The possibility that somebody might want * to run Hbook together with some other Zebra application has been forseen. * * See if the initialization keys match * match = .false. if((inkeys(1).eq.mqkeys(1)).and. + (inkeys(2).eq.mqkeys(2)).and. + (inkeys(3).eq.mqkeys(3))) match = .true. if(match) then call hlimit (-lpaw) else call hlimit ( lpaw) endif * return end subroutine doclose(lun) C do a fortran close integer lun close(lun) return end SUBROUTINE RZCLOS(CHPATH,CHOPT) * ************************************************************************ * * To close all transactions with file CHPATH * Corresponding directories are dropped * A FORTRAN or CFCLOS is also issued for all associated files * Input: * CHPATH Character variable specifying the name of the top directory * CHOPT Character variable specifying the options required * 'A' Close all files currently open * * Called by * * Author : J. Shiers * Written : 11.11.91 * Last mod: 11.11.91 * ************************************************************************ CHARACTER*(*) CHPATH,CHOPT CHARACTER*16 CHNAME integer IHDIR(4) integer iqdrop, iqmark, iqcrit, iqsysx PARAMETER (IQDROP=25, IQMARK=26, IQCRIT=27, IQSYSX=28) * integer iquest COMMON /QUEST/ IQUEST(100) * integer iqfenc, lq, iq real q COMMON /ZEBQ/ IQFENC(4), LQ(100) DIMENSION IQ(92), Q(92) EQUIVALENCE (IQ(1),LQ(9)), (Q(1),IQ(1)) * * Process Master parameters * integer nqstor,nqofft,nqoffs,nqallo, nqiam +, lqatab,lqasto,lqbtis, lqwktb,nqwktb,lqwkfz +, mqkeys,nqinit,nqtsys,nqm99,nqperm,nqfata,nqcase +, nqtrac,mqtrac,kqsp COMMON /MZCA/ NQSTOR,NQOFFT(16),NQOFFS(16),NQALLO(16), NQIAM +, LQATAB,LQASTO,LQBTIS, LQWKTB,NQWKTB,LQWKFZ +, MQKEYS(3),NQINIT,NQTSYS,NQM99,NQPERM,NQFATA,NQCASE +, NQTRAC,MQTRAC(48) EQUIVALENCE (KQSP,NQOFFS(1)) * * Current Store and Division * integer jqstor,kqt,kqs, jqdivi,jqdivr +, jqkind,jqmode,jqdivn,jqshar,jqshr1,jqshr2,nqresv +, lqstor,nqfend,nqstru,nqref,nqlink,nqminr,lq2end +, jqdvll,jqdvsy,nqlogl,nqsnam COMMON /MZCB/ JQSTOR,KQT,KQS, JQDIVI,JQDIVR +, JQKIND,JQMODE,JQDIVN,JQSHAR,JQSHR1,JQSHR2,NQRESV +, LQSTOR,NQFEND,NQSTRU,NQREF,NQLINK,NQMINR,LQ2END +, JQDVLL,JQDVSY,NQLOGL,NQSNAM(6) integer IQCUR(16) * integer lqpsto,nqpfen,nqpstr,nqpref,nqplk,nqpmin,lqp2e +, jqpdvl,jqpdvs,nqplog,nqpnam +, lqsyss,lqsysr,iqtdum +, lqsta, lqend, nqdmax,iqmode +, iqkind,iqrcu, iqrto, iqrno +, nqdini,nqdwip,nqdgau,nqdgaf +, nqdpsh,nqdred,nqdsiz +, iqdn1, iqdn2, kqft, lqfsta COMMON /MZCC/ LQPSTO,NQPFEN,NQPSTR,NQPREF,NQPLK,NQPMIN,LQP2E +, JQPDVL,JQPDVS,NQPLOG,NQPNAM(6) +, LQSYSS(10), LQSYSR(10), IQTDUM(22) +, LQSTA(21), LQEND(20), NQDMAX(20),IQMODE(20) +, IQKIND(20),IQRCU(20), IQRTO(20), IQRNO(20) +, NQDINI(20),NQDWIP(20),NQDGAU(20),NQDGAF(20) +, NQDPSH(20),NQDRED(20),NQDSIZ(20) +, IQDN1(20), IQDN2(20), KQFT, LQFSTA(21) integer IQTABV(16) EQUIVALENCE (IQTABV(1),LQPSTO) C integer ltop,lrz0,lcdir,lrin,lrout,lfree,lused,lpurg +, ltemp,lcord,lfrom COMMON /RZCL/ LTOP,LRZ0,LCDIR,LRIN,LROUT,LFREE,LUSED,LPURG +, LTEMP,LCORD,LFROM * integer lqrs EQUIVALENCE (LQRS,LQSYSS(7)) C * ------------- for ZEBRA CQ ------------------------------ * *--------------------------------------------------------------- * Added 15 July 1998 by JMM * Without the RZCLUN common, RZEND doesn''t know what LUN is. * This fix has been passed back to the CERNlib management and * will appear in the 99a release. Till then, we need this. We * have stitched this version of RZCLOS onto the end of hbfinit * to be sure that this one is used by the linker instead of the * (buggy) one in packlib. * integer lun,lrec,isave,imodex,irelat,nhpwd,ihpwd +, izrecl,imodec,imodeH COMMON /RZCLUN/LUN,LREC,ISAVE,IMODEX,IRELAT,NHPWD,IHPWD(2) +, IZRECL,IMODEC,IMODEH *--------------------------------------------------------------- * integer lp, lc, iopta, lenocc, lrz, loglv, ln * integer iqread,iqprnt,iqpr2,iqlog,iqpnch,iqttin,iqtype COMMON /ZUNIT/ IQREAD,IQPRNT,IQPR2,IQLOG,IQPNCH,IQTTIN,IQTYPE integer iqdlun,iqflun,iqhlun, nqused COMMON /ZUNITZ/IQDLUN,IQFLUN,IQHLUN, NQUSED * integer jbit, jbyt, izw, izp, nzb JBIT (IZW,IZP) = IAND (ISHFT(IZW,1-IZP), 1) * JBYT (IZW,IZP,NZB) = ISHFT (ISHFT(IZW,33-IZP-NZB), -32+NZB) * LP = LENOCC(CHPATH) LC = LENOCC(CHOPT) IOPTA = 0 IF(LC.GT.0) IOPTA = INDEX(CHOPT(1:LC),'A') IF(LQRS.EQ.0) RETURN LRZ=LQRS 10 IF(LRZ.EQ.0) RETURN LUN = IQ(KQSP+LRZ-5) IF(LUN.NE.0) THEN LOGLV = JBYT(IQ(KQSP+LRZ),15,3)-3 CALL ZITOH(IQ(KQSP+LRZ+1),IHDIR,4) CALL UHTOC(IHDIR,4,CHNAME,16) LN = LENOCC(CHNAME) * * Check top directory name unless IOPTA * IF(IOPTA.EQ.0) THEN IF(CHPATH(1:LP).NE.CHNAME(1:LN)) GOTO 20 ENDIF CALL RZEND(CHNAME(1:LN)) * * Close * IF(LUN.GT.0) THEN IF(JBIT(IQ(KQSP+LRZ),5).EQ.0) THEN IF(LOGLV.GT.0) WRITE(6,*) ' RZCLOS. close unit ',LUN, + ' (FORTRAN)' CLOSE(LUN) ELSE IF(LOGLV.GT.0) WRITE(6,*) ' RZCLOS. close unit ',LUN, + ' (C)' CALL CFCLOS(LUN-1000,0) ENDIF ENDIF ENDIF 20 CONTINUE LRZ=LQ(KQSP+LRZ) GO TO 10 END