+TITLE. * MN_FIT 4.07/35 17/09/2003 10.52.58 +PATCH,MNCDE. +DECK,dbcde. +KEEP,DBCDE. * * Common block for L3 database display stuff * INTEGER MDBASE PARAMETER (MDBASE = 7) CHARACTER*4 TDBASE,TYRDB,TYEARDB INTEGER IOPDB,IUNDB,LUNDB,LYEARDB REAL ALIMDB COMMON/M9DBC1/ IOPDB(MDBASE),IUNDB(MDBASE),LUNDB,LYEARDB + ,ALIMDB(2) COMMON/M9DBC2/ TDBASE(MDBASE),TYRDB(MDBASE),TYEARDB +DECK,gks$dev. +KEEP,GKS$DEV,IF=HIGZ,IF=GKSGRAL,IF=VMS. INCLUDE 'GKS$GTSDEV' +KEEP,GKS$DEV,IF=HIGZ,IF=GKSGRAL,IF=UNIX. %INCLUDE '/cern/gks/pro/utl/gks$gtsdev' +KEEP,GKS$DEV,IF=-HIGZ,-GKSGRAL. +DECK,gks$enum. +KEEP,GKS$ENUM,IF=HIGZ,IF=GKSGRAL,IF=VMS. INCLUDE 'GKS$ENUM' +KEEP,GKS$ENUM,IF=HIGZ,IF=DECGKS,IF=VMS. INCLUDE 'SYS$LIBRARY:GKSDEFS.BND' +KEEP,GKS$ENUM,IF=HIGZ,IF=DGKS3D,IF=VMS. INCLUDE 'SYS$LIBRARY:GKS3D$FORBND.FOR' INCLUDE 'SYS$LIBRARY:GKS3D$DEFS.FOR' +KEEP,GKS$ENUM,IF=HIGZ,IF=DGKS3D,IF=DECS. INCLUDE '/usr/include/GKS3D/GKS3Dforbnd.f' #include "/usr/include/GKS3D/GKS3Dgksbnd_defs.h" +KEEP,GKS$ENUM,IF=HIGZ,IF=GKSGRAL,IF=UNIX. %INCLUDE '/cern/gks/pro/utl/gks$enum' +KEEP,GKS$ENUM,IF=HIGZ,IF=X11,DI3000. +KEEP,GKS$ENUM,IF=-HIGZ. +DECK,hbcdes_93,if=v93. +KEEP,HCBITS INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 +DECK,hcdir,if=v93. +KEEP,HCDIR. integer nlpatm, mxfiles PARAMETER (NLPATM=100, MXFILES=50) integer nlcdir, nlndir, nlpat, icdir, nchtop, ichtop, + ichtyp, ichlun COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*80 HFNAME COMMON /HCFILE/HFNAME(MXFILES) +DECK,hicdes_93,if=v93. +KEEP,HIFLAG. COMMON /HIFLAG/ GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG +,ASFLAG,GRFLAG,AXFLAG LOGICAL GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG +,ASFLAG,GRFLAG,AXFLAG +KEEP,HIATT. Attributes list COMMON /HIATT/ INTR,XRATIO,YRATIO +,RWXMIN,RWXMAX,RWYMIN,RWYMAX,RVXMIN,RVXMAX,RVYMIN,RVYMAX +,RDWXMI,RDWXMA,RDWYMI,RDWYMA,RDVXMI,RDVXMA,RDVYMI,RDVYMA +,RMDSX ,RMDSY ,IWTYPE,IDID ,IDTY +,ILOPWK(10),ACWKFL(10),NODRFL(10),IWTYL(10) ,INOPWK +,XWKSIZ(10),YWKSIZ(10),WKMAX(10) ,IWINID(10),XWKR(10),YWKR(10) +,XWKW1(10),YWKW1(10),XWKV1(10),YWKV1(10) +,XWKW2(10),YWKW2(10),XWKV2(10),YWKV2(10) +,IPICT,ICLIP,REDIT,NT0PRI +,RMKSC ,RLWSC ,RBSL ,RANGLE,RCHH ,RCSHIF,RBOF ,RBWD +,RAWL ,RTMS ,RALH ,RALD ,REAATT(18) +,IPLCI ,ILN ,IPMCI ,IMK ,IFACI ,IFAIS ,IFASI ,ITXCI +,ITXALG,IFTPR ,INPASS,IBORD ,INLINE,INTATT(17) +,IFONT,IPREC,ITXALH,ITXALV,RCHUX,RCHUY +,IDIM,INBCOL LOGICAL ACWKFL,NODRFL +KEEP,HIMDOS. COMMON /HIMDOS/ IPICNM,SCMETA +KEEP,HIMETA. COMMON /HIMETA/ IDMETA,XMFACT,YMFACT,TEKACT,METACT,FILOPN INTEGER IDMETA REAL XMFACT,YMFACT LOGICAL TEKACT,METACT,FILOPN COMMON /HIMETC/ CHMETA CHARACTER*24 CHMETA +SEQ,HIMDOS,IF=MSDOS. +DECK,mncmd. +KEEP,MNCMD. CHARACTER*10 COMND1,COMND2,COMND3 common /m9cmd0/ comnd1,comnd2,comnd3 C LOGICAL QRFILE,QABORT INTEGER LUNDMP COMMON/M9CMD1/QRFILE,LUNDMP,QABORT C INTEGER MDRAW,MLOG,MSMOD,MHBP,MCUT,MORD,MNTO,MTBL PARAMETER (MDRAW = 20) PARAMETER (MLOG = 9) PARAMETER (MSMOD = 6) PARAMETER (MHBP = 9) PARAMETER (MCUT = 7) PARAMETER (MORD = 20) PARAMETER (MNTO = 13) PARAMETER (MTBL = 17) C C MCOL Maximum number of colours C integer mcol parameter (mcol = 50) C INTEGER MDRW_LINE, MDRW_ARROW, MDRW_BOX, MDRW_TRIANGLE + ,MDRW_POLYGON,MDRW_POLYLINE + ,MDRW_CIRCLE, MDRW_ARC, MDRW_SINE, MDRW_GLUON, MDRW_SYMBOL + ,MDRW_ELLIPSE,MDRW_SEG PARAMETER (MDRW_LINE = 1) PARAMETER (MDRW_ARROW = 2) PARAMETER (MDRW_BOX = 3) PARAMETER (MDRW_TRIANGLE = 4) PARAMETER (MDRW_POLYGON = 5) PARAMETER (MDRW_POLYLINE = 6) PARAMETER (MDRW_CIRCLE = 7) PARAMETER (MDRW_ARC = 8) PARAMETER (MDRW_SINE = 9) PARAMETER (MDRW_GLUON =10) PARAMETER (MDRW_SYMBOL =11) PARAMETER (MDRW_ELLIPSE =12) PARAMETER (MDRW_SEG =13) C CHARACTER*10 DRWNAM,LOGNAM,SCLMOD + ,OPTNAM,UNTNAM + ,ORDNAM,NTONAM + ,COLNAM + ,TBLNAM CHARACTER*4 CUTNAM CHARACTER*2 CUTNM2 CHARACTER*3 ANDNAM CHARACTER*4 HBPNAM CHARACTER*2 TSPSYM CHARACTER*5 TCMSYM CHARACTER*11 TCTSYM CHARACTER*3 THPSYM CHARACTER*20 TSDSCN,TSVSCN,TS2SCN,TS3SCN,TS4SCN C COMMON/M9CMD2/DRWNAM(MDRAW),LOGNAM(MLOG),SCLMOD(MSMOD) + ,OPTNAM(5),UNTNAM(3) + ,ORDNAM(MORD),NTONAM(MNTO),COLNAM(0:MCOL),TBLNAM(MTBL,2) + ,CUTNAM(MCUT),CUTNM2(MCUT),ANDNAM(3) + ,HBPNAM(MHBP) C common /m9cmd3/ + TSPSYM,TCMSYM,TCTSYM,THPSYM + ,TSDSCN + ,TSVSCN,TS2SCN,TS3SCN,TS4SCN C INTEGER IPNTD,MDUMMY COMMON/M9CMD4/IPNTD(5),MDUMMY C INTEGER MTBL2D,MTBL3D,MTBLEGO,MTBSURF COMMON/M9CMD5/MTBL2D,MTBL3D,MTBLEGO,MTBSURF * integer ncoldef real colfrc common /m9cmd6/ ncoldef,colfrc(3,0:mcol) +DECK,mncmt. C C Comment and continuation line characters C +KEEP,MNCMT. CHARACTER*1 TSCOMM,TSCONT COMMON /M9CMT1/ TSCOMM,TSCONT +DECK,mncndj. +KEEP,MNCNDJ,IF=VAX. INTEGER SS$_USRBASE,SS$_USRCTLC PARAMETER (SS$_USRBASE='08008000'X) PARAMETER (SS$_USRCTLC=SS$_USRBASE+'00000012'X) INTEGER NCTCHN,ICTPAR,IARITH LOGICAL QBREAK,QERROR,QTRAP,QBRKEN COMMON /MNCNDJ/ NCTCHN,ICTPAR,QBREAK,QERROR,QTRAP,QBRKEN,IARITH VOLATILE /MNCNDJ/ +KEEP,MNCNDJ,IF=-VAX. INTEGER NCTCHN,ICTPAR,IARITH LOGICAL QBREAK,QERROR,QTRAP,QBRKEN COMMON /MNCNDJ/ NCTCHN,ICTPAR,QBREAK,QERROR,QTRAP,QBRKEN,IARITH +DECK,mncpc. +KEEP,MNCPC. C C Common blocks for use with CPC C MNCPC_CMD contains the commands being passed to Mn_Fit C MNCPC_MES contains information being sent back C MNCPC_FLG contains the event flag number, infocache contents C and the CPU node C TCPC_FLG says what is being sent (P, E, M, R) or any combination C TCPC_MES contains any messages C INTEGER MCPC_MES PARAMETER (MCPC_MES=20) * INTEGER IF_CMD,IL_CMD CHARACTER*80 TCPC_CMD COMMON/MNCPC_CMD/ IF_CMD,TCPC_CMD,IL_CMD(128) CDEC$ PSECT /MNCPC_CMD/ ALIGN=9 C INTEGER IF_MES,IL_MES CHARACTER*4 TCPC_FLG CHARACTER*80 TCPC_MES COMMON/MNCPC_MES/ IF_MES,TCPC_FLG,TCPC_MES(MCPC_MES),IL_MES(128) CDEC$ PSECT /MNCPC_MES/ ALIGN=9 C INTEGER ICR INTEGER*2 ICMD(8),IMES(8) CHARACTER*6 MNFIT_NODE_NAME COMMON/MNCPC_FLG/ ICR,ICMD,IMES,MNFIT_NODE_NAME C CHARACTER*20 MNFIT_CMD_CLUSCOM_NAME,MNFIT_MES_CLUSCOM_NAME CHARACTER*40 MNFIT_CMD_CLUSCOM_FILE,MNFIT_MES_CLUSCOM_FILE CHARACTER*20 MNFIT_CMD_IC_NAME,MNFIT_MES_IC_NAME COMMON/MNCPC_NAM/ + MNFIT_CMD_CLUSCOM_NAME,MNFIT_CMD_CLUSCOM_FILE,MNFIT_CMD_IC_NAME +,MNFIT_MES_CLUSCOM_NAME,MNFIT_MES_CLUSCOM_FILE,MNFIT_MES_IC_NAME +DECK,mncpc_g. +KEEP,MNCPC_G. C C Common block containing local copy of command for use with CPC C CHARACTER*80 TMN_CMD COMMON/M9CPC_G/ TMN_CMD +DECK,mncpc_m. +KEEP,MNCPC_M. C C Common block containing local copy of flag and message C INTEGER MMN_MES,MMN_MSTACK PARAMETER (MMN_MES=20) PARAMETER (MMN_MSTACK=20) C INTEGER MN_MES CHARACTER*4 TMN_FLG,TMN_FLG_LAST CHARACTER*80 TMN_MES COMMON/M9CPC_M/ MN_MES,TMN_FLG(MMN_MSTACK) + ,TMN_MES(MMN_MES,MMN_MSTACK),TMN_FLG_LAST +DECK,mncut. +KEEP,MNCUT. C C STORAGE OF CUTS *ICTYPE = 1 means simple cut, variable and value *ICTYPE = 2 means an expression for variable then value *ICTYPE = 3 means an expression for value also *ICTYPE = 4 means a COMIS function, compiled in MN_PRJ C INTEGER NCCUT,NCUSE,ICTYPE,ICVAR,ICCOND,ICAND,ICPARI,ICPARO,ICUSE INTEGER ICVAL COMMON/M9CUTA/NCCUT,NCUSE,ICTYPE(MCUTMX),ICVAR(10,MCUTMX) 1 ,ICCOND(MCUTMX),ICVAL(10,MCUTMX) 2 ,ICAND(MCUTMX),ICPARI(MCUTMX) 3 ,ICPARO(MCUTMX),ICUSE(MCUTMX) REAL RCVAL(10,MCUTMX) EQUIVALENCE(ICVAL(1,1),RCVAL(1,1)) CHARACTER*10 TCNAM CHARACTER*255 TCVAR CHARACTER*255 TCVAL COMMON /M9CUTB/ TCNAM(MCUTMX),TCVAR(MCUTMX),TCVAL(MCUTMX) C C Common for parsed CUT expressions C INTEGER MCESUB PARAMETER (MCESUB = 50) C INTEGER NCEXPR,LCEXPR,ICETYP,ICETP,ICETF,ICETV COMMON/M9CUTC/NCEXPR,LCEXPR(MCUTMX) + ,ICETYP(MCESUB,MCUTMX),ICETP(MCESUB,MCUTMX) + ,ICETF(MCESUB,MCUTMX),ICETV(10,MCESUB,MCUTMX) +DECK,mncwn. +keep,mncwn. * * Common Blocks for CWN's * * PAW common blocks for the CWN integer mcr4mx,mcr8mx,mcchmx parameter (mcr4mx = 100000) parameter (mcr8mx = 10000) parameter (mcchmx = 5000) real ar4 common /pawcr4/ ar4(mcr4mx) double precision zr8 common /pawcr8/ zr8(mcr8mx) character*4 cch common /pawcch/ cch(mcchmx) integer ir4(mcr4mx) logical qr4(mcr4mx) * equivalence (ar4(1),ir4(1)) equivalence (ar4(1),qr4(1)) * * CWN structure in terms of variable number * integer nwr4sv,nwr8sv,nwchsv + ,ivsub,ivtype,ivsize,ivelem,ivposn common /m8cwn1/ nwr4sv,nwr8sv,nwchsv + ,ivsub(10,mdimmx),ivtype(mdimmx),ivsize(mdimmx) + ,ivelem(mdimmx),ivposn(mdimmx) * * CWN variables in order that they are asked for. * 1st variables to project onto * 2nd extra variables needed for variables length arrays * 3rd cut variables * 4th extra variables from SET NTUPLE VARIABLE command * integer nvcwn,ivcwn,iecwn common /m8cwn2/ nvcwn,ivcwn(mdimmx),iecwn(9,mdimmx) character chcwn*32,chblk*8,chcwnv*32,cvdesc*40 common /m8cwn3/ chcwn(mdimmx),chblk(mdimmx),chcwnv(mdimmx) + ,cvdesc(mdimmx) * * Extra variables to fetch from SET NTUPLE VARIABLE command * integer mcwn_x,ncwn_x parameter (mcwn_x = 20) common /m8cwn4/ ncwn_x character tcwn_x*32 common /m8cwn5/ tcwn_x(mcwn_x) +DECK,mndat. +KEEP,MNDAT. C C MAIN DATA STORAGE C REAL RDAT COMMON/M9DAT/RDAT(MHSTWD) INTEGER*2 IDAT2(2*MHSTWD) EQUIVALENCE(RDAT,IDAT2) C INTEGER NHSTWD,NDPTE,NDHIS,NDIDB,NIDADT,NIDBDT,NNHDT COMMON/M9DATA/NHSTWD,NDPTE,NDHIS,NDIDB,NIDADT,NIDBDT,NNHDT INTEGER IDIDA,IDIDB,IDPTRH,IDPTRD COMMON/M9DATB/IDIDA(MHSTMX),IDIDB(MHSTMX),IDPTRH(MHSTMX) 1 ,IDPTRD(MHSTMX) C C TDTIT is the plot title C TDFIL is the filename for the plot C TDDIR is the HBOOK directory it is in C TDNAM are the names of the variables C CHARACTER*80 TDTIT CHARACTER*80 TDFIL CHARACTER*40 TDDIR CHARACTER*32 TDNAM COMMON/M9DATC/TDTIT(MHSTMX),TDFIL(MHSTMX),TDDIR(MHSTMX) + ,TDNAM(MDIMMX,MHSTMX) +DECK,mndbg. +KEEP,MNDBG. C C Debug flag for Mn_Fit and COMIS. C To get Mn_Fit debug output set NDEBUG > 100. C LOGICAL QDEBUG INTEGER NDEBUG COMMON/MNDBG/QDEBUG,NDEBUG +DECK,mndir. +KEEP,MNDIR. C C DIRECTORY WHERE CODE AND NECESSARY FILES ARE KEPT C CHARACTER TMNDIR*80,TMNHLP*80,TMNHOM*80,TMNDOC*80 COMMON /M9DIR1/ TMNDIR,TMNHLP,TMNHOM,TMNDOC C INTEGER LMNDIR,LMNHLP,LMNHOM,LMNDOC COMMON /M9DIR2/ LMNDIR,LMNHLP,LMNHOM,LMNDOC +DECK,mndsp. +KEEP,MNDSP,IF=L3DSP_SRC. INTEGER MDET,MDSPAR,MDSKEY PARAMETER (MDET=9, MDSPAR=20, MDSKEY=10) C INTEGER NDSPTP,IDSPTP + ,IPARL3,IPARTE,IPAREC,IPARHC,IPARMU,IPARFB,IPARFW,IPARFS REAL PRD_L3,PRS_L3,PRU_L3,PRP_L3 + ,PRD_TE,PRS_TE,PRU_TE,PRP_TE + ,PRD_EC,PRS_EC,PRU_EC,PRP_EC + ,PRD_HC,PRS_HC,PRU_HC,PRP_HC + ,PRD_MU,PRS_MU,PRU_MU,PRP_MU + ,PRD_FB,PRS_FB,PRU_FB,PRP_FB + ,PRD_FW,PRS_FW,PRU_FW,PRP_FW + ,PRD_FS,PRS_FS,PRU_FS,PRP_FS COMMON/M9DSP1/NDSPTP,IDSPTP(MHPLT) + ,IPARL3(MDSPAR),PRD_L3(MDSPAR),PRS_L3(MDSPAR),PRU_L3(MDSPAR) + ,PRP_L3(MDSPAR,MHPLT) + ,IPARTE(MDSPAR),PRD_TE(MDSPAR),PRS_TE(MDSPAR),PRU_TE(MDSPAR) + ,PRP_TE(MDSPAR,MHPLT) + ,IPAREC(MDSPAR),PRD_EC(MDSPAR),PRS_EC(MDSPAR),PRU_EC(MDSPAR) + ,PRP_EC(MDSPAR,MHPLT) + ,IPARHC(MDSPAR),PRD_HC(MDSPAR),PRS_HC(MDSPAR),PRU_HC(MDSPAR) + ,PRP_HC(MDSPAR,MHPLT) + ,IPARMU(MDSPAR),PRD_MU(MDSPAR),PRS_MU(MDSPAR),PRU_MU(MDSPAR) + ,PRP_MU(MDSPAR,MHPLT) + ,IPARFB(MDSPAR),PRD_FB(MDSPAR),PRS_FB(MDSPAR),PRU_FB(MDSPAR) + ,PRP_FB(MDSPAR,MHPLT) + ,IPARFW(MDSPAR),PRD_FW(MDSPAR),PRS_FW(MDSPAR),PRU_FW(MDSPAR) + ,PRP_FW(MDSPAR,MHPLT) + ,IPARFS(MDSPAR),PRD_FS(MDSPAR),PRS_FS(MDSPAR),PRU_FS(MDSPAR) + ,PRP_FS(MDSPAR,MHPLT) C CHARACTER*4 DETNAM CHARACTER*10 TPARL3,TPARTE,TPAREC,TPARHC,TPARMU + ,TPARFB,TPARFW,TPARFS C COMMON/M9DSP2/DETNAM(MDET),TPARL3(MDSPAR) + ,TPARTE(MDSPAR),TPAREC(MDSPAR),TPARHC(MDSPAR),TPARMU(MDSPAR) + ,TPARFB(MDSPAR),TPARFW(MDSPAR),TPARFS(MDSPAR) C CHARACTER*15 TKYSL3,TKYUL3,TKYPL3,TKYSTE,TKYUTE,TKYPTE + ,TKYSEC,TKYUEC,TKYPEC,TKYSHC,TKYUHC,TKYPHC + ,TKYSMU,TKYUMU,TKYPMU,TKYSFB,TKYUFB,TKYPFB + ,TKYSFW,TKYUFW,TKYPFW,TKYSFS,TKYUFS,TKYPFS COMMON/M9DSP3/ + TKYSL3(MDSKEY),TKYUL3(MDSKEY),TKYPL3(MDSKEY,MHPLT) + ,TKYSTE(MDSKEY),TKYUTE(MDSKEY),TKYPTE(MDSKEY,MHPLT) + ,TKYSEC(MDSKEY),TKYUEC(MDSKEY),TKYPEC(MDSKEY,MHPLT) + ,TKYSHC(MDSKEY),TKYUHC(MDSKEY),TKYPHC(MDSKEY,MHPLT) + ,TKYSMU(MDSKEY),TKYUMU(MDSKEY),TKYPMU(MDSKEY,MHPLT) + ,TKYSFB(MDSKEY),TKYUFB(MDSKEY),TKYPFB(MDSKEY,MHPLT) + ,TKYSFW(MDSKEY),TKYUFW(MDSKEY),TKYPFW(MDSKEY,MHPLT) + ,TKYSFS(MDSKEY),TKYUFS(MDSKEY),TKYPFS(MDSKEY,MHPLT) +KEEP,MNDSP,IF=ZEUSDSP_SRC. INTEGER MDET,MDSPAR,MDSKEY PARAMETER (MDET=4, MDSPAR=20, MDSKEY=10) C INTEGER NDSPTP,IDSPTP + ,IPARFD,IPARFT,IPARTR REAL PRD_FD,PRS_FD,PRU_FD,PRP_FD + ,PRD_FT,PRS_FT,PRU_FT,PRP_FT + ,PRD_TR,PRS_TR,PRU_TR,PRP_TR COMMON/M9DSP1/NDSPTP,IDSPTP(MHPLT) + ,IPARFD(MDSPAR),PRD_FD(MDSPAR),PRS_FD(MDSPAR),PRU_FD(MDSPAR) + ,PRP_FD(MDSPAR,MHPLT) + ,IPARFT(MDSPAR),PRD_FT(MDSPAR),PRS_FT(MDSPAR),PRU_FT(MDSPAR) + ,PRP_FT(MDSPAR,MHPLT) + ,IPARTR(MDSPAR),PRD_TR(MDSPAR),PRS_TR(MDSPAR),PRU_TR(MDSPAR) + ,PRP_TR(MDSPAR,MHPLT) C CHARACTER*4 DETNAM CHARACTER*10 TPARFD,TPARFT,TPARTR C COMMON/M9DSP2/DETNAM(MDET),TPARFD(MDSPAR) + ,TPARFT(MDSPAR),TPARTR(MDSPAR) C CHARACTER*15 TKYSFD,TKYUFD,TKYPFD,TKYSFT,TKYUFT,TKYPFT + ,TKYSTR,TKYUTR,TKYPTR COMMON/M9DSP3/ + TKYSFD(MDSKEY),TKYUFD(MDSKEY),TKYPFD(MDSKEY,MHPLT) + ,TKYSFT(MDSKEY),TKYUFT(MDSKEY),TKYPFT(MDSKEY,MHPLT) + ,TKYSTR(MDSKEY),TKYUTR(MDSKEY),TKYPTR(MDSKEY,MHPLT) +DECK,mnfit. +KEEP,MNFIT. INTEGER MFINTG PARAMETER (MFINTG = 50) C Maximum number of constraints and the depth of each INTEGER MCNSTR,MCNSUB PARAMETER (MCNSTR = 20, MCNSUB = 100) C Maximum number of steps in convoluting function with a Gaussian INTEGER MFCONV PARAMETER (MFCONV = 100) C C STORAGE FOR HISTOGRAMS TO BE FIT C INTEGER NDFIT,NFPTE COMMON/M9FITA/NDFIT,NFPTE C REAL RFIT COMMON/M9FITB/RFIT(MFITWD) C C NFITTP Fit type C NPARTP Type of parameters 0 = Normal C 1 = Fractions + overall normalization C JMINFX,JMINPX Cross-reference from MINUIT to Mn_Fit parameter numbers C INTEGER NFITTP,NPARTP,NHFIT,IDFITA,IDFITB,IFPTRH,IFPTRD + ,IFNDIM,IFWPPT,IFPFIT,IFPUSE + ,IXEXCL,IYEXCL,IXINCL,IYINCL + ,IASSF,IDBCKA,IDBCKB + ,JMINFX,JMINPX REAL XLEXCL,XHEXCL,YLEXCL,YHEXCL,XLINCL,XHINCL,YLINCL,YHINCL + ,XFTPAR COMMON/M9FITC/NFITTP,NPARTP,NHFIT,IDFITA(MFITMX),IDFITB(MFITMX) 1 ,IFPTRH(MFITMX),IFPTRD(MFITMX) 1 ,IFNDIM(MFITMX),IFWPPT(MFITMX),IFPFIT(MFITMX),IFPUSE(MFITMX) 3 ,IXEXCL(MFITMX),XLEXCL(10,MFITMX),XHEXCL(10,MFITMX) 3 ,IYEXCL(MFITMX),YLEXCL(10,MFITMX),YHEXCL(10,MFITMX) 3 ,IXINCL(MFITMX),XLINCL(10,MFITMX),XHINCL(10,MFITMX) 3 ,IYINCL(MFITMX),YLINCL(10,MFITMX),YHINCL(10,MFITMX) 4 ,XFTPAR(20,MFITMX),IASSF(MFUNMX,MFITMX) 6 ,IDBCKA(MFITMX),IDBCKB(MFITMX) + ,JMINFX(MINMAX),JMINPX(MINMAX) C CHARACTER*80 TFTIT CHARACTER*80 TFFIL CHARACTER*32 TFNAM COMMON/M9FITD/TFTIT(MFITMX),TFFIL(MFITMX) 1 ,TFNAM(MDIMMX,MFITMX) C C Fit results C INTEGER NPAR_MN,NFRE_MN,NPTTOT REAL CHI2_MN,ALIK_MN,CONLEV,FICHI,FILIK COMMON/M9FITE/NPAR_MN,CHI2_MN,ALIK_MN,NFRE_MN,CONLEV 1 ,NPTTOT 1 ,FICHI(MFITMX),FILIK(MFITMX) C C QFITER Flag if fit iterations should be shown C QSEXCL C NDMODE Mode for displaying the results of a fit C QSORTH Flag if orthogonality limits have been set C QSNORM Flag if overall normalization factor should be applied C QSBACK Flag if background functions have been specified C QRATIO Flag if ratio of areas used when fitting multiple histograms C QFINTG Flag if function should be integrated across each bin C NFINTG Number of intervals in each bin for integration C QFBINW Use bin width when calculating function value C QFCONV Convolute the function with a Gaussian C RFCONV Width of the Gaussians to convolute C QFAREA Calculate the AREA when using fragmentation functions and C dipion invariant mass functions C QMNCHGE Number of functions or fitting method changed C LOGICAL QFITER,QSEXCL,QSORTH,QSNORM,QSBACK,QRATIO,QFINTG,QFBINW + ,QFCONV,QFAREA,QMNCHGE INTEGER NFITER,NDMODE,NFINTG REAL RFCONV COMMON/M9FITF/QFITER,NFITER,QSEXCL,NDMODE + ,QSORTH,QSNORM,QSBACK,QRATIO,QFINTG,NFINTG,QFBINW + ,QFCONV,RFCONV(10),QFAREA,QMNCHGE C C Constraints C NCNSTR Number of constraints to be applied to the parameters C LCNSTR Length of each constraint C ICNTYP,ICNTP,ICNTF,ICNTV The constraint in form for AM_EXP C JCNSTX Cross-reference from MINUIT parameter to constraint number INTEGER NCNSTR,LCNSTR,ICNPAR,ICNTYP,ICNTP,ICNTF,ICNTV,JCNSTX COMMON/M9FITG/NCNSTR + ,LCNSTR(MCNSTR),ICNPAR(MCNSTR) + ,ICNTYP(MCNSUB,MCNSTR),ICNTP(MCNSUB,MCNSTR),ICNTF(MCNSUB,MCNSTR) + ,ICNTV(10,MCNSUB,MCNSTR) + ,JCNSTX(MINMAX) C CHARACTER*80 TCNSTR COMMON/M9FITH/ TCNSTR(MCNSTR) +DECK,mnflg. +KEEP,MNFLG. C C UNITS FOR READING AND WRITING PLOTS C INTEGER LUNHIN,LUNAIN,LUNDIN,LUNMIN,LUNSIN,LUNFIN + ,LUNYIN + ,LUNHOU,LUNMOU,LUNFOU,LUNPIN,LUNPOU,NRCLHB,npath COMMON/M9JNKT/LUNHIN,LUNAIN,LUNDIN,LUNMIN,LUNSIN,LUNFIN 1 ,LUNYIN 1 ,LUNHOU,LUNMOU,LUNFOU,LUNPIN,LUNPOU,NRCLHB,npath C integer mpath parameter (mpath = 10) CHARACTER*80 FIL_HB,FIL_AV,FIL_DT,FIL_MN,FIL_SC,FIL_FI 1 ,FIL_HY 1 ,FIL_HO,FIL_MO,FIL_FO,FIL_DP,FIL_PI,FIL_PO + ,DIR_HB,DIR_HC,DIR_WD,tpath COMMON/M9JNKU/FIL_HB,FIL_AV,FIL_DT,FIL_MN,FIL_SC,FIL_FI 1 ,FIL_HY 1 ,FIL_HO,FIL_MO,FIL_FO,FIL_DP,FIL_PI,FIL_PO + ,DIR_HB,DIR_HC,DIR_WD,tpath(mpath) C CHARACTER*20 TEDIT CHARACTER*20 TSHELL character tpager*40 COMMON/M9JNKW/TEDIT,TSHELL,tpager C C QHSTAT Use HBOOK statistics rather than Mn_Fit C QMOUSE Use the mouse to get x,y positions C QBREAK Break handling turned on or off C QAFETCH Automatic refetching of Ntuples C QTKTCL Turn on/off TK/TCL interface C IORDMN Expected order of variables for DAT_FETCH C INTPMN Variable specification for plotting Ntuples directly C LOGICAL QSHIST,QHBPRT,QENULL,QHSTAT,QMOUSE,QBREAK,QAFETCH + ,QTKTCL INTEGER IORDMN,INTPMN COMMON/M9JNKX/QSHIST,QHBPRT,QENULL,QHSTAT,QMOUSE,QBREAK,QAFETCH + ,QTKTCL + ,IORDMN(20),INTPMN(9) C C NINTFT Number of intervals when intgrating a function in the parser C FNSTEP Step size when calculating function derivatives in the parser C INTEGER NINTFT REAL FNSTEP COMMON/M9CLC2/NINTFT,FNSTEP +DECK,mnfun. +KEEP,MNFUN. C C STORAGE FOR THE FUNCTION VALUES C C USED FUNCTIONS C INTEGER NFUN_MN,NFUSEM,NFUSEL + ,INUMF,IPARF,IUSEF REAL FPAR,DFPAR,DPFPAR,DNFPAR,FPARLO,FPARHI,XFXPAR INTEGER ISIGF,IBCKF,IADRF,ISFPAR REAL F00,DF00,DPF00,DNF00,F00LO,F00HI INTEGER ISF00 C COMMON/M9FUNA/NFUN_MN,NFUSEM,NFUSEL 1 ,INUMF(MFUNMX),IPARF(MFUNMX),IUSEF(MFUNMX) 1 ,FPAR(20,MFUNMX),DFPAR(20,MFUNMX) 1 ,DPFPAR(20,MFUNMX),DNFPAR(20,MFUNMX) 1 ,FPARLO(20,MFUNMX),FPARHI(20,MFUNMX) 2 ,XFXPAR(20,MFUNMX),ISFPAR(20,MFUNMX) 3 ,ISIGF(MFUNMX),IBCKF(MFUNMX),IADRF(MFUNMX) 4 ,F00,DF00,DPF00,DNF00,F00LO,F00HI,ISF00 C CHARACTER*10 TPARF,TNAMF CHARACTER*80 TUSEF,TFILF C COMMON/M9FUNB/TPARF(20,MFUNMX),TUSEF(MFUNMX),TFILF(MFUNMX) 1 ,TNAMF(MFUNMX) C C Smooth histograms as functions C INTEGER MHPTMX,MHSMMX PARAMETER (MHPTMX = 500) PARAMETER (MHSMMX = 10) INTEGER IHSMOO,IHPSMO DOUBLE PRECISION XHSMOO,AHSMOO,BHSMOO,CHSMOO,DHSMOO COMMON /M9FUNC/ IHSMOO(MHSMMX),IHPSMO(MHSMMX) + ,XHSMOO(0:MHPTMX,MHSMMX) + ,AHSMOO(MHPTMX,MHSMMX),BHSMOO(MHPTMX,MHSMMX) + ,CHSMOO(MHPTMX,MHSMMX),DHSMOO(MHPTMX,MHSMMX) C C DRAWN FUNCTIONS C INTEGER NDFUN REAL AFTTOT,AFFTOT,AHTTOT,AHFTOT C COMMON/M9FUND/NDFUN + ,AFTTOT(MFNHMX,MFITMX),AFFTOT(MFNHMX,MFITMX) + ,AHTTOT(MFITMX),AHFTOT(MFITMX) C C DEFINED FUNCTIONS C INTEGER MMPIPI,MMFRAG PARAMETER (MMPIPI=10) PARAMETER (MMFRAG=10) INTEGER NFNDMX,IFPAR,IPPIPI,IPFRAG INTEGER LFPEXP,LFTRIG,LFPIPI,LFFRAG,LFXRES,LFXCNT,LFUSER + ,LFHFUN,LFHSMO + ,LFCMIS,LFARGU,LFCONV,LF2DIM INTEGER LFGAUSS,LFPOLY,LFCHEB,LFEXP C COMMON/M9FUNE/NFNDMX,IFPAR(MFNDMX),IPPIPI(MMPIPI),IPFRAG(MMFRAG) + ,LFPEXP,LFTRIG,LFPIPI,LFFRAG,LFXRES,LFXCNT,LFUSER + ,LFHFUN,LFHSMO + ,LFCMIS,LFARGU,LFCONV,LF2DIM + ,LFGAUSS,LFPOLY,LFCHEB,LFEXP C CHARACTER*35 TFNNAM CHARACTER*20 TPIPI,TFRAG CHARACTER*10 TFPNAM,TPPIPI,TPFRAG COMMON/M9FUNF/TFNNAM(MFNDMX),TFPNAM(20,MFNDMX) + ,TPIPI(MMPIPI),TPPIPI(20,MMPIPI) + ,TFRAG(MMFRAG),TPFRAG(20,MMFRAG) +DECK,mngrn. +KEEP,MNGRN. INTEGER MPTOT,MTEKDV,MAXPVI,MDISP0 PARAMETER (MPTOT=25,MTEKDV=10,MAXPVI=12,MDISP0=3) INTEGER MPDEV,MPSOF,MPHRD,LPUNIT,LPDEV,IPDEV,IPUNIT,ICONID + ,IPLPOS,NPCMD,NSPAPER,NTEKDV,ITEKDV,JTEKDV + ,ITNR,NP113,NDVLST REAL SZMAX,OFSET + ,XOF_GR,YOF_GR, XSC_GR,YSC_GR, X0_GR, Y0_GR + ,CMTOIN,GRWIND + ,ANTVP LOGICAL QPDEV,QPOP,QPVERT,QSAMDV,QASWCH,QAWAIT,QCOLOUR,QIGARC COMMON/M9GRN/ MPDEV,MPSOF,MPHRD + ,LPUNIT, LPDEV + ,IPDEV(MPTOT), IPUNIT(MPTOT), ICONID(MPTOT) + ,QPDEV(MPTOT), QPOP(MPTOT), QPVERT(MPTOT) + ,SZMAX(2,MPTOT), OFSET(2,MPTOT), IPLPOS(2,MPTOT) + ,XOF_GR, YOF_GR, XSC_GR, YSC_GR, X0_GR, Y0_GR + ,CMTOIN, GRWIND(4) C Paper size + ,NPCMD,NSPAPER C PLOTS ARE ON SAME DEVICE AS TEXT + ,QSAMDV C AUTOMATICALLY SWITCH BETWEEN PLOTTING WINDOWS + ,QASWCH C Wait for a before making next plot + ,QAWAIT C Colour is turned on or off + ,QCOLOUR C Use HIGZ or my circle drawing routines 1 ,QIGARC C KNOWN TEKTRONIX DEVICES + ,NTEKDV,ITEKDV(MTEKDV),JTEKDV(MTEKDV) C Normalization Transformation and Workstation Viewport for IGTABL + ,ITNR,ANTVP(4) C Number of pages of an Encapsulated Postscript plot and last device + ,NP113,NDVLST C CHARACTER*10 TGVERS CHARACTER*40 TPDEV,TPSOF,TPHRD CHARACTER*80 TPNAM,TFHRD COMMON/M9GNM/ TGVERS,TPDEV(MPTOT),TPSOF(MPTOT),TPHRD(MPTOT) + ,TPNAM(MPTOT),TFHRD +DECK,mnhpj. +KEEP,MNHPJ. C C COMMON BLOCKS FOR PLOTTING C SUFFIX U MEANS SIZES ETC TO BE USED IN CURRENT PLOT C S MEANS VALUES SET IN MN_SET WITH SET COMMAND C D MEANS DEFAULT SIZES C W ARE THE MARGIN AND OVERALL PLOT SIZE FOR WINDOWING C P ARE THE SIZES FOR EACH PLOT C C REAL SIZEU,SIZES,SIZED + ,AMRGU,AMRGS,AMRGD,WMRGU,WMRGS,WMRGD + ,HSZEU,HSZES,HSZED,WSZEU,WSZES,WSZED + ,ALIMU,ALIMS,ALIMD + ,ALEGU,ALEGS,ALEGD INTEGER ISIZEN,IMRGN,IHSZEN,ILIMN,ILEGN + ,NSYMU,NSYMS,NSYMD, NHATU,NHATS,NHATD, NPATU,NPATS,NPATD + ,NCLRU, NLEGU LOGICAL + QLIMCU c COMMON/M9HPJA/ C OVERALL PLOT SIZE 1 SIZEU(2),SIZES(2),SIZED(2) ,ISIZEN(2) C MARGIN SIZE 1 ,AMRGU(2),AMRGS(2),AMRGD(2),WMRGU(2),WMRGS(2),WMRGD(2),IMRGN(2) C PLOT SIZE 1 ,HSZEU(2),HSZES(2),HSZED(2),WSZEU(2),WSZES(2),WSZED(2),IHSZEN(2) C PLOT LIMITS 1 ,ALIMU(2,3),ALIMS(2,3),ALIMD(2,3) ,QLIMCU(3) ,ILIMN(10) C PLOT SYMBOL hatch and patterns 1 ,NSYMU,NSYMS,NSYMD ,NHATU,NHATS,NHATD ,NPATU,NPATS,NPATD C CLEAR FLAG, LEGO PLOT FLAG and angles 1 ,NCLRU ,NLEGU ,ALEGU(10),ALEGS(10),ALEGD(10) ,ILEGN(10) C REAL TSZEU,TSZES,TSZED INTEGER IZEROU,IZEROS,IZEROD + ,IGRIDU,IGRIDS,IGRIDD + ,IPWNDU,IPWNDS,IPWNDD LOGICAL QZEROU,QZEROS,QZEROD COMMON/M9HPJB/ C TEXT SIZES 1 = TITLE C 2 = SMALL TEXT IN DISPLAY C 3 = HEADER TEXT SIZE C 4 = SYMBOL SIZE C 5 = LINE UNIT SIZE C 6 = PEN WIDTH C 7 = DOT SCALE FACTOR C 8 = Rotation angle C 9 = Footer size + TSZEU(10),TSZES(10),TSZED(10) C DRAW LINE AT X OR Y = 0 AND SYMBOL + ,QZEROU(2),QZEROS(2),QZEROD(2) ,IZEROU(2),IZEROS(2),IZEROD(2) C Draw a grid - 0 means no grid, otherwise it gives the symbol to use C Window numbers + ,IGRIDU(2,3),IGRIDS(2,3),IGRIDD(2,3) + ,IPWNDU(2),IPWNDS(2),IPWNDD(2) C REAL TICKU,TICKS,TICKD + ,SCALU,SCALS,SCALD + ,ALABLU,ALABLS,ALABLD + ,TITLU,TITLS,TITLD + ,TITGU,TITGS,TITGD + ,ATHKU,ATHKS,ATHKD + ,ABINU,ABINS,ABIND INTEGER ITICKN + ,ISMODU,ISMODS,ISMODD, ISMODN + ,ISCALN + ,ILABLU,ILABLS,ILABLD, ILABLN + ,ICOMMN,IDRWN,IPOSN + ,ITITLN + ,ICOLU,ICOLS,ICOLD, ICOLN + ,ITHKN + ,IFNTU,IFNTS,IFNTD, IFNTN + ,INTPU,INTPS,INTPD, INEVU,INEVS,INEVD + ,IBINN LOGICAL + QFRAMU,QFRAMS,QFRAMD + ,QTICKU,QTICKS,QTICKD + ,QSCALU,QSCALS,QSCALD + ,QLABLU,QLABLS,QLABLD + ,QTITLU,QTITLS,QTITLD C COMMON/M9HPJC/ C Frame around plot + QFRAMU(10,3),QFRAMS(10,3),QFRAMD(10,3) C TICK NUMBERS, SPACING, LIMITS AND OPTIONS 1 ,TICKU(10,3),TICKS(10,3),TICKD(10,3) 1 ,QTICKU(10,3),QTICKS(10,3),QTICKD(10,3) ,ITICKN(10) C SCALE POSITION AND TEXT SIZE AND OPTIONS 1 ,ISMODU(3),ISMODS(3),ISMODD(3) ,ISMODN(1) 1 ,SCALU(10,3),SCALS(10,3),SCALD(10,3) 1 ,QSCALU(10,3),QSCALS(10,3),QSCALD(10,3) ,ISCALN(10) C AXIS LABEL, POSITION SIZE AND OPTIONS 1 ,ILABLU(3),ILABLS(3),ILABLD(3) + ,ALABLU(10,3),ALABLS(10,3),ALABLD(10,3) 1 ,QLABLU(10,3),QLABLS(10,3),QLABLD(10,3) ,ILABLN(10) C Type of COMMENT and KEY parameters, drawing parameters C Title position and options 1 ,ICOMMN(12), IDRWN(10,5), IPOSN(10) + ,TITLU(10),TITLS(10),TITLD(10) + ,TITGU(10),TITGS(10),TITGD(10) 1 ,QTITLU(10),QTITLS(10),QTITLD(10) ,ITITLN(10) C COLOUR NUMBER 1 ,ICOLU(20),ICOLS(20),ICOLD(20) ,ICOLN(20) C LINE THICKNESSES 1 ,ATHKU(10),ATHKS(10),ATHKD(10) ,ITHKN(10) C Fonts 1 ,IFNTU(10),IFNTS(10),IFNTD(10) ,IFNTN(10) C Ntuple parameters and event numbers 1 ,INTPU(9),INTPS(9),INTPD(9) ,INEVU(9),INEVS(9),INEVD(9) C Bin shrink factor and offset + ,ABINU(10),ABINS(10),ABIND(10) ,IBINN(10) * * Array elements for colour * integer mcol_all,mcol_sym + ,mcol_bgd,mcol_on,mcol_off,mcol_def,mcol_rep common /m9hpjc2/ mcol_all, mcol_sym + ,mcol_bgd,mcol_on,mcol_off,mcol_def,mcol_rep C CHARACTER*20 1 TSIZEN,TMRGN,THSZEN,TLEGN 1 ,TLIMN,TTICKN,TSMODN,TSCALN,TLABLN,TTITLN,TCOMMN,TDRWN,TPOSN 1 ,TCOLN,TTHKN,TFNTN,TBINN CHARACTER*80 1 TLABLU,TLABLS,TLABLD C COMMON/M9HPJD/ C NAMES FOR OVERALL PICTURE SIZE, MARGIN AND PLOT SIZE 1 TSIZEN(2) ,TMRGN(2) ,THSZEN(2) C NAMES FOR LEGO PLOT ANGLES, LIMITS AND TICK PARAMETERS 1 ,TLEGN(10) ,TLIMN(10) ,TTICKN(10) C NAMES FOR SCALE PARAMETERS, LABEL PARAMETERS AND TITLE PARAMETER 1 ,TSMODN(1) ,TSCALN(10) ,TLABLN(10) ,TTITLN(10) C Names for COMMENT and KEY parameters, drawing parameters C colours and line thicknesses, fonts 1 ,TCOMMN(12), TDRWN(10,5), TPOSN(10) + ,TCOLN(20), TTHKN(10), TFNTN(10) C Bin shrink factor and offset + ,TBINN(10) C TEXT FOR AXIS LABELS 1 ,TLABLU(3), TLABLS(3), TLABLD(3) C INTEGER NHPLT,IPLTIA,IPLTIB,IPLTSY,IPLTHA,IPLTPA,IPLTCO + ,IPLTFL,IPLTCL,IPLTLG INTEGER IZEROP,IGRIDP,IPWNDP + ,ISMODP,ILABLP + ,NPLTCM,IPLTCM,NPLTKY,IPLTKY,LPLTKY + ,INTPP,INEVP + ,ICOLP,IFNTP REAL ALEGP,AMRGP,WMRGP,HSZEP,WSZEP + ,ALIMP + ,TSZEP + ,TICKP,SCALP,ALABLP + ,RPLTCM,RPLTKY,TITLP,TITGP + ,ATHKP,ABINP LOGICAL QLIMCP,QFRAMP,QTICKP,QSCALP,QLABLP,QTITLP,QZEROP C COMMON/M9HPJE/NHPLT C PLOT IDENTIFIERS 1 ,IPLTIA(MHPLT),IPLTIB(MHPLT) C SYMBOL, HATCH, PATTERN, COLOUR + ,IPLTSY(MHPLT) ,IPLTHA(MHPLT) ,IPLTPA(MHPLT) ,IPLTCO(3,MHPLT) C FLAG FOR TYPE, CLEAR SCREEN BEFORE PLOTTING OR NOT, LEGO FLAG 1 ,IPLTFL(MHPLT) ,IPLTCL(MHPLT) ,IPLTLG(MHPLT) C LEGO PLOT ANGLES 1 ,ALEGP(10,MHPLT) C MARGIN SIZE AND PLOT SIZE 1 ,AMRGP(2,MHPLT),WMRGP(2,MHPLT) ,HSZEP(2,MHPLT),WSZEP(2,MHPLT) C PLOT LIMITS 1 ,ALIMP(2,3,MHPLT),QLIMCP(3,MHPLT) C LINE AT X OR Y = 0 WITH SYMBOL + ,QZEROP(2,MHPLT) ,IZEROP(2,MHPLT) C Draw a grid - 0 means no grid, otherwise it gives the symbol to use + ,IGRIDP(2,3,MHPLT) C TEXT SIZES, WINDOW NUMBER, FRAME OR NOT 1 ,TSZEP(10,MHPLT) ,IPWNDP(2,MHPLT) ,QFRAMP(10,3,MHPLT) C TICK NUMBERS, SPACING LIMITS AND OPTIONS 1 ,TICKP(10,3,MHPLT) ,QTICKP(10,3,MHPLT) C SCALE POSITION, TEXT SIZE AND OPTIONS 1 ,ISMODP(3,MHPLT) ,SCALP(10,3,MHPLT) ,QSCALP(10,3,MHPLT) C AXIS LABEL, POSITION, SIZE AND OPTIONS 1 ,ILABLP(3,MHPLT) ,ALABLP(10,3,MHPLT) ,QLABLP(10,3,MHPLT) C COMMENTS 1 ,NPLTCM(MHPLT),IPLTCM(MCPLT,MHPLT),RPLTCM(11,MCPLT,MHPLT) C KEYS 1 ,NPLTKY(MHPLT),IPLTKY(MCPLT,MHPLT),LPLTKY(MCPLT,MHPLT) 1 ,RPLTKY(11,MCPLT,MHPLT) C TITLE POSITION AND OPTIONS 1 ,TITLP(10,MHPLT),TITGP(10,MHPLT),QTITLP(10,MHPLT) + ,INTPP(9,MHPLT),INEVP(9,MHPLT) C Colours, line thicknesses and fonts 1 ,ICOLP(20,MHPLT) ,ATHKP(10,MHPLT), IFNTP(10,MHPLT) C Bin shrink and offset factors + ,ABINP(10,MHPLT) C C LINES, ARROWS ETC C INTEGER NDRWLN,IDRWTP REAL RDRWPM,XDRWPT,YDRWPT COMMON/M9HPJF/ 1 NDRWLN,IDRWTP(MCLIN) ,RDRWPM(20,MCLIN) 1 ,XDRWPT(MCPNT,MCLIN),YDRWPT(MCPNT,MCLIN) C CHARACTER*80 TLABLP,TPLTCM,TPLTKY COMMON/M9HPJG/ C AXIS LABELS 1 TLABLP(3,MHPLT) C COMMENTS 1 ,TPLTCM(MCPLT,MHPLT) C KEYS 1 ,TPLTKY(MCPLT,MHPLT) C INTEGER NSHEAD,NSID,NSFOOT LOGICAL QSTEXT,QTUSER,QTGLBL,QSBOX,QWIND 1 ,QDFIT,QLEGO,QDFUN,QSNULL,QPIPLT,QASCAL,QATRIM C COMMON/M9HPJH/ C SHOW HEADER TEXT IN DISPLAY ON SCREEN 1 QSTEXT C SHOW HEADER TEXT IN DISPLAY ANYWHERE 1 ,NSHEAD C SHOW FILENAME AND HISTOGRAM NUMBERS 1 ,NSID C Show footer in a picture + ,NSFOOT C USE THE USER TITLE OR NOT 1 ,QTUSER C Put on a global title 1 ,QTGLBL C DRAW A BOX AROUND THE WHOLE PLOT 1 ,QSBOX C WINDOWING ON OR OFF 1 ,QWIND C LAST PICTURE WAS A DISPLAY OR NOT 1 ,QDFIT C LAST PICTURE WAS A LEGO PLOT OR NOT 1 ,QLEGO C Last picture was plotting a function 1 ,QDFUN C SHOW POINTS WITH ZERO ERRORS 1 ,QSNULL C Use pi as a symbol in the scale if possible 1 ,QPIPLT C Automatically rescale text sizes when windowing 1 ,QASCAL C Trim off the last number when windowing with zero spacing 1 ,QATRIM C INTEGER IWIND REAL WSPACE COMMON/M9HPJI/ 1 IWIND(2),WSPACE(2) C CHARACTER*80 TITUSR,TSFOOT COMMON/M9HPJJ/TITUSR,TSFOOT C REAL XLO,XHI,YLO,YHI,ZLO,ZHI + ,XPLO,XPHI,YPLO,YPHI + ,ZLLO COMMON/M9HPJK/XLO,XHI,YLO,YHI,ZLO,ZHI + ,XPLO,XPHI,YPLO,YPHI + ,ZLLO C C SIZES FOR THE DISPLAY C REAL FSIZE,PSIZE,FSIZED + ,FHSZE,PHSZE,FHSZED + ,FAMRG,PAMRG,FAMRGD + ,WPSPAC INTEGER NFSID,NPSID + ,IPWIND LOGICAL QFSTIT,QPSTIT,QFWIND,QPWIND COMMON/M9HPJL/FSIZE(2),PSIZE(2),FSIZED(2) + ,FHSZE(2),PHSZE(2),FHSZED(2) + ,FAMRG(2),PAMRG(2),FAMRGD(2) + ,NFSID,NPSID,QFSTIT,QPSTIT,QFWIND,QPWIND + ,IPWIND(2),WPSPAC(2) C C Parameters for IGTABL C INTEGER MIGPAR PARAMETER (MIGPAR = 100) INTEGER NIGPARU,NIGPARS,NIGPARD,NIGPARP + ,LIGOPTU,LIGOPTS,LIGOPTD,LIGOPTP REAL AIGPARU,AIGPARS,AIGPARD,AIGPARP + ,AJGPAR COMMON/M9HPJM/ NIGPARU,NIGPARS,NIGPARD,NIGPARP(MHPLT) + ,AIGPARU(MIGPAR),AIGPARS(MIGPAR),AIGPARD(MIGPAR) + ,AIGPARP(MIGPAR,MHPLT) + ,AJGPAR(MIGPAR) + ,LIGOPTU,LIGOPTS,LIGOPTD,LIGOPTP(MHPLT) C CHARACTER*10 TIGOPTU,TIGOPTS,TIGOPTD,TIGOPTP COMMON/M9HPJN/ TIGOPTU,TIGOPTS,TIGOPTD,TIGOPTP(MHPLT) +DECK,mninf. +KEEP,MNINF. C C Information on the last plot for which MN_HGT was called C INTEGER IDAC,IDBC,NHC,NPTRH,NPTRD,NDIM,NWPPT,NPNT,NBPPT,NWDAT + ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,IDBIN REAL EDENT,EDLO,EDHI,ADLO,ADHI,AMEAN,ASIG,ACONT COMMON/M9INF/IDAC,IDBC,NHC,NPTRH,NPTRD,NDIM,NWPPT,NPNT,NBPPT,NWDAT + ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN(MDIMMX),ADLO(MDIMMX),ADHI(MDIMMX) + ,AMEAN(MDIMMX),ASIG(MDIMMX),ACONT(3**3) +DECK,mnleg. +KEEP,MNLEG. * * Common Information to pass from lego/surface plots to co-ordinate * transformations * REAL COSA,SINA COMMON /M9LEG2/ COSA,SINA +DECK,mnlst. +KEEP,MNLST. C C Last plot for which AMNE,AMNX, etc. have been called C INTEGER NHALST,IDAL,IDBL,NPTRHL,NPTRDL,NPNTL + ,NWPPTL,NDIML,NBPPTL,NWDATL REAL EDENTL,EDLOL,EDHIL logical qcwntpl INTEGER IDBINL REAL ADLOL,ADHIL COMMON/M9LST/NHALST,IDAL,IDBL,NPTRHL,NPTRDL,NPNTL + ,NWPPTL,NDIML,NBPPTL,NWDATL,EDENTL,EDLOL,EDHIL,qcwntpl + ,IDBINL(MDIMMX),ADLOL(MDIMMX),ADHIL(MDIMMX) +DECK,mnluj. +KEEP,MNLUJ. integer irun_lu,ievt_lu,lmod_pi,nres_lu,lmod_1p real xpar_pi,resmas * common/m9luj1/irun_lu,ievt_lu,lmod_pi,xpar_pi 1 ,nres_lu,resmas(13),lmod_1p * character resnam*10 common/m9luj2/ resnam(13) +DECK,mnlun. +KEEP,MNLUN. C INTEGER LUNTTI, LUNTTO, LUNLPT, LUNERR, LUNTMP, LUNPUN C COMMON /M9LUNA/ LUNTTI, LUNTTO, LUNLPT, LUNERR, LUNTMP, LUNPUN C CHARACTER*255 TXTERR,TXTMES COMMON /M9LUNB/ TXTERR,TXTMES +DECK,mnpar. +KEEP,MNSIZ,IF=VMS. PARAMETER (MHSTMX=500,MHSTWD=500 000) PARAMETER (MHBKWD=500 000, MHGZWD=10 000) +KEEP,MNSIZ,IF=UNIX,IF=CLEO. PARAMETER (MHSTMX=2000,MHSTWD=4 000 000) PARAMETER (MHBKWD=4 000 000, MHGZWD=10 000) +KEEP,MNSIZ,IF=UNIX,IF=-CLEO. PARAMETER (MHSTMX=1000,MHSTWD=1 500 000) PARAMETER (MHBKWD=1 500 000, MHGZWD=10 000) +KEEP,MNPAR. C C MHSTMX = Maximum number of plots in memory C MHSTWD = Space in memory for plots C MDIMMX = Maximum number of Ntuple dimensions C MCUTMX = Maximum number of cuts C MHBKWD = Space in memory for HBOOK plots C INTEGER MHSTMX,MHSTWD,MDIMMX,MCUTMX,MNBLOK INTEGER MHBKWD,MHGZWD C +CDE,MNSIZ. C PARAMETER (MDIMMX=1024) PARAMETER (MCUTMX=100) PARAMETER (MNBLOK=1024) C C MINMAX Maximum number of MINUIT parameters C MFITMX Maximum number of plots to fit simultaneously C MFITWD Maximum number of words for plots being fit C MFUNMX Maximum number of function used to fit with C MFNDMX Maximum number of defined functions C MFNPAR Maximum number of parameters in a function C MFNHMX Maximum number of histograms used as functions C MFNPMX Maximum number of points in histograms used as functions C INTEGER MINMAX,MFITMX,MFITWD,MFUNMX,MFNDMX,MFNPAR + ,MFNHMX,MFNPMX PARAMETER (MINMAX=100) PARAMETER (MFITMX=5, MFITWD=50000) PARAMETER (MFUNMX=20, MFNDMX=50, MFNPAR=20) PARAMETER (MFNHMX=10, MFNPMX=1000) C C Parameters for the pictures C C MHPLT Maximum number of plots in a picture C MCPLT Maximum number of comments/keys C MCPNT Maximum number of points/lines in a shape C MCLIN Maximum number of shapes to draw C INTEGER MHPLT,MCPLT,MCPNT,MCLIN PARAMETER(MHPLT= 200,MCPLT= 100,MCPNT=200,MCLIN= 2000) +DECK,mnpij. +KEEP,MNPIJ. REAL PI,TWOPI,PIHALF,RDEG,DRAD PARAMETER (PI = 3.1415927) PARAMETER (TWOPI = 6.2831853) PARAMETER (PIHALF = 1.5707963) PARAMETER (RDEG = 57.29578) PARAMETER (DRAD = 0.0174532) +DECK,mnplt. +KEEP,MNPLT. C C Number of points for drawing functions C INTEGER NFPNT COMMON /M9PLT/ NFPNT +DECK,mnprj. +KEEP,MNPRJ. C Variables needed for passing to parsing when parsing cuts C QPROJ In the process of doing a projection. Ntuple variable names are C allowed when parsing expressions. C NHP The Ntuple number (position in RDAT) LOGICAL QPROJ INTEGER NHP COMMON/M9PRJ/QPROJ,NHP C C Storage of parsed expressions for variables C MVEXPR is maximum number of expressions C MVESUB is the maximum depth of each C LVEXPR is the depth of the parsed expression C IVETYP,IVETP,IVETF,IVETV are arrays for the expressions C TVEXPR is the expression C INTEGER MVEXPR,MVESUB PARAMETER (MVEXPR = 5, MVESUB = 50) C INTEGER NVEXPR,LVEXPR,IVETYP,IVETP,IVETF,IVETV COMMON/MNPR2/NVEXPR,LVEXPR(MVEXPR) + ,IVETYP(MVESUB,MVEXPR),IVETP(MVESUB,MVEXPR) + ,IVETF(MVESUB,MVEXPR),IVETV(10,MVESUB,MVEXPR) C CHARACTER*40 TVEXPR COMMON/MNPR3/TVEXPR(MVEXPR) C INTEGER MWEXPR,MWESUB PARAMETER (MWEXPR = 2, MWESUB = 20) C INTEGER NWEXPR,LWEXPR,IWETYP,IWETP,IWETF,IWETV COMMON/MNPR4/NWEXPR,LWEXPR(MWEXPR) + ,IWETYP(MWESUB,MWEXPR),IWETP(MWESUB,MWEXPR) + ,IWETF(MWESUB,MWEXPR),IWETV(10,MWESUB,MWEXPR) C CHARACTER*40 TWEXPR COMMON/MNPR5/TWEXPR(MWEXPR) +DECK,mnprs. +KEEP,MNPRS. C C MREGUS is the number of user registers C MREGIS is the total number of registers C MVAR0 is the start of variables - 1 C MTCLC is the number of operations in the parser C MNTP0 is the command number for Ntuple variable - 1 C INTEGER MREGUS,MREGIS,MVAR0,MNTP0,MTCLC PARAMETER (MREGUS = 99) PARAMETER (MREGIS = 500) PARAMETER (MVAR0 = 300) PARAMETER (MNTP0 = 1000) PARAMETER (MTCLC = 100) C C MPRSE are the number of standard variable names C INTEGER MPRSE,MDEPI,MVARBL,MCALC,MDEPO,MREG1 INTEGER MOP PARAMETER (MPRSE = 29, MDEPI = 16, MVARBL=200) PARAMETER (MOP = 10) PARAMETER (MCALC = MPRSE + MDEPI + MVARBL + 1) PARAMETER (MDEPO = MDEPI + MVARBL + 1) PARAMETER (MREG1 = MPRSE + 1) C CHARACTER*1 BLANK PARAMETER (BLANK = ' ') C C NVARBL is the number of variables defined C MP_REG is the position of register (R) in DPINAM C MP_NTP is the position of ntuple contents (X) in DPINAM C REAL REGIS COMMON/MNREGI/REGIS(0:MREGIS) C INTEGER NVARBL,MP_REG,MP_NTP COMMON/M9REG1/NVARBL,MP_REG,MP_NTP C C PRSNAM contains intrinsic functions - SIN, COS TAN etc. C DPINAM contains standard variables, R,P,X etc. C VARNAM contains extra variable names C CHARACTER*8 PRSNAM,DPINAM,VARNAM,TDUMMY CHARACTER*8 CLCNAM(MCALC),DEPNAM(MDEPO) COMMON/M9REG2/PRSNAM(MPRSE),DPINAM(MDEPI),VARNAM(MVARBL),TDUMMY EQUIVALENCE(CLCNAM(1),PRSNAM(1)) EQUIVALENCE(DEPNAM(1),DPINAM(1)) C INTEGER ISTYP,ISTP,ISTF,ISTV COMMON/M9PRS1/ISTYP(MTCLC),ISTP(MTCLC),ISTF(MTCLC),ISTV(10,MTCLC) C INTEGER NCOMMA,NREMN,NOP,NBINRY,IOP,LEVEL + ,LSTOP,LSTLEV,LSTFUN,LSTVAR COMMON/M9PRS2/ C # OF COMMAS * NCOMMA, C # OF UNPAIRED OPERANDS * NREMN, C LENGTH OF OPERATOR LIST * NOP, C # BINARY OPERATORS * NBINRY, C CURRENT OPERATOR * IOP, C PARENTHESIS LEVEL * LEVEL, C LIST OF OPERATORS * LSTOP(MOP), C LIST OF OPERATOR LEVELS * LSTLEV(MOP), C LIST OF FUNCTION NUMBERS * LSTFUN(MOP), C LIST OF VARIABLE NUMBERS * LSTVAR(10,MOP) +DECK,mnscr. +KEEP,MNSCR. REAL SCRATCH COMMON/M9SCR/SCRATCH(101000) +DECK,mnseg. +KEEP,MNSEG. C C Common block containing variables associated with segments C LOGICAL QSGOPEN INTEGER NSGOPEN COMMON/M9SEG/QSGOPEN,NSGOPEN +DECK,mntim. +KEEP, MNTIM. C C Parameters needed for plotting vs. time C INTEGER NMTIME,NDTREF,NTMREF COMMON/M9TIM1/ NMTIME,NDTREF,NTMREF C INTEGER MTIM PARAMETER (MTIM = 5) CHARACTER*10 TIMNAM COMMON/M9TIM2/ TIMNAM(MTIM) +DECK,mntmp. +KEEP,MNTMP. INTEGER MXUBIN PARAMETER (MXUBIN=10) LOGICAL QMNOPN,QMNLOC INTEGER LUNMNU COMMON/M9TMP1/QMNOPN,QMNLOC,LUNMNU INTEGER NUBIN,IDTA,IDTB,IPTR,IDWR REAL RTMP COMMON/M9TMP2/NUBIN,IDTA(MXUBIN),IDTB(MXUBIN),IPTR(MXUBIN) 1 ,IDWR(MXUBIN) 1 ,RTMP(MNBLOK+MDIMMX,MXUBIN) CHARACTER*32 TNDEF,TNNTP COMMON/M9TMP3/TNDEF(MDIMMX),TNNTP(MDIMMX) +DECK,mntpl. +KEEP,MNTPL. * * Contains information on the Ntuple for the COMIS routine called when * scanning it. * INTEGER IDNEVT REAL VIDN1,VIDN2,VIDN3,RVAL COMMON/PAWIDN/IDNEVT,VIDN1,VIDN2,VIDN3,RVAL(MDIMMX) * INTEGER ID,NVAR REAL RLIM COMMON/MNTPL1/ID,NVAR,RLIM(2*MDIMMX) * CHARACTER*80 TITLE CHARACTER*32 TAGS COMMON/MNTPL2/TITLE,TAGS(MDIMMX) +DECK,mntyq. +KEEP,MNTYQ. INTEGER MOPR,MOPRBF,MTCMD,MTDEP,MTPARM,MFORDP,MALIAS,MXIFLV PARAMETER (MOPR=150,MOPRBF=1500) PARAMETER (MTCMD=100,MTDEP=10,MTPARM=9,MFORDP=10,MALIAS=100) PARAMETER (MXIFLV = 20) C C QECHO Echo commands to the terminal when reading from a file C QALOG Log all commands in a file MN_LOG.LOG C QMANUAL Add ## after the prompt when echoing, which is used to C recognize a prompt when making demonstration files C LOGICAL QTREAD,QTLOOP,QECHO,QDSKIP,QALOG,QALIAS,QMANUAL INTEGER NTCMD,NTDEP,LUNCMD,LUNJNK,LUNLOG 1 ,IUNCMD,IUNREC 1 ,NPRCMD,NPMCMD,IPMCMD 1 ,IP1CMD,IP2CMD,NOPR,IOPRP1,IOPRP2 1 ,NFORDP,IFORBG,IFORVL,IFORMX,IFORST + ,NALIAS,LALCMD COMMON /M9TYQ1/ QTREAD,QTLOOP,NTCMD,NTDEP,LUNCMD,LUNJNK,LUNLOG 1 ,IUNCMD(MTDEP),IUNREC(MTDEP) 1 ,NPRCMD,NPMCMD(MTDEP),IPMCMD(MTPARM,MTDEP) 2 ,IP1CMD(MTDEP),IP2CMD(MTDEP) 3 ,NOPR,IOPRP1(MOPR),IOPRP2(MOPR) 4 ,NFORDP(MTDEP),IFORBG(MFORDP,MTDEP),IFORVL(MFORDP,MTDEP) 4 ,IFORMX(MFORDP,MTDEP),IFORST(MFORDP,MTDEP) + ,QECHO,QDSKIP,QALOG,QMANUAL + ,QALIAS,NALIAS,LALCMD(MALIAS) C C Variables used for IF conditional block manipulation. C LOGICAL QIF, QCOND, QCONDI INTEGER IIFLV, IFIIFL COMMON /M9TYQ3/ QIF(MTDEP) + ,QCOND(MXIFLV,MTDEP), QCONDI(MXIFLV,MTDEP) + ,IIFLV(MTDEP), IFIIFL(MTDEP) C CHARACTER*80 TPRCMD CHARACTER*255 TXTCMD,TOPRBF,STRING CHARACTER*80 TPMCMD CHARACTER*10 OPRNAM CHARACTER*1 TFORNM CHARACTER*20 TALIAS CHARACTER*80 TALCMD COMMON /M9TYQ2/ TPRCMD,TXTCMD(MTCMD),TPMCMD(MTPARM,MTDEP) 1 ,STRING 2 ,OPRNAM(MOPR),TOPRBF(MOPRBF) 3 ,TFORNM(MFORDP,MTDEP) + ,TALIAS(MALIAS),TALCMD(MALIAS) C C Stack of commands to execute when starting MINUIT C INTEGER NFSTKD,NFSTKU COMMON /M9TYQ4/ NFSTKD,NFSTKU C INTEGER MFSTK PARAMETER (MFSTK = 10) CHARACTER*80 TFSTK COMMON /M9TYQ5/ TFSTK(MFSTK) +DECK,mnusr. +KEEP,MNUSR. C C COMMON BLOCK WITH ORTHOGONALITY LIMITS AND BIN WIDTHS C FOR THE PLOT YOU ARE FITTING C XMINNM,XMAXNM are the orthogonality limits for the x axis C YMINNM,YMAXNM are the orthogonality limits for the y axis C XBINNM is the bin width for the x axis C YBINNM is the bin width for the y axis C REAL XMINNM,XMAXNM,XBINNM,YMINNM,YMAXNM,YBINNM COMMON/MNUSR/XMINNM,XMAXNM,XBINNM,YMINNM,YMAXNM,YBINNM +DECK,quest. +KEEP,QUEST. INTEGER IQUEST COMMON/QUEST/IQUEST(100) REAL RQUEST(100) EQUIVALENCE(IQUEST(1),RQUEST(1)) +DECK,slate. +KEEP,SLATE. * * Slate common block used by CHPACK routines * integer nd,ne,nf,ng,num,dummy COMMON /SLATE/ ND,NE,NF,NG,NUM(2),DUMMY(34) +DECK,mntimd. +KEEP, MNTIMD. INTEGER MXSEC,MXMIN,MXHOU,MXDAY,MXMON PARAMETER (MXSEC=61, MXMIN=61, MXHOU=25, MXDAY=32, MXMON=13) integer mdayy parameter (mdayy = 100) INTEGER IDAYY(mdayy), IDAYM(12,2) SAVE IDAYY, IDAYM DATA IDAYY / + 366, 731, 1096, 1461, 1827, + 2192, 2557, 2922, 3288, 3653, + 4018, 4383, 4749, 5114, 5479, + 5844, 6210, 6575, 6940, 7305, + 7671, 8036, 8401, 8766, 9132, + 9497, 9862,10227,10593,10958, + 11323,11688,12054,12419,12784, + 13149,13515,13880,14245,14610, + 14976,15341,15706,16071,16437, + 16802,17167,17532,17898,18263, + 18628,18993,19359,19724,20089, + 20454,20820,21185,21550,21915, + 22281,22646,23011,23376,23742, + 24107,24472,24837,25203,25568, + 25933,26298,26664,27029,27394, + 27759,28125,28490,28855,29220, + 29586,29951,30316,30681,31047, + 31412,31777,32142,32508,32873, + 33238,33603,33969,34334,34699, + 35064,35430,35795,36160,36525/ DATA IDAYM / 0, 31, 59, 90, 120, 151, 181, 212, 243, 1 273, 304, 334, 0, 31, 60, 91, 121, 152, 2 182, 213, 244, 274, 305, 335/ +DECK,mnpltd. +KEEP,MNPLTD. C C Tick and scale limit parameters C INTEGER NGSCAL PARAMETER (NGSCAL=19) REAL YGSCAL(NGSCAL) INTEGER IGSCAL(NGSCAL),ITSCAL(NGSCAL),IBSCAL(NGSCAL) DATA YGSCAL/ 0.,10.,12.,15.,16.,18.,20.,24.,25.,30. 1 ,36.,40.,50.,60.,70.,75.,80.,90.,100./ DATA IGSCAL/ 0, 10, 12, 15, 16, 18, 20, 24, 25, 30 1 ,36, 40, 50, 60, 70, 75, 80, 90, 100/ DATA ITSCAL/ 0, 20, 12, 15, 16, 16, 20, 24, 25, 15 1 ,16, 16, 25, 12, 14, 15, 16, 18, 20/ DATA IBSCAL/ 0, 5, 2, 5, 4, 4, 5, 4, 5, 5 1 , 4, 4, 5, 2, 4, 4, 4, 4, 5/ +DECK,MNCHAR. +KEEP,MNCHAR. * * Special characters used in making the manual * CHARACTER*1 TAB,BSL COMMON /M9CHAR/ TAB,BSL +PATCH,HKUIP,T=XCC, INCL. +DECK,hkuip_93d,IF=93D. +KEEP,KHAIX370 #ifndef AIX370 # define AIX370 #endif +KEEP,KHAPOFTN #ifndef APOLLO_FTN # define APOLLO_FTN #endif +KEEP,KHIBMVM #ifndef IBMVM # define IBMVM #endif +KEEP,KHIBMMVS #ifndef IBMMVS # define IBMMVS #endif +KEEP,KHNEWLIB #ifndef NEWLIB # define NEWLIB #endif +KEEP,KUIP_H /* kuip.h: system dependent defines */ /* update version if structures have changed */ #define KUIP_VERSION 921023 /* identify system if not possible from preprocessor defines */ +SEQ,KHAIX370,IF=AIX370 +SEQ,KHAPOFTN,IF=APOFTN +SEQ,KHIBMVM ,IF=IBMVM +SEQ,KHIBMMVS,IF=IBMMVS +SEQ,KHNEWLIB,IF=NEWLIB #ifdef AIX370 # define MACHINE_NAME "IBMAIX" # define UNIX # define F77_EXTERN_INDIRECT #endif #if defined(apollo) || defined(__apollo) # define MACHINE_NAME "APOLLO" # define APOLLO # define UNIX # include # include # include # include # include # include # ifdef APOLLO_FTN /* using /com/ftn instead of /bin/f77 */ # define F77_CHAR_LEN_IND short # define F77_EXTERN_LOWERCASE # endif # define F77_EXTERN_INDIRECT # define F77_COMMON(name) name __attribute((__section(name))) # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_DIRENT_H # define TERMIO_BSD /* for getline we must compile under bsd4.3 */ #endif #if defined(__convexc__) # define CONVEX # define MACHINE_NAME "CONVEX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define MATCH_RE_COMP /* use re_comp/re_exec */ # define F77_BLOCK(name,NAME) F77_NAME(ConCat(_,name),NAME) #endif #ifdef CRAY # define MACHINE_NAME "CRAY" # define UNIX # include # define F77_EXTERN_UPPERCASE # define F77_CHAR_DSC_CRAY # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_EDIT_SERVER #endif #if defined(hpux) || defined(__hpux) # define MACHINE_NAME "HPUX" # define HPUX # define UNIX # ifdef hpux /* cc -Ac */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # ifndef _HPUX_SOURCE # define _HPUX_SOURCE # endif # define FATAL_SIGFPE /* needs f77 +T and ON REAL UNDERFLOW IGNORE */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_STRRSTR #endif #ifdef _IBMR2 # define IBMRT # define MACHINE_NAME "IBMRT" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #ifdef IBMVM # define ARG_STYLE_CMS # define MACHINE_NAME "IBM" # define OS_NAME "VM" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBMMVS # define MACHINE_NAME "IBMMVS" # define OS_NAME "MVS" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBM370 # define F77_CHAR_LEN_IND int /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_EXTERN_INDIRECT # define F77_EXTERN_UPPERCASE # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_V7 #endif #ifdef linux # define LINUX # define MACHINE_NAME "LINUX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #ifdef MSDOS # define MACHINE_NAME "MSDOS" # define UNIX # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define SIGNAL_V7 #endif #ifdef WIN32 # define WINNT # define MACHINE_NAME "WNT" # define UNIX # define MSDOS # include # include # include # define text_mode__() # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define NO_UNISTD_H # define SIGNAL_V7 #endif #ifdef NeXT # define MACHINE_NAME "NEXT" # define UNIX # define getcwd(path,maxlen) getwd(path) # define F77_BLOCK(lc,uc) lc # define F77_EXTERN_INDIRECT /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_XXXX_USE_LEN(x) ,286716 /* don't know if value matters */ # define HAVE_MEMMOVE # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define NO_DIRENT_H # define NO_UNISTD_H # define SIGNAL_BSD # define TERMIO_BSD #endif #ifdef __osf__ # define UNIX # ifdef __alpha # define ALPHA # define MACHINE_NAME "ALPHA" # endif # define const /* wrong prototype for strdup() in string.h */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #if defined(sgi) || defined(__sgi) # define MACHINE_NAME "SGI" # define SGI # define UNIX # ifndef __sgi /* Irix 3 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #if defined(sun) || defined(__sun) # define MACHINE_NAME "SUN" # define SUN # define UNIX # ifndef __STDC__ /* cc vs. acc */ # define NO_ANSI_CPP # define NO_PROTOTYPES # else # define const /* wrong prototype for strdup() in string.h */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_VFORK # include # define MATCH_RE_COMP /* use re_comp/re_exec */ #endif #if defined(ultrix) || defined(__ultrix) # define MACHINE_NAME "DECS" # define ULTRIX # define UNIX # ifndef __ultrix /* cc vs. c89 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_VFORK # define TERMIO_BSD #endif #ifdef vms # define OS_NAME "VMS" # ifdef __ALPHA # define ALPHA # define MACHINE_NAME "ALPHA" # pragma extern_model common_block # include /* inside descrip.h on VAX */ # else # define MACHINE_NAME "VAX" # define NO_ANSI_CPP # define raise gsignal /* raise() not in library ? */ # endif # include # include # include /* lib$... prototypes */ # include # include # include # include # include # include # include # include /* sys$... prototypes */ # include # include # include # ifndef R_OK /* no access() modes in unixio.h on VAX/VMS */ # define F_OK 0 # define X_OK 1 # define W_OK 2 # define R_OK 4 # endif # define ARG_STYLE_VMS # define F77_CHAR_DSC_VMS # define F77_EXTERN_LOWERCASE # define HAVE_MEMMOVE # define HAVE_STAT_H # define HAVE_VFORK /* actually have only vfork */ # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_BSD # define sigmask(sig) (1L << (sig-1)) /* should be in signal.h */ # define USE_EDIT_SERVER /* only for TPU/DISPLAY=MOTIF */ #endif /* vms */ #include #include #include #ifndef NO_FCNTL_H #include #endif #include /* contains strtod() and strtol() on some systems */ #include #include #include #include #include #include #ifndef NO_UNISTD_H #include #endif #ifndef HAVE_VFORK # define vfork fork #endif #ifdef UNIX # define OS_NAME "UNIX" # include # include # ifndef NO_SYS_TIME_H # include /* struct timeval */ # endif # ifndef MSDOS # if !defined(TERMIO_BSD) && !defined(TERMIO_SYSV) # define TERMIO_POSIX # endif # include # ifndef NO_DIRENT_H /* POSIX opendir() */ # include # else /* BSD opendir() */ # include /* plus */ # define dirent direct /* struct dirent... */ # ifndef S_IRUSR # define S_IRUSR (S_IREAD) /* read permission, owner */ # define S_IWUSR (S_IWRITE) /* write permission, owner */ # define S_IXUSR (S_IEXEC) /* execute/search permission, owner */ # endif # endif # endif # define HAVE_STAT_H # ifndef NO_EDIT_SERVER # define USE_EDIT_SERVER # ifndef F_LOCK /* BSD file locking */ # include # define lockf(fd,op,offs) flock(fd,op) # define F_LOCK LOCK_EX # define F_ULOCK LOCK_UN # endif # endif #endif #ifdef SUN # ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 1000000 /* missing in time.h */ # define difftime(t1,t0) ((double)(t1-t0)) # define raise(sig) kill(getpid(),sig) # endif #endif #ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 100 /* missing in VAX/VMS time.h */ #endif #ifdef HAVE_STAT_H # define KmTimeStamp struct stat # define get_stamp(path,stamp) stat(path,stamp) # define cmp_stamp(stamp1,stamp2) ((stamp2)->st_mtime == (stamp1)->st_mtime) #endif #ifndef KmTimeStamp # define KmTimeStamp int # define get_stamp(path,stamp) 0 # define cmp_stamp(stamp1,stamp2) 0 #endif #ifdef MATCH_RE_COMP extern char *re_comp(); extern int re_exec(); #else extern char *regcmp(); extern char *regex(); #endif /* command line arguments recognized by KUARGS */ #if !defined(ARG_STYLE_CMS) && !defined(ARG_STYLE_VMS) # define ARG_STYLE_UNIX #endif #ifndef MACHINE_NAME # define MACHINE_NAME "UNKNOWN" /* value returned by $MACHINE */ #endif #ifndef OS_NAME # define OS_NAME "UNKNOWN" /* value returned by $OS */ #endif /* #define EXTERN must be in one routine to allocate space for globals */ #ifndef EXTERN # define EXTERN extern #endif /* #define STATIC extern if debugger does not see static functions */ #ifndef STATIC # define STATIC static #endif #if defined(__GNUC__) || defined(__STDC__) # ifdef NO_ANSI_CPP # undef NO_ANSI_CPP # endif # ifdef NO_PROTOTYPES # undef NO_PROTOTYPES # endif #endif /* * Preprocessor syntax for token concatenation */ #ifndef NO_ANSI_CPP # define ConCat(con,cat) con##cat #else # define ConCat(con,cat) con/**/cat #endif /* * Prototyping for C functions */ #ifndef NO_PROTOTYPES # define C_PROTO_0(name) \ name(void) # define C_PROTO_1(name,arg1) \ name(arg1) # define C_PROTO_2(name,arg1,arg2) \ name(arg1,arg2) # define C_PROTO_3(name,arg1,arg2,arg3) \ name(arg1,arg2,arg3) # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name(arg1,arg2,arg3,arg4) # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name(arg1,arg2,arg3,arg4,arg5) # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name(arg1,arg2,arg3,arg4,arg5,arg6) # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7) # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) # define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) # define C_PROTO_17(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name(t1 p1) # define C_DECL_2(name,t1,p1,t2,p2) \ name(t1 p1,t2 p2) # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name(t1 p1,t2 p2,t3 p3) # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name(t1 p1,t2 p2,t3 p3,t4 p4) # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5) # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6) # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7) # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8) # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,t9 p9) # define C_DECL_13(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,\ t9,p9,t10,p10,t11,p11,t12,p12,t13,p13) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,\ t9 p9,t10 p10,t11 p11,t12 p12,t13 p13) #else # define const # define C_PROTO_0(name) \ name() # define C_PROTO_1(name,arg1) \ name() # define C_PROTO_2(name,arg1,arg2) \ name() # define C_PROTO_3(name,arg1,arg2,arg3) \ name() # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name() # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name() # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name() # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name() # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name() # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name() # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name() # define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) \ name() # define C_PROTO_17(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) \ name() # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name( p1) \ t1 p1; # define C_DECL_2(name,t1,p1,t2,p2) \ name( p1, p2) \ t1 p1;t2 p2; # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name( p1, p2, p3) \ t1 p1;t2 p2;t3 p3; # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name( p1, p2, p3, p4) \ t1 p1;t2 p2;t3 p3;t4 p4; # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name( p1, p2, p3, p4, p5) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5; # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name( p1, p2, p3, p4, p5, p6) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6; # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name( p1, p2, p3, p4, p5, p6, p7) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7; # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name( p1, p2, p3, p4, p5, p6, p7, p8) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8; # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name( p1, p2, p3, p4, p5, p6, p7, p8, p9)\ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8;t9 p9; # define C_DECL_13(name,A,a,B,b,C,c,D,d,E,e,F,f,G,g,H,h,I,i,J,j,K,k,L,l,M,m)\ name( a, b, c, d, e, f, g, h, i, j, k, l, m)\ A a;B b;C c;D d;E e;F f;G g;H h;I i;J j;K k;L l;M m; #endif typedef int IntFunc(); typedef char* CharFunc(); typedef char** pCharFunc(); #define KUMAC_UNWIND -30041961 /* error status to quit macro execution */ /* * convenience functions from kkern.c */ extern C_PROTO_2(char* fexpand, const char*, const char*); extern C_PROTO_1(char* fsymlink, const char*); extern C_PROTO_3(char* fsearch, const char*, const char*, const char*); extern C_PROTO_2(char* fstrdup, const char*, size_t); extern C_PROTO_2(char* fstr0dup, const char*, size_t); extern C_PROTO_2(char* fstrtrim, const char*, size_t); extern C_PROTO_2(char* fstr0trim, const char*, size_t); extern C_PROTO_2(size_t fstrlen, const char*, size_t); extern C_PROTO_3(size_t fstrset, char*, size_t, const char*); extern C_PROTO_2(double fstrtod, char*, char**); extern C_PROTO_2(int fstrtoi, char*, char**); extern C_PROTO_3(char* fstrvec, char**, int, int*); #ifndef HAVE_MEMMOVE extern C_PROTO_3(void* memmove, void*, const void*, size_t); #endif #ifndef HAVE_STRCASECMP extern C_PROTO_2(int strcasecmp, const char*, const char*); extern C_PROTO_3(int strncasecmp, const char*, const char*, size_t); #endif #ifndef HAVE_STRDUP extern C_PROTO_1(char* strdup, const char*); #endif #ifndef HAVE_STRRSTR extern C_PROTO_2(char* strrstr, const char*, const char*); #endif extern C_PROTO_1(char* str0dup, const char*); extern C_PROTO_2(char* str2dup, const char*, const char*); extern C_PROTO_3(char* str3dup, const char*, const char*, const char*); extern C_PROTO_4(char* str4dup, const char*, const char*, const char*, const char*); extern C_PROTO_5(char* str5dup, const char*, const char*, const char*, const char*, const char*); extern C_PROTO_2(char* strndup, const char*, int); extern C_PROTO_2(char* mstrcat, char*, const char*); extern C_PROTO_3(char* mstr2cat, char*, const char*, const char*); extern C_PROTO_4(char* mstr3cat, char*, const char*, const char*, const char*); extern C_PROTO_5(char* mstr4cat, char*, const char*, const char*, const char*, const char*); extern C_PROTO_3(char* mstrncat, char*, const char*, int); extern C_PROTO_3(char* mstrccat, char*, int, int); extern C_PROTO_2(char* mstricat, char*, int); extern C_PROTO_2(int mstrlen, char**, int); extern C_PROTO_1(char* strqtok, char*); extern C_PROTO_1(char* strlower, char*); extern C_PROTO_1(char* strupper, char*); extern C_PROTO_2(char* strfromd, double, int); extern C_PROTO_2(char* strfromi, int, int); /* * C-interface functions */ extern C_PROTO_0(char* k_getar); extern C_PROTO_2(void k_setar, int, char**); extern C_PROTO_0(char* k_userid); extern C_PROTO_0(void ku_alfa); extern C_PROTO_2(char* ku_appl, int*, int*); extern C_PROTO_1(void ku_cmdl, char*); extern C_PROTO_2(int ku_edit, char*, int); extern C_PROTO_1(char* ku_eval, char*); extern C_PROTO_1(int ku_exec, char*); extern C_PROTO_1(int ku_exel, char*); extern C_PROTO_0(char* ku_getc); extern C_PROTO_0(char* ku_gete); extern C_PROTO_0(char* ku_getf); extern C_PROTO_0(int ku_geti); extern C_PROTO_0(char* ku_getl); extern C_PROTO_0(char* ku_getq); extern C_PROTO_0(double ku_getr); extern C_PROTO_0(char* ku_gets); extern C_PROTO_1(char* ku_fcase, char*); extern C_PROTO_2(char* ku_home, char*, char*); extern C_PROTO_1(int ku_intr, int); extern C_PROTO_1(void ku_last, char*); extern C_PROTO_2(int ku_more, char*, char*); extern C_PROTO_0(int ku_npar); extern C_PROTO_2(void ku_pad, char*, int); extern C_PROTO_0(char* ku_path); extern C_PROTO_2(void ku_piaf, int, void(*)()); extern C_PROTO_2(char* ku_proc, char*, char*); extern C_PROTO_2(char* ku_prof, char*, char*); extern C_PROTO_2(int ku_proi, char*, int); extern C_PROTO_1(char* ku_prop, char*); extern C_PROTO_2(double ku_pror, char*, double); extern C_PROTO_2(char* ku_pros, char*, char*); extern C_PROTO_0(char** ku_qenv); extern C_PROTO_1(char* ku_qexe, char*); extern C_PROTO_2(int ku_sapp, char*, char*); extern C_PROTO_0(void ku_shut); extern C_PROTO_1(int ku_stop, int); extern C_PROTO_2(void ku_time, time_t, clock_t); extern C_PROTO_2(void ku_trap, int, int); extern C_PROTO_1(int ku_vqaddr, char*); extern C_PROTO_1(int ku_vtype, char*); extern C_PROTO_2(int ku_vvalue, char*, double*); extern C_PROTO_0(void ku_whag); extern C_PROTO_1(void ku_what, void(*)()); extern C_PROTO_1(char* getline, char*); extern C_PROTO_2(void gl_config, char*, int); extern C_PROTO_1(void gl_histadd, char*); extern C_PROTO_1(void gl_setwidth, int); extern C_PROTO_2(char* input_line, char*, int); extern C_PROTO_0(void leave_kuip); extern C_PROTO_2(int len_alias, char*, int); extern C_PROTO_1(int len_sysfun, char*); extern C_PROTO_1(int len_vector, char*); extern C_PROTO_2(char* quote_string, char*, int); extern C_PROTO_0(void reset_break); extern C_PROTO_1(void signal_handler, int ); extern C_PROTO_2(int vms_signal_handler, void*, void* ); +KEEP,KFOR_H /* kfor.h: Fortran-C interface */ /* * Fortran data types */ typedef int INTEGER; typedef int LOGICAL; typedef float REAL; typedef double DBLPREC; typedef INTEGER INT_FUNCTION(); typedef INT_FUNCTION *INT_FUNCPTR; typedef void (*SUBRPTR)(); typedef void SUBROUTINE(); #ifdef IBM370 #pragma linkage(SUBROUTINE,FORTRAN) #pragma linkage(INT_FUNCTION,FORTRAN) #pragma map(__CTOF,"@@CTOF") extern INTEGER __CTOF( INT_FUNCPTR, ... ); #endif typedef union _EQUIV_INT_REAL { INTEGER i; LOGICAL l; REAL r; } EQUIV_INT_REAL; /* * Mapping of C-routine name for Fortran CALL SUB * * #define F77_EXTERN_LOWERCASE ==> void sub() * #define F77_EXTERN_UPPERCASE ==> void SUB() * otherwise ==> void sub_() */ #ifdef F77_EXTERN_UPPERCASE # define F77_NAME(name,NAME) NAME #else # ifdef F77_EXTERN_LOWERCASE # define F77_NAME(name,NAME) name # else # define F77_NAME(name,NAME) ConCat(name,_) # endif #endif #ifndef F77_BLOCK # define F77_BLOCK(name,NAME) F77_NAME(name,NAME) #endif #ifndef F77_COMMON # define F77_COMMON(name) name #endif /* * Routine address in CALL SUB(FUN) ; EXTERNAL FUN * * #define F77_EXTERN_INDIRECT ==> void (**fun)(); * otherwise ==> void (*fun)(); */ #ifdef F77_EXTERN_INDIRECT # define F77_EXTERN_ARG(e) ConCat(e,_dsc) # define F77_EXTERN_DCL(e) SUBROUTINE **ConCat(e,_dsc); # define F77_EXTERN_DEF(e) SUBROUTINE *e = *ConCat(e,_dsc); #else # define F77_EXTERN_ARG(e) e # define F77_EXTERN_DCL(e) SUBROUTINE *e; # define F77_EXTERN_DEF(e) #endif #define F77_EXTERN2ARG(e1,e2) F77_EXTERN_ARG(e1),F77_EXTERN_ARG(e2) #define F77_EXTERN2DCL(e1,e2) F77_EXTERN_DCL(e1) F77_EXTERN_DCL(e2) #define F77_EXTERN2DEF(e1,e2) F77_EXTERN_DEF(e1) F77_EXTERN_DEF(e2) #define F77_EXTERN3ARG(e1,e2,e3) F77_EXTERN_ARG(e1),F77_EXTERN2ARG(e2,e3) #define F77_EXTERN3DCL(e1,e2,e3) F77_EXTERN_DCL(e1) F77_EXTERN2DCL(e2,e3) #define F77_EXTERN3DEF(e1,e2,e3) F77_EXTERN_DEF(e1) F77_EXTERN2DEF(e2,e3) #define F77_EXTERN4ARG(e1,e2,e3,e4) F77_EXTERN_ARG(e1),F77_EXTERN3ARG(e2,e3,e4) #define F77_EXTERN4DCL(e1,e2,e3,e4) F77_EXTERN_DCL(e1) F77_EXTERN3DCL(e2,e3,e4) #define F77_EXTERN4DEF(e1,e2,e3,e4) F77_EXTERN_DEF(e1) F77_EXTERN3DEF(e2,e3,e4) /* * Access to Fortran CHARACTER arguments */ #ifdef F77_CHAR_DSC_VMS /* VMS string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_dsc) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) struct dsc$descriptor_s *ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_dsc)->dsc$a_pointer; \ int ConCat(len_,s) = ConCat(s,_dsc)->dsc$w_length; # define F77_CHAR_DEF_DSC(s,p,l) struct dsc$descriptor_s ConCat(s,__dsc); # define F77_CHAR_ASS_DSC(s,p,l) ConCat(s,__dsc).dsc$w_length = l; \ ConCat(s,__dsc).dsc$b_dtype = DSC$K_DTYPE_T;\ ConCat(s,__dsc).dsc$b_class = DSC$K_CLASS_S;\ ConCat(s,__dsc).dsc$a_pointer = p; # define F77_CHAR_USE_PTR(s,p,l) &ConCat(s,__dsc) # define F77_CHAR_USE_LEN(s,p,l) #endif #ifdef F77_CHAR_DSC_CRAY /* Cray string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_dsc) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) _fcd ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = _fcdtocp(ConCat(s,_dsc)); \ int ConCat(len_,s) = _fcdlen(ConCat(s,_dsc)); # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) _cptofcd(p,l) # define F77_CHAR_USE_LEN(s,p,l) #endif #ifdef F77_CHAR_LEN_IND /* string length passed by reference */ /* * The IBM C/370 compiler passes the Fortran CHARACTER pointer directly * instead of making a private copy. Therefore we have to do the copy * char *s = s_ptr ourself in case the routine uses s as local variable. */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) , ConCat(s,_dsc) # define F77_CHAR_ARG_DCL(s) char *ConCat(s,_ptr); \ F77_CHAR_LEN_IND *ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr); \ int ConCat(len_,s) = *ConCat(s,_dsc); # define F77_CHAR_DEF_DSC(s,p,l) F77_CHAR_LEN_IND ConCat(s,__dsc) = l; # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , &ConCat(s,__dsc) #endif #ifndef F77_CHAR_ARG_PTR /* string length passed by value */ # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(len_,s) # define F77_CHAR_ARG_DCL(s) char *s; int ConCat(len_,s); # define F77_CHAR_ARG_DEF(s) # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , l #endif #ifndef F77_XXXX_ARG_LEN /* length argument of non-CHARACTER arguments */ # define F77_XXXX_ARG_LEN(x) /* nil */ # define F77_XXXX_USE_LEN(x) /* nil */ #endif /* * Fortran-calls-C interface * * To define a C function called by Fortran CALL SUB(A,B,C): * * #define Sub F77_NAME(sub,SUB) * #pragma linkage(SUB,FORTRAN) // for IBM C/370 compiler * * F77_ENTRY_xyz(Sub,a,b,c) // opening { contained in macro * // body ... * } * * Each character in xyz declares the type of the corresponding parameter: * * C = CHARACTER * D = DOUBLE PRECISION * E = EXTERNAL * I = INTEGER * L = LOGICAL * R = REAL * X = COMPLEX * * If a parameter PAR is declared as CHARACTER the macro defines: * * char *PAR; // pointer to string (not terminated by \0 !!!) * int len_PAR; // length of string as defined by Fortran's LEN(PAR) * * The name PAR_dsc is reserved for internal use. * * Note: The function body follows the F77_ENTRY_... macro call directly. * The opening { is generated by the macro. */ #define F77_CHAR_ARG2PTR(c1,c2) \ F77_CHAR_ARG_PTR(c1),F77_CHAR_ARG_PTR(c2) #define F77_CHAR_ARG2LEN(c1,c2) \ F77_CHAR_ARG_LEN(c1) F77_CHAR_ARG_LEN(c2) #define F77_XXXX_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(c1) F77_XXXX_ARG_LEN(c2) #define F77_CHAR_ARG2DCL(c1,c2) \ F77_CHAR_ARG_DCL(c1) F77_CHAR_ARG_DCL(c2) #define F77_CHAR_ARG2DEF(c1,c2) \ F77_CHAR_ARG_DEF(c1) F77_CHAR_ARG_DEF(c2) #define F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG2PTR(c1,c2),F77_CHAR_ARG_PTR(c3) #define F77_CHAR_ARG3LEN(c1,c2,c3) \ F77_CHAR_ARG2LEN(c1,c2) F77_CHAR_ARG_LEN(c3) #define F77_XXXX_ARG3LEN(c1,c2,c3) \ F77_XXXX_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(c3) #define F77_CHAR_ARG3DCL(c1,c2,c3) \ F77_CHAR_ARG2DCL(c1,c2) F77_CHAR_ARG_DCL(c3) #define F77_CHAR_ARG3DEF(c1,c2,c3) \ F77_CHAR_ARG2DEF(c1,c2) F77_CHAR_ARG_DEF(c3) #define F77_CHAR_ARG4PTR(c1,c2,c3,c4) \ F77_CHAR_ARG3PTR(c1,c2,c3),F77_CHAR_ARG_PTR(c4) #define F77_CHAR_ARG4LEN(c1,c2,c3,c4) \ F77_CHAR_ARG3LEN(c1,c2,c3) F77_CHAR_ARG_LEN(c4) #define F77_XXXX_ARG4LEN(c1,c2,c3,c4) \ F77_XXXX_ARG3LEN(c1,c2,c3) F77_XXXX_ARG_LEN(c4) #define F77_CHAR_ARG4DCL(c1,c2,c3,c4) \ F77_CHAR_ARG3DCL(c1,c2,c3) F77_CHAR_ARG_DCL(c4) #define F77_CHAR_ARG4DEF(c1,c2,c3,c4) \ F77_CHAR_ARG3DEF(c1,c2,c3) F77_CHAR_ARG_DEF(c4) #define F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_CHAR_ARG_PTR(c5) #define F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) F77_CHAR_ARG_LEN(c5) #define F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_CHAR_ARG_DCL(c5) #define F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_CHAR_ARG_DEF(c5) #define F77_ENTRY_C(name,c1) \ name( F77_CHAR_ARG_PTR(c1) F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CC(name,c1,c2) \ name( F77_CHAR_ARG2PTR(c1,c2) F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_C3(name,c1,c2,c3) \ name( F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG3LEN(c1,c2,c3) ) \ F77_CHAR_ARG3DCL(c1,c2,c3) \ { F77_CHAR_ARG3DEF(c1,c2,c3) #define F77_ENTRY_C5(name,c1,c2,c3,c4,c5) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) #define F77_ENTRY_C4E(name,c1,c2,c3,c4,e5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_EXTERN_ARG(e5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_EXTERN_DCL(e5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_EXTERN_DEF(e5) #define F77_ENTRY_C4I(name,c1,c2,c3,c4,i5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4), i5 \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) INTEGER *i5; \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) #define F77_ENTRY_C5E(name,c1,c2,c3,c4,c5,e6) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5),F77_EXTERN_ARG(e6) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) F77_EXTERN_DCL(e6) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) F77_EXTERN_DEF(e6) #define F77_ENTRY_CCE(name,c1,c2,e3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN_ARG(e3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN_DCL(e3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN_DEF(e3) #define F77_ENTRY_CCEE(name,c1,c2,e3,e4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN2ARG(e3,e4) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN2DCL(e3,e4) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN2DEF(e3,e4) #define F77_ENTRY_CCI(name,c1,c2,i3) \ name( F77_CHAR_ARG2PTR(c1,c2), i3 \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) INTEGER *i3; \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_CCIC(name,c1,c2,i3,c4) \ name( F77_CHAR_ARG2PTR(c1,c2), i3, F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(i3) \ F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG3DCL(c1,c2,c4) INTEGER *i3; \ { F77_CHAR_ARG3DEF(c1,c2,c4) #define F77_ENTRY_CCIRCC(name,c1,c2,i3,r4,c5,c6) \ name( F77_CHAR_ARG2PTR(c1,c2), i3, r4, F77_CHAR_ARG2PTR(c5,c6) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG2LEN(i3,r4) \ F77_CHAR_ARG2LEN(c5,c6) ) \ F77_CHAR_ARG4DCL(c1,c2,c5,c6) INTEGER *i3; REAL *r4; \ { F77_CHAR_ARG4DEF(c1,c2,c5,c6) #define F77_ENTRY_CE(name,c1,e2) \ name( F77_CHAR_ARG_PTR(c1),F77_EXTERN_ARG(e2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_EXTERN_DCL(e2) \ { F77_CHAR_ARG_DEF(c1) F77_EXTERN_DEF(e2) #define F77_ENTRY_CI(name,c1,i2) \ name( F77_CHAR_ARG_PTR(c1), i2 F77_CHAR_ARG_LEN(c1) ) \ INTEGER *i2; F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CICI(name,c1,i2,c3,i4) \ name( F77_CHAR_ARG_PTR(c1), i2, F77_CHAR_ARG_PTR(c3), i4 \ F77_CHAR_ARG_LEN(c1) \ F77_XXXX_ARG_LEN(i2) \ F77_CHAR_ARG_LEN(c3) ) \ F77_CHAR_ARG2DCL(c1,c3) INTEGER *i2, *i4; \ { F77_CHAR_ARG2DEF(c1,c3) #define F77_ENTRY_CII(name,c1,i2,i3) \ name( F77_CHAR_ARG_PTR(c1), i2, i3 \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) INTEGER *i2, *i3; \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CIIC(name,c1,i2,i3,c4) \ name( F77_CHAR_ARG_PTR(c1), i2, i3, F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG_LEN(c1) \ F77_XXXX_ARG2LEN(i2,i3) \ F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG2DCL(c1,c4) INTEGER *i2, *i3; \ { F77_CHAR_ARG2DEF(c1,c4) #define F77_ENTRY_CR(name,c1,r2) \ name( F77_CHAR_ARG_PTR(c1), r2 F77_CHAR_ARG_LEN(c1) ) \ REAL *r2; F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_E(name,e1) \ name( F77_EXTERN_ARG(e1) ) \ F77_EXTERN_DCL(e1) \ { F77_EXTERN_DEF(e1) #define F77_ENTRY_E4(name,e1,e2,e3,e4) \ name( F77_EXTERN4ARG(e1,e2,e3,e4) ) \ F77_EXTERN4DCL(e1,e2,e3,e4) \ { F77_EXTERN4DEF(e1,e2,e3,e4) #define F77_ENTRY_IC(name,i1,c2) \ name( i1, F77_CHAR_ARG_PTR(c2) \ F77_XXXX_ARG_LEN(i1) \ F77_CHAR_ARG_LEN(c2) ) \ INTEGER *i1; F77_CHAR_ARG_DCL(c2) \ { F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_ICI(name,i1,c2,i3) \ name( i1, F77_CHAR_ARG_PTR(c2), i3 \ F77_XXXX_ARG_LEN(i1) \ F77_CHAR_ARG_LEN(c2) ) \ INTEGER *i1, *i3; F77_CHAR_ARG_DCL(c2) \ { F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_IIC(name,i1,i2,c3) \ name( i1, i2, F77_CHAR_ARG_PTR(c3) \ F77_XXXX_ARG2LEN(i1,i2) \ F77_CHAR_ARG_LEN(c3) ) \ INTEGER *i1, *i2; F77_CHAR_ARG_DCL(c3) \ { F77_CHAR_ARG_DEF(c3) #define F77_ENTRY_I3C(name,i1,i2,i3,c4) \ name( i1, i2, i3, F77_CHAR_ARG_PTR(c4) \ F77_XXXX_ARG3LEN(i1,i2,i3) \ F77_CHAR_ARG_LEN(c4) ) \ INTEGER *i1, *i2, *i3; \ F77_CHAR_ARG_DCL(c4) \ { F77_CHAR_ARG_DEF(c4) #define F77_ENTRY_I4CCC(name,i1,i2,i3,i4,c5,c6,c7) \ name( i1, i2, i3, i4, F77_CHAR_ARG3PTR(c5,c6,c7) \ F77_XXXX_ARG4LEN(i1,i2,i3,i4) \ F77_CHAR_ARG3LEN(c5,c6,c7) ) \ INTEGER *i1, *i2, *i3, *i4; \ F77_CHAR_ARG3DCL(c5,c6,c7) \ { F77_CHAR_ARG3DEF(c5,c6,c7) #define F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_DEF_DSC(s1,p1,l1) F77_CHAR_DEF_DSC(s2,p2,l2) #define F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS_DSC(s1,p1,l1) F77_CHAR_ASS_DSC(s2,p2,l2) #define F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_PTR(s1,p1,l1),F77_CHAR_USE_PTR(s2,p2,l2) #define F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_LEN(s1,p1,l1) F77_CHAR_USE_LEN(s2,p2,l2) #define F77_XXXX_USE2LEN(x1,x2) \ F77_XXXX_USE_LEN(x1) F77_XXXX_USE_LEN(x2) #define F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_DEF_DSC(s3,p3,l3) #define F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_ASS_DSC(s3,p3,l3) #define F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2),F77_CHAR_USE_PTR(s3,p3,l3) #define F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) F77_CHAR_USE_LEN(s3,p3,l3) #define F77_XXXX_USE3LEN(x1,x2,x3) \ F77_XXXX_USE2LEN(x1,x2) F77_XXXX_USE_LEN(x3) #define F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_DEF_DSC(s4,p4,l4) #define F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_ASS_DSC(s4,p4,l4) #define F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3),F77_CHAR_USE_PTR(s4,p4,l4) #define F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_USE_LEN(s4,p4,l4) #define F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_XXXX_USE3LEN(x1,x2,x3) F77_XXXX_USE_LEN(x4) #define F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) F77_XXXX_USE_LEN(x5) #define F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) \ F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) F77_XXXX_USE_LEN(x6) #define F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) \ F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) F77_XXXX_USE_LEN(x7) #define F77_XXXX_USE8LEN(x1,x2,x3,x4,x5,x6,x7,x8) \ F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) F77_XXXX_USE_LEN(x8) #ifdef IBM370 #pragma linkage(K77C,FORTRAN) #define F77_CALL_C(name,p1,l1) do { \ SUBROUTINE *F77 = name; \ K77C(&F77,p1,l1); } while(0) #else #define F77_CALL_C(name,p1,l1) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1) \ F77_CHAR_USE_LEN(s1,p1,l1) \ ); } while(0) #endif #if 0 #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77CC(&F77,p1,l1,p2,l2); } while(0) #else #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #else #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ i0 = K77CC(&name,p1,l1,p2,l2); } while(0) #else #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_CC(_i0_,_p0_,p1,l1,p2,l2); \ } while(0) #endif #ifdef IBM370 #pragma linkage(K77C3,FORTRAN) #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77C3(&F77,p1,l1,p2,l2,p3,l3); } while(0) #else #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ name( F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77C7,FORTRAN) #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ SUBROUTINE *F77 = name; \ K77C7(&F77,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); } while(0) #else #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ name( F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4), \ F77_CHAR_USE3PTR(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx,FORTRAN) #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77CCx(&F77,p1,l1,p2,l2,x3); } while(0) #else #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx3,FORTRAN) #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ SUBROUTINE *F77 = name; \ K77CCx3(&F77,p1,l1,p2,l2,x3,x4,x5); } while(0) #else #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4,x5 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE3LEN(x3,x4,x5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cx,FORTRAN) #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ i0 = K77Cx(&name,p1,l1,x2); } while(0) #else #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1), \ x2 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ ); } while(0) #endif #define F77_CALL_Cx(name,p1,l1,x2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_Cx(_i0_,_p0_,p1,l1,x2); \ } while(0) #ifdef IBM370 #pragma linkage(K77CxC,FORTRAN) #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77CxC(&F77,p1,l1,x2,p3,l3); } while(0) #else #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s3,p3,l3) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2, \ F77_CHAR_USE_PTR(s3,p3,l3) \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ F77_CHAR_USE_LEN(s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cxx,FORTRAN) #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ SUBROUTINE *F77 = name; \ K77Cxx(&F77,p1,l1,x2,x3); } while(0) #else #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2,x3 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE2LEN(x2,x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xC,FORTRAN) #define F77_CALL_xC(name,x1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77xC(&F77,x1,p2,l2); } while(0) #else #define F77_CALL_xC(name,x1,p2,l2) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCCx,FORTRAN) #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ SUBROUTINE *F77 = name; \ K77xCCx(&F77,x1,p2,l2,p3,l3,x4); } while(0) #else #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ name( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3), \ x4 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x4) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCx,FORTRAN) #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ i0 = K77xCx(&name,x1,p2,l2,x3); } while(0) #else #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_xCx(_i0_,_p0_,x1,p2,l2,x3); \ } while(0) #ifdef IBM370 #pragma linkage(K77x4C,FORTRAN) #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ SUBROUTINE *F77 = name; \ K77x4C(&F77,x1,x2,x3,x4,p5,l5); } while(0) #else #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77x4Cxx,FORTRAN) #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ SUBROUTINE *F77 = name; \ K77x4Cxx(&F77,x1,x2,x3,x4,p5,l5,x6,x7); } while(0) #else #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5), \ x6,x7 \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ F77_XXXX_USE2LEN(x6,x7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(KIGMENU,FORTRAN) /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 */ #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ SUBROUTINE *F77 = name; \ KIGMENU(&F77,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N); } while(0) #else #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ F77_CHAR_DEF_DSC(sb,b,B) \ F77_CHAR_DEF_DSC(sh,h,H) \ F77_CHAR_DEF3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_DEF_DSC(sn,n,N) \ F77_CHAR_ASS_DSC(sb,b,B) \ F77_CHAR_ASS_DSC(sh,h,H) \ F77_CHAR_ASS3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_ASS_DSC(sn,n,N) \ name( a, \ F77_CHAR_USE_PTR(sb,b,B), \ c,d,e,f,g, \ F77_CHAR_USE_PTR(sh,h,H), \ i, \ F77_CHAR_USE3PTR(sj,j,J,sk,k,K,sl,l,L), \ m, \ F77_CHAR_USE_PTR(sn,n,N) \ F77_XXXX_USE_LEN(a) \ F77_CHAR_USE_LEN(sb,b,B) \ F77_XXXX_USE5LEN(c,d,e,f,g) \ F77_CHAR_USE_LEN(sh,h,H) \ F77_XXXX_USE_LEN(i) \ F77_CHAR_USE3LEN(sj,j,J,sk,k,K,sl,l,L) \ F77_XXXX_USE_LEN(m) \ F77_CHAR_USE_LEN(sn,n,N) \ ); } while(0) #endif #ifdef IBM370 #define F77_IFUN_x(i0,name,x1) i0 = __CTOF(name,x1) #else #define F77_IFUN_x(i0,name,x1) i0 = (*name)(x1) #endif #ifdef IBM370 #define F77_IFUN_xx(i0,name,x1,x2) i0 = __CTOF(name,x1,x2) #else #define F77_IFUN_xx(i0,name,x1,x2) i0 = (*name)(x1,x2) #endif #ifdef IBM370 #pragma linkage(K77xCx8,FORTRAN) #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ i0 = K77xCx8(&name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10); } while(0) #else #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3,x4,x5,x6,x7,x8,x9,x10 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE8LEN(x3,x4,x5,x6,x7,x8,x9,x10) \ ); } while(0) #endif /* * routines called by Fortran */ #define Errrun F77_NAME(errrun,ERRRUN) #define Fmemcpy F77_NAME(fmemcpy,FMEMCPY) #define Getarg F77_NAME(getarg,GETARG) extern SUBROUTINE Getarg; #define Goparm F77_NAME(goparm,GOPARM) extern SUBROUTINE Goparm; #define Gl_char_cleanup F77_NAME(gl_char_cleanup,GL_CHAR_CLEANUP) #define Gl_reset F77_NAME(gl_reset,GL_RESET) #define Gl_reinit F77_NAME(gl_reinit,GL_REINIT) #define Iclrwk F77_NAME(iclrwk,ICLRWK) extern SUBROUTINE Iclrwk; #define Iginit F77_NAME(iginit,IGINIT) extern SUBROUTINE Iginit; #define Igmenu F77_NAME(igmenu,IGMENU) extern SUBROUTINE Igmenu; #define Igrng F77_NAME(igrng,IGRNG) extern SUBROUTINE Igrng; #define Igsse F77_NAME(igsse,IGSSE) extern SUBROUTINE Igsse; #define Igsrap F77_NAME(igsrap,IGSRAP) extern SUBROUTINE Igsrap; #define Igwkty F77_NAME(igwkty,IGWKTY) extern SUBROUTINE Igwkty; #define Kcexec F77_NAME(kcexec,KCEXEC) #define Kdialo F77_NAME(kdialo,KDIALO) extern SUBROUTINE Kdialo; #define Kgetar F77_NAME(kgetar,KGETAR) #define Kialid F77_NAME(kialid,KIALID) #define Kiargc F77_NAME(kiargc,KIARGC) extern INT_FUNCTION Kiargc; #define Kibres F77_NAME(kibres,KIBRES) extern SUBROUTINE Kibres; #define Kiclos F77_NAME(kiclos,KICLOS) extern SUBROUTINE Kiclos; #define Kicomv F77_NAME(kicomv,KICOMV) #define Kidtab F77_NAME(kidtab,KIDTAB) #define Kierrf F77_NAME(kierrf,KIERRF) extern SUBROUTINE Kierrf; #define Kiinit F77_NAME(kiinit,KIINIT) extern SUBROUTINE Kiinit; #define Kilun F77_NAME(kilun,KILUN) extern SUBROUTINE Kilun; #define Kimath F77_NAME(kimath,KIMATH) #define Kimdef F77_NAME(kimdef,KIMDEF) #define Kimexe F77_NAME(kimexe,KIMEXE) #define Kipawc F77_NAME(kipawc,KIPAWC) #define Kipiaf F77_NAME(kipiaf,KIPIAF) #define Kiprmt F77_NAME(kiprmt,KIPRMT) #define Kirtim F77_NAME(kirtim,KIRTIM) #define Kisigm F77_NAME(kisigm,KISIGM) #define Kivect F77_NAME(kivect,KIVECT) #define Kmpst2 F77_NAME(kmpst2,KMPST2) #define Kmpst3 F77_NAME(kmpst3,KMPST3) #define Kmpx22 F77_NAME(kmpx22,KMPX22) #define Kmpx23 F77_NAME(kmpx23,KMPX23) #define Kmvsed F77_NAME(kmvsed,KMVSED) extern SUBROUTINE Kmvsed; #define Kmvspg F77_NAME(kmvspg,KMVSPG) extern SUBROUTINE Kmvspg; #define Kmvssh F77_NAME(kmvssh,KMVSSH) extern SUBROUTINE Kmvssh; #define Ksvpar F77_NAME(ksvpar,KSVPAR) #define Kuach F77_NAME(kuach,KUACH) #define Kuact F77_NAME(kuact,KUACT) #define Kualfa F77_NAME(kualfa,KUALFA) #define Kuappl F77_NAME(kuappl,KUAPPL) #define Kuargs F77_NAME(kuargs,KUARGS) #define Kubrek F77_NAME(kubrek,KUBREK) #define Kubrof F77_NAME(kubrof,KUBROF) #define Kubron F77_NAME(kubron,KUBRON) #define Kucmd F77_NAME(kucmd,KUCMD) #define Kucmdl F77_NAME(kucmdl,KUCMDL) #define Kucomv F77_NAME(kucomv,KUCOMV) #define Kuedit F77_NAME(kuedit,KUEDIT) #define Kuesvr F77_NAME(kuesvr,KUESVR) #define Kueusr F77_NAME(kueusr,KUEUSR) #define Kuexec F77_NAME(kuexec,KUEXEC) #define Kuexel F77_NAME(kuexel,KUEXEL) #define Kuexit F77_NAME(kuexit,KUEXIT) #define Kufcas F77_NAME(kufcas,KUFCAS) #define Kufdef F77_NAME(kufdef,KUFDEF) #define Kugetc F77_NAME(kugetc,KUGETC) #define Kugete F77_NAME(kugete,KUGETE) #define Kugetf F77_NAME(kugetf,KUGETF) #define Kugeti F77_NAME(kugeti,KUGETI) #define Kugetl F77_NAME(kugetl,KUGETL) #define Kugetq F77_NAME(kugetq,KUGETQ) #define Kugetr F77_NAME(kugetr,KUGETR) #define Kugets F77_NAME(kugets,KUGETS) #define Kugrfl F77_NAME(kugrfl,KUGRFL) #define Kuguid F77_NAME(kuguid,KUGUID) #define Kuhelp F77_NAME(kuhelp,KUHELP) #define Kuhome F77_NAME(kuhome,KUHOME) #define Kuidf1 F77_NAME(kuidf1,KUIDF1) extern SUBROUTINE Kuidf1; #define Kuidf2 F77_NAME(kuidf2,KUIDF2) extern SUBROUTINE Kuidf2; #define Kuidfm F77_NAME(kuidfm,KUIDFM) #define Kuinim F77_NAME(kuinim,KUINIM) #define Kuinit F77_NAME(kuinit,KUINIT) #define Kulun F77_NAME(kulun,KULUN) #define Kumloc F77_NAME(kumloc,KUMLOC) #define Kumout F77_NAME(kumout,KUMOUT) #define Kumpad F77_NAME(kumpad,KUMPAD) #define Kumpst F77_NAME(kumpst,KUMPST) #define Kumpx2 F77_NAME(kumpx2,KUMPX2) #define Kundpv F77_NAME(kundpv,KUNDPV) #define Kunpar F77_NAME(kunpar,KUNPAR) #define Kunwg F77_NAME(kunwg,KUNWG) #define Kuopen F77_NAME(kuopen,KUOPEN) extern SUBROUTINE Kuopen; #define Kupad F77_NAME(kupad,KUPAD) #define Kupar F77_NAME(kupar,KUPAR) #define Kupath F77_NAME(kupath,KUPATH) #define Kupatl F77_NAME(kupatl,KUPATL) #define Kuproc F77_NAME(kuproc,KUPROC) #define Kuprof F77_NAME(kuprof,KUPROF) #define Kuproi F77_NAME(kuproi,KUPROI) #define Kuprop F77_NAME(kuprop,KUPROP) #define Kupror F77_NAME(kupror,KUPROR) #define Kupros F77_NAME(kupros,KUPROS) #define Kumess F77_NAME(kumess,KUMESS) #define Kupval F77_NAME(kupval,KUPVAL) #define Kuqcas F77_NAME(kuqcas,KUQCAS) #define Kuqenv F77_NAME(kuqenv,KUQENV) #define Kuqexe F77_NAME(kuqexe,KUQEXE) #define Kuqsvr F77_NAME(kuqsvr,KUQSVR) #define Kuquit F77_NAME(kuquit,KUQUIT) #define Kusapp F77_NAME(kusapp,KUSAPP) #define Kuser F77_NAME(kuser,KUSER) #define Kuserid F77_NAME(kuserid,KUSERID) #define Kusibr F77_NAME(kusibr,KUSIBR) #define Kusigm F77_NAME(kusigm,KUSIGM) #define Kuspy F77_NAME(kuspy,KUSPY) #define Kustat F77_NAME(kustat,KUSTAT) #define Kustop F77_NAME(kustop,KUSTOP) #define Kuterm F77_NAME(kuterm,KUTERM) #define Kutime F77_NAME(kutime,KUTIME) #define Kutim0 F77_NAME(kutim0,KUTIM0) extern SUBROUTINE Kutim0; #define Kutrue F77_NAME(kutrue,KUTRUE) #define Kuvcre F77_NAME(kuvcre,KUVCRE) extern SUBROUTINE Kuvcre; #define Kuvdel F77_NAME(kuvdel,KUVDEL) extern SUBROUTINE Kuvdel; #define Kuvect F77_NAME(kuvect,KUVECT) extern SUBROUTINE Kuvect; #define Kuvnam F77_NAME(kuvnam,KUVNAM) #define Kuwhag F77_NAME(kuwhag,KUWHAG) #define Kuwham F77_NAME(kuwham,KUWHAM) #define Kuwhat F77_NAME(kuwhat,KUWHAT) #define Kxali1 F77_NAME(kxali1,KXALI1) #define Kxcrv2 F77_NAME(kxcrv2,KXCRV2) extern SUBROUTINE Kxcrv2; #define Macdef F77_NAME(macdef,MACDEF) extern SUBROUTINE Macdef; #define Mdmenu F77_NAME(mdmenu,MDMENU) #define Mhi_close F77_NAME(mhi_close,MHI_CLOSE) extern SUBROUTINE Mhi_close; #define Mhi_open F77_NAME(mhi_open,MHI_OPEN) extern SUBROUTINE Mhi_open; #define Mzwipe F77_NAME(mzwipe,MZWIPE) extern SUBROUTINE Mzwipe; #define Traceq F77_NAME(traceq,TRACEQ) extern SUBROUTINE Traceq; #define Xuflow F77_NAME(xuflow,XUFLOW) extern SUBROUTINE Xuflow; #ifdef IBM370 # pragma linkage(ERRRUN,FORTRAN) # pragma linkage(FMEMCPY,FORTRAN) # pragma linkage(GOPARM,FORTRAN) # pragma linkage(ICLRWK,FORTRAN) # pragma linkage(IGINIT,FORTRAN) # pragma linkage(IGMENU,FORTRAN) # pragma linkage(IGRNG,FORTRAN) # pragma linkage(IGSSE,FORTRAN) # pragma linkage(IGSRAP,FORTRAN) # pragma linkage(IGWKTY,FORTRAN) # pragma linkage(KCEXEC,FORTRAN) # pragma linkage(KDIALO,FORTRAN) # pragma linkage(KGETAR,FORTRAN) # pragma linkage(KIALID,FORTRAN) # pragma linkage(KIBRES,FORTRAN) # pragma linkage(KICLOS,FORTRAN) # pragma linkage(KICOMV,FORTRAN) # pragma linkage(KIDTAB,FORTRAN) # pragma linkage(KIERRF,FORTRAN) # pragma linkage(KIINIT,FORTRAN) # pragma linkage(KILUN,FORTRAN) # pragma linkage(KIMATH,FORTRAN) # pragma linkage(KIMDEF,FORTRAN) # pragma linkage(KIMEXE,FORTRAN) # pragma linkage(KIPAWC,FORTRAN) # pragma linkage(KIPIAF,FORTRAN) # pragma linkage(KIPRMT,FORTRAN) # pragma linkage(KIRTIM,FORTRAN) # pragma linkage(KISIGM,FORTRAN) # pragma linkage(KIVECT,FORTRAN) # pragma linkage(KMPST2,FORTRAN) # pragma linkage(KMPST3,FORTRAN) # pragma linkage(KMPX22,FORTRAN) # pragma linkage(KMPX23,FORTRAN) # pragma linkage(KMVSED,FORTRAN) # pragma linkage(KMVSPG,FORTRAN) # pragma linkage(KMVSSH,FORTRAN) # pragma linkage(KSVPAR,FORTRAN) # pragma linkage(KUACH,FORTRAN) # pragma linkage(KUACT,FORTRAN) # pragma linkage(KUALFA,FORTRAN) # pragma linkage(KUAPPL,FORTRAN) # pragma linkage(KUARGS,FORTRAN) # pragma linkage(KUBREK,FORTRAN) # pragma linkage(KUBROF,FORTRAN) # pragma linkage(KUBRON,FORTRAN) # pragma linkage(KUCMD,FORTRAN) # pragma linkage(KUCMDL,FORTRAN) # pragma linkage(KUCOMV,FORTRAN) # pragma linkage(KUEDIT,FORTRAN) # pragma linkage(KUESVR,FORTRAN) # pragma linkage(KUEUSR,FORTRAN) # pragma linkage(KUEXEC,FORTRAN) # pragma linkage(KUEXEL,FORTRAN) # pragma linkage(KUEXIT,FORTRAN) # pragma linkage(KUFCAS,FORTRAN) # pragma linkage(KUFDEF,FORTRAN) # pragma linkage(KUGETC,FORTRAN) # pragma linkage(KUGETE,FORTRAN) # pragma linkage(KUGETF,FORTRAN) # pragma linkage(KUGETI,FORTRAN) # pragma linkage(KUGETL,FORTRAN) # pragma linkage(KUGETQ,FORTRAN) # pragma linkage(KUGETR,FORTRAN) # pragma linkage(KUGETS,FORTRAN) # pragma linkage(KUGRFL,FORTRAN) # pragma linkage(KUGUID,FORTRAN) # pragma linkage(KUHELP,FORTRAN) # pragma linkage(KUHOME,FORTRAN) # pragma linkage(KUIDF1,FORTRAN) # pragma linkage(KUIDF2,FORTRAN) # pragma linkage(KUIDFM,FORTRAN) # pragma linkage(KUINIM,FORTRAN) # pragma linkage(KUINIT,FORTRAN) # pragma linkage(KULUN,FORTRAN) # pragma linkage(KUMLOC,FORTRAN) # pragma linkage(KUMOUT,FORTRAN) # pragma linkage(KUMPAD,FORTRAN) # pragma linkage(KUMPST,FORTRAN) # pragma linkage(KUMPX2,FORTRAN) # pragma linkage(KUNDPV,FORTRAN) # pragma linkage(KUNPAR,FORTRAN) # pragma linkage(KUNWG,FORTRAN) # pragma linkage(KUOPEN,FORTRAN) # pragma linkage(KUPAD,FORTRAN) # pragma linkage(KUPAR,FORTRAN) # pragma linkage(KUPATH,FORTRAN) # pragma linkage(KUPATL,FORTRAN) # pragma linkage(KUPROC,FORTRAN) # pragma linkage(KUPROF,FORTRAN) # pragma linkage(KUPROI,FORTRAN) # pragma linkage(KUPROP,FORTRAN) # pragma linkage(KUPROR,FORTRAN) # pragma linkage(KUPROS,FORTRAN) # pragma linkage(KUPVAL,FORTRAN) # pragma linkage(KUQCAS,FORTRAN) # pragma linkage(KUQENV,FORTRAN) # pragma linkage(KUQEXE,FORTRAN) # pragma linkage(KUQSVR,FORTRAN) # pragma linkage(KUQUIT,FORTRAN) # pragma linkage(KUSAPP,FORTRAN) # pragma linkage(KUSIBR,FORTRAN) # pragma linkage(KUSIGM,FORTRAN) # pragma linkage(KUSPY,FORTRAN) # pragma linkage(KUSTAT,FORTRAN) # pragma linkage(KUSTOP,FORTRAN) # pragma linkage(KUTERM,FORTRAN) # pragma linkage(KUTIME,FORTRAN) # pragma linkage(KUTIM0,FORTRAN) # pragma linkage(KUTRUE,FORTRAN) # pragma linkage(KUSER,FORTRAN) # pragma linkage(KUVCRE,FORTRAN) # pragma linkage(KUVDEL,FORTRAN) # pragma linkage(KUVECT,FORTRAN) # pragma linkage(KUVNAM,FORTRAN) # pragma linkage(KUWHAG,FORTRAN) # pragma linkage(KUWHAM,FORTRAN) # pragma linkage(KUWHAT,FORTRAN) # pragma linkage(KXALI1,FORTRAN) # pragma linkage(KXCRV2,FORTRAN) # pragma linkage(MACDEF,FORTRAN) # pragma linkage(MDMENU,FORTRAN) # pragma linkage(MHI_CLOSE,FORTRAN) # pragma linkage(MHI_OPEN,FORTRAN) # pragma linkage(MZWIPE,FORTRAN) # pragma linkage(TRACEQ,FORTRAN) # pragma linkage(XUFLOW,FORTRAN) #endif #define MAXCMD 512 /* max length of a command line */ #define MAXEDT 32 /* max length of names in edit server */ #define MAXLEV 10 /* max levels of command name path */ #define MAXSVR 20 /* max number of edit server processes */ /* * The PAWC common is referenced through a pointer to allow the use of * dynamic common blocks on IBM systems. */ #define Pawc kc_pawc EXTERN struct COMMON_PAWC { INTEGER NWPAR; INTEGER IXPAWC; INTEGER IHBOOK; INTEGER IXHIGZ; INTEGER IXKUIP; INTEGER IFENCE[5]; INTEGER LQ[8]; INTEGER DATA[999]; } *Pawc; #define IQ(n) Pawc->DATA[n-1] #define Q(n) (((REAL*)(Pawc->DATA))[n-1]) +KEEP,KCOM_H /* kcom.h: Fortran COMMON blocks */ #define Kcalia F77_BLOCK(kcalia,KCALIA) #define MALIAS 200 EXTERN struct { INTEGER NALIAS; LOGICAL ALIFLG; INTEGER ALITYP[MALIAS]; } F77_COMMON(Kcalia); #define Kcalic F77_BLOCK(kcalic,KCALIC) EXTERN struct { char ALINAM[MALIAS][60]; char ALIVAL[MALIAS][80]; } F77_COMMON(Kcalic); #define Kcbrek F77_BLOCK(kcbrek,KCBREK) EXTERN struct { LOGICAL TRAP; /* flag if signal trapping is enabled */ LOGICAL BRKEN; /* not used, always true */ LOGICAL FIRST; /* only used for Apollo */ LOGICAL FIRSG; /* only used for Apollo */ LOGICAL CLWHAT; /* flag if KUWHAT installed break handler */ LOGICAL CLWHAG; /* flag if KUWHAG installed break handler */ LOGICAL TBFLAG; /* flag if traceback should be printed */ } F77_COMMON(Kcbrek); #define Kcefil F77_BLOCK(kcefil,KCEFIL) EXTERN struct { char EDTFIL[MAXSVR][MAXEDT]; /* file name */ char EDTCMD[MAXSVR][MAXEDT]; /* KUIP command */ } F77_COMMON(Kcefil); #define Kcesvr F77_BLOCK(kcesvr,KCESVR) EXTERN struct { INTEGER NSVFIL; /* number of edited file */ INTEGER NSVCUR; /* pointer to current file */ SUBRPTR IESADD; /* routine set by KUEUSR */ LOGICAL SERVER; /* flag if edit server is used */ } F77_COMMON(Kcesvr); #define Kcexit F77_BLOCK(kcexit,KCEXIT) EXTERN struct { SUBRPTR IEXADD; /* routine set by KUEXIT */ SUBRPTR IUSADD; /* routine set by KUSER */ SUBRPTR NEXADD; /* routine set by KUNEXT */ SUBRPTR IUTADD; /* routine set by KUTERM */ SUBRPTR IQUADD; /* routine set by KUQUIT */ SUBRPTR IBRADD; /* routine set by KUBREK */ LOGICAL LICALL; LOGICAL LICAL2; LOGICAL LICAL3; } F77_COMMON(Kcexit); #define Kcmac F77_BLOCK(kcmac,KCMAC) EXTERN struct { LOGICAL MACTAB; INTEGER NSTLEV; LOGICAL QUITFL; LOGICAL WAITFL; LOGICAL WAITFF; LOGICAL DEBTAB; LOGICAL SKIPFL; LOGICAL HEADFL; INTEGER IONERF; LOGICAL NOEXEC; } F77_COMMON(Kcmac); #define Kcparc F77_BLOCK(kcparc,KCPARC) EXTERN struct { char PARLST[512]; /* interface block for KUSER */ char CLIST[80]; char NOALIN[512]; char COMAND[80]; char CHLAST[512]; char NONPOS[512]; } F77_COMMON(Kcparc); #define Kcsigm F77_BLOCK(kcsigm,KCSIGM) EXTERN struct { SUBRPTR ISIADD; /* routine set by KUSIGM */ INTEGER NVSIGM; /* number of temp vectors create for $SIGMA */ } F77_COMMON(Kcsigm); #define Kcutil F77_BLOCK(kcutil,KCUTIL) EXTERN struct { INTEGER NCMD; INTEGER IWD; INTEGER LUNFIL; INTEGER LPRMPT; LOGICAL TIMING; LOGICAL TRACE; INTEGER CALMOD; INTEGER NVADD; INTEGER IREPET; INTEGER IREFAC; INTEGER IBRAK; LOGICAL TIMALL; INTEGER LENTER; LOGICAL UNIQUE; INTEGER LENMUL; LOGICAL MULTFL; LOGICAL HISTOK; LOGICAL NOHIST; INTEGER LENMUM; LOGICAL FILCAS; LOGICAL MEXEFL; } F77_COMMON(Kcutil); #define Kcvect F77_BLOCK(kcvect,KCVECT) EXTERN struct { INTEGER NUMVEC; /* number of vectors stored */ INTEGER TOTPAV; INTEGER GETPAV; LOGICAL TVECFL; } F77_COMMON(Kcvect); #define Quest F77_BLOCK(quest,QUEST) EXTERN struct { INTEGER DATA[100]; } F77_COMMON(Quest); #define IQUEST(n) Quest.DATA[n-1] #define Sikuip F77_BLOCK(sikuip,SIKUIP) EXTERN struct { char CHSIGM[80]; /* command string passed to SIGMA */ } F77_COMMON(Sikuip); +KEEP,KSIG_H /* ksig.h: signal and break handling */ /* * Available signal handling package * * #define SIGNAL_POSIX ==> sigaction() for Unix * #define SIGNAL_BSD ==> sigvec() for VMS and NeXT * #define SIGNAL_V7 ==> signal() */ #if !defined(SIGNAL_BSD) && !defined(SIGNAL_V7) # define SIGNAL_POSIX #else # define sigjmp_buf jmp_buf # define sigsetjmp(buf,save) setjmp(buf) # define siglongjmp(buf,val) longjmp(buf,val) # ifdef vms # define sv_flags sv_onstack # endif #endif EXTERN struct { int trap_enabled; /* flag if exceptions should be trapped */ int traceback; /* print traceback on signal */ char *error_msg; /* messages is handler cannot do print */ int intr_count; /* count number of consecutive ^C interrupts */ int soft_intr; /* flag to stop at a convenient point */ int jump_set; /* flag if stack has been setup */ sigjmp_buf stack; int sockfd; /* socket descriptor and routine to */ void (*piaf_sync)(); /* resynchronize Piaf communication */ } kc_break; +KEEP,KBROW_H /* kbrow.h: browser definitions */ #define KBROW_H1 \ +SEQ,KBROW_H1 KBROW_H1 #define KBROW_H2 \ +SEQ,KBROW_H2 KBROW_H2 typedef struct _KmObject { struct _KmObject *next; /* link to next object definition */ char *name; /* unique identifier name */ char *stext; /* short description text */ char *ltext; /* long description text */ KmClass *class; /* pointer to objects's class structure */ } KmObject; typedef struct _BrVariable { struct _BrVariable *next; /* link to next variable definition */ char *name; /* variable name */ char *value; /* replacement value */ } BrVariable; typedef struct _BrObject { struct _BrObject *next; /* link to next browsable object */ char *name; /* name of the browsable object */ BrClass *class; /* pointer to browsable's class structure */ BrVariable *vars; /* linked list of variable substitutions */ } BrObject; typedef struct _BrClientdata { BrActTag tag; char *brobj; char *brcls; char *path; char *kmobj; char *kmcls; char *stext; char *ltext; char *mtext; } BrClientdata; EXTERN BrClass *brclasses; EXTERN KmObject *kmobjects; EXTERN KmButton *kmbuttons; extern C_PROTO_2(void klnkbrcl, BrClass*, int); extern C_PROTO_2(void klnkkmcl, KmClass*, int); extern C_PROTO_2(void klnkicon, KmIcon*, int); extern C_PROTO_2(void klnkbutt, KmButton*, int); extern C_PROTO_6(void exec_action, BrAction*, char*, char*, int, KmWidget, KmCalldata); extern C_PROTO_2(KmWidget find_button, char*, char*); extern C_PROTO_1(KmIcon* find_kmicon, char*); extern C_PROTO_1(KmClass* find_kmclass, char*); extern C_PROTO_1(BrObject* find_brobject, char*); extern C_PROTO_2(char* get_variable, char*, char*); extern C_PROTO_0(BrObject* scan_brobjects); extern C_PROTO_3(KmObject* scan_kmobjects, char*, char*, int); extern C_PROTO_7(int set_action, char*, int, int, char*, char*, int, int); extern C_PROTO_3(void set_variable, BrObject*, char*, char*); +KEEP,KLINK_H /* klink.h: demand linking of special routines */ #define KLINK_H1 EXTERN \ +SEQ,KLINK_H1 KLINK_H1 EXTERN struct { SUBROUTINE *user_exit_F; /* set by KUEXIT */ SUBROUTINE *user_quit_F; /* set by KUQUIT */ SUBROUTINE *user_break_F; /* set by KUBREK */ SUBROUTINE *user_edit_F; /* set by KUEUSR */ SUBROUTINE *user_comis_F; /* set by KUCOMV */ SUBROUTINE *user_sigma_F; /* set by KUSIGM */ SUBROUTINE *user_grfl_F; /* set by KUGRFL */ SUBROUTINE *user_term_F; /* set by KUTERM */ SUBROUTINE *user_input_F; /* set by KUSER */ SUBROUTINE *user_locate_F; /* set by KUMLOC */ /* indirect calls to avoid linking Motif */ IntFunc *disp_panel_C; /* display command panel (km_display_cmdpan) */ IntFunc *disp_kpanel_C; /* display KUIP panel (km_display_kpanel) */ IntFunc *disp_text_C; /* display text widget (km_display_sctext) */ IntFunc *disp_choice_C; /* display a choice of commands (?) */ IntFunc *disp_clean_C; /* clean before action (km_destroy_all_popup)*/ IntFunc *disp_flush_C; /* flush event queue (FlushEvents) */ IntFunc *disp_busy_C; /* show busy cursor (km_all_cursor) */ IntFunc *disp_exit_C; /* ask confirmation for exit */ IntFunc *disp_quit_C; /* ask confirmation for exit */ IntFunc *disp_select_C; /* select from a number of buttons */ IntFunc *disp_cmd_list_C; /* display list of commands (km_print_list) */ CharFunc *disp_prompt_C; /* prompt for input */ CharFunc *disp_passwd_C; /* prompt for password input */ /* indirect calls to avoid linking HIGZ without style G */ IntFunc *higz_init_C; /* initialize menu mode */ SUBROUTINE *higz_menu_F; /* IGMENU */ } kjmpaddr; +KEEP,KFLAG_H typedef enum { KmMACRO_COMMAND = 0, /* don't look for macros */ KmMACRO_AUTO, /* look for macros before commands */ KmMACRO_AUTOREVERSE /* look for macros after commands */ } KmMacOrder; typedef enum { KmSTYLE_A = 0x0001, /* Alpha menus */ KmSTYLE_C = 0x0002, /* Command line */ KmSTYLE_G = 0x0004, /* Graphics menus */ KmSTYLE_M = 0x0008, /* Model Human Interface */ KmSTYLE_U = 0x0010, /* User */ KmSTYLE_XM = 0x0020, /* Motif/X11 */ KmSTYLE_major = 0x00FF, /* A..X are mutually exclusive */ KmSTYLE_xL = 0x0100, /* Alpha Letter menus */ KmSTYLE_xP = 0x0200, /* Panel style GP or MP */ KmSTYLE_xS = 0x0400, /* Graphics with Software fonts */ KmSTYLE_xW = 0x0800 /* Graphics with shadowed Width */ } KmStyleFlag; typedef enum { KmTIMING_OFF, /* no timing */ KmTIMING_ON, /* time typed commands */ KmTIMING_ALL /* time individual commands inside macro */ } KmTiming; EXTERN struct { LOGICAL f77_true; /* value of .TRUE. */ LOGICAL f77_false; /* value of .FALSE. */ int do_exit; /* set by KXEXIT */ int do_quit; /* set by KXQUIT */ char *curr_prompt; /* current prompt string */ char *last_cmd; /* last command for $LAST */ KmTiming timing; /* timing on/off/all */ time_t real_time; /* real time at last timing off */ clock_t user_time; /* CPU time at last timing off */ int in_macro; /* command executed in macro */ int in_application; /* application mode is active */ int appl_called; /* application is executing */ char *appl_exit; /* string which leaves application mode */ KmCommand *appl_cmd; /* command which handles application */ char appl_file[256]; /* temporary file to pass application text */ FILE *appl_stream; /* C stream used for writing appl_file */ int appl_luno; /* Fortran logical unit opened for appl_file */ char help_file[256]; /* temporary file to view help text */ char uhlp_file[256]; /* temporary file to get user help text */ int uhlp_luno; /* Fortran logical unit opened for user help */ int in_motif; /* Motif mode is active */ int echo_command; /* echo commands in Motif mode */ char *echo_prompt; /* prompt string for echo commands */ KmStyleFlag style; /* input mode */ int keep_fcase; /* flag if no case conversion for filenames */ int use_kxterm; /* flag if kxterm should be used */ int use_server; /* flag if edit server should be used */ int editor_exit; /* flag set if edit server sent SIGUSR1 */ char *editor_cbuf; /* buffer of for edit servers commands */ char *macro_path; /* MACRO/DEFAULT search path */ KmMacOrder macro_search; /* MACRO/DEFAULT search order */ int temp_vectors; /* number of ?SIGMA vectors */ char init_wdir[256]; /* initial working directory */ } kc_flags; EXTERN struct { char *set_break; /* SET_SHOW/BREAK */ char set_columns[8]; /* SET_SHOW/COLUMNS */ char *set_command; /* SET_SHOW/COMMAND */ char *set_filecase; /* SET_SHOW/FILECASE */ char *set_host_editor; /* SET_SHOW/HOST_EDITOR */ char *set_host_pager; /* SET_SHOW/HOST_PAGER */ char *set_host_shell; /* SET_SHOW/HOST_SHELL */ char *set_prompt; /* SET_SHOW/PROMPT */ char *set_recall_style; /* SET_SHOW/RECALL_STYLE */ char set_recording[8]; /* SET_SHOW/RECORDING */ char *set_root; /* SET_SHOW/ROOT */ char *set_style; /* SET_SHOW/STYLE */ char *set_timing; /* SET_SHOW/TIMING */ char *help_edit; /* HELP edit mode */ char *defaults_path; /* MACRO/DEFAULTS search path */ char *defaults_order; /* MACRO/DEFAULTS search order */ } kc_value; typedef struct { int top; int left; int width; int height; } KmWindowDsc; EXTERN struct { KmWindowDsc edit_pad; /* coordinates for edit window */ KmWindowDsc help_pad; /* coordinates for readonly window */ int voffset; /* vertical offset */ int hoffset; /* horizontal offset */ int shift_max; /* maximum number of shifted pads */ int shift_now; /* current shift count */ int shift_dir; /* shift direction +/-1 */ int is_a_pad; /* flag if running in an Apollo DM pad */ int is_a_tty; /* flag if stdin and stdout at terminal */ int use_getline; /* flag for using getline() or normal read */ int use_no_echo; /* flag for using no echo in password prompt */ int term_width; /* terminal width in columns */ int kuwhag_called; /* allow style G */ float sgylen; float sgsize; float sgyspa; float sgbord; int panel_rows; /* number of rows in style GP panel */ int *panel_cols; /* number of columns in each row */ char ***panel_keys; /* key labels */ char *panel_keynum; /* value of $KEYNUM */ char *panel_keyval; /* value of $KEYVAL */ } kc_window; extern C_PROTO_1(char* style_name, KmStyleFlag); +KEEP,KMENU_H /* kmenu.h: data structures for menu and command definitions */ #define KMENU_H1 \ +SEQ,KMENU_H1 KMENU_H1 #define KMENU_H2 \ +SEQ,KMENU_H2 KMENU_H2 #define KMENU_H3 \ +SEQ,KMENU_H3 KMENU_H3 /* * temporary fix until we can reserve an extra word in KmCommand structure * to count keyboard and macro commands separately */ #define XCOUNT_SHIFT 10 #define XCOUNT_OFFSET (1 << XCOUNT_SHIFT) #define XCOUNT_MASK (XCOUNT_OFFSET - 1) extern C_PROTO_2(void check_version, int, int); extern C_PROTO_0(void check_edit_server); extern C_PROTO_3(int exec_cmd_string, char*, int, int(*)()); extern C_PROTO_1(int exec_decoded_cmd, KmCommand*); extern C_PROTO_1(KmMenu* find_submenu, char*); extern C_PROTO_2(char* fmt_cmd_help, KmCommand*, int); extern C_PROTO_0(void menu_style); extern C_PROTO_2(void print_cmd_list, KmCommand**, char*); extern C_PROTO_1(void reset_arg_list, KmCommand*); extern C_PROTO_1(KmMenu** root_menu_list, char*); extern C_PROTO_2(KmCommand* search_command, char*, KmCommand***); +KEEP,KHASH_H /* khash.h: hash table management */ typedef struct _HashArray { char *name; /* symbol name */ void *value; /* symbol value */ } HashArray; typedef struct _HashEntry { struct _HashEntry *next; /* link to next entry */ char *name; /* symbol name */ void *value; /* symbol value */ } HashEntry; typedef struct { int size; /* table size should be a prime number */ HashEntry **entries; /* pointer to array of size entries */ int nentries; /* number of entries */ int copy; /* flag if strdup/free(value) should be used */ } HashTable; #define ALIAS_TABLE_SIZE 97 /* should be a prime */ EXTERN struct { int translate; /* flag if translation wanted */ int substitutions; /* how many more before recursive alarm */ HashTable *arg_table; /* Argument alias table */ HashTable *cmd_table; /* Command alias table */ HashTable *var_table; /* macro variables */ } kc_alias; extern C_PROTO_2(HashTable* hash_create, int, int); extern C_PROTO_1(void hash_clear, HashTable*); extern C_PROTO_1(void hash_destroy, HashTable*); extern C_PROTO_3(void hash_insert, HashTable*, const char*, void*); extern C_PROTO_2(void hash_remove, HashTable*, const char*); extern C_PROTO_2(void* hash_lookup, HashTable*, const char*); extern C_PROTO_1(int hash_entries, HashTable*); extern C_PROTO_1(HashArray* hash_array, HashTable*); extern C_PROTO_1(int match_paren, char*); extern C_PROTO_1(char* repl_variable, char*); extern C_PROTO_2(char* repl_sysfun, char*, int); extern C_PROTO_1(char* subst_arg_alias, char*); extern C_PROTO_1(char* subst_cmd_alias, char*); extern C_PROTO_1(char* subst_var_alias, char*); extern C_PROTO_2(char* subst_sysfun, char*, int); extern C_PROTO_1(char* var_value, char*); +KEEP,MKTERM. #define ESCAPE "#@" typedef void (*KxtermActionProc)( #ifndef NO_PROTOTYPES char** /* params */, int /* num_params */ #endif ); typedef struct _KxtermActionsRec{ char *string; KxtermActionProc proc; } KxtermActionsRec; typedef KxtermActionsRec *KxtermActionList; extern C_PROTO_1(void kxterm_add_actions, KxtermActionList); extern C_PROTO_1(void handle_kxterm_action, char *); extern C_PROTO_1(void send_kxterm_cmd, char**); extern C_PROTO_1(void send_single_kxterm_cmd, char*); +DECK,hkuip_93b,IF=93B. +KEEP,KHAIX370 #ifndef AIX370 # define AIX370 #endif +KEEP,KHAPOFTN #ifndef APOLLO_FTN # define APOLLO_FTN #endif +KEEP,KHIBMVM #ifndef IBMVM # define IBMVM #endif +KEEP,KHIBMMVS #ifndef IBMMVS # define IBMMVS #endif +KEEP,KHNEWLIB #ifndef NEWLIB # define NEWLIB #endif +KEEP,KUIP_H #ifndef KUIP_H_INCLUDED #define KUIP_H_INCLUDED /* kuip.h: system dependent defines */ /* update version if structures have changed */ #define KUIP_VERSION 921023 /* identify system if not possible from preprocessor defines */ +SEQ,KHAIX370,IF=AIX370 +SEQ,KHAPOFTN,IF=APOFTN +SEQ,KHIBMVM ,IF=IBMVM +SEQ,KHIBMMVS,IF=IBMMVS +SEQ,KHNEWLIB,IF=NEWLIB #ifdef AIX370 # define MACHINE_NAME "IBMAIX" # define UNIX # define F77_EXTERN_INDIRECT #endif #if defined(apollo) || defined(__apollo) # define MACHINE_NAME "APOLLO" # define APOLLO # define UNIX # include # include # include # include # include # ifdef APOLLO_FTN /* using /com/ftn instead of /bin/f77 */ # define F77_CHAR_LEN_IND short # define F77_EXTERN_LOWERCASE # endif # define F77_EXTERN_INDIRECT # define F77_COMMON(name) name __attribute((__section(name))) # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #ifdef CRAY # define MACHINE_NAME "CRAY" # define UNIX # include # define F77_EXTERN_UPPERCASE # define F77_CHAR_DSC_CRAY # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_EDIT_SERVER #endif #if defined(hpux) || defined(__hpux) # define MACHINE_NAME "HPUX" # define HPUX # define UNIX # ifdef hpux /* cc -Ac */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # ifndef _HPUX_SOURCE # define _HPUX_SOURCE # endif # define FATAL_SIGFPE /* needs f77 +T and ON REAL UNDERFLOW IGNORE */ # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_STRRSTR #endif #ifdef _IBMR2 # define IBMRT # define MACHINE_NAME "IBMRT" # define UNIX # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #ifdef IBMVM # define ARG_STYLE_CMS # define MACHINE_NAME "IBM" # define OS_NAME "VM" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBMMVS # define MACHINE_NAME "IBMMVS" # define OS_NAME "MVS" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBM370 # define F77_CHAR_LEN_IND int /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_EXTERN_INDIRECT # define F77_EXTERN_UPPERCASE # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_V7 #endif #ifdef MSDOS # define MACHINE_NAME "MSDOS" # include # define F77_INTEGER_IS_LONG # define SIGNAL_V7 #endif #ifdef NeXT # define MACHINE_NAME "NEXT" # define UNIX # define getcwd(path,maxlen) getwd(path) # define F77_BLOCK(lc,uc) lc # define F77_EXTERN_INDIRECT /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_XXXX_USE_LEN(x) ,286716 /* don't know if value matters */ # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define NO_DIRENT_H # define NO_UNISTD_H # define SIGNAL_BSD #endif #ifdef __osf__ # define UNIX # ifdef __alpha # define ALPHA # define MACHINE_NAME "ALPHA" # endif # include /* struct timeval for gettimeofday() */ # define const /* wrong prototype for strdup() in string.h */ # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #if defined(sgi) || defined(__sgi) # define MACHINE_NAME "SGI" # define SGI # define UNIX # ifndef __sgi /* Irix 3 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #if defined(sun) || defined(__sun) # define MACHINE_NAME "SUN" # define SUN # define UNIX # ifndef __STDC__ /* cc vs. acc */ # define NO_ANSI_CPP # define NO_PROTOTYPES # else # define const /* wrong prototype for strdup() in string.h */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_VFORK # include # define MATCH_RE_COMP /* use re_comp/re_exec */ #endif #if defined(ultrix) || defined(__ultrix) # define MACHINE_NAME "DECS" # define ULTRIX # define UNIX # ifndef __ultrix /* cc vs. c89 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_STRCASECMP # define HAVE_VFORK #endif #ifdef vms # define OS_NAME "VMS" # ifdef __ALPHA # define ALPHA # define MACHINE_NAME "ALPHA" # pragma extern_model common_block # else # define MACHINE_NAME "VAX" # define NO_ANSI_CPP # define raise gsignal /* raise() not in library ? */ # endif # include # include /* lib$... prototypes */ # include # include # include # include /* sys$... prototypes */ # include # include # include # ifndef R_OK /* no access() modes in unixio.h on VAX/VMS */ # define F_OK 0 # define X_OK 1 # define W_OK 2 # define R_OK 4 # endif # define ARG_STYLE_VMS # define F77_CHAR_DSC_VMS # define F77_EXTERN_LOWERCASE # define HAVE_STAT_H # define HAVE_VFORK /* actually have only vfork */ # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_BSD # define sigmask(sig) (1L << (sig-1)) /* should be in signal.h */ #endif /* vms */ #include #include #include #ifndef NO_FCNTL_H #include #endif #include /* contains strtod() and strtol() on some systems */ #include #include #include #include #include #include #ifndef NO_UNISTD_H #include #endif #ifndef HAVE_VFORK # define vfork fork #endif #ifdef UNIX # define OS_NAME "UNIX" # ifndef unix # define unix # endif # include # include # include # ifndef NO_DIRENT_H /* POSIX opendir() */ # include # else /* BSD opendir() */ # include /* plus */ # define dirent direct /* struct dirent... */ # define S_IRUSR (S_IREAD) /* read permission, owner */ # define S_IWUSR (S_IWRITE) /* write permission, owner */ # define S_IXUSR (S_IEXEC) /* execute/search permission, owner */ # endif # define HAVE_STAT_H # ifndef NO_EDIT_SERVER # define USE_EDIT_SERVER # endif #endif #ifdef SUN # ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 1000000 /* missing in time.h */ # define difftime(t1,t0) ((double)(t1-t0)) # define raise(sig) kill(getpid(),sig) # endif #endif #ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 100 /* missing in VAX/VMS time.h */ #endif #ifdef HAVE_STAT_H # define KmTimeStamp struct stat # define get_stamp(path,stamp) stat(path,stamp) # define cmp_stamp(stamp1,stamp2) ((stamp2)->st_mtime == (stamp1)->st_mtime) #endif #ifndef KmTimeStamp # define KmTimeStamp int # define get_stamp(path,stamp) 0 # define cmp_stamp(stamp1,stamp2) 0 #endif #ifdef MATCH_RE_COMP extern char *re_comp(); extern int re_exec(); #else extern char *regcmp(); extern char *regex(); #endif /* command line arguments recognized by KUARGS */ #if !defined(ARG_STYLE_CMS) && !defined(ARG_STYLE_VMS) # define ARG_STYLE_UNIX #endif #ifndef MACHINE_NAME # define MACHINE_NAME "UNKNOWN" /* value returned by $MACHINE */ #endif #ifndef OS_NAME # define OS_NAME "UNKNOWN" /* value returned by $OS */ #endif /* #define EXTERN must be in one routine to allocate space for globals */ #ifndef EXTERN # define EXTERN extern #endif /* #define STATIC extern if debugger does not see static functions */ #ifndef STATIC # define STATIC static #endif #if defined(__GNUC__) || defined(__STDC__) # ifdef NO_ANSI_CPP # undef NO_ANSI_CPP # endif # ifdef NO_PROTOTYPES # undef NO_PROTOTYPES # endif #endif /* * Preprocessor syntax for token concatenation */ #ifndef NO_ANSI_CPP # define ConCat(con,cat) con##cat #else # define ConCat(con,cat) con/**/cat #endif /* * Prototyping for C functions */ #ifndef NO_PROTOTYPES # define C_PROTO_0(name) \ name(void) # define C_PROTO_1(name,arg1) \ name(arg1) # define C_PROTO_2(name,arg1,arg2) \ name(arg1,arg2) # define C_PROTO_3(name,arg1,arg2,arg3) \ name(arg1,arg2,arg3) # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name(arg1,arg2,arg3,arg4) # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name(arg1,arg2,arg3,arg4,arg5) # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name(arg1,arg2,arg3,arg4,arg5,arg6) # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7) # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13) # define \ C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16) # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name(t1 p1) # define C_DECL_2(name,t1,p1,t2,p2) \ name(t1 p1,t2 p2) # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name(t1 p1,t2 p2,t3 p3) # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name(t1 p1,t2 p2,t3 p3,t4 p4) # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5) # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6) # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7) # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8) # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,t9 p9) # define C_DECL_13(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,\ t9,p9,t10,p10,t11,p11,t12,p12,t13,p13) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,\ t9 p9,t10 p10,t11 p11,t12 p12,t13 p13) #else # define const # define C_PROTO_0(name) \ name() # define C_PROTO_1(name,arg1) \ name() # define C_PROTO_2(name,arg1,arg2) \ name() # define C_PROTO_3(name,arg1,arg2,arg3) \ name() # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name() # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name() # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name() # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name() # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name() # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name() # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13) \ name() #define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16)\ name() # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name( p1) \ t1 p1; # define C_DECL_2(name,t1,p1,t2,p2) \ name( p1, p2) \ t1 p1;t2 p2; # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name( p1, p2, p3) \ t1 p1;t2 p2;t3 p3; # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name( p1, p2, p3, p4) \ t1 p1;t2 p2;t3 p3;t4 p4; # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name( p1, p2, p3, p4, p5) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5; # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name( p1, p2, p3, p4, p5, p6) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6; # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name( p1, p2, p3, p4, p5, p6, p7) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7; # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name( p1, p2, p3, p4, p5, p6, p7, p8) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8; # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name( p1, p2, p3, p4, p5, p6, p7, p8, p9)\ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8;t9 p9; # define C_DECL_13(name,A,a,B,b,C,c,D,d,E,e,F,f,G,g,H,h,I,i,J,j,K,k,L,l,M,m)\ name( a, b, c, d, e, f, g, h, i, j, k, l, m)\ A a;B b;C c;D d;E e;F f;G g;H h;I i;J j;K k;L l;M m; #endif typedef int IntFunc(); typedef char* CharFunc(); typedef char** pCharFunc(); /* valid characters to build KUIP identifiers */ #define isident(c) ( isalnum(c) || ((c)=='_') || ((c)=='@') || ((c)==('$')) ) #define KUMAC_UNWIND -30041961 /* error status to quit macro execution */ /* * convenience functions from kkern.c */ extern C_PROTO_2(char* fexpand, const char*, const char*); extern C_PROTO_3(char* fsearch, const char*, const char*, const char*); extern C_PROTO_2(char* fstrdup, const char*, size_t); extern C_PROTO_2(char* fstr0dup, const char*, size_t); extern C_PROTO_2(char* fstrtrim, const char*, size_t); extern C_PROTO_2(char* fstr0trim, const char*, size_t); extern C_PROTO_2(size_t fstrlen, const char*, size_t); extern C_PROTO_3(size_t fstrset, char*, size_t, const char*); extern C_PROTO_2(double fstrtod, char*, char**); extern C_PROTO_2(int fstrtoi, char*, char**); extern C_PROTO_3(char* fstrvec, char**, int, int*); #ifndef HAVE_STRCASECMP extern C_PROTO_2(int strcasecmp, const char*, const char*); extern C_PROTO_3(int strncasecmp, const char*, const char*, size_t); #endif #ifndef HAVE_STRDUP extern C_PROTO_1(char* strdup, const char*); #endif #ifndef HAVE_STRRSTR extern C_PROTO_2(char* strrstr, const char*, const char*); #endif extern C_PROTO_1(char* str0dup, const char*); extern C_PROTO_2(char* str2dup, const char*, const char*); extern C_PROTO_3(char* str3dup, const char*, const char*, const char*); extern C_PROTO_4(char* str4dup, const char*, const char*, const char*, const char*); extern C_PROTO_5(char* str5dup, const char*, const char*, const char*, const char*, const char*); extern C_PROTO_2(char* strndup, const char*, int); extern C_PROTO_2(char* mstrcat, char*, const char*); extern C_PROTO_3(char* mstr2cat, char*, const char*, const char*); extern C_PROTO_4(char* mstr3cat, char*, const char*, const char*, const char*); extern C_PROTO_5(char* mstr4cat, char*, const char*, const char*, const char*, const char*); extern C_PROTO_3(char* mstrncat, char*, const char*, int); extern C_PROTO_3(char* mstrccat, char*, int, int); extern C_PROTO_2(char* mstricat, char*, int); extern C_PROTO_2(int mstrlen, char**, int); extern C_PROTO_1(char* strqtok, char*); extern C_PROTO_1(char* strlower, char*); extern C_PROTO_1(char* strupper, char*); extern C_PROTO_2(char* strfromd, double, int); extern C_PROTO_2(char* strfromi, int, int); /* * C-interface functions */ extern C_PROTO_0(char* k_getar); extern C_PROTO_2(void k_setar, int, char**); extern C_PROTO_0(void ku_alfa); extern C_PROTO_2(char* ku_appl, int*, int*); extern C_PROTO_1(void ku_cmdl, char*); extern C_PROTO_2(int ku_edit, char*, int); extern C_PROTO_1(int ku_exec, char*); extern C_PROTO_1(int ku_exel, char*); extern C_PROTO_0(char* ku_getc); extern C_PROTO_0(char* ku_gete); extern C_PROTO_0(char* ku_getf); extern C_PROTO_0(int ku_geti); extern C_PROTO_0(char* ku_getl); extern C_PROTO_0(char* ku_getq); extern C_PROTO_0(double ku_getr); extern C_PROTO_0(char* ku_gets); extern C_PROTO_1(char* ku_fcase, char*); extern C_PROTO_2(char* ku_home, char*, char*); extern C_PROTO_1(int ku_intr, int); extern C_PROTO_2(int ku_more, char*, char*); extern C_PROTO_0(int ku_npar); extern C_PROTO_2(void ku_pad, char*, int); extern C_PROTO_0(char* ku_path); extern C_PROTO_2(char* ku_proc, char*, char*); extern C_PROTO_2(int ku_proi, char*, int); extern C_PROTO_2(double ku_pror, char*, double); extern C_PROTO_2(char* ku_pros, char*, char*); extern C_PROTO_0(char** ku_qenv); extern C_PROTO_1(char* ku_qexe, char*); extern C_PROTO_2(int ku_sapp, char*, char*); extern C_PROTO_0(void ku_shut); extern C_PROTO_2(void ku_time, time_t, clock_t); extern C_PROTO_2(void ku_trap, int, int); extern C_PROTO_0(void ku_whag); extern C_PROTO_1(void ku_what, void(*)()); extern C_PROTO_1(char* getline, char*); extern C_PROTO_2(void gl_config, char*, int); extern C_PROTO_1(void gl_histadd, char*); extern C_PROTO_1(void gl_setwidth, int); extern C_PROTO_2(char* input_line, char*, int); extern C_PROTO_0(void leave_kuip); extern C_PROTO_0(void reset_break); #endif +KEEP,KFOR_H #ifndef KFOR_H_INCLUDED #define KFOR_H_INCLUDED /* kfor.h: Fortran-C interface */ /* * Fortran data types */ typedef int INTEGER; typedef int LOGICAL; typedef float REAL; typedef void (*SUBRPTR)(); typedef void SUBROUTINE(); typedef INTEGER INTEGER_FUNCTION(); #ifdef IBM370 #pragma linkage(SUBROUTINE,FORTRAN) #pragma linkage(INTEGER_FUNCTION,FORTRAN) #endif /* * Mapping of C-routine name for Fortran CALL SUB * * #define F77_EXTERN_LOWERCASE ==> void sub() * #define F77_EXTERN_UPPERCASE ==> void SUB() * otherwise ==> void sub_() */ #ifdef F77_EXTERN_UPPERCASE # define F77_NAME(name,NAME) NAME #else # ifdef F77_EXTERN_LOWERCASE # define F77_NAME(name,NAME) name # else # define F77_NAME(name,NAME) ConCat(name,_) # endif #endif #ifndef F77_BLOCK # define F77_BLOCK(name,NAME) F77_NAME(name,NAME) #endif #ifndef F77_COMMON # define F77_COMMON(name) name #endif /* * Routine address in CALL SUB(FUN) ; EXTERNAL FUN * * #define F77_EXTERN_INDIRECT ==> void (**fun)(); * otherwise ==> void (*fun)(); */ #ifdef F77_EXTERN_INDIRECT # define F77_EXTERN_ARG(e) ConCat(e,_dsc) # define F77_EXTERN_DCL(e) SUBROUTINE **ConCat(e,_dsc); # define F77_EXTERN_DEF(e) SUBROUTINE *e = *ConCat(e,_dsc); #else # define F77_EXTERN_ARG(e) e # define F77_EXTERN_DCL(e) SUBROUTINE *e; # define F77_EXTERN_DEF(e) #endif #define F77_EXTERN2ARG(e1,e2) F77_EXTERN_ARG(e1),F77_EXTERN_ARG(e2) #define F77_EXTERN2DCL(e1,e2) F77_EXTERN_DCL(e1) F77_EXTERN_DCL(e2) #define F77_EXTERN2DEF(e1,e2) F77_EXTERN_DEF(e1) F77_EXTERN_DEF(e2) /* * Access to Fortran CHARACTER arguments */ #ifdef F77_CHAR_DSC_VMS /* VMS string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_dsc) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) struct dsc$descriptor_s *ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_dsc)->dsc$a_pointer; \ int ConCat(len_,s) = ConCat(s,_dsc)->dsc$w_length; # define F77_CHAR_DEF_DSC(s,p,l) struct dsc$descriptor_s ConCat(s,__dsc); # define F77_CHAR_ASS_DSC(s,p,l) ConCat(s,__dsc).dsc$w_length = l; \ ConCat(s,__dsc).dsc$b_dtype = DSC$K_DTYPE_T;\ ConCat(s,__dsc).dsc$b_class = DSC$K_CLASS_S;\ ConCat(s,__dsc).dsc$a_pointer = p; # define F77_CHAR_USE_PTR(s,p,l) &ConCat(s,__dsc) # define F77_CHAR_USE_LEN(s,p,l) #endif #ifdef F77_CHAR_DSC_CRAY /* Cray string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_dsc) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) _fcd ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = _fcdtocp(ConCat(s,_dsc)); \ int ConCat(len_,s) = _fcdlen(ConCat(s,_dsc)); # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) _cptofcd(p,l) # define F77_CHAR_USE_LEN(s,p,l) #endif #ifdef F77_CHAR_LEN_IND /* string length passed by reference */ /* * The IBM C/370 compiler passes the Fortran CHARACTER pointer directly * instead of making a private copy. Therefore we have to do the copy * char *s = s_ptr ourself in case the routine uses s as local variable. */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) , ConCat(s,_dsc) # define F77_CHAR_ARG_DCL(s) char *ConCat(s,_ptr); \ F77_CHAR_LEN_IND *ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr); \ int ConCat(len_,s) = *ConCat(s,_dsc); # define F77_CHAR_DEF_DSC(s,p,l) F77_CHAR_LEN_IND ConCat(s,__dsc) = l; # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , &ConCat(s,__dsc) #endif #ifndef F77_CHAR_ARG_PTR /* string length passed by value */ # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(len_,s) # define F77_CHAR_ARG_DCL(s) char *s; int ConCat(len_,s); # define F77_CHAR_ARG_DEF(s) # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , l #endif #ifndef F77_XXXX_ARG_LEN /* length argument of non-CHARACTER arguments */ # define F77_XXXX_ARG_LEN(x) /* nil */ # define F77_XXXX_USE_LEN(x) /* nil */ #endif /* * Fortran-calls-C interface * * To define a C function called by Fortran CALL SUB(A,B,C): * * #define Sub F77_NAME(sub,SUB) * #pragma linkage(SUB,FORTRAN) // for IBM C/370 compiler * * F77_ENTRY_xyz(Sub,a,b,c) // opening { contained in macro * // body ... * } * * Each character in xyz declares the type of the corresponding parameter: * * C = CHARACTER * D = DOUBLE PRECISION * E = EXTERNAL * I = INTEGER * L = LOGICAL * R = REAL * X = COMPLEX * * If a parameter PAR is declared as CHARACTER the macro defines: * * char *PAR; // pointer to string (not terminated by \0 !!!) * int len_PAR; // length of string as defined by Fortran's LEN(PAR) * * The name PAR_dsc is reserved for internal use. * * Note: The function body follows the F77_ENTRY_... macro call directly. * The opening { is generated by the macro. */ #define F77_CHAR_ARG2PTR(c1,c2) \ F77_CHAR_ARG_PTR(c1),F77_CHAR_ARG_PTR(c2) #define F77_CHAR_ARG2LEN(c1,c2) \ F77_CHAR_ARG_LEN(c1) F77_CHAR_ARG_LEN(c2) #define F77_XXXX_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(c1) F77_XXXX_ARG_LEN(c2) #define F77_CHAR_ARG2DCL(c1,c2) \ F77_CHAR_ARG_DCL(c1) F77_CHAR_ARG_DCL(c2) #define F77_CHAR_ARG2DEF(c1,c2) \ F77_CHAR_ARG_DEF(c1) F77_CHAR_ARG_DEF(c2) #define F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG2PTR(c1,c2),F77_CHAR_ARG_PTR(c3) #define F77_CHAR_ARG3LEN(c1,c2,c3) \ F77_CHAR_ARG2LEN(c1,c2) F77_CHAR_ARG_LEN(c3) #define F77_XXXX_ARG3LEN(c1,c2,c3) \ F77_XXXX_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(c3) #define F77_CHAR_ARG3DCL(c1,c2,c3) \ F77_CHAR_ARG2DCL(c1,c2) F77_CHAR_ARG_DCL(c3) #define F77_CHAR_ARG3DEF(c1,c2,c3) \ F77_CHAR_ARG2DEF(c1,c2) F77_CHAR_ARG_DEF(c3) #define F77_CHAR_ARG4PTR(c1,c2,c3,c4) \ F77_CHAR_ARG3PTR(c1,c2,c3),F77_CHAR_ARG_PTR(c4) #define F77_CHAR_ARG4LEN(c1,c2,c3,c4) \ F77_CHAR_ARG3LEN(c1,c2,c3) F77_CHAR_ARG_LEN(c4) #define F77_XXXX_ARG4LEN(c1,c2,c3,c4) \ F77_XXXX_ARG3LEN(c1,c2,c3) F77_XXXX_ARG_LEN(c4) #define F77_CHAR_ARG4DCL(c1,c2,c3,c4) \ F77_CHAR_ARG3DCL(c1,c2,c3) F77_CHAR_ARG_DCL(c4) #define F77_CHAR_ARG4DEF(c1,c2,c3,c4) \ F77_CHAR_ARG3DEF(c1,c2,c3) F77_CHAR_ARG_DEF(c4) #define F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_CHAR_ARG_PTR(c5) #define F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) F77_CHAR_ARG_LEN(c5) #define F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_CHAR_ARG_DCL(c5) #define F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_CHAR_ARG_DEF(c5) #define F77_ENTRY_C(name,c1) \ name( F77_CHAR_ARG_PTR(c1) F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CC(name,c1,c2) \ name( F77_CHAR_ARG2PTR(c1,c2) F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_C3(name,c1,c2,c3) \ name( F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG3LEN(c1,c2,c3) ) \ F77_CHAR_ARG3DCL(c1,c2,c3) \ { F77_CHAR_ARG3DEF(c1,c2,c3) #define F77_ENTRY_C5(name,c1,c2,c3,c4,c5) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) #define F77_ENTRY_C4E(name,c1,c2,c3,c4,e5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_EXTERN_ARG(e5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_EXTERN_DCL(e5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_EXTERN_DEF(e5) #define F77_ENTRY_C4I(name,c1,c2,c3,c4,i5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4), i5 \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) INTEGER *i5; \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) #define F77_ENTRY_C5E(name,c1,c2,c3,c4,c5,e6) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5),F77_EXTERN_ARG(e6) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) F77_EXTERN_DCL(e6) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) F77_EXTERN_DEF(e6) #define F77_ENTRY_CCEE(name,c1,c2,e3,e4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN2ARG(e3,e4) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN2DCL(e3,e4) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN2DEF(e3,e4) #define F77_ENTRY_CCI(name,c1,c2,i3) \ name( F77_CHAR_ARG2PTR(c1,c2), i3 \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) INTEGER *i3; \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_CCIC(name,c1,c2,i3,c4) \ name( F77_CHAR_ARG2PTR(c1,c2), i3, F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(i3) \ F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG3DCL(c1,c2,c4) INTEGER *i3; \ { F77_CHAR_ARG3DEF(c1,c2,c4) #define F77_ENTRY_CCIRCC(name,c1,c2,i3,r4,c5,c6) \ name( F77_CHAR_ARG2PTR(c1,c2), i3, r4, F77_CHAR_ARG2PTR(c5,c6) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG2LEN(i3,r4) \ F77_CHAR_ARG2LEN(c5,c6) ) \ F77_CHAR_ARG4DCL(c1,c2,c5,c6) INTEGER *i3; REAL *r4; \ { F77_CHAR_ARG4DEF(c1,c2,c5,c6) #define F77_ENTRY_CE(name,c1,e2) \ name( F77_CHAR_ARG_PTR(c1),F77_EXTERN_ARG(e2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_EXTERN_DCL(e2) \ { F77_CHAR_ARG_DEF(c1) F77_EXTERN_DEF(e2) #define F77_ENTRY_CI(name,c1,i2) \ name( F77_CHAR_ARG_PTR(c1), i2 F77_CHAR_ARG_LEN(c1) ) \ INTEGER *i2; F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CICI(name,c1,i2,c3,i4) \ name( F77_CHAR_ARG_PTR(c1), i2, F77_CHAR_ARG_PTR(c3), i4 \ F77_CHAR_ARG_LEN(c1) \ F77_XXXX_ARG_LEN(i2) \ F77_CHAR_ARG_LEN(c3) ) \ F77_CHAR_ARG2DCL(c1,c3) INTEGER *i2, *i4; \ { F77_CHAR_ARG2DEF(c1,c3) #define F77_ENTRY_CII(name,c1,i2,i3) \ name( F77_CHAR_ARG_PTR(c1), i2, i3 \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) INTEGER *i2, *i3; \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CIIC(name,c1,i2,i3,c4) \ name( F77_CHAR_ARG_PTR(c1), i2, i3, F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG_LEN(c1) \ F77_XXXX_ARG2LEN(i2,i3) \ F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG2DCL(c1,c4) INTEGER *i2, *i3; \ { F77_CHAR_ARG2DEF(c1,c4) #define F77_ENTRY_CR(name,c1,r2) \ name( F77_CHAR_ARG_PTR(c1), r2 F77_CHAR_ARG_LEN(c1) ) \ REAL *r2; F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_E(name,e1) \ name( F77_EXTERN_ARG(e1) ) \ F77_EXTERN_DCL(e1) \ { F77_EXTERN_DEF(e1) #define F77_ENTRY_IC(name,i1,c2) \ name( i1, F77_CHAR_ARG_PTR(c2) \ F77_XXXX_ARG_LEN(i1) \ F77_CHAR_ARG_LEN(c2) ) \ INTEGER *i1; F77_CHAR_ARG_DCL(c2) \ { F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_ICI(name,i1,c2,i3) \ name( i1, F77_CHAR_ARG_PTR(c2), i3 \ F77_XXXX_ARG_LEN(i1) \ F77_CHAR_ARG_LEN(c2) ) \ INTEGER *i1, *i3; F77_CHAR_ARG_DCL(c2) \ { F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_IIC(name,i1,i2,c3) \ name( i1, i2, F77_CHAR_ARG_PTR(c3) \ F77_XXXX_ARG2LEN(i1,i2) \ F77_CHAR_ARG_LEN(c3) ) \ INTEGER *i1, *i2; F77_CHAR_ARG_DCL(c3) \ { F77_CHAR_ARG_DEF(c3) #define F77_ENTRY_I3C(name,i1,i2,i3,c4) \ name( i1, i2, i3, F77_CHAR_ARG_PTR(c4) \ F77_XXXX_ARG3LEN(i1,i2,i3) \ F77_CHAR_ARG_LEN(c4) ) \ INTEGER *i1, *i2, *i3; \ F77_CHAR_ARG_DCL(c4) \ { F77_CHAR_ARG_DEF(c4) #define F77_ENTRY_I4CCC(name,i1,i2,i3,i4,c5,c6,c7) \ name( i1, i2, i3, i4, F77_CHAR_ARG3PTR(c5,c6,c7) \ F77_XXXX_ARG4LEN(i1,i2,i3,i4) \ F77_CHAR_ARG3LEN(c5,c6,c7) ) \ INTEGER *i1, *i2, *i3, *i4; \ F77_CHAR_ARG3DCL(c5,c6,c7) \ { F77_CHAR_ARG3DEF(c5,c6,c7) #define F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_DEF_DSC(s1,p1,l1) F77_CHAR_DEF_DSC(s2,p2,l2) #define F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS_DSC(s1,p1,l1) F77_CHAR_ASS_DSC(s2,p2,l2) #define F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_PTR(s1,p1,l1),F77_CHAR_USE_PTR(s2,p2,l2) #define F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_LEN(s1,p1,l1) F77_CHAR_USE_LEN(s2,p2,l2) #define F77_XXXX_USE2LEN(x1,x2) \ F77_XXXX_USE_LEN(x1) F77_XXXX_USE_LEN(x2) #define F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_DEF_DSC(s3,p3,l3) #define F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_ASS_DSC(s3,p3,l3) #define F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2),F77_CHAR_USE_PTR(s3,p3,l3) #define F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) F77_CHAR_USE_LEN(s3,p3,l3) #define F77_XXXX_USE3LEN(x1,x2,x3) \ F77_XXXX_USE2LEN(x1,x2) F77_XXXX_USE_LEN(x3) #define F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_DEF_DSC(s4,p4,l4) #define F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_ASS_DSC(s4,p4,l4) #define F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3),F77_CHAR_USE_PTR(s4,p4,l4) #define F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_USE_LEN(s4,p4,l4) #define F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_XXXX_USE3LEN(x1,x2,x3) F77_XXXX_USE_LEN(x4) #define F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) F77_XXXX_USE_LEN(x5) #ifdef IBM370 #pragma linkage(K77C,FORTRAN) #define F77_CALL_C(name,p1,l1) do { \ SUBROUTINE *F77 = name; \ K77C(&F77,p1,l1); } while(0) #else #define F77_CALL_C(name,p1,l1) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1) \ F77_CHAR_USE_LEN(s1,p1,l1) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77CC(&F77,p1,l1,p2,l2); } while(0) #else #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77C3,FORTRAN) #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77C3(&F77,p1,l1,p2,l2,p3,l3); } while(0) #else #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ name( F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77C7,FORTRAN) #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ SUBROUTINE *F77 = name; \ K77C7(&F77,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); } while(0) #else #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ name( F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4), \ F77_CHAR_USE3PTR(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx,FORTRAN) #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77CCx(&F77,p1,l1,p2,l2,x3); } while(0) #else #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx3,FORTRAN) #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ SUBROUTINE *F77 = name; \ K77CCx3(&F77,p1,l1,p2,l2,x3,x4,x5); } while(0) #else #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4,x5 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE3LEN(x3,x4,x5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cx,FORTRAN) #define F77_CALL_Cx(name,p1,l1,x2) do { \ SUBROUTINE *F77 = name; \ K77Cx(&F77,p1,l1,x2); } while(0) #else #define F77_CALL_Cx(name,p1,l1,x2) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cxx,FORTRAN) #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ SUBROUTINE *F77 = name; \ K77Cxx(&F77,p1,l1,x2,x3); } while(0) #else #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2,x3 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE2LEN(x2,x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xC,FORTRAN) #define F77_CALL_xC(name,x1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77xC(&F77,x1,p2,l2); } while(0) #else #define F77_CALL_xC(name,x1,p2,l2) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCCx,FORTRAN) #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ SUBROUTINE *F77 = name; \ K77xCCx(&F77,x1,p2,l2,p3,l3,x4); } while(0) #else #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ name( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3), \ x4 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x4) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCx,FORTRAN) #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77xCx(&F77,x1,p2,l2,x3); } while(0) #else #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77x4C,FORTRAN) #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ SUBROUTINE *F77 = name; \ K77x4C(&F77,x1,x2,x3,x4,p5,l5); } while(0) #else #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(KIGMENU,FORTRAN) /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 */ #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ SUBROUTINE *F77 = name; \ KIGMENU(&F77,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N); } while(0) #else #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ F77_CHAR_DEF_DSC(sb,b,B) \ F77_CHAR_DEF_DSC(sh,h,H) \ F77_CHAR_DEF3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_DEF_DSC(sn,n,N) \ F77_CHAR_ASS_DSC(sb,b,B) \ F77_CHAR_ASS_DSC(sh,h,H) \ F77_CHAR_ASS3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_ASS_DSC(sn,n,N) \ name( a, \ F77_CHAR_USE_PTR(sb,b,B), \ c,d,e,f,g, \ F77_CHAR_USE_PTR(sh,h,H), \ i, \ F77_CHAR_USE3PTR(sj,j,J,sk,k,K,sl,l,L), \ m, \ F77_CHAR_USE_PTR(sn,n,N) \ F77_XXXX_USE_LEN(a) \ F77_CHAR_USE_LEN(sb,b,B) \ F77_XXXX_USE5LEN(c,d,e,f,g) \ F77_CHAR_USE_LEN(sh,h,H) \ F77_XXXX_USE_LEN(i) \ F77_CHAR_USE3LEN(sj,j,J,sk,k,K,sl,l,L) \ F77_XXXX_USE_LEN(m) \ F77_CHAR_USE_LEN(sn,n,N) \ ); } while(0) #endif /* * routines called by Fortran */ #define Errrun F77_NAME(errrun,ERRRUN) #define Fmemcpy F77_NAME(fmemcpy,FMEMCPY) #define Getarg F77_NAME(getarg,GETARG) extern SUBROUTINE Getarg; #define Goparm F77_NAME(goparm,GOPARM) extern SUBROUTINE Goparm; #define Gl_char_cleanup F77_NAME(gl_char_cleanup,GL_CHAR_CLEANUP) #define Gl_reset F77_NAME(gl_reset,GL_RESET) #define Gl_reinit F77_NAME(gl_reinit,GL_REINIT) #define Iclrwk F77_NAME(iclrwk,ICLRWK) extern SUBROUTINE Iclrwk; #define Iginit F77_NAME(iginit,IGINIT) extern SUBROUTINE Iginit; #define Igmenu F77_NAME(igmenu,IGMENU) extern SUBROUTINE Igmenu; #define Igrng F77_NAME(igrng,IGRNG) extern SUBROUTINE Igrng; #define Igsse F77_NAME(igsse,IGSSE) extern SUBROUTINE Igsse; #define Igsrap F77_NAME(igsrap,IGSRAP) extern SUBROUTINE Igsrap; #define Igwkty F77_NAME(igwkty,IGWKTY) extern SUBROUTINE Igwkty; #define Kcexec F77_NAME(kcexec,KCEXEC) #define Kdialo F77_NAME(kdialo,KDIALO) extern SUBROUTINE Kdialo; #define Kgetar F77_NAME(kgetar,KGETAR) #define Kialid F77_NAME(kialid,KIALID) #define Kiargc F77_NAME(kiargc,KIARGC) extern INTEGER_FUNCTION Kiargc; #define Kibres F77_NAME(kibres,KIBRES) extern SUBROUTINE Kibres; #define Kiclos F77_NAME(kiclos,KICLOS) extern SUBROUTINE Kiclos; #define Kierrf F77_NAME(kierrf,KIERRF) extern SUBROUTINE Kierrf; #define Kiinit F77_NAME(kiinit,KIINIT) extern SUBROUTINE Kiinit; #define Kilun F77_NAME(kilun,KILUN) extern SUBROUTINE Kilun; #define Kimdef F77_NAME(kimdef,KIMDEF) #define Kimexe F77_NAME(kimexe,KIMEXE) #define Kipawc F77_NAME(kipawc,KIPAWC) #define Kiprmt F77_NAME(kiprmt,KIPRMT) #define Kirtim F77_NAME(kirtim,KIRTIM) #define Kisigm F77_NAME(kisigm,KISIGM) #define Kmpst2 F77_NAME(kmpst2,KMPST2) #define Kmpst3 F77_NAME(kmpst3,KMPST3) #define Kmpx22 F77_NAME(kmpx22,KMPX22) #define Kmpx23 F77_NAME(kmpx23,KMPX23) #define Kmvsed F77_NAME(kmvsed,KMVSED) extern SUBROUTINE Kmvsed; #define Kmvspg F77_NAME(kmvspg,KMVSPG) extern SUBROUTINE Kmvspg; #define Kmvssh F77_NAME(kmvssh,KMVSSH) extern SUBROUTINE Kmvssh; #define Ksvpar F77_NAME(ksvpar,KSVPAR) #define Kuach F77_NAME(kuach,KUACH) #define Kuact F77_NAME(kuact,KUACT) #define Kualfa F77_NAME(kualfa,KUALFA) #define Kuappl F77_NAME(kuappl,KUAPPL) #define Kuargs F77_NAME(kuargs,KUARGS) #define Kubrek F77_NAME(kubrek,KUBREK) #define Kubrof F77_NAME(kubrof,KUBROF) #define Kubron F77_NAME(kubron,KUBRON) #define Kucmd F77_NAME(kucmd,KUCMD) #define Kucmdl F77_NAME(kucmdl,KUCMDL) #define Kuedit F77_NAME(kuedit,KUEDIT) #define Kuesvr F77_NAME(kuesvr,KUESVR) #define Kueusr F77_NAME(kueusr,KUEUSR) #define Kuexec F77_NAME(kuexec,KUEXEC) #define Kuexel F77_NAME(kuexel,KUEXEL) #define Kuexit F77_NAME(kuexit,KUEXIT) #define Kufcas F77_NAME(kufcas,KUFCAS) #define Kugetc F77_NAME(kugetc,KUGETC) #define Kugete F77_NAME(kugete,KUGETE) #define Kugetf F77_NAME(kugetf,KUGETF) #define Kugeti F77_NAME(kugeti,KUGETI) #define Kugetl F77_NAME(kugetl,KUGETL) #define Kugetq F77_NAME(kugetq,KUGETQ) #define Kugetr F77_NAME(kugetr,KUGETR) #define Kugets F77_NAME(kugets,KUGETS) #define Kugrfl F77_NAME(kugrfl,KUGRFL) #define Kuguid F77_NAME(kuguid,KUGUID) #define Kuhelp F77_NAME(kuhelp,KUHELP) #define Kuhome F77_NAME(kuhome,KUHOME) #define Kuidf1 F77_NAME(kuidf1,KUIDF1) extern SUBROUTINE Kuidf1; #define Kuidf2 F77_NAME(kuidf2,KUIDF2) extern SUBROUTINE Kuidf2; #define Kuidfm F77_NAME(kuidfm,KUIDFM) #define Kuinim F77_NAME(kuinim,KUINIM) #define Kuinit F77_NAME(kuinit,KUINIT) #define Kulun F77_NAME(kulun,KULUN) #define Kumloc F77_NAME(kumloc,KUMLOC) #define Kumout F77_NAME(kumout,KUMOUT) #define Kumpad F77_NAME(kumpad,KUMPAD) #define Kumpst F77_NAME(kumpst,KUMPST) #define Kumpx2 F77_NAME(kumpx2,KUMPX2) #define Kundpv F77_NAME(kundpv,KUNDPV) #define Kunpar F77_NAME(kunpar,KUNPAR) #define Kunwg F77_NAME(kunwg,KUNWG) #define Kuopen F77_NAME(kuopen,KUOPEN) extern SUBROUTINE Kuopen; #define Kupad F77_NAME(kupad,KUPAD) #define Kupar F77_NAME(kupar,KUPAR) #define Kupath F77_NAME(kupath,KUPATH) #define Kupatl F77_NAME(kupatl,KUPATL) #define Kuproc F77_NAME(kuproc,KUPROC) #define Kuproi F77_NAME(kuproi,KUPROI) #define Kupror F77_NAME(kupror,KUPROR) #define Kupros F77_NAME(kupros,KUPROS) #define Kupval F77_NAME(kupval,KUPVAL) #define Kuqcas F77_NAME(kuqcas,KUQCAS) #define Kuqenv F77_NAME(kuqenv,KUQENV) #define Kuqexe F77_NAME(kuqexe,KUQEXE) #define Kuqsvr F77_NAME(kuqsvr,KUQSVR) #define Kuquit F77_NAME(kuquit,KUQUIT) #define Kusapp F77_NAME(kusapp,KUSAPP) #define Kusibr F77_NAME(kusibr,KUSIBR) #define Kusigm F77_NAME(kusigm,KUSIGM) #define Kuspy F77_NAME(kuspy,KUSPY) #define Kustat F77_NAME(kustat,KUSTAT) #define Kuterm F77_NAME(kuterm,KUTERM) #define Kutime F77_NAME(kutime,KUTIME) #define Kutim0 F77_NAME(kutim0,KUTIM0) extern SUBROUTINE Kutim0; #define Kutrue F77_NAME(kutrue,KUTRUE) #define Kuser F77_NAME(kuser,KUSER) #define Kuvcre F77_NAME(kuvcre,KUVCRE) extern SUBROUTINE Kuvcre; #define Kuvdel F77_NAME(kuvdel,KUVDEL) extern SUBROUTINE Kuvdel; #define Kuvect F77_NAME(kuvect,KUVECT) extern SUBROUTINE Kuvect; #define Kuwhag F77_NAME(kuwhag,KUWHAG) #define Kuwham F77_NAME(kuwham,KUWHAM) #define Kuwhat F77_NAME(kuwhat,KUWHAT) #define Kxali1 F77_NAME(kxali1,KXALI1) #define Kxpanlm F77_NAME(kxpanlm,KXPANLM) extern SUBROUTINE Kxpanlm; #define Macdef F77_NAME(macdef,MACDEF) extern SUBROUTINE Macdef; #define Mdmenu F77_NAME(mdmenu,MDMENU) #define Mhi_close F77_NAME(mhi_close,MHI_CLOSE) extern SUBROUTINE Mhi_close; #define Mhi_open F77_NAME(mhi_open,MHI_OPEN) extern SUBROUTINE Mhi_open; #define Mzwipe F77_NAME(mzwipe,MZWIPE) extern SUBROUTINE Mzwipe; #define Traceq F77_NAME(traceq,TRACEQ) extern SUBROUTINE Traceq; #ifdef IBM370 # pragma linkage(ERRRUN,FORTRAN) # pragma linkage(FMEMCPY,FORTRAN) # pragma linkage(GOPARM,FORTRAN) # pragma linkage(ICLRWK,FORTRAN) # pragma linkage(IGINIT,FORTRAN) # pragma linkage(IGMENU,FORTRAN) # pragma linkage(IGRNG,FORTRAN) # pragma linkage(IGSSE,FORTRAN) # pragma linkage(IGSRAP,FORTRAN) # pragma linkage(IGWKTY,FORTRAN) # pragma linkage(KCEXEC,FORTRAN) # pragma linkage(KDIALO,FORTRAN) # pragma linkage(KGETAR,FORTRAN) # pragma linkage(KIALID,FORTRAN) # pragma linkage(KIBRES,FORTRAN) # pragma linkage(KICLOS,FORTRAN) # pragma linkage(KIERRF,FORTRAN) # pragma linkage(KIINIT,FORTRAN) # pragma linkage(KILUN,FORTRAN) # pragma linkage(KIMDEF,FORTRAN) # pragma linkage(KIMEXE,FORTRAN) # pragma linkage(KIPAWC,FORTRAN) # pragma linkage(KIPRMT,FORTRAN) # pragma linkage(KIRTIM,FORTRAN) # pragma linkage(KISIGM,FORTRAN) # pragma linkage(KMPST2,FORTRAN) # pragma linkage(KMPST3,FORTRAN) # pragma linkage(KMPX22,FORTRAN) # pragma linkage(KMPX23,FORTRAN) # pragma linkage(KMVSED,FORTRAN) # pragma linkage(KMVSPG,FORTRAN) # pragma linkage(KMVSSH,FORTRAN) # pragma linkage(KSVPAR,FORTRAN) # pragma linkage(KUACH,FORTRAN) # pragma linkage(KUACT,FORTRAN) # pragma linkage(KUALFA,FORTRAN) # pragma linkage(KUAPPL,FORTRAN) # pragma linkage(KUARGS,FORTRAN) # pragma linkage(KUBREK,FORTRAN) # pragma linkage(KUBROF,FORTRAN) # pragma linkage(KUBRON,FORTRAN) # pragma linkage(KUCMD,FORTRAN) # pragma linkage(KUCMDL,FORTRAN) # pragma linkage(KUEDIT,FORTRAN) # pragma linkage(KUESVR,FORTRAN) # pragma linkage(KUEUSR,FORTRAN) # pragma linkage(KUEXEC,FORTRAN) # pragma linkage(KUEXEL,FORTRAN) # pragma linkage(KUEXIT,FORTRAN) # pragma linkage(KUFCAS,FORTRAN) # pragma linkage(KUGETC,FORTRAN) # pragma linkage(KUGETE,FORTRAN) # pragma linkage(KUGETF,FORTRAN) # pragma linkage(KUGETI,FORTRAN) # pragma linkage(KUGETL,FORTRAN) # pragma linkage(KUGETQ,FORTRAN) # pragma linkage(KUGETR,FORTRAN) # pragma linkage(KUGETS,FORTRAN) # pragma linkage(KUGRFL,FORTRAN) # pragma linkage(KUGUID,FORTRAN) # pragma linkage(KUHELP,FORTRAN) # pragma linkage(KUHOME,FORTRAN) # pragma linkage(KUIDF1,FORTRAN) # pragma linkage(KUIDF2,FORTRAN) # pragma linkage(KUIDFM,FORTRAN) # pragma linkage(KUINIM,FORTRAN) # pragma linkage(KUINIT,FORTRAN) # pragma linkage(KULUN,FORTRAN) # pragma linkage(KUMLOC,FORTRAN) # pragma linkage(KUMOUT,FORTRAN) # pragma linkage(KUMPAD,FORTRAN) # pragma linkage(KUMPST,FORTRAN) # pragma linkage(KUMPX2,FORTRAN) # pragma linkage(KUNDPV,FORTRAN) # pragma linkage(KUNPAR,FORTRAN) # pragma linkage(KUNWG,FORTRAN) # pragma linkage(KUOPEN,FORTRAN) # pragma linkage(KUPAD,FORTRAN) # pragma linkage(KUPAR,FORTRAN) # pragma linkage(KUPATH,FORTRAN) # pragma linkage(KUPATL,FORTRAN) # pragma linkage(KUPROC,FORTRAN) # pragma linkage(KUPROI,FORTRAN) # pragma linkage(KUPROR,FORTRAN) # pragma linkage(KUPROS,FORTRAN) # pragma linkage(KUPVAL,FORTRAN) # pragma linkage(KUQCAS,FORTRAN) # pragma linkage(KUQENV,FORTRAN) # pragma linkage(KUQEXE,FORTRAN) # pragma linkage(KUQSVR,FORTRAN) # pragma linkage(KUQUIT,FORTRAN) # pragma linkage(KUSAPP,FORTRAN) # pragma linkage(KUSIBR,FORTRAN) # pragma linkage(KUSIGM,FORTRAN) # pragma linkage(KUSPY,FORTRAN) # pragma linkage(KUSTAT,FORTRAN) # pragma linkage(KUTERM,FORTRAN) # pragma linkage(KUTIME,FORTRAN) # pragma linkage(KUTIM0,FORTRAN) # pragma linkage(KUTRUE,FORTRAN) # pragma linkage(KUSER,FORTRAN) # pragma linkage(KUVCRE,FORTRAN) # pragma linkage(KUVDEL,FORTRAN) # pragma linkage(KUVECT,FORTRAN) # pragma linkage(KUWHAG,FORTRAN) # pragma linkage(KUWHAM,FORTRAN) # pragma linkage(KUWHAT,FORTRAN) # pragma linkage(KXALI1,FORTRAN) # pragma linkage(KXPANLM,FORTRAN) # pragma linkage(MACDEF,FORTRAN) # pragma linkage(MDMENU,FORTRAN) # pragma linkage(MHI_CLOSE,FORTRAN) # pragma linkage(MHI_OPEN,FORTRAN) # pragma linkage(MZWIPE,FORTRAN) # pragma linkage(TRACEQ,FORTRAN) #endif #define MAXCMD 512 /* max length of a command line */ #define MAXEDT 32 /* max length of names in edit server */ #define MAXLEV 10 /* max levels of command name path */ #define MAXSVR 20 /* max number of edit server processes */ /* * The PAWC common is referenced through a pointer to allow the use of * dynamic common blocks on IBM systems. */ #define Pawc kc_pawc EXTERN struct COMMON_PAWC { INTEGER NWPAR; INTEGER IXPAWC; INTEGER IHBOOK; INTEGER IXHIGZ; INTEGER IXKUIP; INTEGER IFENCE[5]; INTEGER LQ[8]; INTEGER DATA[999]; } *Pawc; #define IQ(n) Pawc->DATA[n-1] #define Q(n) (((REAL*)(Pawc->DATA))[n-1]) #endif +KEEP,KCOM_H #ifndef KCOM_H_INCLUDED #define KCOM_H_INCLUDED /* kcom.h: Fortran COMMON blocks */ #define Kcalia F77_BLOCK(kcalia,KCALIA) #define MALIAS 200 EXTERN struct { INTEGER NALIAS; LOGICAL ALIFLG; INTEGER ALITYP[MALIAS]; } F77_COMMON(Kcalia); #define Kcalic F77_BLOCK(kcalic,KCALIC) EXTERN struct { char ALINAM[MALIAS][60]; char ALIVAL[MALIAS][80]; } F77_COMMON(Kcalic); #define Kcbrek F77_BLOCK(kcbrek,KCBREK) EXTERN struct { LOGICAL TRAP; /* flag if signal trapping is enabled */ LOGICAL BRKEN; /* not used, always true */ LOGICAL FIRST; /* only used for Apollo */ LOGICAL FIRSG; /* only used for Apollo */ LOGICAL CLWHAT; /* flag if KUWHAT installed break handler */ LOGICAL CLWHAG; /* flag if KUWHAG installed break handler */ LOGICAL TBFLAG; /* flag if traceback should be printed */ } F77_COMMON(Kcbrek); #define Kcefil F77_BLOCK(kcefil,KCEFIL) EXTERN struct { char EDTFIL[MAXSVR][MAXEDT]; /* file name */ char EDTCMD[MAXSVR][MAXEDT]; /* KUIP command */ } F77_COMMON(Kcefil); #define Kcesvr F77_BLOCK(kcesvr,KCESVR) EXTERN struct { INTEGER NSVFIL; /* number of edited file */ INTEGER NSVCUR; /* pointer to current file */ SUBRPTR IESADD; /* routine set by KUEUSR */ LOGICAL SERVER; /* flag if edit server is used */ } F77_COMMON(Kcesvr); #define Kcexit F77_BLOCK(kcexit,KCEXIT) EXTERN struct { SUBRPTR IEXADD; /* routine set by KUEXIT */ SUBRPTR IUSADD; /* routine set by KUSER */ SUBRPTR NEXADD; /* routine set by KUNEXT */ SUBRPTR IUTADD; /* routine set by KUTERM */ SUBRPTR IQUADD; /* routine set by KUQUIT */ SUBRPTR IBRADD; /* routine set by KUBREK */ LOGICAL LICALL; LOGICAL LICAL2; LOGICAL LICAL3; } F77_COMMON(Kcexit); #define Kcmac F77_BLOCK(kcmac,KCMAC) EXTERN struct { LOGICAL MACTAB; INTEGER NSTLEV; LOGICAL QUITFL; LOGICAL WAITFL; LOGICAL WAITFF; LOGICAL DEBTAB; LOGICAL SKIPFL; LOGICAL HEADFL; INTEGER IONERF; LOGICAL NOEXEC; } F77_COMMON(Kcmac); #define Kcparc F77_BLOCK(kcparc,KCPARC) EXTERN struct { char PARLST[512]; /* interface block for KUSER */ char CLIST[80]; char NOALIN[512]; char COMAND[80]; char CHLAST[512]; char NONPOS[512]; } F77_COMMON(Kcparc); #define Kcsigm F77_BLOCK(kcsigm,KCSIGM) EXTERN struct { SUBRPTR ISIADD; /* routine set by KUSIGM */ INTEGER NVSIGM; /* number of temp vectors create for $SIGMA */ } F77_COMMON(Kcsigm); #define Kcutil F77_BLOCK(kcutil,KCUTIL) EXTERN struct { INTEGER NCMD; INTEGER IWD; INTEGER LUNFIL; INTEGER LPRMPT; LOGICAL TIMING; LOGICAL TRACE; INTEGER CALMOD; INTEGER NVADD; INTEGER IREPET; INTEGER IREFAC; INTEGER IBRAK; LOGICAL TIMALL; INTEGER LENTER; LOGICAL UNIQUE; INTEGER LENMUL; LOGICAL MULTFL; LOGICAL HISTOK; LOGICAL NOHIST; INTEGER LENMUM; LOGICAL FILCAS; LOGICAL MEXEFL; } F77_COMMON(Kcutil); #define Kcvect F77_BLOCK(kcvect,KCVECT) EXTERN struct { INTEGER NUMVEC; /* number of vectors stored */ INTEGER TOTPAV; INTEGER GETPAV; LOGICAL TVECFL; } F77_COMMON(Kcvect); #define Quest F77_BLOCK(quest,QUEST) EXTERN struct { INTEGER DATA[100]; } F77_COMMON(Quest); #define IQUEST(n) Quest.DATA[n-1] #define Sikuip F77_BLOCK(sikuip,SIKUIP) EXTERN struct { char CHSIGM[80]; /* command string passed to SIGMA */ } F77_COMMON(Sikuip); #endif +KEEP,KSIG_H #ifndef KSIG_H_INCLUDED #define KSIG_H_INCLUDED /* ksig.h: signal and break handling */ /* * Available signal handling package * * #define SIGNAL_POSIX ==> sigaction() for Unix * #define SIGNAL_BSD ==> sigvec() for VMS and NeXT * #define SIGNAL_V7 ==> signal() */ #if !defined(SIGNAL_BSD) && !defined(SIGNAL_V7) # define SIGNAL_POSIX #else # define sigjmp_buf jmp_buf # define sigsetjmp(buf,save) setjmp(buf) # define siglongjmp(buf,val) longjmp(buf,val) # ifdef vms # define sv_flags sv_onstack # endif #endif EXTERN struct { int trap_enabled; /* flag if exceptions should be trapped */ int traceback; /* print traceback on signal */ int intr_count; /* count number of consecutive ^C interrupts */ int jump_set; /* flag if stack has been setup */ sigjmp_buf stack; } kc_break; #endif +KEEP,KBROW_H1 typedef unsigned long KmPixmap; /* Pixmap from */ \ typedef void *KmWidget; /* Widget from */ \ typedef void *KmCalldata; /* XmAnyCallbackStruct from */ \ /* */ \ typedef enum { /* */ \ BRACT_OPEN = 0, /* */ \ BRACT_ROOT = 1, /* */ \ BRACT_CONT = 2, /* */ \ BRACT_GRAF = 3 /* */ \ } BrActTag; /* */ \ /* */ \ typedef enum { /* */ \ BrActUpdate = 0x01, /* browser window has to be updated ('!') */ \ BrActSeparator = 0x02, /* put separator in menu ('/') */ \ BrActToggle = 0x04, /* register as toggle button */ \ BrActToggleOn = 0x08, /* toggle state is on */ \ BrActSensitive = 0x10 /* button is sensitive */ \ } BrActFlag; /* */ \ /* */ \ typedef struct _BrAction { /* */ \ struct _BrAction *next; /* link to next action binding */ \ BrActFlag flags; /* */ \ char *text; /* text line in menu */ \ char *user_text; /* user text overriding CDF text (malloced)*/ \ char *accel; /* accelerator */ \ char *exec; /* action commands */ \ SUBROUTINE *call_F; /* action routine */ \ IntFunc *call_C; /* action function */ \ BrActTag tag; /* for which window the action is defined */ \ struct _BrClass *class; /* pointer to BrClass in case of open menu */ \ } BrAction; /* */ \ /* */ \ typedef struct _BrClass { /* */ \ struct _BrClass *next; /* link to next browsable class */ \ char *name; /* unique identifier name */ \ char *title; /* title for popup menu (maybe NULL) */ \ SUBROUTINE *scan_km_F; /* user function scanning the directory */ \ pCharFunc *scan_km_C; /* user function scanning the directory */ \ SUBROUTINE *scan_br_F; /* user function scanning for browsables */ \ pCharFunc *scan_br_C; /* user function scanning for browsables */ \ BrAction *root; /* list of actions in root window */ \ BrAction *open; /* list of actions in open menu */ \ } BrClass; /* */ \ /* */ \ +KEEP,KBROW_H2 typedef struct _KmIcon { /* */ \ struct _KmIcon *next; /* link to next icon */ \ char *name; /* unique identifier name */ \ int width; /* width of the pixmap */ \ int height; /* height of the pixmap */ \ char *bitmap; /* bitmap data */ \ KmPixmap pix; /* filled in Motif part */ \ KmPixmap hi_pix; /* high lighted pixmap */ \ } KmIcon; /* */ \ /* */ \ typedef struct _KmClass { /* */ \ struct _KmClass *next; /* link to next object class */ \ int is_dir; /* flag if class has is a directory */ \ char *name; /* unique identifier name */ \ char *title; /* title for popup menu (maybe NULL) */ \ char *big_icon; /* name of the big icon */ \ KmIcon *bicon; /* pointer to the big icon structure */ \ char *sm_icon; /* name of the small icon */ \ KmIcon *sicon; /* pointer to the small icon structure */ \ SUBROUTINE *user_icon_F; /* user function to return icon bitmap */ \ IntFunc *user_icon_C; /* user function to return icon bitmap */ \ BrAction *cont; /* list of actions in content window */ \ BrAction *graf; /* list of actions in graphics window */ \ int obj_count; /* number of objects in content window */ \ } KmClass; /* */ \ /* */ \ typedef enum { /* */ \ KmButtSensitive = 0x00, /* sensitive button */ \ KmButtNonSensitive = 0x01, /* non-sensitive button ('NS') */ \ KmButtToggleSensitive = 0x02, /* toggle-sensitive button ('TS') */ \ KmButtSensitivityMask = 0x03, /* mask for sensitivity type */ \ KmButtSeparator = 0x04 /* put separator in menu ('/') */ \ } KmButtFlag; /* */ \ /* */ \ typedef struct _KmButton { /* */ \ struct _KmButton *next; /* button label or menu item */ \ char *label; /* button label or menu item */ \ char *menu; /* menu name or NULL for buttons */ \ KmButtFlag flags; /* sensitivity type etc. */ \ SUBROUTINE *action_F; /* Fortran routine called with (LABEL,MENU)*/ \ IntFunc *action_C; /* C function called with (label,menu) */ \ KmWidget widget; /* Motif widget ID */ \ } KmButton; /* */ \ +KEEP,KBROW_Q1 "\ +SEQ,KBROW_H1 " +KEEP,KBROW_Q2 "\ +SEQ,KBROW_H2 " +KEEP,KBROW_H #ifndef KBROW_H_INCLUDED #define KBROW_H_INCLUDED /* kbrow.h: browser definitions */ #define KBROW_H1 \ +SEQ,KBROW_H1 KBROW_H1 #define KBROW_H2 \ +SEQ,KBROW_H2 KBROW_H2 typedef struct _KmObject { struct _KmObject *next; /* link to next object definition */ char *name; /* unique identifier name */ char *stext; /* short description text */ char *ltext; /* long description text */ KmClass *class; /* pointer to objects's class structure */ } KmObject; typedef struct _BrVariable { struct _BrVariable *next; /* link to next variable definition */ char *name; /* variable name */ char *value; /* replacement value */ } BrVariable; typedef struct _BrObject { struct _BrObject *next; /* link to next browsable object */ char *name; /* name of the browsable object */ BrClass *class; /* pointer to browsable's class structure */ BrVariable *vars; /* linked list of variable substitutions */ } BrObject; typedef struct _BrClientdata { BrActTag tag; char *brobj; char *brcls; char *path; char *kmobj; char *kmcls; char *stext; char *ltext; char *mtext; } BrClientdata; EXTERN BrClass *brclasses; EXTERN KmObject *kmobjects; EXTERN KmButton *kmbuttons; extern C_PROTO_2(void klnkbrcl, BrClass*, int); extern C_PROTO_2(void klnkkmcl, KmClass*, int); extern C_PROTO_2(void klnkicon, KmIcon*, int); extern C_PROTO_2(void klnkbutt, KmButton*, int); extern C_PROTO_6(void exec_action, BrAction*, char*, char*, int, KmWidget, KmCalldata); extern C_PROTO_2(KmWidget find_button, char*, char*); extern C_PROTO_1(KmIcon* find_kmicon, char*); extern C_PROTO_1(KmClass* find_kmclass, char*); extern C_PROTO_1(BrObject* find_brobject, char*); extern C_PROTO_2(char* get_variable, char*, char*); extern C_PROTO_0(BrObject* scan_brobjects); extern C_PROTO_3(KmObject* scan_kmobjects, char*, char*, int); extern C_PROTO_7(int set_action, char*, int, int, char*, char*, int, int); extern C_PROTO_3(void set_variable, BrObject*, char*, char*); #endif +KEEP,KLINK_H1 struct { /* */ \ /* indirect calls to avoid linking HIGZ */ \ IntFunc *graf_info_C; /* pass display, open and close (ixmotif) */ \ SUBROUTINE *graf_size_F; /* resize window (IGRSIZ) */ \ SUBROUTINE *graf_pick_F; /* identifying graphics objects (IGOBJ) */ \ SUBROUTINE *graf_attr_F; /* set attributes (IGSET) */ \ SUBROUTINE *graf_close_F; /* close workstation (ICLWK) */ \ /* optional routines for Motif customization */ \ pCharFunc *user_FallBk_C; /* get application fallbacks */ \ IntFunc *user_TopWid_C; /* pass toplevel widget identifiers */ \ } klnkaddr; /* */ \ +KEEP,KLINK_Q1 "extern \ +SEQ,KLINK_H1 " +KEEP,KLINK_H #ifndef KLINK_H_INCLUDED #define KLINK_H_INCLUDED /* klink.h: demand linking of special routines */ #define KLINK_H1 EXTERN \ +SEQ,KLINK_H1 KLINK_H1 EXTERN struct { SUBROUTINE *user_exit_F; /* set by KUEXIT */ SUBROUTINE *user_quit_F; /* set by KUQUIT */ SUBROUTINE *user_break_F; /* set by KUBREK */ SUBROUTINE *user_edit_F; /* set by KUEUSR */ SUBROUTINE *user_sigma_F; /* set by KUSIGM */ SUBROUTINE *user_grfl_F; /* set by KUGRFL */ SUBROUTINE *user_term_F; /* set by KUTERM */ SUBROUTINE *user_input_F; /* set by KUSER */ SUBROUTINE *user_locate_F; /* set by KUMLOC */ /* indirect calls to avoid linking Motif */ IntFunc *disp_panel_C; /* display command panel (km_display_cmdpan) */ IntFunc *disp_text_C; /* display text widget (km_display_sctext) */ IntFunc *disp_choice_C; /* display a choice of commands (?) */ IntFunc *disp_clean_C; /* clean before action (km_destroy_all_popup)*/ IntFunc *disp_flush_C; /* flush event queue (FlushEvents) */ IntFunc *disp_busy_C; /* show busy cursor (km_all_cursor) */ IntFunc *disp_exit_C; /* ask confirmation for exit */ IntFunc *disp_quit_C; /* ask confirmation for exit */ IntFunc *disp_select_C; /* select from a number of buttons */ CharFunc *disp_prompt_C; /* prompt for input */ /* indirect calls to avoid linking HIGZ without style G */ IntFunc *higz_init_C; /* initialize menu mode */ SUBROUTINE *higz_menu_F; /* IGMENU */ } kjmpaddr; #endif +KEEP,KFLAG_H #ifndef KFLAG_H_INCLUDED #define KFLAG_H_INCLUDED typedef enum { KmMACRO_COMMAND = 0, /* don't look for macros */ KmMACRO_AUTO, /* look for macros before commands */ KmMACRO_AUTOREVERSE /* look for macros after commands */ } KmMacOrder; typedef enum { KmSTYLE_A = 0x0001, /* Alpha menus */ KmSTYLE_C = 0x0002, /* Command line */ KmSTYLE_G = 0x0004, /* Graphics menus */ KmSTYLE_M = 0x0008, /* Model Human Interface */ KmSTYLE_U = 0x0010, /* User */ KmSTYLE_XM = 0x0020, /* Motif/X11 */ KmSTYLE_major = 0x00FF, /* A..X are mutually exclusive */ KmSTYLE_xL = 0x0100, /* Alpha Letter menus */ KmSTYLE_xP = 0x0200, /* Panel style GP or MP */ KmSTYLE_xS = 0x0400, /* Graphics with Software fonts */ KmSTYLE_xW = 0x0800 /* Graphics with shadowed Width */ } KmStyleFlag; typedef enum { KmTIMING_OFF, /* no timing */ KmTIMING_ON, /* time typed commands */ KmTIMING_ALL /* time individual commands inside macro */ } KmTiming; EXTERN struct { LOGICAL f77_true; /* value of .TRUE. */ LOGICAL f77_false; /* value of .FALSE. */ int do_exit; /* set by KXEXIT */ int do_quit; /* set by KXQUIT */ char *curr_prompt; /* current prompt string */ char *last_cmd; /* last command for $LAST */ KmTiming timing; /* timing on/off/all */ time_t real_time; /* real time at last timing off */ clock_t user_time; /* CPU time at last timing off */ int in_macro; /* command executed in macro */ int in_application; /* application mode is active */ int appl_called; /* application is executing */ char *appl_exit; /* string which leaves application mode */ KmCommand *appl_cmd; /* command which handles application */ char *appl_file; /* temporary file to pass application text */ FILE *appl_stream; /* C stream used for writing appl_file */ int appl_luno; /* Fortran logical unit opened for appl_file */ char *help_file; /* temporary file to view help text */ char *uhlp_file; /* temporary file to get user help text */ int uhlp_luno; /* Fortran logical unit opened for user help */ int in_motif; /* Motif mode is active */ int echo_command; /* echo commands in Motif mode */ char *echo_prompt; /* prompt string for echo commands */ KmStyleFlag style; /* input mode */ int keep_fcase; /* flag if no case conversion for filenames */ int use_server; /* flag if edit server should be used */ int use_kxterm; /* flag if kxterm should be used */ int editor_exit; /* flag set if edit server sent SIGUSR1 */ char *macro_path; /* MACRO/DEFAULT search path */ KmMacOrder macro_search; /* MACRO/DEFAULT search order */ int temp_vectors; /* number of ?SIGMA vectors */ } kc_flags; EXTERN struct { char *set_break; /* SET_SHOW/BREAK */ char set_columns[8]; /* SET_SHOW/COLUMNS */ char *set_command; /* SET_SHOW/COMMAND */ char *set_filecase; /* SET_SHOW/FILECASE */ char *set_host_editor; /* SET_SHOW/HOST_EDITOR */ char *set_host_pager; /* SET_SHOW/HOST_PAGER */ char *set_host_shell; /* SET_SHOW/HOST_SHELL */ char *set_prompt; /* SET_SHOW/PROMPT */ char *set_recall_style; /* SET_SHOW/RECALL_STYLE */ char set_recording[8]; /* SET_SHOW/RECORDING */ char *set_root; /* SET_SHOW/ROOT */ char *set_style; /* SET_SHOW/STYLE */ char *set_timing; /* SET_SHOW/TIMING */ char *help_edit; /* HELP edit mode */ char *defaults_path; /* MACRO/DEFAULTS search path */ char *defaults_order; /* MACRO/DEFAULTS search order */ } kc_value; typedef struct { int top; int left; int width; int height; } KmWindowDsc; EXTERN struct { KmWindowDsc edit_pad; /* coordinates for edit window */ KmWindowDsc help_pad; /* coordinates for readonly window */ int voffset; /* vertical offset */ int hoffset; /* horizontal offset */ int shift_max; /* maximum number of shifted pads */ int shift_now; /* current shift count */ int shift_dir; /* shift direction +/-1 */ int is_a_pad; /* flag if running in an Apollo DM pad */ int is_a_tty; /* flag if stdin and stdout at terminal */ int use_getline; /* flag for using getline() or normal read */ int term_width; /* terminal width in columns */ int kuwhag_called; /* allow style G */ float sgylen; float sgsize; float sgyspa; float sgbord; int panel_rows; /* number of rows in style GP panel */ int *panel_cols; /* number of columns in each row */ char ***panel_keys; /* key labels */ char *panel_keynum; /* value of $KEYNUM */ char *panel_keyval; /* value of $KEYVAL */ } kc_window; extern C_PROTO_1(char* style_name, KmStyleFlag); #endif +KEEP,KMENU_H1 typedef enum { /* */ \ KmFLAG_FORGET = 0x01, /* last value is not kept for Motif panels */ \ KmFLAG_MINUS = 0x02, /* -VALUE is not an abbrev for CHOPT=VALUE */ \ KmFLAG_QUOTE = 0x04, /* do not remove quotes */ \ KmFLAG_VARARG = 0x08 /* append additional args to this param. */ \ } KmParFlag; /* */ \ /* */ \ typedef enum { /* */ \ KmTYPE_CHAR = 'C', /* character string */ \ KmTYPE_FILE = 'F', /* file name */ \ KmTYPE_INT = 'I', /* integer */ \ KmTYPE_OPTION = 'O', /* option */ \ KmTYPE_REAL = 'R' /* real */ \ } KmParType; /* */ \ /* */ \ typedef struct { /* file name */ \ char *filter_default; /* filter wildcard */ \ char *filter_current; /* current filter */ \ } KmParFile; /* */ \ /* */ \ typedef struct { /* */ \ char *range_lower; /* lower value of range */ \ char *range_upper; /* upper value of range */ \ char *slider_lower; /* lower limit for slider */ \ char *slider_upper; /* upper limit for slider */ \ int decimals; /* number of decimals used for slider */ \ } KmParInt; /* */ \ /* */ \ typedef struct { /* option */ \ char **text; /* explanations (parallel to range_value) */ \ int *mutex; /* mutex group to which text belongs */ \ int *radio; /* radio group to which text belongs */ \ } KmParOption; /* */ \ /* */ \ typedef KmParInt KmParReal; /* real and int have the same fields */ \ /* */ \ typedef struct { /* */ \ char *name; /* parameter name */ \ int abbrev; /* minimum length that name is recognized */ \ char *prompt; /* prompt string */ \ char *dfault; /* default value */ \ char *last; /* last value for Motif panel (malloced) */ \ int width; /* width of input field */ \ int range_count; /* number of items in range_value */ \ char **range_value; /* list of allowed values */ \ int select_count; /* number of items in select_count */ \ char **select_value; /* list of values for selection box */ \ KmParFlag flags; /* special flags */ \ KmParType type; /* parameter type */ \ void *ptype; /* structure pointer selected by type */ \ } KmParameter; /* */ \ +KEEP,KMENU_H2 typedef struct _KmCommand { /* */ \ struct _KmCommand *next; /* link to next command */ \ char *path; /* command path */ \ char *name; /* command name */ \ int hidden; /* flag if command is invisible */ \ int level; /* depth of submenus */ \ int total; /* total number of parameters */ \ int mandatory; /* number of mandatory parameters */ \ KmParameter **par; /* list of total parameter descriptions */ \ int list_par; /* index+1 of parameter taking a list */ \ int xcount; /* count number of action calls */ \ SUBROUTINE *action_F; /* action routine */ \ IntFunc *action_C; /* action routine */ \ SUBROUTINE *user_help_F; /* user help routine */ \ IntFunc *user_help_C; /* user help routine */ \ int nguidance; /* number of lines in guidance text */ \ char **guidance; /* help text */ \ int argc; /* number of arguments entered */ \ char **argv; /* argc argument values */ \ char *argline; /* argument line as entered */ \ int *argoffs; /* argc offsets into argline for KUGETE */ \ } KmCommand; /* */ \ /* */ \ typedef struct _KmMenu { /* */ \ struct _KmMenu *next; /* link to next menu */ \ struct _KmMenu *down; /* link to submenu */ \ char *path; /* path of parent menu */ \ char *name; /* menu name */ \ int level; /* depth of submenus */ \ KmCommand *cmds; /* link to first command */ \ int nguidance; /* number of lines in guidance text */ \ char **guidance; /* help text */ \ } KmMenu; /* */ \ /* */ \ extern void klnkbrcl(); /* */ \ extern void klnkicon(); /* */ \ extern void klnkkmcl(); /* */ \ extern void klnkmenu(); /* */ \ +KEEP,KMENU_Q1 "\ +SEQ,KMENU_H1 " +KEEP,KMENU_Q2 "\ +SEQ,KMENU_H2 " +KEEP,KMENU_H #ifndef KMENU_H_INCLUDED #define KMENU_H_INCLUDED /* kmenu.h: data structures for menu and command definitions */ #define KMENU_H1 \ +SEQ,KMENU_H1 KMENU_H1 #define KMENU_H2 \ +SEQ,KMENU_H2 KMENU_H2 /* * temporary fix until we can reserve an extra word in KmCommand structure * to count keyboard and macro commands separately */ #define XCOUNT_SHIFT 10 #define XCOUNT_OFFSET (1 << XCOUNT_SHIFT) #define XCOUNT_MASK (XCOUNT_OFFSET - 1) extern C_PROTO_2(void check_version, int, int); extern C_PROTO_0(void check_edit_server); extern C_PROTO_3(int exec_cmd_string, char*, int, int(*)()); extern C_PROTO_1(int exec_decoded_cmd, KmCommand*); extern C_PROTO_1(KmMenu* find_submenu, char*); extern C_PROTO_2(char* fmt_cmd_help, KmCommand*, int); extern C_PROTO_0(void menu_style); extern C_PROTO_2(void print_cmd_list, KmCommand**, char*); extern C_PROTO_1(void reset_arg_list, KmCommand*); extern C_PROTO_1(KmMenu** root_menu_list, char*); extern C_PROTO_2(KmCommand* search_command, char*, KmCommand***); #endif +KEEP,KHASH_H #ifndef KHASH_H_INCLUDED #define KHASH_H_INCLUDED /* khash.h: hash table management */ typedef struct _HashEntry { struct _HashEntry *next; /* link to next entry */ char *name; /* symbol name */ void *value; /* symbol value */ } HashEntry; typedef struct { int size; /* table size should be a prime number */ HashEntry **entries; /* pointer to array of size entries */ int nentries; /* number of entries */ int copy; /* flag if strdup/free(value) should be used */ } HashTable; #define ALIAS_TABLE_SIZE 3 /* should be a prime */ EXTERN struct { int translate; /* flag if translation wanted */ int substitutions; /* how many more before recursive alarm */ HashTable *arg_table; /* Argument alias table */ HashTable *cmd_table; /* Command alias table */ HashTable *var_table; /* macro variables */ } kc_alias; extern C_PROTO_2(HashTable* hash_create, int, int); extern C_PROTO_1(void hash_clear, HashTable*); extern C_PROTO_1(void hash_destroy, HashTable*); extern C_PROTO_3(void hash_insert, HashTable*, const char*, void*); extern C_PROTO_2(void hash_remove, HashTable*, const char*); extern C_PROTO_2(void* hash_lookup, HashTable*, const char*); extern C_PROTO_1(int hash_entries, HashTable*); extern C_PROTO_1(char** hash_names, HashTable*); extern C_PROTO_1(void** hash_values, HashTable*); extern C_PROTO_1(char* subst_arg_alias, char*); extern C_PROTO_1(char* subst_cmd_alias, char*); extern C_PROTO_1(char* subst_var_alias, char*); extern C_PROTO_1(char* subst_sys_fun, char*); #endif +KEEP,MKTERM. #ifndef MKTERM_INCLUDED #define MKTERM_INCLUDED #define ESCAPE "#@" typedef void (*KxtermActionProc)( #ifndef NO_PROTOTYPES char** /* params */, int /* num_params */ #endif ); typedef struct _KxtermActionsRec{ char *string; KxtermActionProc proc; } KxtermActionsRec; typedef KxtermActionsRec *KxtermActionList; extern C_PROTO_1(void kxterm_add_actions, KxtermActionList); extern C_PROTO_1(void handle_kxterm_action, char *); extern C_PROTO_1(void send_kxterm_cmd, char**); extern C_PROTO_1(void send_single_kxterm_cmd, char*); #endif +DECK,hkuip_t,IF=TEST. +KEEP,KHAIX370 #ifndef AIX370 # define AIX370 #endif +KEEP,KHAPOFTN #ifndef APOLLO_FTN # define APOLLO_FTN #endif +KEEP,KHIBMVM #ifndef IBMVM # define IBMVM #endif +KEEP,KHIBMMVS #ifndef IBMMVS # define IBMMVS #endif +KEEP,KHNEWLIB #ifndef NEWLIB # define NEWLIB #endif +KEEP,KUIP_H /* kuip.h: system dependent defines */ /* update version if structures have changed */ #define KUIP_VERSION 921023 /* identify system if not possible from preprocessor defines */ +SEQ,KHAIX370,IF=AIX370 +SEQ,KHAPOFTN,IF=APOFTN +SEQ,KHIBMVM ,IF=IBMVM +SEQ,KHIBMMVS,IF=IBMMVS +SEQ,KHNEWLIB,IF=NEWLIB #ifdef AIX370 # define MACHINE_NAME "IBMAIX" # define UNIX # define F77_EXTERN_INDIRECT #endif #if defined(apollo) || defined(__apollo) # define MACHINE_NAME "APOLLO" # define APOLLO # define UNIX # include # include # include # include # include # include # ifdef APOLLO_FTN /* using /com/ftn instead of /bin/f77 */ # define F77_CHAR_LEN_IND short # define F77_EXTERN_LOWERCASE # endif # define F77_EXTERN_INDIRECT # define F77_COMMON(name) name __attribute((__section(name))) # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_DIRENT_H # define TERMIO_BSD /* for getline we must compile under bsd4.3 */ #endif #if defined(__convexc__) # define CONVEX # define MACHINE_NAME "CONVEX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define MATCH_RE_COMP /* use re_comp/re_exec */ # define F77_BLOCK(name,NAME) F77_NAME(ConCat(_,name),NAME) #endif #ifdef CRAY # define MACHINE_NAME "CRAY" # define UNIX # include # define F77_EXTERN_UPPERCASE # define F77_CHAR_DSC_CRAY # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_EDIT_SERVER #endif #if defined(hpux) || defined(__hpux) # define MACHINE_NAME "HPUX" # define HPUX # define UNIX # ifdef hpux /* cc -Ac */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # ifndef _HPUX_SOURCE # define _HPUX_SOURCE # endif # define FATAL_SIGFPE /* needs f77 +T and ON REAL UNDERFLOW IGNORE */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_STRRSTR #endif #ifdef _IBMR2 # define IBMRT # define MACHINE_NAME "IBMRT" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #ifdef IBMVM # define ARG_STYLE_CMS # define MACHINE_NAME "IBM" # define OS_NAME "VM" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBMMVS # define MACHINE_NAME "IBMMVS" # define OS_NAME "MVS" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBM370 # define F77_CHAR_LEN_IND int /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_EXTERN_INDIRECT # define F77_EXTERN_UPPERCASE # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_V7 #endif #ifdef linux # define LINUX # define MACHINE_NAME "LINUX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #ifdef MSDOS # define MACHINE_NAME "MSDOS" # define UNIX # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define SIGNAL_V7 #endif #ifdef WIN32 # define WINNT # define MACHINE_NAME "WNT" # define UNIX # define MSDOS # include # include # include # define text_mode__() # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define NO_UNISTD_H # define SIGNAL_V7 #endif #ifdef NeXT # define MACHINE_NAME "NEXT" # define UNIX # define getcwd(path,maxlen) getwd(path) # define F77_BLOCK(lc,uc) lc # define F77_EXTERN_INDIRECT /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_XXXX_USE_LEN(x) ,286716 /* don't know if value matters */ # define HAVE_MEMMOVE # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define NO_DIRENT_H # define NO_UNISTD_H # define SIGNAL_BSD # define TERMIO_BSD #endif #ifdef __osf__ # define UNIX # ifdef __alpha # define ALPHA # define MACHINE_NAME "ALPHA" # endif # define const /* wrong prototype for strdup() in string.h */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #if defined(sgi) || defined(__sgi) # define MACHINE_NAME "SGI" # define SGI # define UNIX # ifndef __sgi /* Irix 3 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP #endif #if defined(sun) || defined(__sun) # define MACHINE_NAME "SUN" # define SUN # define UNIX # ifndef __STDC__ /* cc vs. acc */ # define NO_ANSI_CPP # define NO_PROTOTYPES # else # define const /* wrong prototype for strdup() in string.h */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_VFORK # include # define MATCH_RE_COMP /* use re_comp/re_exec */ #endif #if defined(ultrix) || defined(__ultrix) # define MACHINE_NAME "DECS" # define ULTRIX # define UNIX # ifndef __ultrix /* cc vs. c89 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_VFORK # define TERMIO_BSD #endif #ifdef vms # define OS_NAME "VMS" # ifdef __ALPHA # define ALPHA # define MACHINE_NAME "ALPHA" # pragma extern_model common_block # include /* inside descrip.h on VAX */ # else # define MACHINE_NAME "VAX" # define NO_ANSI_CPP # define raise gsignal /* raise() not in library ? */ # endif # include # include # include /* lib$... prototypes */ # include # include # include # include # include # include # include # include /* sys$... prototypes */ # include # include # include # ifndef R_OK /* no access() modes in unixio.h on VAX/VMS */ # define F_OK 0 # define X_OK 1 # define W_OK 2 # define R_OK 4 # endif # define ARG_STYLE_VMS # define F77_CHAR_DSC_VMS # define F77_EXTERN_LOWERCASE # define HAVE_MEMMOVE # define HAVE_STAT_H # define HAVE_VFORK /* actually have only vfork */ # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_BSD # define sigmask(sig) (1L << (sig-1)) /* should be in signal.h */ # define USE_EDIT_SERVER /* only for TPU/DISPLAY=MOTIF */ #endif /* vms */ #include #include #include #ifndef NO_FCNTL_H #include #endif #include /* contains strtod() and strtol() on some systems */ #include #include #include #include #include #include #ifndef NO_UNISTD_H #include #endif #ifndef HAVE_VFORK # define vfork fork #endif #ifdef UNIX # define OS_NAME "UNIX" # include # include # ifndef NO_SYS_TIME_H # include /* struct timeval */ # endif # ifndef MSDOS # if !defined(TERMIO_BSD) && !defined(TERMIO_SYSV) # define TERMIO_POSIX # endif # include # ifndef NO_DIRENT_H /* POSIX opendir() */ # include # else /* BSD opendir() */ # include /* plus */ # define dirent direct /* struct dirent... */ # ifndef S_IRUSR # define S_IRUSR (S_IREAD) /* read permission, owner */ # define S_IWUSR (S_IWRITE) /* write permission, owner */ # define S_IXUSR (S_IEXEC) /* execute/search permission, owner */ # endif # endif # endif # define HAVE_STAT_H # ifndef NO_EDIT_SERVER # define USE_EDIT_SERVER # ifndef F_LOCK /* BSD file locking */ # include # define lockf(fd,op,offs) flock(fd,op) # define F_LOCK LOCK_EX # define F_ULOCK LOCK_UN # endif # endif #endif #ifdef SUN # ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 1000000 /* missing in time.h */ # define difftime(t1,t0) ((double)(t1-t0)) # define raise(sig) kill(getpid(),sig) # endif #endif #ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 100 /* missing in VAX/VMS time.h */ #endif #ifdef HAVE_STAT_H # define KmTimeStamp struct stat # define get_stamp(path,stamp) stat(path,stamp) # define cmp_stamp(stamp1,stamp2) ((stamp2)->st_mtime == (stamp1)->st_mtime) #endif #ifndef KmTimeStamp # define KmTimeStamp int # define get_stamp(path,stamp) 0 # define cmp_stamp(stamp1,stamp2) 0 #endif #ifdef MATCH_RE_COMP extern char *re_comp(); extern int re_exec(); #else extern char *regcmp(); extern char *regex(); #endif /* command line arguments recognized by KUARGS */ #if !defined(ARG_STYLE_CMS) && !defined(ARG_STYLE_VMS) # define ARG_STYLE_UNIX #endif #ifndef MACHINE_NAME # define MACHINE_NAME "UNKNOWN" /* value returned by $MACHINE */ #endif #ifndef OS_NAME # define OS_NAME "UNKNOWN" /* value returned by $OS */ #endif /* #define EXTERN must be in one routine to allocate space for globals */ #ifndef EXTERN # define EXTERN extern #endif /* #define STATIC extern if debugger does not see static functions */ #ifndef STATIC # define STATIC static #endif #if defined(__GNUC__) || defined(__STDC__) # ifdef NO_ANSI_CPP # undef NO_ANSI_CPP # endif # ifdef NO_PROTOTYPES # undef NO_PROTOTYPES # endif #endif /* * Preprocessor syntax for token concatenation */ #ifndef NO_ANSI_CPP # define ConCat(con,cat) con##cat #else # define ConCat(con,cat) con/**/cat #endif /* * Prototyping for C functions */ #ifndef NO_PROTOTYPES # define C_PROTO_0(name) \ name(void) # define C_PROTO_1(name,arg1) \ name(arg1) # define C_PROTO_2(name,arg1,arg2) \ name(arg1,arg2) # define C_PROTO_3(name,arg1,arg2,arg3) \ name(arg1,arg2,arg3) # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name(arg1,arg2,arg3,arg4) # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name(arg1,arg2,arg3,arg4,arg5) # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name(arg1,arg2,arg3,arg4,arg5,arg6) # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7) # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) # define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) # define C_PROTO_17(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name(t1 p1) # define C_DECL_2(name,t1,p1,t2,p2) \ name(t1 p1,t2 p2) # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name(t1 p1,t2 p2,t3 p3) # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name(t1 p1,t2 p2,t3 p3,t4 p4) # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5) # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6) # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7) # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8) # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,t9 p9) # define C_DECL_13(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,\ t9,p9,t10,p10,t11,p11,t12,p12,t13,p13) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,\ t9 p9,t10 p10,t11 p11,t12 p12,t13 p13) #else # define const # define C_PROTO_0(name) \ name() # define C_PROTO_1(name,arg1) \ name() # define C_PROTO_2(name,arg1,arg2) \ name() # define C_PROTO_3(name,arg1,arg2,arg3) \ name() # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name() # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name() # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name() # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name() # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name() # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name() # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name() # define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) \ name() # define C_PROTO_17(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) \ name() # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name( p1) \ t1 p1; # define C_DECL_2(name,t1,p1,t2,p2) \ name( p1, p2) \ t1 p1;t2 p2; # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name( p1, p2, p3) \ t1 p1;t2 p2;t3 p3; # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name( p1, p2, p3, p4) \ t1 p1;t2 p2;t3 p3;t4 p4; # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name( p1, p2, p3, p4, p5) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5; # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name( p1, p2, p3, p4, p5, p6) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6; # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name( p1, p2, p3, p4, p5, p6, p7) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7; # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name( p1, p2, p3, p4, p5, p6, p7, p8) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8; # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name( p1, p2, p3, p4, p5, p6, p7, p8, p9)\ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8;t9 p9; # define C_DECL_13(name,A,a,B,b,C,c,D,d,E,e,F,f,G,g,H,h,I,i,J,j,K,k,L,l,M,m)\ name( a, b, c, d, e, f, g, h, i, j, k, l, m)\ A a;B b;C c;D d;E e;F f;G g;H h;I i;J j;K k;L l;M m; #endif typedef int IntFunc(); typedef char* CharFunc(); typedef char** pCharFunc(); #define KUMAC_UNWIND -30041961 /* error status to quit macro execution */ /* * convenience functions from kkern.c */ extern C_PROTO_2(char* fexpand, const char*, const char*); extern C_PROTO_1(char* fsymlink, const char*); extern C_PROTO_3(char* fsearch, const char*, const char*, const char*); extern C_PROTO_2(char* fstrdup, const char*, size_t); extern C_PROTO_2(char* fstr0dup, const char*, size_t); extern C_PROTO_2(char* fstrtrim, const char*, size_t); extern C_PROTO_2(char* fstr0trim, const char*, size_t); extern C_PROTO_2(size_t fstrlen, const char*, size_t); extern C_PROTO_3(size_t fstrset, char*, size_t, const char*); extern C_PROTO_2(double fstrtod, char*, char**); extern C_PROTO_2(int fstrtoi, char*, char**); extern C_PROTO_3(char* fstrvec, char**, int, int*); #ifndef HAVE_MEMMOVE extern C_PROTO_3(void* memmove, void*, const void*, size_t); #endif #ifndef HAVE_STRCASECMP extern C_PROTO_2(int strcasecmp, const char*, const char*); extern C_PROTO_3(int strncasecmp, const char*, const char*, size_t); #endif #ifndef HAVE_STRDUP extern C_PROTO_1(char* strdup, const char*); #endif #ifndef HAVE_STRRSTR extern C_PROTO_2(char* strrstr, const char*, const char*); #endif extern C_PROTO_1(char* str0dup, const char*); extern C_PROTO_2(char* str2dup, const char*, const char*); extern C_PROTO_3(char* str3dup, const char*, const char*, const char*); extern C_PROTO_4(char* str4dup, const char*, const char*, const char*, const char*); extern C_PROTO_5(char* str5dup, const char*, const char*, const char*, const char*, const char*); extern C_PROTO_2(char* strndup, const char*, int); extern C_PROTO_2(char* mstrcat, char*, const char*); extern C_PROTO_3(char* mstr2cat, char*, const char*, const char*); extern C_PROTO_4(char* mstr3cat, char*, const char*, const char*, const char*); extern C_PROTO_5(char* mstr4cat, char*, const char*, const char*, const char*, const char*); extern C_PROTO_3(char* mstrncat, char*, const char*, int); extern C_PROTO_3(char* mstrccat, char*, int, int); extern C_PROTO_2(char* mstricat, char*, int); extern C_PROTO_2(int mstrlen, char**, int); extern C_PROTO_1(char* strqtok, char*); extern C_PROTO_1(char* strlower, char*); extern C_PROTO_1(char* strupper, char*); extern C_PROTO_2(char* strfromd, double, int); extern C_PROTO_2(char* strfromi, int, int); /* * C-interface functions */ extern C_PROTO_0(char* k_getar); extern C_PROTO_2(void k_setar, int, char**); extern C_PROTO_0(char* k_userid); extern C_PROTO_0(void ku_alfa); extern C_PROTO_2(char* ku_appl, int*, int*); extern C_PROTO_1(void ku_cmdl, char*); extern C_PROTO_2(int ku_edit, char*, int); extern C_PROTO_1(char* ku_eval, char*); extern C_PROTO_1(int ku_exec, char*); extern C_PROTO_1(int ku_exel, char*); extern C_PROTO_0(char* ku_getc); extern C_PROTO_0(char* ku_gete); extern C_PROTO_0(char* ku_getf); extern C_PROTO_0(int ku_geti); extern C_PROTO_0(char* ku_getl); extern C_PROTO_0(char* ku_getq); extern C_PROTO_0(double ku_getr); extern C_PROTO_0(char* ku_gets); extern C_PROTO_1(char* ku_fcase, char*); extern C_PROTO_2(char* ku_home, char*, char*); extern C_PROTO_1(int ku_intr, int); extern C_PROTO_1(void ku_last, char*); extern C_PROTO_2(int ku_more, char*, char*); extern C_PROTO_0(int ku_npar); extern C_PROTO_2(void ku_pad, char*, int); extern C_PROTO_0(char* ku_path); extern C_PROTO_2(void ku_piaf, int, void(*)()); extern C_PROTO_2(char* ku_proc, char*, char*); extern C_PROTO_2(char* ku_prof, char*, char*); extern C_PROTO_2(int ku_proi, char*, int); extern C_PROTO_1(char* ku_prop, char*); extern C_PROTO_2(double ku_pror, char*, double); extern C_PROTO_2(char* ku_pros, char*, char*); extern C_PROTO_0(char** ku_qenv); extern C_PROTO_1(char* ku_qexe, char*); extern C_PROTO_2(int ku_sapp, char*, char*); extern C_PROTO_0(void ku_shut); extern C_PROTO_1(int ku_stop, int); extern C_PROTO_2(void ku_time, time_t, clock_t); extern C_PROTO_2(void ku_trap, int, int); extern C_PROTO_1(int ku_vqaddr, char*); extern C_PROTO_1(int ku_vtype, char*); extern C_PROTO_2(int ku_vvalue, char*, double*); extern C_PROTO_0(void ku_whag); extern C_PROTO_1(void ku_what, void(*)()); extern C_PROTO_1(char* getline, char*); extern C_PROTO_2(void gl_config, char*, int); extern C_PROTO_1(void gl_histadd, char*); extern C_PROTO_1(void gl_setwidth, int); extern C_PROTO_2(char* input_line, char*, int); extern C_PROTO_0(void leave_kuip); extern C_PROTO_2(int len_alias, char*, int); extern C_PROTO_1(int len_sysfun, char*); extern C_PROTO_1(int len_vector, char*); extern C_PROTO_2(char* quote_string, char*, int); extern C_PROTO_0(void reset_break); extern C_PROTO_1(void signal_handler, int ); extern C_PROTO_2(int vms_signal_handler, void*, void* ); +KEEP,KFOR_H /* kfor.h: Fortran-C interface */ /* * Fortran data types */ typedef int INTEGER; typedef int LOGICAL; typedef float REAL; typedef double DBLPREC; typedef INTEGER INT_FUNCTION(); typedef INT_FUNCTION *INT_FUNCPTR; typedef void (*SUBRPTR)(); typedef void SUBROUTINE(); #ifdef IBM370 #pragma linkage(SUBROUTINE,FORTRAN) #pragma linkage(INT_FUNCTION,FORTRAN) #pragma map(__CTOF,"@@CTOF") extern INTEGER __CTOF( INT_FUNCPTR, ... ); #endif typedef union _EQUIV_INT_REAL { INTEGER i; LOGICAL l; REAL r; } EQUIV_INT_REAL; /* * Mapping of C-routine name for Fortran CALL SUB * * #define F77_EXTERN_LOWERCASE ==> void sub() * #define F77_EXTERN_UPPERCASE ==> void SUB() * otherwise ==> void sub_() */ #ifdef F77_EXTERN_UPPERCASE # define F77_NAME(name,NAME) NAME #else # ifdef F77_EXTERN_LOWERCASE # define F77_NAME(name,NAME) name # else # define F77_NAME(name,NAME) ConCat(name,_) # endif #endif #ifndef F77_BLOCK # define F77_BLOCK(name,NAME) F77_NAME(name,NAME) #endif #ifndef F77_COMMON # define F77_COMMON(name) name #endif /* * Routine address in CALL SUB(FUN) ; EXTERNAL FUN * * #define F77_EXTERN_INDIRECT ==> void (**fun)(); * otherwise ==> void (*fun)(); */ #ifdef F77_EXTERN_INDIRECT # define F77_EXTERN_ARG(e) ConCat(e,_dsc) # define F77_EXTERN_DCL(e) SUBROUTINE **ConCat(e,_dsc); # define F77_EXTERN_DEF(e) SUBROUTINE *e = *ConCat(e,_dsc); #else # define F77_EXTERN_ARG(e) e # define F77_EXTERN_DCL(e) SUBROUTINE *e; # define F77_EXTERN_DEF(e) #endif #define F77_EXTERN2ARG(e1,e2) F77_EXTERN_ARG(e1),F77_EXTERN_ARG(e2) #define F77_EXTERN2DCL(e1,e2) F77_EXTERN_DCL(e1) F77_EXTERN_DCL(e2) #define F77_EXTERN2DEF(e1,e2) F77_EXTERN_DEF(e1) F77_EXTERN_DEF(e2) #define F77_EXTERN3ARG(e1,e2,e3) F77_EXTERN_ARG(e1),F77_EXTERN2ARG(e2,e3) #define F77_EXTERN3DCL(e1,e2,e3) F77_EXTERN_DCL(e1) F77_EXTERN2DCL(e2,e3) #define F77_EXTERN3DEF(e1,e2,e3) F77_EXTERN_DEF(e1) F77_EXTERN2DEF(e2,e3) #define F77_EXTERN4ARG(e1,e2,e3,e4) F77_EXTERN_ARG(e1),F77_EXTERN3ARG(e2,e3,e4) #define F77_EXTERN4DCL(e1,e2,e3,e4) F77_EXTERN_DCL(e1) F77_EXTERN3DCL(e2,e3,e4) #define F77_EXTERN4DEF(e1,e2,e3,e4) F77_EXTERN_DEF(e1) F77_EXTERN3DEF(e2,e3,e4) /* * Access to Fortran CHARACTER arguments */ #ifdef F77_CHAR_DSC_VMS /* VMS string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_dsc) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) struct dsc$descriptor_s *ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_dsc)->dsc$a_pointer; \ int ConCat(len_,s) = ConCat(s,_dsc)->dsc$w_length; # define F77_CHAR_DEF_DSC(s,p,l) struct dsc$descriptor_s ConCat(s,__dsc); # define F77_CHAR_ASS_DSC(s,p,l) ConCat(s,__dsc).dsc$w_length = l; \ ConCat(s,__dsc).dsc$b_dtype = DSC$K_DTYPE_T;\ ConCat(s,__dsc).dsc$b_class = DSC$K_CLASS_S;\ ConCat(s,__dsc).dsc$a_pointer = p; # define F77_CHAR_USE_PTR(s,p,l) &ConCat(s,__dsc) # define F77_CHAR_USE_LEN(s,p,l) #endif #ifdef F77_CHAR_DSC_CRAY /* Cray string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_dsc) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) _fcd ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = _fcdtocp(ConCat(s,_dsc)); \ int ConCat(len_,s) = _fcdlen(ConCat(s,_dsc)); # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) _cptofcd(p,l) # define F77_CHAR_USE_LEN(s,p,l) #endif #ifdef F77_CHAR_LEN_IND /* string length passed by reference */ /* * The IBM C/370 compiler passes the Fortran CHARACTER pointer directly * instead of making a private copy. Therefore we have to do the copy * char *s = s_ptr ourself in case the routine uses s as local variable. */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) , ConCat(s,_dsc) # define F77_CHAR_ARG_DCL(s) char *ConCat(s,_ptr); \ F77_CHAR_LEN_IND *ConCat(s,_dsc); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr); \ int ConCat(len_,s) = *ConCat(s,_dsc); # define F77_CHAR_DEF_DSC(s,p,l) F77_CHAR_LEN_IND ConCat(s,__dsc) = l; # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , &ConCat(s,__dsc) #endif #ifndef F77_CHAR_ARG_PTR /* string length passed by value */ # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(len_,s) # define F77_CHAR_ARG_DCL(s) char *s; int ConCat(len_,s); # define F77_CHAR_ARG_DEF(s) # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , l #endif #ifndef F77_XXXX_ARG_LEN /* length argument of non-CHARACTER arguments */ # define F77_XXXX_ARG_LEN(x) /* nil */ # define F77_XXXX_USE_LEN(x) /* nil */ #endif /* * Fortran-calls-C interface * * To define a C function called by Fortran CALL SUB(A,B,C): * * #define Sub F77_NAME(sub,SUB) * #pragma linkage(SUB,FORTRAN) // for IBM C/370 compiler * * F77_ENTRY_xyz(Sub,a,b,c) // opening { contained in macro * // body ... * } * * Each character in xyz declares the type of the corresponding parameter: * * C = CHARACTER * D = DOUBLE PRECISION * E = EXTERNAL * I = INTEGER * L = LOGICAL * R = REAL * X = COMPLEX * * If a parameter PAR is declared as CHARACTER the macro defines: * * char *PAR; // pointer to string (not terminated by \0 !!!) * int len_PAR; // length of string as defined by Fortran's LEN(PAR) * * The name PAR_dsc is reserved for internal use. * * Note: The function body follows the F77_ENTRY_... macro call directly. * The opening { is generated by the macro. */ #define F77_CHAR_ARG2PTR(c1,c2) \ F77_CHAR_ARG_PTR(c1),F77_CHAR_ARG_PTR(c2) #define F77_CHAR_ARG2LEN(c1,c2) \ F77_CHAR_ARG_LEN(c1) F77_CHAR_ARG_LEN(c2) #define F77_XXXX_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(c1) F77_XXXX_ARG_LEN(c2) #define F77_CHAR_ARG2DCL(c1,c2) \ F77_CHAR_ARG_DCL(c1) F77_CHAR_ARG_DCL(c2) #define F77_CHAR_ARG2DEF(c1,c2) \ F77_CHAR_ARG_DEF(c1) F77_CHAR_ARG_DEF(c2) #define F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG2PTR(c1,c2),F77_CHAR_ARG_PTR(c3) #define F77_CHAR_ARG3LEN(c1,c2,c3) \ F77_CHAR_ARG2LEN(c1,c2) F77_CHAR_ARG_LEN(c3) #define F77_XXXX_ARG3LEN(c1,c2,c3) \ F77_XXXX_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(c3) #define F77_CHAR_ARG3DCL(c1,c2,c3) \ F77_CHAR_ARG2DCL(c1,c2) F77_CHAR_ARG_DCL(c3) #define F77_CHAR_ARG3DEF(c1,c2,c3) \ F77_CHAR_ARG2DEF(c1,c2) F77_CHAR_ARG_DEF(c3) #define F77_CHAR_ARG4PTR(c1,c2,c3,c4) \ F77_CHAR_ARG3PTR(c1,c2,c3),F77_CHAR_ARG_PTR(c4) #define F77_CHAR_ARG4LEN(c1,c2,c3,c4) \ F77_CHAR_ARG3LEN(c1,c2,c3) F77_CHAR_ARG_LEN(c4) #define F77_XXXX_ARG4LEN(c1,c2,c3,c4) \ F77_XXXX_ARG3LEN(c1,c2,c3) F77_XXXX_ARG_LEN(c4) #define F77_CHAR_ARG4DCL(c1,c2,c3,c4) \ F77_CHAR_ARG3DCL(c1,c2,c3) F77_CHAR_ARG_DCL(c4) #define F77_CHAR_ARG4DEF(c1,c2,c3,c4) \ F77_CHAR_ARG3DEF(c1,c2,c3) F77_CHAR_ARG_DEF(c4) #define F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_CHAR_ARG_PTR(c5) #define F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) F77_CHAR_ARG_LEN(c5) #define F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_CHAR_ARG_DCL(c5) #define F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_CHAR_ARG_DEF(c5) #define F77_ENTRY_C(name,c1) \ name( F77_CHAR_ARG_PTR(c1) F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CC(name,c1,c2) \ name( F77_CHAR_ARG2PTR(c1,c2) F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_C3(name,c1,c2,c3) \ name( F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG3LEN(c1,c2,c3) ) \ F77_CHAR_ARG3DCL(c1,c2,c3) \ { F77_CHAR_ARG3DEF(c1,c2,c3) #define F77_ENTRY_C5(name,c1,c2,c3,c4,c5) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) #define F77_ENTRY_C4E(name,c1,c2,c3,c4,e5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_EXTERN_ARG(e5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_EXTERN_DCL(e5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_EXTERN_DEF(e5) #define F77_ENTRY_C4I(name,c1,c2,c3,c4,i5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4), i5 \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) INTEGER *i5; \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) #define F77_ENTRY_C5E(name,c1,c2,c3,c4,c5,e6) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5),F77_EXTERN_ARG(e6) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) F77_EXTERN_DCL(e6) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) F77_EXTERN_DEF(e6) #define F77_ENTRY_CCE(name,c1,c2,e3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN_ARG(e3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN_DCL(e3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN_DEF(e3) #define F77_ENTRY_CCEE(name,c1,c2,e3,e4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN2ARG(e3,e4) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN2DCL(e3,e4) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN2DEF(e3,e4) #define F77_ENTRY_CCI(name,c1,c2,i3) \ name( F77_CHAR_ARG2PTR(c1,c2), i3 \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) INTEGER *i3; \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_CCIC(name,c1,c2,i3,c4) \ name( F77_CHAR_ARG2PTR(c1,c2), i3, F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(i3) \ F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG3DCL(c1,c2,c4) INTEGER *i3; \ { F77_CHAR_ARG3DEF(c1,c2,c4) #define F77_ENTRY_CCIRCC(name,c1,c2,i3,r4,c5,c6) \ name( F77_CHAR_ARG2PTR(c1,c2), i3, r4, F77_CHAR_ARG2PTR(c5,c6) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG2LEN(i3,r4) \ F77_CHAR_ARG2LEN(c5,c6) ) \ F77_CHAR_ARG4DCL(c1,c2,c5,c6) INTEGER *i3; REAL *r4; \ { F77_CHAR_ARG4DEF(c1,c2,c5,c6) #define F77_ENTRY_CE(name,c1,e2) \ name( F77_CHAR_ARG_PTR(c1),F77_EXTERN_ARG(e2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_EXTERN_DCL(e2) \ { F77_CHAR_ARG_DEF(c1) F77_EXTERN_DEF(e2) #define F77_ENTRY_CI(name,c1,i2) \ name( F77_CHAR_ARG_PTR(c1), i2 F77_CHAR_ARG_LEN(c1) ) \ INTEGER *i2; F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CICI(name,c1,i2,c3,i4) \ name( F77_CHAR_ARG_PTR(c1), i2, F77_CHAR_ARG_PTR(c3), i4 \ F77_CHAR_ARG_LEN(c1) \ F77_XXXX_ARG_LEN(i2) \ F77_CHAR_ARG_LEN(c3) ) \ F77_CHAR_ARG2DCL(c1,c3) INTEGER *i2, *i4; \ { F77_CHAR_ARG2DEF(c1,c3) #define F77_ENTRY_CII(name,c1,i2,i3) \ name( F77_CHAR_ARG_PTR(c1), i2, i3 \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) INTEGER *i2, *i3; \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CIIC(name,c1,i2,i3,c4) \ name( F77_CHAR_ARG_PTR(c1), i2, i3, F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG_LEN(c1) \ F77_XXXX_ARG2LEN(i2,i3) \ F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG2DCL(c1,c4) INTEGER *i2, *i3; \ { F77_CHAR_ARG2DEF(c1,c4) #define F77_ENTRY_CR(name,c1,r2) \ name( F77_CHAR_ARG_PTR(c1), r2 F77_CHAR_ARG_LEN(c1) ) \ REAL *r2; F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_E(name,e1) \ name( F77_EXTERN_ARG(e1) ) \ F77_EXTERN_DCL(e1) \ { F77_EXTERN_DEF(e1) #define F77_ENTRY_E4(name,e1,e2,e3,e4) \ name( F77_EXTERN4ARG(e1,e2,e3,e4) ) \ F77_EXTERN4DCL(e1,e2,e3,e4) \ { F77_EXTERN4DEF(e1,e2,e3,e4) #define F77_ENTRY_IC(name,i1,c2) \ name( i1, F77_CHAR_ARG_PTR(c2) \ F77_XXXX_ARG_LEN(i1) \ F77_CHAR_ARG_LEN(c2) ) \ INTEGER *i1; F77_CHAR_ARG_DCL(c2) \ { F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_ICI(name,i1,c2,i3) \ name( i1, F77_CHAR_ARG_PTR(c2), i3 \ F77_XXXX_ARG_LEN(i1) \ F77_CHAR_ARG_LEN(c2) ) \ INTEGER *i1, *i3; F77_CHAR_ARG_DCL(c2) \ { F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_IIC(name,i1,i2,c3) \ name( i1, i2, F77_CHAR_ARG_PTR(c3) \ F77_XXXX_ARG2LEN(i1,i2) \ F77_CHAR_ARG_LEN(c3) ) \ INTEGER *i1, *i2; F77_CHAR_ARG_DCL(c3) \ { F77_CHAR_ARG_DEF(c3) #define F77_ENTRY_I3C(name,i1,i2,i3,c4) \ name( i1, i2, i3, F77_CHAR_ARG_PTR(c4) \ F77_XXXX_ARG3LEN(i1,i2,i3) \ F77_CHAR_ARG_LEN(c4) ) \ INTEGER *i1, *i2, *i3; \ F77_CHAR_ARG_DCL(c4) \ { F77_CHAR_ARG_DEF(c4) #define F77_ENTRY_I4CCC(name,i1,i2,i3,i4,c5,c6,c7) \ name( i1, i2, i3, i4, F77_CHAR_ARG3PTR(c5,c6,c7) \ F77_XXXX_ARG4LEN(i1,i2,i3,i4) \ F77_CHAR_ARG3LEN(c5,c6,c7) ) \ INTEGER *i1, *i2, *i3, *i4; \ F77_CHAR_ARG3DCL(c5,c6,c7) \ { F77_CHAR_ARG3DEF(c5,c6,c7) #define F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_DEF_DSC(s1,p1,l1) F77_CHAR_DEF_DSC(s2,p2,l2) #define F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS_DSC(s1,p1,l1) F77_CHAR_ASS_DSC(s2,p2,l2) #define F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_PTR(s1,p1,l1),F77_CHAR_USE_PTR(s2,p2,l2) #define F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_LEN(s1,p1,l1) F77_CHAR_USE_LEN(s2,p2,l2) #define F77_XXXX_USE2LEN(x1,x2) \ F77_XXXX_USE_LEN(x1) F77_XXXX_USE_LEN(x2) #define F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_DEF_DSC(s3,p3,l3) #define F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_ASS_DSC(s3,p3,l3) #define F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2),F77_CHAR_USE_PTR(s3,p3,l3) #define F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) F77_CHAR_USE_LEN(s3,p3,l3) #define F77_XXXX_USE3LEN(x1,x2,x3) \ F77_XXXX_USE2LEN(x1,x2) F77_XXXX_USE_LEN(x3) #define F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_DEF_DSC(s4,p4,l4) #define F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_ASS_DSC(s4,p4,l4) #define F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3),F77_CHAR_USE_PTR(s4,p4,l4) #define F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_USE_LEN(s4,p4,l4) #define F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_XXXX_USE3LEN(x1,x2,x3) F77_XXXX_USE_LEN(x4) #define F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) F77_XXXX_USE_LEN(x5) #define F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) \ F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) F77_XXXX_USE_LEN(x6) #define F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) \ F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) F77_XXXX_USE_LEN(x7) #define F77_XXXX_USE8LEN(x1,x2,x3,x4,x5,x6,x7,x8) \ F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) F77_XXXX_USE_LEN(x8) #ifdef IBM370 #pragma linkage(K77C,FORTRAN) #define F77_CALL_C(name,p1,l1) do { \ SUBROUTINE *F77 = name; \ K77C(&F77,p1,l1); } while(0) #else #define F77_CALL_C(name,p1,l1) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1) \ F77_CHAR_USE_LEN(s1,p1,l1) \ ); } while(0) #endif #if 0 #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77CC(&F77,p1,l1,p2,l2); } while(0) #else #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #else #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ i0 = K77CC(&name,p1,l1,p2,l2); } while(0) #else #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_CC(_i0_,_p0_,p1,l1,p2,l2); \ } while(0) #endif #ifdef IBM370 #pragma linkage(K77C3,FORTRAN) #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77C3(&F77,p1,l1,p2,l2,p3,l3); } while(0) #else #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ name( F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77C7,FORTRAN) #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ SUBROUTINE *F77 = name; \ K77C7(&F77,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); } while(0) #else #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ name( F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4), \ F77_CHAR_USE3PTR(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx,FORTRAN) #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77CCx(&F77,p1,l1,p2,l2,x3); } while(0) #else #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx3,FORTRAN) #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ SUBROUTINE *F77 = name; \ K77CCx3(&F77,p1,l1,p2,l2,x3,x4,x5); } while(0) #else #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4,x5 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE3LEN(x3,x4,x5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cx,FORTRAN) #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ i0 = K77Cx(&name,p1,l1,x2); } while(0) #else #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1), \ x2 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ ); } while(0) #endif #define F77_CALL_Cx(name,p1,l1,x2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_Cx(_i0_,_p0_,p1,l1,x2); \ } while(0) #ifdef IBM370 #pragma linkage(K77CxC,FORTRAN) #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77CxC(&F77,p1,l1,x2,p3,l3); } while(0) #else #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s3,p3,l3) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2, \ F77_CHAR_USE_PTR(s3,p3,l3) \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ F77_CHAR_USE_LEN(s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cxx,FORTRAN) #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ SUBROUTINE *F77 = name; \ K77Cxx(&F77,p1,l1,x2,x3); } while(0) #else #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2,x3 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE2LEN(x2,x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xC,FORTRAN) #define F77_CALL_xC(name,x1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77xC(&F77,x1,p2,l2); } while(0) #else #define F77_CALL_xC(name,x1,p2,l2) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCCx,FORTRAN) #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ SUBROUTINE *F77 = name; \ K77xCCx(&F77,x1,p2,l2,p3,l3,x4); } while(0) #else #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ name( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3), \ x4 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x4) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCx,FORTRAN) #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ i0 = K77xCx(&name,x1,p2,l2,x3); } while(0) #else #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_xCx(_i0_,_p0_,x1,p2,l2,x3); \ } while(0) #ifdef IBM370 #pragma linkage(K77x4C,FORTRAN) #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ SUBROUTINE *F77 = name; \ K77x4C(&F77,x1,x2,x3,x4,p5,l5); } while(0) #else #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77x4Cxx,FORTRAN) #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ SUBROUTINE *F77 = name; \ K77x4Cxx(&F77,x1,x2,x3,x4,p5,l5,x6,x7); } while(0) #else #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5), \ x6,x7 \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ F77_XXXX_USE2LEN(x6,x7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(KIGMENU,FORTRAN) /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 */ #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ SUBROUTINE *F77 = name; \ KIGMENU(&F77,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N); } while(0) #else #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ F77_CHAR_DEF_DSC(sb,b,B) \ F77_CHAR_DEF_DSC(sh,h,H) \ F77_CHAR_DEF3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_DEF_DSC(sn,n,N) \ F77_CHAR_ASS_DSC(sb,b,B) \ F77_CHAR_ASS_DSC(sh,h,H) \ F77_CHAR_ASS3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_ASS_DSC(sn,n,N) \ name( a, \ F77_CHAR_USE_PTR(sb,b,B), \ c,d,e,f,g, \ F77_CHAR_USE_PTR(sh,h,H), \ i, \ F77_CHAR_USE3PTR(sj,j,J,sk,k,K,sl,l,L), \ m, \ F77_CHAR_USE_PTR(sn,n,N) \ F77_XXXX_USE_LEN(a) \ F77_CHAR_USE_LEN(sb,b,B) \ F77_XXXX_USE5LEN(c,d,e,f,g) \ F77_CHAR_USE_LEN(sh,h,H) \ F77_XXXX_USE_LEN(i) \ F77_CHAR_USE3LEN(sj,j,J,sk,k,K,sl,l,L) \ F77_XXXX_USE_LEN(m) \ F77_CHAR_USE_LEN(sn,n,N) \ ); } while(0) #endif #ifdef IBM370 #define F77_IFUN_x(i0,name,x1) i0 = __CTOF(name,x1) #else #define F77_IFUN_x(i0,name,x1) i0 = (*name)(x1) #endif #ifdef IBM370 #define F77_IFUN_xx(i0,name,x1,x2) i0 = __CTOF(name,x1,x2) #else #define F77_IFUN_xx(i0,name,x1,x2) i0 = (*name)(x1,x2) #endif #ifdef IBM370 #pragma linkage(K77xCx8,FORTRAN) #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ i0 = K77xCx8(&name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10); } while(0) #else #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3,x4,x5,x6,x7,x8,x9,x10 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE8LEN(x3,x4,x5,x6,x7,x8,x9,x10) \ ); } while(0) #endif /* * routines called by Fortran */ #define Errrun F77_NAME(errrun,ERRRUN) #define Fmemcpy F77_NAME(fmemcpy,FMEMCPY) #define Getarg F77_NAME(getarg,GETARG) extern SUBROUTINE Getarg; #define Goparm F77_NAME(goparm,GOPARM) extern SUBROUTINE Goparm; #define Gl_char_cleanup F77_NAME(gl_char_cleanup,GL_CHAR_CLEANUP) #define Gl_reset F77_NAME(gl_reset,GL_RESET) #define Gl_reinit F77_NAME(gl_reinit,GL_REINIT) #define Iclrwk F77_NAME(iclrwk,ICLRWK) extern SUBROUTINE Iclrwk; #define Iginit F77_NAME(iginit,IGINIT) extern SUBROUTINE Iginit; #define Igmenu F77_NAME(igmenu,IGMENU) extern SUBROUTINE Igmenu; #define Igrng F77_NAME(igrng,IGRNG) extern SUBROUTINE Igrng; #define Igsse F77_NAME(igsse,IGSSE) extern SUBROUTINE Igsse; #define Igsrap F77_NAME(igsrap,IGSRAP) extern SUBROUTINE Igsrap; #define Igwkty F77_NAME(igwkty,IGWKTY) extern SUBROUTINE Igwkty; #define Kcexec F77_NAME(kcexec,KCEXEC) #define Kdialo F77_NAME(kdialo,KDIALO) extern SUBROUTINE Kdialo; #define Kgetar F77_NAME(kgetar,KGETAR) #define Kialid F77_NAME(kialid,KIALID) #define Kiargc F77_NAME(kiargc,KIARGC) extern INT_FUNCTION Kiargc; #define Kibres F77_NAME(kibres,KIBRES) extern SUBROUTINE Kibres; #define Kiclos F77_NAME(kiclos,KICLOS) extern SUBROUTINE Kiclos; #define Kicomv F77_NAME(kicomv,KICOMV) #define Kidtab F77_NAME(kidtab,KIDTAB) #define Kierrf F77_NAME(kierrf,KIERRF) extern SUBROUTINE Kierrf; #define Kiinit F77_NAME(kiinit,KIINIT) extern SUBROUTINE Kiinit; #define Kilun F77_NAME(kilun,KILUN) extern SUBROUTINE Kilun; #define Kimath F77_NAME(kimath,KIMATH) #define Kimdef F77_NAME(kimdef,KIMDEF) #define Kimexe F77_NAME(kimexe,KIMEXE) #define Kipawc F77_NAME(kipawc,KIPAWC) #define Kipiaf F77_NAME(kipiaf,KIPIAF) #define Kiprmt F77_NAME(kiprmt,KIPRMT) #define Kirtim F77_NAME(kirtim,KIRTIM) #define Kisigm F77_NAME(kisigm,KISIGM) #define Kivect F77_NAME(kivect,KIVECT) #define Kmpst2 F77_NAME(kmpst2,KMPST2) #define Kmpst3 F77_NAME(kmpst3,KMPST3) #define Kmpx22 F77_NAME(kmpx22,KMPX22) #define Kmpx23 F77_NAME(kmpx23,KMPX23) #define Kmvsed F77_NAME(kmvsed,KMVSED) extern SUBROUTINE Kmvsed; #define Kmvspg F77_NAME(kmvspg,KMVSPG) extern SUBROUTINE Kmvspg; #define Kmvssh F77_NAME(kmvssh,KMVSSH) extern SUBROUTINE Kmvssh; #define Ksvpar F77_NAME(ksvpar,KSVPAR) #define Kuach F77_NAME(kuach,KUACH) #define Kuact F77_NAME(kuact,KUACT) #define Kualfa F77_NAME(kualfa,KUALFA) #define Kuappl F77_NAME(kuappl,KUAPPL) #define Kuargs F77_NAME(kuargs,KUARGS) #define Kubrek F77_NAME(kubrek,KUBREK) #define Kubrof F77_NAME(kubrof,KUBROF) #define Kubron F77_NAME(kubron,KUBRON) #define Kucmd F77_NAME(kucmd,KUCMD) #define Kucmdl F77_NAME(kucmdl,KUCMDL) #define Kucomv F77_NAME(kucomv,KUCOMV) #define Kuedit F77_NAME(kuedit,KUEDIT) #define Kuesvr F77_NAME(kuesvr,KUESVR) #define Kueusr F77_NAME(kueusr,KUEUSR) #define Kuexec F77_NAME(kuexec,KUEXEC) #define Kuexel F77_NAME(kuexel,KUEXEL) #define Kuexit F77_NAME(kuexit,KUEXIT) #define Kufcas F77_NAME(kufcas,KUFCAS) #define Kufdef F77_NAME(kufdef,KUFDEF) #define Kugetc F77_NAME(kugetc,KUGETC) #define Kugete F77_NAME(kugete,KUGETE) #define Kugetf F77_NAME(kugetf,KUGETF) #define Kugeti F77_NAME(kugeti,KUGETI) #define Kugetl F77_NAME(kugetl,KUGETL) #define Kugetq F77_NAME(kugetq,KUGETQ) #define Kugetr F77_NAME(kugetr,KUGETR) #define Kugets F77_NAME(kugets,KUGETS) #define Kugrfl F77_NAME(kugrfl,KUGRFL) #define Kuguid F77_NAME(kuguid,KUGUID) #define Kuhelp F77_NAME(kuhelp,KUHELP) #define Kuhome F77_NAME(kuhome,KUHOME) #define Kuidf1 F77_NAME(kuidf1,KUIDF1) extern SUBROUTINE Kuidf1; #define Kuidf2 F77_NAME(kuidf2,KUIDF2) extern SUBROUTINE Kuidf2; #define Kuidfm F77_NAME(kuidfm,KUIDFM) #define Kuinim F77_NAME(kuinim,KUINIM) #define Kuinit F77_NAME(kuinit,KUINIT) #define Kulun F77_NAME(kulun,KULUN) #define Kumloc F77_NAME(kumloc,KUMLOC) #define Kumout F77_NAME(kumout,KUMOUT) #define Kumpad F77_NAME(kumpad,KUMPAD) #define Kumpst F77_NAME(kumpst,KUMPST) #define Kumpx2 F77_NAME(kumpx2,KUMPX2) #define Kundpv F77_NAME(kundpv,KUNDPV) #define Kunpar F77_NAME(kunpar,KUNPAR) #define Kunwg F77_NAME(kunwg,KUNWG) #define Kuopen F77_NAME(kuopen,KUOPEN) extern SUBROUTINE Kuopen; #define Kupad F77_NAME(kupad,KUPAD) #define Kupar F77_NAME(kupar,KUPAR) #define Kupath F77_NAME(kupath,KUPATH) #define Kupatl F77_NAME(kupatl,KUPATL) #define Kuproc F77_NAME(kuproc,KUPROC) #define Kuprof F77_NAME(kuprof,KUPROF) #define Kuproi F77_NAME(kuproi,KUPROI) #define Kuprop F77_NAME(kuprop,KUPROP) #define Kupror F77_NAME(kupror,KUPROR) #define Kupros F77_NAME(kupros,KUPROS) #define Kumess F77_NAME(kumess,KUMESS) #define Kupval F77_NAME(kupval,KUPVAL) #define Kuqcas F77_NAME(kuqcas,KUQCAS) #define Kuqenv F77_NAME(kuqenv,KUQENV) #define Kuqexe F77_NAME(kuqexe,KUQEXE) #define Kuqsvr F77_NAME(kuqsvr,KUQSVR) #define Kuquit F77_NAME(kuquit,KUQUIT) #define Kusapp F77_NAME(kusapp,KUSAPP) #define Kuser F77_NAME(kuser,KUSER) #define Kuserid F77_NAME(kuserid,KUSERID) #define Kusibr F77_NAME(kusibr,KUSIBR) #define Kusigm F77_NAME(kusigm,KUSIGM) #define Kuspy F77_NAME(kuspy,KUSPY) #define Kustat F77_NAME(kustat,KUSTAT) #define Kustop F77_NAME(kustop,KUSTOP) #define Kuterm F77_NAME(kuterm,KUTERM) #define Kutime F77_NAME(kutime,KUTIME) #define Kutim0 F77_NAME(kutim0,KUTIM0) extern SUBROUTINE Kutim0; #define Kutrue F77_NAME(kutrue,KUTRUE) #define Kuvcre F77_NAME(kuvcre,KUVCRE) extern SUBROUTINE Kuvcre; #define Kuvdel F77_NAME(kuvdel,KUVDEL) extern SUBROUTINE Kuvdel; #define Kuvect F77_NAME(kuvect,KUVECT) extern SUBROUTINE Kuvect; #define Kuvnam F77_NAME(kuvnam,KUVNAM) #define Kuwhag F77_NAME(kuwhag,KUWHAG) #define Kuwham F77_NAME(kuwham,KUWHAM) #define Kuwhat F77_NAME(kuwhat,KUWHAT) #define Kxali1 F77_NAME(kxali1,KXALI1) #define Kxcrv2 F77_NAME(kxcrv2,KXCRV2) extern SUBROUTINE Kxcrv2; #define Macdef F77_NAME(macdef,MACDEF) extern SUBROUTINE Macdef; #define Mdmenu F77_NAME(mdmenu,MDMENU) #define Mhi_close F77_NAME(mhi_close,MHI_CLOSE) extern SUBROUTINE Mhi_close; #define Mhi_open F77_NAME(mhi_open,MHI_OPEN) extern SUBROUTINE Mhi_open; #define Mzwipe F77_NAME(mzwipe,MZWIPE) extern SUBROUTINE Mzwipe; #define Traceq F77_NAME(traceq,TRACEQ) extern SUBROUTINE Traceq; #define Xuflow F77_NAME(xuflow,XUFLOW) extern SUBROUTINE Xuflow; #ifdef IBM370 # pragma linkage(ERRRUN,FORTRAN) # pragma linkage(FMEMCPY,FORTRAN) # pragma linkage(GOPARM,FORTRAN) # pragma linkage(ICLRWK,FORTRAN) # pragma linkage(IGINIT,FORTRAN) # pragma linkage(IGMENU,FORTRAN) # pragma linkage(IGRNG,FORTRAN) # pragma linkage(IGSSE,FORTRAN) # pragma linkage(IGSRAP,FORTRAN) # pragma linkage(IGWKTY,FORTRAN) # pragma linkage(KCEXEC,FORTRAN) # pragma linkage(KDIALO,FORTRAN) # pragma linkage(KGETAR,FORTRAN) # pragma linkage(KIALID,FORTRAN) # pragma linkage(KIBRES,FORTRAN) # pragma linkage(KICLOS,FORTRAN) # pragma linkage(KICOMV,FORTRAN) # pragma linkage(KIDTAB,FORTRAN) # pragma linkage(KIERRF,FORTRAN) # pragma linkage(KIINIT,FORTRAN) # pragma linkage(KILUN,FORTRAN) # pragma linkage(KIMATH,FORTRAN) # pragma linkage(KIMDEF,FORTRAN) # pragma linkage(KIMEXE,FORTRAN) # pragma linkage(KIPAWC,FORTRAN) # pragma linkage(KIPIAF,FORTRAN) # pragma linkage(KIPRMT,FORTRAN) # pragma linkage(KIRTIM,FORTRAN) # pragma linkage(KISIGM,FORTRAN) # pragma linkage(KIVECT,FORTRAN) # pragma linkage(KMPST2,FORTRAN) # pragma linkage(KMPST3,FORTRAN) # pragma linkage(KMPX22,FORTRAN) # pragma linkage(KMPX23,FORTRAN) # pragma linkage(KMVSED,FORTRAN) # pragma linkage(KMVSPG,FORTRAN) # pragma linkage(KMVSSH,FORTRAN) # pragma linkage(KSVPAR,FORTRAN) # pragma linkage(KUACH,FORTRAN) # pragma linkage(KUACT,FORTRAN) # pragma linkage(KUALFA,FORTRAN) # pragma linkage(KUAPPL,FORTRAN) # pragma linkage(KUARGS,FORTRAN) # pragma linkage(KUBREK,FORTRAN) # pragma linkage(KUBROF,FORTRAN) # pragma linkage(KUBRON,FORTRAN) # pragma linkage(KUCMD,FORTRAN) # pragma linkage(KUCMDL,FORTRAN) # pragma linkage(KUCOMV,FORTRAN) # pragma linkage(KUEDIT,FORTRAN) # pragma linkage(KUESVR,FORTRAN) # pragma linkage(KUEUSR,FORTRAN) # pragma linkage(KUEXEC,FORTRAN) # pragma linkage(KUEXEL,FORTRAN) # pragma linkage(KUEXIT,FORTRAN) # pragma linkage(KUFCAS,FORTRAN) # pragma linkage(KUFDEF,FORTRAN) # pragma linkage(KUGETC,FORTRAN) # pragma linkage(KUGETE,FORTRAN) # pragma linkage(KUGETF,FORTRAN) # pragma linkage(KUGETI,FORTRAN) # pragma linkage(KUGETL,FORTRAN) # pragma linkage(KUGETQ,FORTRAN) # pragma linkage(KUGETR,FORTRAN) # pragma linkage(KUGETS,FORTRAN) # pragma linkage(KUGRFL,FORTRAN) # pragma linkage(KUGUID,FORTRAN) # pragma linkage(KUHELP,FORTRAN) # pragma linkage(KUHOME,FORTRAN) # pragma linkage(KUIDF1,FORTRAN) # pragma linkage(KUIDF2,FORTRAN) # pragma linkage(KUIDFM,FORTRAN) # pragma linkage(KUINIM,FORTRAN) # pragma linkage(KUINIT,FORTRAN) # pragma linkage(KULUN,FORTRAN) # pragma linkage(KUMLOC,FORTRAN) # pragma linkage(KUMOUT,FORTRAN) # pragma linkage(KUMPAD,FORTRAN) # pragma linkage(KUMPST,FORTRAN) # pragma linkage(KUMPX2,FORTRAN) # pragma linkage(KUNDPV,FORTRAN) # pragma linkage(KUNPAR,FORTRAN) # pragma linkage(KUNWG,FORTRAN) # pragma linkage(KUOPEN,FORTRAN) # pragma linkage(KUPAD,FORTRAN) # pragma linkage(KUPAR,FORTRAN) # pragma linkage(KUPATH,FORTRAN) # pragma linkage(KUPATL,FORTRAN) # pragma linkage(KUPROC,FORTRAN) # pragma linkage(KUPROF,FORTRAN) # pragma linkage(KUPROI,FORTRAN) # pragma linkage(KUPROP,FORTRAN) # pragma linkage(KUPROR,FORTRAN) # pragma linkage(KUPROS,FORTRAN) # pragma linkage(KUPVAL,FORTRAN) # pragma linkage(KUQCAS,FORTRAN) # pragma linkage(KUQENV,FORTRAN) # pragma linkage(KUQEXE,FORTRAN) # pragma linkage(KUQSVR,FORTRAN) # pragma linkage(KUQUIT,FORTRAN) # pragma linkage(KUSAPP,FORTRAN) # pragma linkage(KUSIBR,FORTRAN) # pragma linkage(KUSIGM,FORTRAN) # pragma linkage(KUSPY,FORTRAN) # pragma linkage(KUSTAT,FORTRAN) # pragma linkage(KUSTOP,FORTRAN) # pragma linkage(KUTERM,FORTRAN) # pragma linkage(KUTIME,FORTRAN) # pragma linkage(KUTIM0,FORTRAN) # pragma linkage(KUTRUE,FORTRAN) # pragma linkage(KUSER,FORTRAN) # pragma linkage(KUVCRE,FORTRAN) # pragma linkage(KUVDEL,FORTRAN) # pragma linkage(KUVECT,FORTRAN) # pragma linkage(KUVNAM,FORTRAN) # pragma linkage(KUWHAG,FORTRAN) # pragma linkage(KUWHAM,FORTRAN) # pragma linkage(KUWHAT,FORTRAN) # pragma linkage(KXALI1,FORTRAN) # pragma linkage(KXCRV2,FORTRAN) # pragma linkage(MACDEF,FORTRAN) # pragma linkage(MDMENU,FORTRAN) # pragma linkage(MHI_CLOSE,FORTRAN) # pragma linkage(MHI_OPEN,FORTRAN) # pragma linkage(MZWIPE,FORTRAN) # pragma linkage(TRACEQ,FORTRAN) # pragma linkage(XUFLOW,FORTRAN) #endif #define MAXCMD 512 /* max length of a command line */ #define MAXEDT 32 /* max length of names in edit server */ #define MAXLEV 10 /* max levels of command name path */ #define MAXSVR 20 /* max number of edit server processes */ /* * The PAWC common is referenced through a pointer to allow the use of * dynamic common blocks on IBM systems. */ #define Pawc kc_pawc EXTERN struct COMMON_PAWC { INTEGER NWPAR; INTEGER IXPAWC; INTEGER IHBOOK; INTEGER IXHIGZ; INTEGER IXKUIP; INTEGER IFENCE[5]; INTEGER LQ[8]; INTEGER DATA[999]; } *Pawc; #define IQ(n) Pawc->DATA[n-1] #define Q(n) (((REAL*)(Pawc->DATA))[n-1]) +KEEP,KCOM_H /* kcom.h: Fortran COMMON blocks */ #define Kcalia F77_BLOCK(kcalia,KCALIA) #define MALIAS 200 EXTERN struct { INTEGER NALIAS; LOGICAL ALIFLG; INTEGER ALITYP[MALIAS]; } F77_COMMON(Kcalia); #define Kcalic F77_BLOCK(kcalic,KCALIC) EXTERN struct { char ALINAM[MALIAS][60]; char ALIVAL[MALIAS][80]; } F77_COMMON(Kcalic); #define Kcbrek F77_BLOCK(kcbrek,KCBREK) EXTERN struct { LOGICAL TRAP; /* flag if signal trapping is enabled */ LOGICAL BRKEN; /* not used, always true */ LOGICAL FIRST; /* only used for Apollo */ LOGICAL FIRSG; /* only used for Apollo */ LOGICAL CLWHAT; /* flag if KUWHAT installed break handler */ LOGICAL CLWHAG; /* flag if KUWHAG installed break handler */ LOGICAL TBFLAG; /* flag if traceback should be printed */ } F77_COMMON(Kcbrek); #define Kcefil F77_BLOCK(kcefil,KCEFIL) EXTERN struct { char EDTFIL[MAXSVR][MAXEDT]; /* file name */ char EDTCMD[MAXSVR][MAXEDT]; /* KUIP command */ } F77_COMMON(Kcefil); #define Kcesvr F77_BLOCK(kcesvr,KCESVR) EXTERN struct { INTEGER NSVFIL; /* number of edited file */ INTEGER NSVCUR; /* pointer to current file */ SUBRPTR IESADD; /* routine set by KUEUSR */ LOGICAL SERVER; /* flag if edit server is used */ } F77_COMMON(Kcesvr); #define Kcexit F77_BLOCK(kcexit,KCEXIT) EXTERN struct { SUBRPTR IEXADD; /* routine set by KUEXIT */ SUBRPTR IUSADD; /* routine set by KUSER */ SUBRPTR NEXADD; /* routine set by KUNEXT */ SUBRPTR IUTADD; /* routine set by KUTERM */ SUBRPTR IQUADD; /* routine set by KUQUIT */ SUBRPTR IBRADD; /* routine set by KUBREK */ LOGICAL LICALL; LOGICAL LICAL2; LOGICAL LICAL3; } F77_COMMON(Kcexit); #define Kcmac F77_BLOCK(kcmac,KCMAC) EXTERN struct { LOGICAL MACTAB; INTEGER NSTLEV; LOGICAL QUITFL; LOGICAL WAITFL; LOGICAL WAITFF; LOGICAL DEBTAB; LOGICAL SKIPFL; LOGICAL HEADFL; INTEGER IONERF; LOGICAL NOEXEC; } F77_COMMON(Kcmac); #define Kcparc F77_BLOCK(kcparc,KCPARC) EXTERN struct { char PARLST[512]; /* interface block for KUSER */ char CLIST[80]; char NOALIN[512]; char COMAND[80]; char CHLAST[512]; char NONPOS[512]; } F77_COMMON(Kcparc); #define Kcsigm F77_BLOCK(kcsigm,KCSIGM) EXTERN struct { SUBRPTR ISIADD; /* routine set by KUSIGM */ INTEGER NVSIGM; /* number of temp vectors create for $SIGMA */ } F77_COMMON(Kcsigm); #define Kcutil F77_BLOCK(kcutil,KCUTIL) EXTERN struct { INTEGER NCMD; INTEGER IWD; INTEGER LUNFIL; INTEGER LPRMPT; LOGICAL TIMING; LOGICAL TRACE; INTEGER CALMOD; INTEGER NVADD; INTEGER IREPET; INTEGER IREFAC; INTEGER IBRAK; LOGICAL TIMALL; INTEGER LENTER; LOGICAL UNIQUE; INTEGER LENMUL; LOGICAL MULTFL; LOGICAL HISTOK; LOGICAL NOHIST; INTEGER LENMUM; LOGICAL FILCAS; LOGICAL MEXEFL; } F77_COMMON(Kcutil); #define Kcvect F77_BLOCK(kcvect,KCVECT) EXTERN struct { INTEGER NUMVEC; /* number of vectors stored */ INTEGER TOTPAV; INTEGER GETPAV; LOGICAL TVECFL; } F77_COMMON(Kcvect); #define Quest F77_BLOCK(quest,QUEST) EXTERN struct { INTEGER DATA[100]; } F77_COMMON(Quest); #define IQUEST(n) Quest.DATA[n-1] #define Sikuip F77_BLOCK(sikuip,SIKUIP) EXTERN struct { char CHSIGM[80]; /* command string passed to SIGMA */ } F77_COMMON(Sikuip); +KEEP,KSIG_H /* ksig.h: signal and break handling */ /* * Available signal handling package * * #define SIGNAL_POSIX ==> sigaction() for Unix * #define SIGNAL_BSD ==> sigvec() for VMS and NeXT * #define SIGNAL_V7 ==> signal() */ #if !defined(SIGNAL_BSD) && !defined(SIGNAL_V7) # define SIGNAL_POSIX #else # define sigjmp_buf jmp_buf # define sigsetjmp(buf,save) setjmp(buf) # define siglongjmp(buf,val) longjmp(buf,val) # ifdef vms # define sv_flags sv_onstack # endif #endif EXTERN struct { int trap_enabled; /* flag if exceptions should be trapped */ int traceback; /* print traceback on signal */ char *error_msg; /* messages is handler cannot do print */ int intr_count; /* count number of consecutive ^C interrupts */ int soft_intr; /* flag to stop at a convenient point */ int jump_set; /* flag if stack has been setup */ sigjmp_buf stack; int sockfd; /* socket descriptor and routine to */ void (*piaf_sync)(); /* resynchronize Piaf communication */ } kc_break; +KEEP,KBROW_H /* kbrow.h: browser definitions */ #define KBROW_H1 \ +SEQ,KBROW_H1 KBROW_H1 #define KBROW_H2 \ +SEQ,KBROW_H2 KBROW_H2 typedef struct _KmObject { struct _KmObject *next; /* link to next object definition */ char *name; /* unique identifier name */ char *stext; /* short description text */ char *ltext; /* long description text */ KmClass *class; /* pointer to objects's class structure */ } KmObject; typedef struct _BrVariable { struct _BrVariable *next; /* link to next variable definition */ char *name; /* variable name */ char *value; /* replacement value */ } BrVariable; typedef struct _BrObject { struct _BrObject *next; /* link to next browsable object */ char *name; /* name of the browsable object */ BrClass *class; /* pointer to browsable's class structure */ BrVariable *vars; /* linked list of variable substitutions */ } BrObject; typedef struct _BrClientdata { BrActTag tag; char *brobj; char *brcls; char *path; char *kmobj; char *kmcls; char *stext; char *ltext; char *mtext; } BrClientdata; EXTERN BrClass *brclasses; EXTERN KmObject *kmobjects; EXTERN KmButton *kmbuttons; extern C_PROTO_2(void klnkbrcl, BrClass*, int); extern C_PROTO_2(void klnkkmcl, KmClass*, int); extern C_PROTO_2(void klnkicon, KmIcon*, int); extern C_PROTO_2(void klnkbutt, KmButton*, int); extern C_PROTO_6(void exec_action, BrAction*, char*, char*, int, KmWidget, KmCalldata); extern C_PROTO_2(KmWidget find_button, char*, char*); extern C_PROTO_1(KmIcon* find_kmicon, char*); extern C_PROTO_1(KmClass* find_kmclass, char*); extern C_PROTO_1(BrObject* find_brobject, char*); extern C_PROTO_2(char* get_variable, char*, char*); extern C_PROTO_0(BrObject* scan_brobjects); extern C_PROTO_3(KmObject* scan_kmobjects, char*, char*, int); extern C_PROTO_7(int set_action, char*, int, int, char*, char*, int, int); extern C_PROTO_3(void set_variable, BrObject*, char*, char*); +KEEP,KLINK_H /* klink.h: demand linking of special routines */ #define KLINK_H1 EXTERN \ +SEQ,KLINK_H1 KLINK_H1 EXTERN struct { SUBROUTINE *user_exit_F; /* set by KUEXIT */ SUBROUTINE *user_quit_F; /* set by KUQUIT */ SUBROUTINE *user_break_F; /* set by KUBREK */ SUBROUTINE *user_edit_F; /* set by KUEUSR */ SUBROUTINE *user_comis_F; /* set by KUCOMV */ SUBROUTINE *user_sigma_F; /* set by KUSIGM */ SUBROUTINE *user_grfl_F; /* set by KUGRFL */ SUBROUTINE *user_term_F; /* set by KUTERM */ SUBROUTINE *user_input_F; /* set by KUSER */ SUBROUTINE *user_locate_F; /* set by KUMLOC */ /* indirect calls to avoid linking Motif */ IntFunc *disp_panel_C; /* display command panel (km_display_cmdpan) */ IntFunc *disp_kpanel_C; /* display KUIP panel (km_display_kpanel) */ IntFunc *disp_text_C; /* display text widget (km_display_sctext) */ IntFunc *disp_choice_C; /* display a choice of commands (?) */ IntFunc *disp_clean_C; /* clean before action (km_destroy_all_popup)*/ IntFunc *disp_flush_C; /* flush event queue (FlushEvents) */ IntFunc *disp_busy_C; /* show busy cursor (km_all_cursor) */ IntFunc *disp_exit_C; /* ask confirmation for exit */ IntFunc *disp_quit_C; /* ask confirmation for exit */ IntFunc *disp_select_C; /* select from a number of buttons */ IntFunc *disp_cmd_list_C; /* display list of commands (km_print_list) */ CharFunc *disp_prompt_C; /* prompt for input */ CharFunc *disp_passwd_C; /* prompt for password input */ /* indirect calls to avoid linking HIGZ without style G */ IntFunc *higz_init_C; /* initialize menu mode */ SUBROUTINE *higz_menu_F; /* IGMENU */ } kjmpaddr; +KEEP,KFLAG_H typedef enum { KmMACRO_COMMAND = 0, /* don't look for macros */ KmMACRO_AUTO, /* look for macros before commands */ KmMACRO_AUTOREVERSE /* look for macros after commands */ } KmMacOrder; typedef enum { KmSTYLE_A = 0x0001, /* Alpha menus */ KmSTYLE_C = 0x0002, /* Command line */ KmSTYLE_G = 0x0004, /* Graphics menus */ KmSTYLE_M = 0x0008, /* Model Human Interface */ KmSTYLE_U = 0x0010, /* User */ KmSTYLE_XM = 0x0020, /* Motif/X11 */ KmSTYLE_major = 0x00FF, /* A..X are mutually exclusive */ KmSTYLE_xL = 0x0100, /* Alpha Letter menus */ KmSTYLE_xP = 0x0200, /* Panel style GP or MP */ KmSTYLE_xS = 0x0400, /* Graphics with Software fonts */ KmSTYLE_xW = 0x0800 /* Graphics with shadowed Width */ } KmStyleFlag; typedef enum { KmTIMING_OFF, /* no timing */ KmTIMING_ON, /* time typed commands */ KmTIMING_ALL /* time individual commands inside macro */ } KmTiming; EXTERN struct { LOGICAL f77_true; /* value of .TRUE. */ LOGICAL f77_false; /* value of .FALSE. */ int do_exit; /* set by KXEXIT */ int do_quit; /* set by KXQUIT */ char *curr_prompt; /* current prompt string */ char *last_cmd; /* last command for $LAST */ KmTiming timing; /* timing on/off/all */ time_t real_time; /* real time at last timing off */ clock_t user_time; /* CPU time at last timing off */ int in_macro; /* command executed in macro */ int in_application; /* application mode is active */ int appl_called; /* application is executing */ char *appl_exit; /* string which leaves application mode */ KmCommand *appl_cmd; /* command which handles application */ char appl_file[256]; /* temporary file to pass application text */ FILE *appl_stream; /* C stream used for writing appl_file */ int appl_luno; /* Fortran logical unit opened for appl_file */ char help_file[256]; /* temporary file to view help text */ char uhlp_file[256]; /* temporary file to get user help text */ int uhlp_luno; /* Fortran logical unit opened for user help */ int in_motif; /* Motif mode is active */ int echo_command; /* echo commands in Motif mode */ char *echo_prompt; /* prompt string for echo commands */ KmStyleFlag style; /* input mode */ int keep_fcase; /* flag if no case conversion for filenames */ int use_kxterm; /* flag if kxterm should be used */ int use_server; /* flag if edit server should be used */ int editor_exit; /* flag set if edit server sent SIGUSR1 */ char *editor_cbuf; /* buffer of for edit servers commands */ char *macro_path; /* MACRO/DEFAULT search path */ KmMacOrder macro_search; /* MACRO/DEFAULT search order */ int temp_vectors; /* number of ?SIGMA vectors */ char init_wdir[256]; /* initial working directory */ } kc_flags; EXTERN struct { char *set_break; /* SET_SHOW/BREAK */ char set_columns[8]; /* SET_SHOW/COLUMNS */ char *set_command; /* SET_SHOW/COMMAND */ char *set_filecase; /* SET_SHOW/FILECASE */ char *set_host_editor; /* SET_SHOW/HOST_EDITOR */ char *set_host_pager; /* SET_SHOW/HOST_PAGER */ char *set_host_shell; /* SET_SHOW/HOST_SHELL */ char *set_prompt; /* SET_SHOW/PROMPT */ char *set_recall_style; /* SET_SHOW/RECALL_STYLE */ char set_recording[8]; /* SET_SHOW/RECORDING */ char *set_root; /* SET_SHOW/ROOT */ char *set_style; /* SET_SHOW/STYLE */ char *set_timing; /* SET_SHOW/TIMING */ char *help_edit; /* HELP edit mode */ char *defaults_path; /* MACRO/DEFAULTS search path */ char *defaults_order; /* MACRO/DEFAULTS search order */ } kc_value; typedef struct { int top; int left; int width; int height; } KmWindowDsc; EXTERN struct { KmWindowDsc edit_pad; /* coordinates for edit window */ KmWindowDsc help_pad; /* coordinates for readonly window */ int voffset; /* vertical offset */ int hoffset; /* horizontal offset */ int shift_max; /* maximum number of shifted pads */ int shift_now; /* current shift count */ int shift_dir; /* shift direction +/-1 */ int is_a_pad; /* flag if running in an Apollo DM pad */ int is_a_tty; /* flag if stdin and stdout at terminal */ int use_getline; /* flag for using getline() or normal read */ int use_no_echo; /* flag for using no echo in password prompt */ int term_width; /* terminal width in columns */ int kuwhag_called; /* allow style G */ float sgylen; float sgsize; float sgyspa; float sgbord; int panel_rows; /* number of rows in style GP panel */ int *panel_cols; /* number of columns in each row */ char ***panel_keys; /* key labels */ char *panel_keynum; /* value of $KEYNUM */ char *panel_keyval; /* value of $KEYVAL */ } kc_window; extern C_PROTO_1(char* style_name, KmStyleFlag); +KEEP,KMENU_H /* kmenu.h: data structures for menu and command definitions */ #define KMENU_H1 \ +SEQ,KMENU_H1 KMENU_H1 #define KMENU_H2 \ +SEQ,KMENU_H2 KMENU_H2 #define KMENU_H3 \ +SEQ,KMENU_H3 KMENU_H3 /* * temporary fix until we can reserve an extra word in KmCommand structure * to count keyboard and macro commands separately */ #define XCOUNT_SHIFT 10 #define XCOUNT_OFFSET (1 << XCOUNT_SHIFT) #define XCOUNT_MASK (XCOUNT_OFFSET - 1) extern C_PROTO_2(void check_version, int, int); extern C_PROTO_0(void check_edit_server); extern C_PROTO_3(int exec_cmd_string, char*, int, int(*)()); extern C_PROTO_1(int exec_decoded_cmd, KmCommand*); extern C_PROTO_1(KmMenu* find_submenu, char*); extern C_PROTO_2(char* fmt_cmd_help, KmCommand*, int); extern C_PROTO_0(void menu_style); extern C_PROTO_2(void print_cmd_list, KmCommand**, char*); extern C_PROTO_1(void reset_arg_list, KmCommand*); extern C_PROTO_1(KmMenu** root_menu_list, char*); extern C_PROTO_2(KmCommand* search_command, char*, KmCommand***); +KEEP,KHASH_H /* khash.h: hash table management */ typedef struct _HashArray { char *name; /* symbol name */ void *value; /* symbol value */ } HashArray; typedef struct _HashEntry { struct _HashEntry *next; /* link to next entry */ char *name; /* symbol name */ void *value; /* symbol value */ } HashEntry; typedef struct { int size; /* table size should be a prime number */ HashEntry **entries; /* pointer to array of size entries */ int nentries; /* number of entries */ int copy; /* flag if strdup/free(value) should be used */ } HashTable; #define ALIAS_TABLE_SIZE 97 /* should be a prime */ EXTERN struct { int translate; /* flag if translation wanted */ int substitutions; /* how many more before recursive alarm */ HashTable *arg_table; /* Argument alias table */ HashTable *cmd_table; /* Command alias table */ HashTable *var_table; /* macro variables */ } kc_alias; extern C_PROTO_2(HashTable* hash_create, int, int); extern C_PROTO_1(void hash_clear, HashTable*); extern C_PROTO_1(void hash_destroy, HashTable*); extern C_PROTO_3(void hash_insert, HashTable*, const char*, void*); extern C_PROTO_2(void hash_remove, HashTable*, const char*); extern C_PROTO_2(void* hash_lookup, HashTable*, const char*); extern C_PROTO_1(int hash_entries, HashTable*); extern C_PROTO_1(HashArray* hash_array, HashTable*); extern C_PROTO_1(int match_paren, char*); extern C_PROTO_1(char* repl_variable, char*); extern C_PROTO_2(char* repl_sysfun, char*, int); extern C_PROTO_1(char* subst_arg_alias, char*); extern C_PROTO_1(char* subst_cmd_alias, char*); extern C_PROTO_1(char* subst_var_alias, char*); extern C_PROTO_2(char* subst_sysfun, char*, int); extern C_PROTO_1(char* var_value, char*); +KEEP,MKTERM. #define ESCAPE "#@" typedef void (*KxtermActionProc)( #ifndef NO_PROTOTYPES char** /* params */, int /* num_params */ #endif ); typedef struct _KxtermActionsRec{ char *string; KxtermActionProc proc; } KxtermActionsRec; typedef KxtermActionsRec *KxtermActionList; extern C_PROTO_1(void kxterm_add_actions, KxtermActionList); extern C_PROTO_1(void handle_kxterm_action, char *); extern C_PROTO_1(void send_kxterm_cmd, char**); extern C_PROTO_1(void send_single_kxterm_cmd, char*); +DECK,hkuip_94a,if=94a. +KEEP,KHAIX370 #ifndef AIX370 # define AIX370 #endif +KEEP,KHAPOFTN #ifndef APOLLO_FTN # define APOLLO_FTN #endif +KEEP,KHIBMVM #ifndef IBMVM # define IBMVM #endif +KEEP,KHIBMMVS #ifndef IBMMVS # define IBMMVS #endif +KEEP,KHNEWLIB #ifndef NEWLIB # define NEWLIB #endif +KEEP,KUIP_H /* kuip.h: system dependent defines */ /* update version if structures have changed */ #define KUIP_VERSION 921023 /* identify system if not possible from preprocessor defines */ +SEQ,KHAIX370,IF=AIX370 +SEQ,KHAPOFTN,IF=APOFTN +SEQ,KHIBMVM ,IF=IBMVM +SEQ,KHIBMMVS,IF=IBMMVS +SEQ,KHNEWLIB,IF=NEWLIB #ifdef AIX370 # define MACHINE_NAME "IBMAIX" # define UNIX # define F77_EXTERN_INDIRECT #endif #if defined(apollo) || defined(__apollo) # define MACHINE_NAME "APOLLO" # define APOLLO # define UNIX # include # include # include # include # include # include # ifdef APOLLO_FTN /* using /com/ftn instead of /bin/f77 */ # define F77_CHAR_LEN_IND # define F77_CHAR_LEN_TYPE short # define F77_EXTERN_LOWERCASE # endif # define F77_EXTERN_INDIRECT # define F77_COMMON(name) name __attribute((__section(name))) # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_DIRENT_H # define TERMIO_BSD /* for getline we must compile under bsd4.3 */ #endif #if defined(__convexc__) # define CONVEX # define MACHINE_NAME "CONVEX" # define UNIX # define F77_BLOCK(name,NAME) _##name##_ # define F77_ARG_CONSTANT # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define BROKEN_STRDUP /* wrong prototype for strdup() in string.h */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRNCASECMP # define HAVE_SELECT # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ # define USE_EDIT_SERVER #endif #ifdef CRAY # define MACHINE_NAME "CRAY" # define UNIX # include # define F77_EXTERN_UPPERCASE # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define HAVE_STRCASECMP # define HAVE_STRDUP # define NO_EDIT_SERVER #endif #if defined(hpux) || defined(__hpux) # define MACHINE_NAME "HPUX" # define HPUX # define UNIX # ifdef hpux /* cc -Ac */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # ifndef _HPUX_SOURCE # define _HPUX_SOURCE # endif # define FATAL_SIGFPE /* needs f77 +T and ON REAL UNDERFLOW IGNORE */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_STRRSTR # define HAVE_SELECT # define SELECT_CAST(fds) (int*)fds #endif #ifdef _IBMR2 # define IBMRT # define MACHINE_NAME "IBMRT" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # include # define HAVE_SELECT # define BROKEN_F77_IO #endif #ifdef IBMVM # define ARG_STYLE_CMS # define MACHINE_NAME "IBM" # define OS_NAME "VM" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBMMVS # define MACHINE_NAME "IBMMVS" # define OS_NAME "MVS" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBM370 # define F77_ARG_CONSTANT # define F77_CHAR_LEN_IND /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_EXTERN_INDIRECT # define F77_EXTERN_UPPERCASE # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_V7 #endif #ifdef linux # define LINUX # define MACHINE_NAME "LINUX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_SELECT #endif #ifdef MSDOS # define MACHINE_NAME "IBMPC" # define OS_NAME "MSDOS" # define UNIX # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define SIGNAL_V7 # define SLASHES "\\/" # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ #endif #ifdef WIN32 # define WINNT # ifdef _ALPHA_ # define MACHINE_NAME "ALPHA" # else # define MACHINE_NAME "IBMPC" # endif # define OS_NAME "WINNT" # define UNIX # define MSDOS # include # include # include # include # define text_mode__() # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define NO_UNISTD_H # define SIGNAL_V7 # define SLASHES "\\" #endif #ifdef NeXT # define MACHINE_NAME "NEXT" # define UNIX # define getcwd(path,maxlen) getwd(path) # define F77_BLOCK(lc,uc) lc # define F77_EXTERN_INDIRECT /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_XXXX_USE_LEN(x) ,286716 /* don't know if value matters */ # define HAVE_MEMMOVE # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define NO_DIRENT_H # define NO_UNISTD_H # define SIGNAL_BSD # define TERMIO_BSD #endif #ifdef __osf__ # define UNIX # ifdef __alpha # define ALPHA # define MACHINE_NAME "ALPHA" # endif # define BROKEN_STRDUP /* wrong prototype for strdup() in string.h */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT # define BROKEN_F77_IO #endif #if defined(sgi) || defined(__sgi) # define MACHINE_NAME "SGI" # define SGI # define UNIX # ifndef __sgi /* Irix 3 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_SELECT #endif #if defined(sun) || defined(__sun) # define SUN # define UNIX # ifdef Solaris2 # define MACHINE_NAME "SOLARIS" # define SOLARIS # define HAVE_MEMMOVE # define HAVE_SELECT # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_VFORK # else # define MACHINE_NAME "SUN" # ifndef __STDC__ /* cc vs. acc */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_SELECT # define HAVE_STRCASECMP # define HAVE_STRDUP # define HAVE_VFORK # include # define MATCH_RE_COMP /* use re_comp/re_exec */ # endif #endif #if defined(ultrix) || defined(__ultrix) # define MACHINE_NAME "DECS" # define ULTRIX # define UNIX # ifndef __ultrix /* cc vs. c89 */ # define NO_ANSI_CPP # define NO_PROTOTYPES # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_VFORK # define TERMIO_BSD # define BROKEN_F77_IO #endif #ifdef vms # define OS_NAME "VMS" # ifdef __ALPHA # define ALPHA # define MACHINE_NAME "ALPHA" # pragma extern_model common_block # include /* inside descrip.h on VAX */ # else # define MACHINE_NAME "VAX" # define NO_ANSI_CPP # endif # include # include # include /* lib$... prototypes */ # include # include # include # include # include # include # include # include # include /* sys$... prototypes */ # include # include # include # include # include # ifndef R_OK /* no access() modes in unixio.h on VAX/VMS */ # define F_OK 0 # define X_OK 1 # define W_OK 2 # define R_OK 4 # endif # define ARG_STYLE_VMS # define F77_EXTERN_LOWERCASE # define HAVE_MEMMOVE # define HAVE_STAT_H # define HAVE_VFORK /* actually have only vfork */ # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_BSD # define sigmask(sig) (1L << (sig-1)) /* should be in signal.h */ # define USE_EDIT_SERVER /* only for TPU/DISPLAY=MOTIF */ # define fix_descriptor(dsc,str,n) \ do { \ dsc.dsc$b_dtype = DSC$K_DTYPE_T; \ dsc.dsc$b_class = DSC$K_CLASS_S; \ dsc.dsc$a_pointer = str; \ dsc.dsc$w_length = n; \ } while( 0 ) # define var_descriptor(dsc,str) \ do { \ dsc.dsc$b_dtype = DSC$K_DTYPE_T; \ dsc.dsc$b_class = DSC$K_CLASS_S; \ dsc.dsc$a_pointer = str; \ dsc.dsc$w_length = strlen( dsc.dsc$a_pointer ); \ } while( 0 ) #endif /* vms */ #include #include #include #ifndef NO_FCNTL_H #include #endif #include /* contains strtod() and strtol() on some systems */ #include #include #include #include #include #include #ifndef NO_UNISTD_H #include #endif #ifndef HAVE_VFORK # define vfork fork #endif #ifdef UNIX /* also defined for MSDOS and Windows/NT*/ # ifndef OS_NAME # define OS_NAME "UNIX" # endif # include # include # ifndef NO_SYS_TIME_H # include /* struct timeval */ # endif # ifndef MSDOS # ifdef TERMIO_BSD # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ # define HAVE_SELECT # endif # if defined(HAVE_SELECT) && !defined(SELECT_CAST) # define SELECT_CAST(fds) fds # endif # if !defined(TERMIO_BSD) && !defined(TERMIO_SYSV) # define TERMIO_POSIX # endif # include # ifndef NO_DIRENT_H /* POSIX opendir() */ # include # else /* BSD opendir() */ # include /* plus */ # define dirent direct /* struct dirent... */ # ifndef S_IRUSR # define S_IRUSR (S_IREAD) /* read permission, owner */ # define S_IWUSR (S_IWRITE) /* write permission, owner */ # define S_IXUSR (S_IEXEC) /* execute/search permission, owner */ # endif # endif # endif # define HAVE_STAT_H # ifndef NO_EDIT_SERVER # define USE_EDIT_SERVER # ifndef F_LOCK /* BSD file locking */ # include # define lockf(fd,op,offs) flock(fd,op) # define F_LOCK LOCK_EX # define F_ULOCK LOCK_UN # endif # endif # ifndef SLASHES # define SLASHES "/" # endif #endif #ifdef SUN # ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 1000000 /* missing in time.h */ # define difftime(t1,t0) ((double)(t1-t0)) # define raise(sig) kill(getpid(),sig) # endif #endif #ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 100 /* missing in VAX/VMS time.h */ #endif #ifdef HAVE_STAT_H # define KmTimeStamp struct stat # define get_stamp(path,stamp) stat(path,stamp) # define cmp_stamp(stamp1,stamp2) ((stamp2)->st_mtime == (stamp1)->st_mtime) #endif #ifndef KmTimeStamp # define KmTimeStamp int # define get_stamp(path,stamp) 0 # define cmp_stamp(stamp1,stamp2) 0 #endif #ifdef MATCH_RE_COMP extern char *re_comp(); extern int re_exec(); #else extern char *regcmp(); extern char *regex(); #endif /* command line arguments recognized by KUARGS */ #if !defined(ARG_STYLE_CMS) && !defined(ARG_STYLE_VMS) # define ARG_STYLE_UNIX #endif #ifndef MACHINE_NAME # define MACHINE_NAME "UNKNOWN" /* value returned by $MACHINE */ #endif #ifndef OS_NAME # define OS_NAME "UNKNOWN" /* value returned by $OS */ #endif /* #define EXTERN must be in one routine to allocate space for globals */ #ifndef EXTERN # define EXTERN extern #endif /* #define STATIC extern if debugger does not see static functions */ #ifndef STATIC # define STATIC static #endif #if defined(__GNUC__) || defined(__STDC__) # ifdef NO_ANSI_CPP # undef NO_ANSI_CPP # endif # ifdef NO_PROTOTYPES # undef NO_PROTOTYPES # endif #endif /* * Preprocessor syntax for token concatenation */ #ifndef NO_ANSI_CPP # define ConCat(con,cat) con##cat #else # define ConCat(con,cat) con/**/cat #endif /* * Prototyping for C functions */ #ifndef NO_PROTOTYPES # define C_PROTO_0(name) \ name(void) # define C_PROTO_1(name,arg1) \ name(arg1) # define C_PROTO_2(name,arg1,arg2) \ name(arg1,arg2) # define C_PROTO_3(name,arg1,arg2,arg3) \ name(arg1,arg2,arg3) # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name(arg1,arg2,arg3,arg4) # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name(arg1,arg2,arg3,arg4,arg5) # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name(arg1,arg2,arg3,arg4,arg5,arg6) # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7) # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) # define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) # define C_PROTO_17(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name(t1 p1) # define C_DECL_2(name,t1,p1,t2,p2) \ name(t1 p1,t2 p2) # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name(t1 p1,t2 p2,t3 p3) # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name(t1 p1,t2 p2,t3 p3,t4 p4) # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5) # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6) # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7) # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8) # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,t9 p9) # define C_DECL_13(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,\ t9,p9,t10,p10,t11,p11,t12,p12,t13,p13) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,\ t9 p9,t10 p10,t11 p11,t12 p12,t13 p13) #else # define const # define C_PROTO_0(name) \ name() # define C_PROTO_1(name,arg1) \ name() # define C_PROTO_2(name,arg1,arg2) \ name() # define C_PROTO_3(name,arg1,arg2,arg3) \ name() # define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name() # define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name() # define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name() # define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name() # define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name() # define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name() # define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name() # define C_PROTO_16(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6) \ name() # define C_PROTO_17(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3,b4,b5,b6,b7) \ name() # define C_DECL_0(name) \ name() # define C_DECL_1(name,t1,p1) \ name( p1) \ t1 p1; # define C_DECL_2(name,t1,p1,t2,p2) \ name( p1, p2) \ t1 p1;t2 p2; # define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name( p1, p2, p3) \ t1 p1;t2 p2;t3 p3; # define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name( p1, p2, p3, p4) \ t1 p1;t2 p2;t3 p3;t4 p4; # define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name( p1, p2, p3, p4, p5) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5; # define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name( p1, p2, p3, p4, p5, p6) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6; # define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name( p1, p2, p3, p4, p5, p6, p7) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7; # define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name( p1, p2, p3, p4, p5, p6, p7, p8) \ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8; # define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name( p1, p2, p3, p4, p5, p6, p7, p8, p9)\ t1 p1;t2 p2;t3 p3;t4 p4;t5 p5;t6 p6;t7 p7;t8 p8;t9 p9; # define C_DECL_13(name,A,a,B,b,C,c,D,d,E,e,F,f,G,g,H,h,I,i,J,j,K,k,L,l,M,m)\ name( a, b, c, d, e, f, g, h, i, j, k, l, m)\ A a;B b;C c;D d;E e;F f;G g;H h;I i;J j;K k;L l;M m; #endif typedef int IntFunc(); typedef char* CharFunc(); typedef char** pCharFunc(); #define KUMAC_UNWIND -30041961 /* error status to quit macro execution */ /* * convenience functions from kkern.c */ extern C_PROTO_2(char* fexpand, const char*, const char*); extern C_PROTO_1(char* fsymlink, const char*); extern C_PROTO_3(char* fsearch, const char*, const char*, const char*); extern C_PROTO_2(char* fstrdup, const char*, size_t); extern C_PROTO_2(char* fstr0dup, const char*, size_t); extern C_PROTO_2(char* fstrtrim, const char*, size_t); extern C_PROTO_2(char* fstr0trim, const char*, size_t); extern C_PROTO_2(size_t fstrlen, const char*, size_t); extern C_PROTO_3(size_t fstrset, char*, size_t, const char*); extern C_PROTO_2(double fstrtod, char*, char**); extern C_PROTO_2(int fstrtoi, char*, char**); extern C_PROTO_3(char* fstrvec, char**, int, int*); #ifndef HAVE_MEMMOVE extern C_PROTO_3(void* memmove, void*, const void*, size_t); #endif #ifndef HAVE_STRCASECMP extern C_PROTO_2(int strcasecmp, const char*, const char*); extern C_PROTO_3(int strncasecmp, const char*, const char*, size_t); #endif #ifndef HAVE_STRDUP #ifdef BROKEN_STRDUP /* prototype without const */ # define strdup Strdup #endif extern C_PROTO_1(char* strdup, const char*); #endif #ifndef HAVE_STRRSTR extern C_PROTO_2(char* strrstr, const char*, const char*); #endif extern C_PROTO_2(char* strrpbrk, const char*, const char*); extern C_PROTO_1(char* str0dup, const char*); extern C_PROTO_2(char* str2dup, const char*, const char*); extern C_PROTO_3(char* str3dup, const char*, const char*, const char*); extern C_PROTO_4(char* str4dup, const char*, const char*, const char*, const char*); extern C_PROTO_5(char* str5dup, const char*, const char*, const char*, const char*, const char*); extern C_PROTO_2(char* strndup, const char*, int); extern C_PROTO_2(char* mstrcat, char*, const char*); extern C_PROTO_3(char* mstr2cat, char*, const char*, const char*); extern C_PROTO_4(char* mstr3cat, char*, const char*, const char*, const char*); extern C_PROTO_5(char* mstr4cat, char*, const char*, const char*, const char*, const char*); extern C_PROTO_3(char* mstrncat, char*, const char*, int); extern C_PROTO_3(char* mstrccat, char*, int, int); extern C_PROTO_2(char* mstricat, char*, int); extern C_PROTO_2(int mstrlen, char**, int); extern C_PROTO_1(char* strqtok, char*); extern C_PROTO_1(char* strlower, char*); extern C_PROTO_1(char* strupper, char*); extern C_PROTO_1(char* struntab, char*); extern C_PROTO_2(char* strfromd, double, int); extern C_PROTO_2(char* strfromi, int, int); /* * C-interface functions */ extern C_PROTO_0(char* k_getar); extern C_PROTO_2(void k_setar, int, char**); extern C_PROTO_0(char* k_userid); extern C_PROTO_0(void ku_alfa); extern C_PROTO_2(char* ku_appl, int*, int*); extern C_PROTO_1(int ku_close, int); extern C_PROTO_1(void ku_cmdl, char*); extern C_PROTO_2(int ku_edit, char*, int); extern C_PROTO_1(char* ku_eval, char*); extern C_PROTO_1(int ku_exec, char*); extern C_PROTO_1(int ku_exel, char*); extern C_PROTO_0(char* ku_getc); extern C_PROTO_0(char* ku_gete); extern C_PROTO_0(char* ku_getf); extern C_PROTO_0(int ku_geti); extern C_PROTO_0(char* ku_getl); extern C_PROTO_0(char* ku_getq); extern C_PROTO_0(double ku_getr); extern C_PROTO_0(char* ku_gets); extern C_PROTO_1(char* ku_fcase, char*); extern C_PROTO_2(char* ku_home, char*, char*); extern C_PROTO_1(int ku_inqf, char*); extern C_PROTO_1(int ku_intr, int); extern C_PROTO_1(void ku_last, char*); extern C_PROTO_2(int ku_more, char*, char*); extern C_PROTO_0(int ku_npar); extern C_PROTO_3(int ku_open, int, char*, char*); extern C_PROTO_2(void ku_pad, char*, int); extern C_PROTO_0(char* ku_path); extern C_PROTO_2(void ku_piaf, int, void(*)()); extern C_PROTO_2(char* ku_proc, char*, char*); extern C_PROTO_2(char* ku_prof, char*, char*); extern C_PROTO_2(int ku_proi, char*, int); extern C_PROTO_1(char* ku_prop, char*); extern C_PROTO_2(double ku_pror, char*, double); extern C_PROTO_2(char* ku_pros, char*, char*); extern C_PROTO_0(char** ku_qenv); extern C_PROTO_1(char* ku_qexe, char*); extern C_PROTO_3(int ku_read, int, char*, int); extern C_PROTO_2(int ku_sapp, char*, char*); extern C_PROTO_0(void ku_shut); extern C_PROTO_1(int ku_stop, int); extern C_PROTO_2(void ku_time, time_t, clock_t); extern C_PROTO_2(void ku_trap, int, int); extern C_PROTO_1(int ku_vqaddr, char*); extern C_PROTO_1(int ku_vtype, char*); extern C_PROTO_2(int ku_vvalue, char*, double*); extern C_PROTO_0(void ku_whag); extern C_PROTO_1(void ku_what, void(*)()); extern C_PROTO_2(void ku_write, int, char*); extern C_PROTO_1(char* getline, char*); extern C_PROTO_2(void gl_config, char*, int); extern C_PROTO_1(void gl_histadd, char*); extern C_PROTO_1(void gl_setwidth, int); extern C_PROTO_2(char* input_line, char*, int); extern C_PROTO_0(void leave_kuip); extern C_PROTO_2(int len_alias, char*, int); extern C_PROTO_1(int len_sysfun, char*); extern C_PROTO_1(int len_vector, char*); extern C_PROTO_2(char* quote_string, char*, int); extern C_PROTO_0(void reset_break); #ifndef vms extern C_PROTO_1(void signal_handler, int ); #else extern C_PROTO_2(int signal_handler, void*, void* ); extern C_PROTO_1(int control_C_ast, int ); #endif +KEEP,KFOR_H /* kfor.h: Fortran-C interface */ /* * Fortran data types */ typedef int INTEGER; typedef int LOGICAL; typedef float REAL; typedef double DBLPREC; typedef struct { REAL re; REAL im; } COMPLEX; typedef INTEGER INT_FUNCTION(); typedef INT_FUNCTION *INT_FUNCPTR; typedef void (*SUBRPTR)(); typedef void SUBROUTINE(); #ifdef IBM370 #pragma linkage(SUBROUTINE,FORTRAN) #pragma linkage(INT_FUNCTION,FORTRAN) #pragma map(__CTOF,"@@CTOF") extern INTEGER __CTOF( INT_FUNCPTR, ... ); #endif typedef union _EQUIV_INT_REAL { INTEGER i; LOGICAL l; REAL r; } EQUIV_INT_REAL; /* * Mapping of C-routine name for Fortran CALL SUB * * #define F77_EXTERN_LOWERCASE ==> void sub() * #define F77_EXTERN_UPPERCASE ==> void SUB() * otherwise ==> void sub_() */ #ifdef F77_EXTERN_UPPERCASE # define F77_NAME(name,NAME) NAME #else # ifdef F77_EXTERN_LOWERCASE # define F77_NAME(name,NAME) name # else # define F77_NAME(name,NAME) ConCat(name,_) # endif #endif #ifndef F77_BLOCK # define F77_BLOCK(name,NAME) F77_NAME(name,NAME) #endif #ifndef F77_COMMON # define F77_COMMON(name) name #endif /* * Routine address in CALL SUB(FUN) ; EXTERNAL FUN * * #define F77_EXTERN_INDIRECT ==> void (**fun)(); * otherwise ==> void (*fun)(); */ #ifdef F77_EXTERN_INDIRECT # define F77_EXTERN_ARG(e) ConCat(e,_ptr) # define F77_EXTERN_DCL(e) SUBROUTINE **ConCat(e,_ptr); # define F77_EXTERN_DEF(e) SUBROUTINE *e = *ConCat(e,_ptr); #else # define F77_EXTERN_ARG(e) e # define F77_EXTERN_DCL(e) SUBROUTINE *e; # define F77_EXTERN_DEF(e) #endif #define F77_EXTERN2ARG(e1,e2) F77_EXTERN_ARG(e1),F77_EXTERN_ARG(e2) #define F77_EXTERN2DCL(e1,e2) F77_EXTERN_DCL(e1) F77_EXTERN_DCL(e2) #define F77_EXTERN2DEF(e1,e2) F77_EXTERN_DEF(e1) F77_EXTERN_DEF(e2) #define F77_EXTERN3ARG(e1,e2,e3) F77_EXTERN_ARG(e1),F77_EXTERN2ARG(e2,e3) #define F77_EXTERN3DCL(e1,e2,e3) F77_EXTERN_DCL(e1) F77_EXTERN2DCL(e2,e3) #define F77_EXTERN3DEF(e1,e2,e3) F77_EXTERN_DEF(e1) F77_EXTERN2DEF(e2,e3) #define F77_EXTERN4ARG(e1,e2,e3,e4) F77_EXTERN_ARG(e1),F77_EXTERN3ARG(e2,e3,e4) #define F77_EXTERN4DCL(e1,e2,e3,e4) F77_EXTERN_DCL(e1) F77_EXTERN3DCL(e2,e3,e4) #define F77_EXTERN4DEF(e1,e2,e3,e4) F77_EXTERN_DEF(e1) F77_EXTERN3DEF(e2,e3,e4) #ifdef F77_ARG_CONSTANT /* * If the Fortran compiler (e.g. VSFORTRAN and Convex fc without -sa option) * uses constant argument blocks we have to make a private copy in case the * routine uses the arguments as local variables. */ # define F77_XXXX_ARG_PTR(t,x) ConCat(x,_ptr) # define F77_XXXX_ARG_DCL(t,x) t *ConCat(x,_ptr); # define F77_XXXX_ARG_DEF(t,x) t *x = ConCat(x,_ptr); #else # define F77_XXXX_ARG_PTR(t,x) x # define F77_XXXX_ARG_DCL(t,x) t *x; # define F77_XXXX_ARG_DEF(t,x) #endif #define F77_REAL_ARG_PTR(r) F77_XXXX_ARG_PTR(REAL,r) #define F77_REAL_ARG_DCL(r) F77_XXXX_ARG_DCL(REAL,r) #define F77_REAL_ARG_DEF(r) F77_XXXX_ARG_DEF(REAL,r) #define F77_INTG_ARG_PTR(i) F77_XXXX_ARG_PTR(INTEGER,i) #define F77_INTG_ARG_DCL(i) F77_XXXX_ARG_DCL(INTEGER,i) #define F77_INTG_ARG_DEF(i) F77_XXXX_ARG_DEF(INTEGER,i) #define F77_INTG_ARG2PTR(i1,i2) F77_INTG_ARG_PTR(i1),F77_INTG_ARG_PTR(i2) #define F77_INTG_ARG2DCL(i1,i2) F77_INTG_ARG_DCL(i1) F77_INTG_ARG_DCL(i2) #define F77_INTG_ARG2DEF(i1,i2) F77_INTG_ARG_DEF(i1) F77_INTG_ARG_DEF(i2) #define F77_INTG_ARG3PTR(i1,i2,i3) F77_INTG_ARG_PTR(i1),F77_INTG_ARG2PTR(i2,i3) #define F77_INTG_ARG3DCL(i1,i2,i3) F77_INTG_ARG_DCL(i1) F77_INTG_ARG2DCL(i2,i3) #define F77_INTG_ARG3DEF(i1,i2,i3) F77_INTG_ARG_DEF(i1) F77_INTG_ARG2DEF(i2,i3) #define F77_INTG_ARG4PTR(i1,i2,i3,i4) F77_INTG_ARG_PTR(i1), \ F77_INTG_ARG3PTR(i2,i3,i4) #define F77_INTG_ARG4DCL(i1,i2,i3,i4) F77_INTG_ARG_DCL(i1) \ F77_INTG_ARG3DCL(i2,i3,i4) #define F77_INTG_ARG4DEF(i1,i2,i3,i4) F77_INTG_ARG_DEF(i1) \ F77_INTG_ARG3DEF(i2,i3,i4) /* * Access to Fortran CHARACTER arguments */ #ifdef vms /* VMS string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) struct dsc$descriptor_s *ConCat(s,_ptr); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr)->dsc$a_pointer; \ int ConCat(len_,s) = ConCat(s,_ptr)->dsc$w_length; # define F77_CHAR_DEF_DSC(s,p,l) struct dsc$descriptor_s ConCat(s,_dsc); # define F77_CHAR_ASS_DSC(s,p,l) ConCat(s,_dsc).dsc$w_length = l; \ ConCat(s,_dsc).dsc$b_dtype = DSC$K_DTYPE_T;\ ConCat(s,_dsc).dsc$b_class = DSC$K_CLASS_S;\ ConCat(s,_dsc).dsc$a_pointer = p; # define F77_CHAR_USE_PTR(s,p,l) &ConCat(s,_dsc) # define F77_CHAR_USE_LEN(s,p,l) #else #ifdef CRAY /* Cray string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) _fcd ConCat(s,_ptr); # define F77_CHAR_ARG_DEF(s) char *s = _fcdtocp(ConCat(s,_ptr)); \ int ConCat(len_,s) = _fcdlen(ConCat(s,_ptr)); # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) _cptofcd(p,l) # define F77_CHAR_USE_LEN(s,p,l) #else /* length passed as additional argument */ # ifdef F77_CHAR_LEN_IND /* length passed by reference */ # define F77_CHAR_LEN_STAR(len) *len # else # define F77_CHAR_LEN_STAR(len) len # endif # ifndef F77_CHAR_LEN_TYPE # define F77_CHAR_LEN_TYPE int # endif # ifdef F77_ARG_CONSTANT # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) , ConCat(s,_len) # define F77_CHAR_ARG_DCL(s) char *ConCat(s,_ptr); \ F77_CHAR_LEN_TYPE F77_CHAR_LEN_STAR(ConCat(s,_len)); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr); \ int ConCat(len_,s) = F77_CHAR_LEN_STAR(ConCat(s,_len)); # else # ifdef F77_CHAR_LEN_IND # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(s,_len) # define F77_CHAR_ARG_DCL(s) char *s; \ F77_CHAR_LEN_TYPE F77_CHAR_LEN_STAR(ConCat(s,_len)); # define F77_CHAR_ARG_DEF(s) \ int ConCat(len_,s) = F77_CHAR_LEN_STAR(ConCat(s,_len)); # else # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(len_,s) # define F77_CHAR_ARG_DCL(s) char *s; int ConCat(len_,s); # define F77_CHAR_ARG_DEF(s) # endif # endif # if defined(F77_CHAR_LEN_IND) # define F77_CHAR_DEF_DSC(s,p,l) F77_CHAR_LEN_TYPE ConCat(s,_dsc) = l; # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , &ConCat(s,_dsc) # else # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , l # endif #endif #endif #ifndef F77_XXXX_ARG_LEN /* length argument of non-CHARACTER arguments */ # define F77_XXXX_ARG_LEN(x) /* nil */ # define F77_XXXX_USE_LEN(x) /* nil */ #endif #define F77_CHAR_ARG2PTR(c1,c2) \ F77_CHAR_ARG_PTR(c1),F77_CHAR_ARG_PTR(c2) #define F77_CHAR_ARG2LEN(c1,c2) \ F77_CHAR_ARG_LEN(c1) F77_CHAR_ARG_LEN(c2) #define F77_XXXX_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(c1) F77_XXXX_ARG_LEN(c2) #define F77_CHAR_ARG2DCL(c1,c2) \ F77_CHAR_ARG_DCL(c1) F77_CHAR_ARG_DCL(c2) #define F77_CHAR_ARG2DEF(c1,c2) \ F77_CHAR_ARG_DEF(c1) F77_CHAR_ARG_DEF(c2) #define F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG2PTR(c1,c2),F77_CHAR_ARG_PTR(c3) #define F77_CHAR_ARG3LEN(c1,c2,c3) \ F77_CHAR_ARG2LEN(c1,c2) F77_CHAR_ARG_LEN(c3) #define F77_XXXX_ARG3LEN(c1,c2,c3) \ F77_XXXX_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(c3) #define F77_CHAR_ARG3DCL(c1,c2,c3) \ F77_CHAR_ARG2DCL(c1,c2) F77_CHAR_ARG_DCL(c3) #define F77_CHAR_ARG3DEF(c1,c2,c3) \ F77_CHAR_ARG2DEF(c1,c2) F77_CHAR_ARG_DEF(c3) #define F77_CHAR_ARG4PTR(c1,c2,c3,c4) \ F77_CHAR_ARG3PTR(c1,c2,c3),F77_CHAR_ARG_PTR(c4) #define F77_CHAR_ARG4LEN(c1,c2,c3,c4) \ F77_CHAR_ARG3LEN(c1,c2,c3) F77_CHAR_ARG_LEN(c4) #define F77_XXXX_ARG4LEN(c1,c2,c3,c4) \ F77_XXXX_ARG3LEN(c1,c2,c3) F77_XXXX_ARG_LEN(c4) #define F77_CHAR_ARG4DCL(c1,c2,c3,c4) \ F77_CHAR_ARG3DCL(c1,c2,c3) F77_CHAR_ARG_DCL(c4) #define F77_CHAR_ARG4DEF(c1,c2,c3,c4) \ F77_CHAR_ARG3DEF(c1,c2,c3) F77_CHAR_ARG_DEF(c4) #define F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_CHAR_ARG_PTR(c5) #define F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) F77_CHAR_ARG_LEN(c5) #define F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_CHAR_ARG_DCL(c5) #define F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_CHAR_ARG_DEF(c5) /* * Fortran-calls-C interface * * To define a C function called by Fortran CALL SUB(A,B,C): * * #define Sub F77_NAME(sub,SUB) * #pragma linkage(SUB,FORTRAN) // for IBM C/370 compiler * * F77_ENTRY_xyz(Sub,a,b,c) // opening { contained in macro * // body ... * } * * Each character in xyz declares the type of the corresponding parameter: * * C = CHARACTER * E = EXTERNAL * I = INTEGER * R = REAL * * If a parameter PAR is declared as CHARACTER the macro defines: * * char *PAR; // pointer to string (not terminated by \0 !!!) * int len_PAR; // length of string as defined by Fortran's LEN(PAR) * * The names PAR_dsc and PAR_ptr are reserved for internal use. * * Note: The function body follows the F77_ENTRY_... macro call directly. * The opening { is generated by the macro. */ #define F77_ENTRY_C(name,c1) \ name( F77_CHAR_ARG_PTR(c1) F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CC(name,c1,c2) \ name( F77_CHAR_ARG2PTR(c1,c2) F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_C3(name,c1,c2,c3) \ name( F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG3LEN(c1,c2,c3) ) \ F77_CHAR_ARG3DCL(c1,c2,c3) \ { F77_CHAR_ARG3DEF(c1,c2,c3) #define F77_ENTRY_C5(name,c1,c2,c3,c4,c5) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) #define F77_ENTRY_C4E(name,c1,c2,c3,c4,e5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_EXTERN_ARG(e5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_EXTERN_DCL(e5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_EXTERN_DEF(e5) #define F77_ENTRY_C4I(name,c1,c2,c3,c4,i5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_INTG_ARG_PTR(i5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_INTG_ARG_DCL(i5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_INTG_ARG_DEF(i5) #define F77_ENTRY_C5E(name,c1,c2,c3,c4,c5,e6) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5),F77_EXTERN_ARG(e6) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) F77_EXTERN_DCL(e6) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) F77_EXTERN_DEF(e6) #define F77_ENTRY_CCE(name,c1,c2,e3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN_ARG(e3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN_DCL(e3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN_DEF(e3) #define F77_ENTRY_CCEE(name,c1,c2,e3,e4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN2ARG(e3,e4) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN2DCL(e3,e4) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN2DEF(e3,e4) #define F77_ENTRY_CCI(name,c1,c2,i3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG_PTR(i3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_INTG_ARG_DCL(i3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_INTG_ARG_DEF(i3) #define F77_ENTRY_CCIC(name,c1,c2,i3,c4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG_PTR(i3),F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(i3) F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG3DCL(c1,c2,c4) F77_INTG_ARG_DCL(i3) \ { F77_CHAR_ARG3DEF(c1,c2,c4) F77_INTG_ARG_DEF(i3) #define F77_ENTRY_CCI3(name,c1,c2,i3,i4,i5) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG3PTR(i3,i4,i5) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_INTG_ARG3DCL(i3,i4,i5) \ { F77_CHAR_ARG2DEF(c1,c2) F77_INTG_ARG3DEF(i3,i4,i5) #define F77_ENTRY_CCIRCC(name,c1,c2,i3,r4,c5,c6) \ name( F77_CHAR_ARG2PTR(c1,c2), \ F77_INTG_ARG_PTR(i3),F77_REAL_ARG_PTR(r4),F77_CHAR_ARG2PTR(c5,c6) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG2LEN(i3,r4) F77_CHAR_ARG2LEN(c5,c6) ) \ F77_CHAR_ARG4DCL(c1,c2,c5,c6) \ F77_INTG_ARG_DCL(i3) F77_REAL_ARG_DCL(r4) \ { F77_CHAR_ARG4DEF(c1,c2,c5,c6) \ F77_INTG_ARG_DEF(i3) F77_REAL_ARG_DEF(r4) \ #define F77_ENTRY_CE(name,c1,e2) \ name( F77_CHAR_ARG_PTR(c1),F77_EXTERN_ARG(e2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_EXTERN_DCL(e2) \ { F77_CHAR_ARG_DEF(c1) F77_EXTERN_DEF(e2) #define F77_ENTRY_CI(name,c1,i2) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG_PTR(i2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_INTG_ARG_DCL(i2) \ { F77_CHAR_ARG_DEF(c1) F77_INTG_ARG_DEF(i2) #define F77_ENTRY_CICI(name,c1,i2,c3,i4) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG_PTR(i2), \ F77_CHAR_ARG_PTR(c3),F77_INTG_ARG_PTR(i4) \ F77_CHAR_ARG_LEN(c1) F77_XXXX_ARG_LEN(i2) \ F77_CHAR_ARG_LEN(c3) ) \ F77_CHAR_ARG2DCL(c1,c3) F77_INTG_ARG2DCL(i2,i4) \ { F77_CHAR_ARG2DEF(c1,c3) F77_INTG_ARG2DEF(i2,i4) #define F77_ENTRY_CII(name,c1,i2,i3) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG2PTR(i2,i3) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_INTG_ARG2DCL(i2,i3) \ { F77_CHAR_ARG_DEF(c1) F77_INTG_ARG2DEF(i2,i3) #define F77_ENTRY_CIIC(name,c1,i2,i3,c4) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG2PTR(i2,i3),F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG_LEN(c1) F77_XXXX_ARG2LEN(i2,i3) F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG2DCL(c1,c4) F77_INTG_ARG2DCL(i2,i3) \ { F77_CHAR_ARG2DEF(c1,c4) F77_INTG_ARG2DEF(i2,i3) #define F77_ENTRY_CR(name,c1,r2) \ name( F77_CHAR_ARG_PTR(c1),F77_REAL_ARG_PTR(r2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_REAL_ARG_DCL(r2) \ { F77_CHAR_ARG_DEF(c1) F77_REAL_ARG_DEF(r2) #define F77_ENTRY_E(name,e1) \ name( F77_EXTERN_ARG(e1) ) \ F77_EXTERN_DCL(e1) \ { F77_EXTERN_DEF(e1) #define F77_ENTRY_E4(name,e1,e2,e3,e4) \ name( F77_EXTERN4ARG(e1,e2,e3,e4) ) \ F77_EXTERN4DCL(e1,e2,e3,e4) \ { F77_EXTERN4DEF(e1,e2,e3,e4) #define F77_ENTRY_IC(name,i1,c2) \ name( F77_INTG_ARG_PTR(i1),F77_CHAR_ARG_PTR(c2) \ F77_XXXX_ARG_LEN(i1) F77_CHAR_ARG_LEN(c2) ) \ F77_INTG_ARG_DCL(i1) F77_CHAR_ARG_DCL(c2) \ { F77_INTG_ARG_DEF(i1) F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_ICI(name,i1,c2,i3) \ name( F77_INTG_ARG_PTR(i1), F77_CHAR_ARG_PTR(c2),F77_INTG_ARG_PTR(i3) \ F77_XXXX_ARG_LEN(i1) F77_CHAR_ARG_LEN(c2) ) \ F77_INTG_ARG2DCL(i1,i3) F77_CHAR_ARG_DCL(c2) \ { F77_INTG_ARG2DEF(i1,i3) F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_IIC(name,i1,i2,c3) \ name( F77_INTG_ARG2PTR(i1,i2),F77_CHAR_ARG_PTR(c3) \ F77_XXXX_ARG2LEN(i1,i2) F77_CHAR_ARG_LEN(c3) ) \ F77_INTG_ARG2DCL(i1,i2) F77_CHAR_ARG_DCL(c3) \ { F77_INTG_ARG2DEF(i1,i2) F77_CHAR_ARG_DEF(c3) #define F77_ENTRY_I3C(name,i1,i2,i3,c4) \ name( F77_INTG_ARG3PTR(i1,i2,i3),F77_CHAR_ARG_PTR(c4) \ F77_XXXX_ARG3LEN(i1,i2,i3) F77_CHAR_ARG_LEN(c4) ) \ F77_INTG_ARG3DCL(i1,i2,i3) F77_CHAR_ARG_DCL(c4) \ { F77_INTG_ARG3DEF(i1,i2,i3) F77_CHAR_ARG_DEF(c4) #define F77_ENTRY_I4CCC(name,i1,i2,i3,i4,c5,c6,c7) \ name( F77_INTG_ARG4PTR(i1,i2,i3,i4),F77_CHAR_ARG3PTR(c5,c6,c7) \ F77_XXXX_ARG4LEN(i1,i2,i3,i4) F77_CHAR_ARG3LEN(c5,c6,c7) ) \ F77_INTG_ARG4DCL(i1,i2,i3,i4) F77_CHAR_ARG3DCL(c5,c6,c7) \ { F77_INTG_ARG4DEF(i1,i2,i3,i4) F77_CHAR_ARG3DEF(c5,c6,c7) #define F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_DEF_DSC(s1,p1,l1) F77_CHAR_DEF_DSC(s2,p2,l2) #define F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS_DSC(s1,p1,l1) F77_CHAR_ASS_DSC(s2,p2,l2) #define F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_PTR(s1,p1,l1),F77_CHAR_USE_PTR(s2,p2,l2) #define F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_LEN(s1,p1,l1) F77_CHAR_USE_LEN(s2,p2,l2) #define F77_XXXX_USE2LEN(x1,x2) \ F77_XXXX_USE_LEN(x1) F77_XXXX_USE_LEN(x2) #define F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_DEF_DSC(s3,p3,l3) #define F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_ASS_DSC(s3,p3,l3) #define F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2),F77_CHAR_USE_PTR(s3,p3,l3) #define F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) F77_CHAR_USE_LEN(s3,p3,l3) #define F77_XXXX_USE3LEN(x1,x2,x3) \ F77_XXXX_USE2LEN(x1,x2) F77_XXXX_USE_LEN(x3) #define F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_DEF_DSC(s4,p4,l4) #define F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_ASS_DSC(s4,p4,l4) #define F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3),F77_CHAR_USE_PTR(s4,p4,l4) #define F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_USE_LEN(s4,p4,l4) #define F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_XXXX_USE3LEN(x1,x2,x3) F77_XXXX_USE_LEN(x4) #define F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) F77_XXXX_USE_LEN(x5) #define F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) \ F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) F77_XXXX_USE_LEN(x6) #define F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) \ F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) F77_XXXX_USE_LEN(x7) #define F77_XXXX_USE8LEN(x1,x2,x3,x4,x5,x6,x7,x8) \ F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) F77_XXXX_USE_LEN(x8) #ifdef IBM370 #pragma linkage(K77C,FORTRAN) #define F77_CALL_C(name,p1,l1) do { \ SUBROUTINE *F77 = name; \ K77C(&F77,p1,l1); } while(0) #else #define F77_CALL_C(name,p1,l1) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1) \ F77_CHAR_USE_LEN(s1,p1,l1) \ ); } while(0) #endif #if 0 #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77CC(&F77,p1,l1,p2,l2); } while(0) #else #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #else #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ i0 = K77CC(&name,p1,l1,p2,l2); } while(0) #else #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_CC(_i0_,_p0_,p1,l1,p2,l2); \ } while(0) #endif #ifdef IBM370 #pragma linkage(K77C3,FORTRAN) #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77C3(&F77,p1,l1,p2,l2,p3,l3); } while(0) #else #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ name( F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77C7,FORTRAN) #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ SUBROUTINE *F77 = name; \ K77C7(&F77,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); } while(0) #else #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ name( F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4), \ F77_CHAR_USE3PTR(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx,FORTRAN) #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77CCx(&F77,p1,l1,p2,l2,x3); } while(0) #else #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCx3,FORTRAN) #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ SUBROUTINE *F77 = name; \ K77CCx3(&F77,p1,l1,p2,l2,x3,x4,x5); } while(0) #else #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4,x5 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE3LEN(x3,x4,x5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cx,FORTRAN) #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ i0 = K77Cx(&name,p1,l1,x2); } while(0) #else #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1), \ x2 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ ); } while(0) #endif #define F77_CALL_Cx(name,p1,l1,x2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_Cx(_i0_,_p0_,p1,l1,x2); \ } while(0) #ifdef IBM370 #pragma linkage(K77CxC,FORTRAN) #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77CxC(&F77,p1,l1,x2,p3,l3); } while(0) #else #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s3,p3,l3) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2, \ F77_CHAR_USE_PTR(s3,p3,l3) \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ F77_CHAR_USE_LEN(s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cxx,FORTRAN) #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ SUBROUTINE *F77 = name; \ K77Cxx(&F77,p1,l1,x2,x3); } while(0) #else #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2,x3 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE2LEN(x2,x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xC,FORTRAN) #define F77_CALL_xC(name,x1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77xC(&F77,x1,p2,l2); } while(0) #else #define F77_CALL_xC(name,x1,p2,l2) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCCx,FORTRAN) #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ SUBROUTINE *F77 = name; \ K77xCCx(&F77,x1,p2,l2,p3,l3,x4); } while(0) #else #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ name( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3), \ x4 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x4) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCC,FORTRAN) #define F77_IFUN_xCC(i0,name,x1,p2,l2,p3,l3) do { \ i0 = K77xCC(&name,x1,p2,l2,p3,l3); } while(0) #else #define F77_IFUN_xCC(i0,name,x1,p2,l2,p3,l3) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ i0 = (*name)( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #define F77_CALL_xCC(name,x1,p2,l2,p3,l3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_xCC(_i0_,_p0_,x1,p2,l2,p3,l3); \ } while(0) #ifdef IBM370 #pragma linkage(K77xCx,FORTRAN) #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ i0 = K77xCx(&name,x1,p2,l2,x3); } while(0) #else #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ INTEGER _i0_; \ F77_IFUN_xCx(_i0_,_p0_,x1,p2,l2,x3); \ } while(0) #ifdef IBM370 #pragma linkage(K77x4C,FORTRAN) #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ SUBROUTINE *F77 = name; \ K77x4C(&F77,x1,x2,x3,x4,p5,l5); } while(0) #else #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77x4Cxx,FORTRAN) #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ SUBROUTINE *F77 = name; \ K77x4Cxx(&F77,x1,x2,x3,x4,p5,l5,x6,x7); } while(0) #else #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5), \ x6,x7 \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ F77_XXXX_USE2LEN(x6,x7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(KIGMENU,FORTRAN) /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 */ #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ SUBROUTINE *F77 = name; \ KIGMENU(&F77,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N); } while(0) #else #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ F77_CHAR_DEF_DSC(sb,b,B) \ F77_CHAR_DEF_DSC(sh,h,H) \ F77_CHAR_DEF3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_DEF_DSC(sn,n,N) \ F77_CHAR_ASS_DSC(sb,b,B) \ F77_CHAR_ASS_DSC(sh,h,H) \ F77_CHAR_ASS3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_ASS_DSC(sn,n,N) \ name( a, \ F77_CHAR_USE_PTR(sb,b,B), \ c,d,e,f,g, \ F77_CHAR_USE_PTR(sh,h,H), \ i, \ F77_CHAR_USE3PTR(sj,j,J,sk,k,K,sl,l,L), \ m, \ F77_CHAR_USE_PTR(sn,n,N) \ F77_XXXX_USE_LEN(a) \ F77_CHAR_USE_LEN(sb,b,B) \ F77_XXXX_USE5LEN(c,d,e,f,g) \ F77_CHAR_USE_LEN(sh,h,H) \ F77_XXXX_USE_LEN(i) \ F77_CHAR_USE3LEN(sj,j,J,sk,k,K,sl,l,L) \ F77_XXXX_USE_LEN(m) \ F77_CHAR_USE_LEN(sn,n,N) \ ); } while(0) #endif #ifdef IBM370 #define F77_IFUN_x(i0,name,x1) i0 = __CTOF(name,x1) #else #define F77_IFUN_x(i0,name,x1) i0 = (*name)(x1) #endif #ifdef IBM370 #define F77_IFUN_xx(i0,name,x1,x2) i0 = __CTOF(name,x1,x2) #else #define F77_IFUN_xx(i0,name,x1,x2) i0 = (*name)(x1,x2) #endif #ifdef IBM370 #pragma linkage(K77xCx8,FORTRAN) #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ i0 = K77xCx8(&name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10); } while(0) #else #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3,x4,x5,x6,x7,x8,x9,x10 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE8LEN(x3,x4,x5,x6,x7,x8,x9,x10) \ ); } while(0) #endif /* * routines called by Fortran */ #define Errrun F77_NAME(errrun,ERRRUN) #define Fmemcpy F77_NAME(fmemcpy,FMEMCPY) #define Getarg F77_NAME(getarg,GETARG) extern SUBROUTINE Getarg; #define Goparm F77_NAME(goparm,GOPARM) extern SUBROUTINE Goparm; #define Gl_char_cleanup F77_NAME(gl_char_cleanup,GL_CHAR_CLEANUP) #define Gl_reset F77_NAME(gl_reset,GL_RESET) #define Gl_reinit F77_NAME(gl_reinit,GL_REINIT) #define Iclrwk F77_NAME(iclrwk,ICLRWK) extern SUBROUTINE Iclrwk; #define Iginit F77_NAME(iginit,IGINIT) extern SUBROUTINE Iginit; #define Igmenu F77_NAME(igmenu,IGMENU) extern SUBROUTINE Igmenu; #define Igrng F77_NAME(igrng,IGRNG) extern SUBROUTINE Igrng; #define Igsse F77_NAME(igsse,IGSSE) extern SUBROUTINE Igsse; #define Igsrap F77_NAME(igsrap,IGSRAP) extern SUBROUTINE Igsrap; #define Igwkty F77_NAME(igwkty,IGWKTY) extern SUBROUTINE Igwkty; #define Kcexec F77_NAME(kcexec,KCEXEC) #define Kdialo F77_NAME(kdialo,KDIALO) extern SUBROUTINE Kdialo; #define Kgetar F77_NAME(kgetar,KGETAR) #define Kialid F77_NAME(kialid,KIALID) #define Kiargc F77_NAME(kiargc,KIARGC) extern INT_FUNCTION Kiargc; #define Kibres F77_NAME(kibres,KIBRES) extern SUBROUTINE Kibres; #define Kiclos F77_NAME(kiclos,KICLOS) extern SUBROUTINE Kiclos; #define Kicomv F77_NAME(kicomv,KICOMV) #define Kidtab F77_NAME(kidtab,KIDTAB) #define Kierrf F77_NAME(kierrf,KIERRF) extern SUBROUTINE Kierrf; #define Kiinit F77_NAME(kiinit,KIINIT) extern SUBROUTINE Kiinit; #define Kilun F77_NAME(kilun,KILUN) extern SUBROUTINE Kilun; #define Kimath F77_NAME(kimath,KIMATH) #define Kimdef F77_NAME(kimdef,KIMDEF) #define Kimexe F77_NAME(kimexe,KIMEXE) #define Kipawc F77_NAME(kipawc,KIPAWC) #define Kipiaf F77_NAME(kipiaf,KIPIAF) #define Kiprmt F77_NAME(kiprmt,KIPRMT) #define Kirtim F77_NAME(kirtim,KIRTIM) #define Kisigm F77_NAME(kisigm,KISIGM) #define Kivect F77_NAME(kivect,KIVECT) #define Kmpst2 F77_NAME(kmpst2,KMPST2) #define Kmpst3 F77_NAME(kmpst3,KMPST3) #define Kmpx22 F77_NAME(kmpx22,KMPX22) #define Kmpx23 F77_NAME(kmpx23,KMPX23) #define Kmvsed F77_NAME(kmvsed,KMVSED) extern SUBROUTINE Kmvsed; #define Kmvspg F77_NAME(kmvspg,KMVSPG) extern SUBROUTINE Kmvspg; #define Kmvssh F77_NAME(kmvssh,KMVSSH) extern SUBROUTINE Kmvssh; #define Ksvpar F77_NAME(ksvpar,KSVPAR) #define Kuach F77_NAME(kuach,KUACH) #define Kuact F77_NAME(kuact,KUACT) #define Kualfa F77_NAME(kualfa,KUALFA) #define Kuappl F77_NAME(kuappl,KUAPPL) #define Kuargs F77_NAME(kuargs,KUARGS) #define Kubrek F77_NAME(kubrek,KUBREK) #define Kubrof F77_NAME(kubrof,KUBROF) #define Kubron F77_NAME(kubron,KUBRON) #define Kucmd F77_NAME(kucmd,KUCMD) #define Kucmdl F77_NAME(kucmdl,KUCMDL) #define Kucomv F77_NAME(kucomv,KUCOMV) #define Kuedit F77_NAME(kuedit,KUEDIT) #define Kuesvr F77_NAME(kuesvr,KUESVR) #define Kueusr F77_NAME(kueusr,KUEUSR) #define Kuexec F77_NAME(kuexec,KUEXEC) #define Kuexel F77_NAME(kuexel,KUEXEL) #define Kuexit F77_NAME(kuexit,KUEXIT) #define Kufcas F77_NAME(kufcas,KUFCAS) #define Kufdef F77_NAME(kufdef,KUFDEF) #define Kugetc F77_NAME(kugetc,KUGETC) #define Kugete F77_NAME(kugete,KUGETE) #define Kugetf F77_NAME(kugetf,KUGETF) #define Kugeti F77_NAME(kugeti,KUGETI) #define Kugetl F77_NAME(kugetl,KUGETL) #define Kugetq F77_NAME(kugetq,KUGETQ) #define Kugetr F77_NAME(kugetr,KUGETR) #define Kugets F77_NAME(kugets,KUGETS) #define Kugrfl F77_NAME(kugrfl,KUGRFL) #define Kuguid F77_NAME(kuguid,KUGUID) #define Kuhelp F77_NAME(kuhelp,KUHELP) #define Kuhome F77_NAME(kuhome,KUHOME) #define Kuidf1 F77_NAME(kuidf1,KUIDF1) extern SUBROUTINE Kuidf1; #define Kuidf2 F77_NAME(kuidf2,KUIDF2) extern SUBROUTINE Kuidf2; #define Kuidfm F77_NAME(kuidfm,KUIDFM) #define Kuinim F77_NAME(kuinim,KUINIM) #define Kuinit F77_NAME(kuinit,KUINIT) #define Kuinqf F77_NAME(kuinqf,KUINQF) extern SUBROUTINE Kuinqf; #define Kulun F77_NAME(kulun,KULUN) #define Kumloc F77_NAME(kumloc,KUMLOC) #define Kumout F77_NAME(kumout,KUMOUT) #define Kumpad F77_NAME(kumpad,KUMPAD) #define Kumpst F77_NAME(kumpst,KUMPST) #define Kumpx2 F77_NAME(kumpx2,KUMPX2) #define Kundpv F77_NAME(kundpv,KUNDPV) #define Kunpar F77_NAME(kunpar,KUNPAR) #define Kunwg F77_NAME(kunwg,KUNWG) #define Kuopen F77_NAME(kuopen,KUOPEN) extern SUBROUTINE Kuopen; #define Kupad F77_NAME(kupad,KUPAD) #define Kupar F77_NAME(kupar,KUPAR) #define Kupath F77_NAME(kupath,KUPATH) #define Kupatl F77_NAME(kupatl,KUPATL) #define Kuproc F77_NAME(kuproc,KUPROC) #define Kuprof F77_NAME(kuprof,KUPROF) #define Kuproi F77_NAME(kuproi,KUPROI) #define Kuprop F77_NAME(kuprop,KUPROP) #define Kupror F77_NAME(kupror,KUPROR) #define Kupros F77_NAME(kupros,KUPROS) #define Kumess F77_NAME(kumess,KUMESS) #define Kupval F77_NAME(kupval,KUPVAL) #define Kuqcas F77_NAME(kuqcas,KUQCAS) #define Kuqenv F77_NAME(kuqenv,KUQENV) #define Kuqexe F77_NAME(kuqexe,KUQEXE) #define Kuqsvr F77_NAME(kuqsvr,KUQSVR) #define Kuquit F77_NAME(kuquit,KUQUIT) #define Kuread F77_NAME(kuread,KUREAD) extern SUBROUTINE Kuread; #define Kusapp F77_NAME(kusapp,KUSAPP) #define Kuser F77_NAME(kuser,KUSER) #define Kuserid F77_NAME(kuserid,KUSERID) #define Kusibr F77_NAME(kusibr,KUSIBR) #define Kusigm F77_NAME(kusigm,KUSIGM) #define Kuspy F77_NAME(kuspy,KUSPY) #define Kustat F77_NAME(kustat,KUSTAT) #define Kustop F77_NAME(kustop,KUSTOP) #define Kuterm F77_NAME(kuterm,KUTERM) #define Kutime F77_NAME(kutime,KUTIME) #define Kutim0 F77_NAME(kutim0,KUTIM0) extern SUBROUTINE Kutim0; #define Kutrue F77_NAME(kutrue,KUTRUE) #define Kuvcre F77_NAME(kuvcre,KUVCRE) extern SUBROUTINE Kuvcre; #define Kuvdel F77_NAME(kuvdel,KUVDEL) extern SUBROUTINE Kuvdel; #define Kuvect F77_NAME(kuvect,KUVECT) extern SUBROUTINE Kuvect; #define Kuvnam F77_NAME(kuvnam,KUVNAM) #define Kuwhag F77_NAME(kuwhag,KUWHAG) #define Kuwham F77_NAME(kuwham,KUWHAM) #define Kuwhat F77_NAME(kuwhat,KUWHAT) #define Kuwrit F77_NAME(kuwrit,KUWRIT) extern SUBROUTINE Kuwrit; #define Kxali1 F77_NAME(kxali1,KXALI1) #define Kxcrv2 F77_NAME(kxcrv2,KXCRV2) extern SUBROUTINE Kxcrv2; #define Macdef F77_NAME(macdef,MACDEF) extern SUBROUTINE Macdef; #define Mdmenu F77_NAME(mdmenu,MDMENU) #define Mhi_close F77_NAME(mhi_close,MHI_CLOSE) extern SUBROUTINE Mhi_close; #define Mhi_open F77_NAME(mhi_open,MHI_OPEN) extern SUBROUTINE Mhi_open; #define Mzwipe F77_NAME(mzwipe,MZWIPE) extern SUBROUTINE Mzwipe; #define Traceq F77_NAME(traceq,TRACEQ) extern SUBROUTINE Traceq; #define Xuflow F77_NAME(xuflow,XUFLOW) extern SUBROUTINE Xuflow; #ifdef IBM370 # pragma linkage(ERRRUN,FORTRAN) # pragma linkage(FMEMCPY,FORTRAN) # pragma linkage(GOPARM,FORTRAN) # pragma linkage(ICLRWK,FORTRAN) # pragma linkage(IGINIT,FORTRAN) # pragma linkage(IGMENU,FORTRAN) # pragma linkage(IGRNG,FORTRAN) # pragma linkage(IGSSE,FORTRAN) # pragma linkage(IGSRAP,FORTRAN) # pragma linkage(IGWKTY,FORTRAN) # pragma linkage(KCEXEC,FORTRAN) # pragma linkage(KDIALO,FORTRAN) # pragma linkage(KGETAR,FORTRAN) # pragma linkage(KIALID,FORTRAN) # pragma linkage(KIBRES,FORTRAN) # pragma linkage(KICLOS,FORTRAN) # pragma linkage(KICOMV,FORTRAN) # pragma linkage(KIDTAB,FORTRAN) # pragma linkage(KIERRF,FORTRAN) # pragma linkage(KIINIT,FORTRAN) # pragma linkage(KILUN,FORTRAN) # pragma linkage(KIMATH,FORTRAN) # pragma linkage(KIMDEF,FORTRAN) # pragma linkage(KIMEXE,FORTRAN) # pragma linkage(KIPAWC,FORTRAN) # pragma linkage(KIPIAF,FORTRAN) # pragma linkage(KIPRMT,FORTRAN) # pragma linkage(KIRTIM,FORTRAN) # pragma linkage(KISIGM,FORTRAN) # pragma linkage(KIVECT,FORTRAN) # pragma linkage(KMPST2,FORTRAN) # pragma linkage(KMPST3,FORTRAN) # pragma linkage(KMPX22,FORTRAN) # pragma linkage(KMPX23,FORTRAN) # pragma linkage(KMVSED,FORTRAN) # pragma linkage(KMVSPG,FORTRAN) # pragma linkage(KMVSSH,FORTRAN) # pragma linkage(KSVPAR,FORTRAN) # pragma linkage(KUACH,FORTRAN) # pragma linkage(KUACT,FORTRAN) # pragma linkage(KUALFA,FORTRAN) # pragma linkage(KUAPPL,FORTRAN) # pragma linkage(KUARGS,FORTRAN) # pragma linkage(KUBREK,FORTRAN) # pragma linkage(KUBROF,FORTRAN) # pragma linkage(KUBRON,FORTRAN) # pragma linkage(KUCMD,FORTRAN) # pragma linkage(KUCMDL,FORTRAN) # pragma linkage(KUCOMV,FORTRAN) # pragma linkage(KUEDIT,FORTRAN) # pragma linkage(KUESVR,FORTRAN) # pragma linkage(KUEUSR,FORTRAN) # pragma linkage(KUEXEC,FORTRAN) # pragma linkage(KUEXEL,FORTRAN) # pragma linkage(KUEXIT,FORTRAN) # pragma linkage(KUFCAS,FORTRAN) # pragma linkage(KUFDEF,FORTRAN) # pragma linkage(KUGETC,FORTRAN) # pragma linkage(KUGETE,FORTRAN) # pragma linkage(KUGETF,FORTRAN) # pragma linkage(KUGETI,FORTRAN) # pragma linkage(KUGETL,FORTRAN) # pragma linkage(KUGETQ,FORTRAN) # pragma linkage(KUGETR,FORTRAN) # pragma linkage(KUGETS,FORTRAN) # pragma linkage(KUGRFL,FORTRAN) # pragma linkage(KUGUID,FORTRAN) # pragma linkage(KUHELP,FORTRAN) # pragma linkage(KUHOME,FORTRAN) # pragma linkage(KUIDF1,FORTRAN) # pragma linkage(KUIDF2,FORTRAN) # pragma linkage(KUIDFM,FORTRAN) # pragma linkage(KUINIM,FORTRAN) # pragma linkage(KUINIT,FORTRAN) # pragma linkage(KUINQF,FORTRAN) # pragma linkage(KULUN,FORTRAN) # pragma linkage(KUMLOC,FORTRAN) # pragma linkage(KUMOUT,FORTRAN) # pragma linkage(KUMPAD,FORTRAN) # pragma linkage(KUMPST,FORTRAN) # pragma linkage(KUMPX2,FORTRAN) # pragma linkage(KUNDPV,FORTRAN) # pragma linkage(KUNPAR,FORTRAN) # pragma linkage(KUNWG,FORTRAN) # pragma linkage(KUOPEN,FORTRAN) # pragma linkage(KUPAD,FORTRAN) # pragma linkage(KUPAR,FORTRAN) # pragma linkage(KUPATH,FORTRAN) # pragma linkage(KUPATL,FORTRAN) # pragma linkage(KUPROC,FORTRAN) # pragma linkage(KUPROF,FORTRAN) # pragma linkage(KUPROI,FORTRAN) # pragma linkage(KUPROP,FORTRAN) # pragma linkage(KUPROR,FORTRAN) # pragma linkage(KUPROS,FORTRAN) # pragma linkage(KUPVAL,FORTRAN) # pragma linkage(KUQCAS,FORTRAN) # pragma linkage(KUQENV,FORTRAN) # pragma linkage(KUQEXE,FORTRAN) # pragma linkage(KUQSVR,FORTRAN) # pragma linkage(KUQUIT,FORTRAN) # pragma linkage(KUREAD,FORTRAN) # pragma linkage(KUSAPP,FORTRAN) # pragma linkage(KUSIBR,FORTRAN) # pragma linkage(KUSIGM,FORTRAN) # pragma linkage(KUSPY,FORTRAN) # pragma linkage(KUSTAT,FORTRAN) # pragma linkage(KUSTOP,FORTRAN) # pragma linkage(KUTERM,FORTRAN) # pragma linkage(KUTIME,FORTRAN) # pragma linkage(KUTIM0,FORTRAN) # pragma linkage(KUTRUE,FORTRAN) # pragma linkage(KUSER,FORTRAN) # pragma linkage(KUVCRE,FORTRAN) # pragma linkage(KUVDEL,FORTRAN) # pragma linkage(KUVECT,FORTRAN) # pragma linkage(KUVNAM,FORTRAN) # pragma linkage(KUWHAG,FORTRAN) # pragma linkage(KUWHAM,FORTRAN) # pragma linkage(KUWHAT,FORTRAN) # pragma linkage(KUWRIT,FORTRAN) # pragma linkage(KXALI1,FORTRAN) # pragma linkage(KXCRV2,FORTRAN) # pragma linkage(MACDEF,FORTRAN) # pragma linkage(MDMENU,FORTRAN) # pragma linkage(MHI_CLOSE,FORTRAN) # pragma linkage(MHI_OPEN,FORTRAN) # pragma linkage(MZWIPE,FORTRAN) # pragma linkage(TRACEQ,FORTRAN) # pragma linkage(XUFLOW,FORTRAN) #endif #define MAXCMD 512 /* max length of a command line */ #define MAXEDT 32 /* max length of names in edit server */ #define MAXLEV 10 /* max levels of command name path */ #define MAXSVR 20 /* max number of edit server processes */ /* * The PAWC common is referenced through a pointer to allow the use of * dynamic common blocks on IBM systems. */ #define Pawc kc_pawc EXTERN struct COMMON_PAWC { INTEGER NWPAR; INTEGER IXPAWC; INTEGER IHBOOK; INTEGER IXHIGZ; INTEGER IXKUIP; INTEGER IFENCE[5]; INTEGER LQ[8]; INTEGER DATA[999]; } *Pawc; #define IQ(n) Pawc->DATA[n-1] #define Q(n) (((REAL*)(Pawc->DATA))[n-1]) +KEEP,KCOM_H /* kcom.h: Fortran COMMON blocks */ #define Kcalia F77_BLOCK(kcalia,KCALIA) #define MALIAS 200 EXTERN struct { INTEGER NALIAS; LOGICAL ALIFLG; INTEGER ALITYP[MALIAS]; } F77_COMMON(Kcalia); #define Kcalic F77_BLOCK(kcalic,KCALIC) EXTERN struct { char ALINAM[MALIAS][60]; char ALIVAL[MALIAS][80]; } F77_COMMON(Kcalic); #define Kcbrek F77_BLOCK(kcbrek,KCBREK) EXTERN struct { LOGICAL TRAP; /* flag if signal trapping is enabled */ LOGICAL BRKEN; /* not used, always true */ LOGICAL FIRST; /* only used for Apollo */ LOGICAL FIRSG; /* only used for Apollo */ LOGICAL CLWHAT; /* flag if KUWHAT installed break handler */ LOGICAL CLWHAG; /* flag if KUWHAG installed break handler */ LOGICAL TBFLAG; /* flag if traceback should be printed */ } F77_COMMON(Kcbrek); #define Kcefil F77_BLOCK(kcefil,KCEFIL) EXTERN struct { char EDTFIL[MAXSVR][MAXEDT]; /* file name */ char EDTCMD[MAXSVR][MAXEDT]; /* KUIP command */ } F77_COMMON(Kcefil); #define Kcesvr F77_BLOCK(kcesvr,KCESVR) EXTERN struct { INTEGER NSVFIL; /* number of edited file */ INTEGER NSVCUR; /* pointer to current file */ SUBRPTR IESADD; /* routine set by KUEUSR */ LOGICAL SERVER; /* flag if edit server is used */ } F77_COMMON(Kcesvr); #define Kcexit F77_BLOCK(kcexit,KCEXIT) EXTERN struct { SUBRPTR IEXADD; /* routine set by KUEXIT */ SUBRPTR IUSADD; /* routine set by KUSER */ SUBRPTR NEXADD; /* routine set by KUNEXT */ SUBRPTR IUTADD; /* routine set by KUTERM */ SUBRPTR IQUADD; /* routine set by KUQUIT */ SUBRPTR IBRADD; /* routine set by KUBREK */ LOGICAL LICALL; LOGICAL LICAL2; LOGICAL LICAL3; } F77_COMMON(Kcexit); #define Kcmac F77_BLOCK(kcmac,KCMAC) EXTERN struct { LOGICAL MACTAB; INTEGER NSTLEV; LOGICAL QUITFL; LOGICAL WAITFL; LOGICAL WAITFF; LOGICAL DEBTAB; LOGICAL SKIPFL; LOGICAL HEADFL; INTEGER IONERF; LOGICAL NOEXEC; } F77_COMMON(Kcmac); #define Kcparc F77_BLOCK(kcparc,KCPARC) EXTERN struct { char PARLST[512]; /* interface block for KUSER */ char CLIST[80]; char NOALIN[512]; char COMAND[80]; char CHLAST[512]; char NONPOS[512]; } F77_COMMON(Kcparc); #define Kcsigm F77_BLOCK(kcsigm,KCSIGM) EXTERN struct { SUBRPTR ISIADD; /* routine set by KUSIGM */ INTEGER NVSIGM; /* number of temp vectors create for $SIGMA */ } F77_COMMON(Kcsigm); #define Kcutil F77_BLOCK(kcutil,KCUTIL) EXTERN struct { INTEGER NCMD; INTEGER IWD; INTEGER LUNFIL; INTEGER LPRMPT; LOGICAL TIMING; LOGICAL TRACE; INTEGER CALMOD; INTEGER NVADD; INTEGER IREPET; INTEGER IREFAC; INTEGER IBRAK; LOGICAL TIMALL; INTEGER LENTER; LOGICAL UNIQUE; INTEGER LENMUL; LOGICAL MULTFL; LOGICAL HISTOK; LOGICAL NOHIST; INTEGER LENMUM; LOGICAL FILCAS; LOGICAL MEXEFL; } F77_COMMON(Kcutil); #define Kcvect F77_BLOCK(kcvect,KCVECT) EXTERN struct { INTEGER NUMVEC; /* number of vectors stored */ INTEGER TOTPAV; INTEGER GETPAV; LOGICAL TVECFL; } F77_COMMON(Kcvect); #define Kcwork F77_BLOCK(kcwork,KCWORK) EXTERN struct { REAL VECTOR[100]; /* vector '?' */ } F77_COMMON(Kcwork); #define Quest F77_BLOCK(quest,QUEST) EXTERN struct { INTEGER DATA[100]; } F77_COMMON(Quest); #define IQUEST(n) Quest.DATA[n-1] #define Sikuip F77_BLOCK(sikuip,SIKUIP) EXTERN struct { char CHSIGM[80]; /* command string passed to SIGMA */ } F77_COMMON(Sikuip); +KEEP,KSIG_H /* ksig.h: signal and break handling */ /* * Available signal handling package * * #define SIGNAL_POSIX ==> sigaction() for Unix * #define SIGNAL_BSD ==> sigvec() for VMS and NeXT * #define SIGNAL_V7 ==> signal() */ #if !defined(SIGNAL_BSD) && !defined(SIGNAL_V7) # define SIGNAL_POSIX #else # define sigjmp_buf jmp_buf # define sigsetjmp(buf,save) setjmp(buf) # define siglongjmp(buf,val) longjmp(buf,val) # ifdef vms # define sv_flags sv_onstack # endif #endif EXTERN struct { int trap_enabled; /* flag if exceptions should be trapped */ int intr_enabled; /* flag if ^C delivery is allowed */ int intr_pending; /* flag if ^C happened while disabled */ int intr_count; /* count number of consecutive ^C interrupts */ int traceback; /* print traceback on signal */ char *error_msg; /* messages is handler cannot do print */ int soft_intr; /* flag to stop at a convenient point */ int jump_set; /* flag if stack has been setup */ sigjmp_buf stack; int sockfd; /* socket descriptor and routine to */ void (*piaf_sync)(); /* resynchronize Piaf communication */ } kc_break; +KEEP,KBROW_H /* kbrow.h: browser definitions */ #define KBROW_H1 \ +SEQ,KBROW_H1 KBROW_H1 #define KBROW_H2 \ +SEQ,KBROW_H2 KBROW_H2 #define KBROW_H3 \ +SEQ,KBROW_H3 KBROW_H3 #define KBROW_H4 \ +SEQ,KBROW_H4 KBROW_H4 typedef struct _KmObject { struct _KmObject *next; /* link to next object definition */ char *name; /* unique identifier name */ char *stext; /* short description text */ char *ltext; /* long description text */ KmClass *class; /* pointer to objects's class structure */ } KmObject; typedef struct _BrVariable { struct _BrVariable *next; /* link to next variable definition */ char *name; /* variable name */ char *value; /* replacement value */ } BrVariable; typedef struct _BrObject { struct _BrObject *next; /* link to next browsable object */ char *name; /* name of the browsable object */ BrClass *class; /* pointer to browsable's class structure */ BrVariable *vars; /* linked list of variable substitutions */ } BrObject; typedef struct _BrClientdata { BrActTag tag; char *brobj; char *brcls; char *path; char *kmobj; char *kmcls; char *stext; char *ltext; char *mtext; } BrClientdata; EXTERN BrClass *brclasses; EXTERN KmObject *kmobjects; EXTERN KmButton *kmbuttons; extern C_PROTO_2(void klnkbrcl, BrClass*, int); extern C_PROTO_2(void klnkkmcl, KmClass*, int); extern C_PROTO_2(void klnkicon, KmIcon*, int); extern C_PROTO_2(void klnkbutt, KmButton*, int); extern C_PROTO_6(void exec_action, BrAction*, char*, char*, int, KmWidget, KmCalldata); extern C_PROTO_2(KmWidget find_button, char*, char*); extern C_PROTO_1(KmIcon* find_kmicon, char*); extern C_PROTO_1(KmClass* find_kmclass, char*); extern C_PROTO_1(BrObject* find_brobject, char*); extern C_PROTO_2(char* get_variable, char*, char*); extern C_PROTO_0(BrObject* scan_brobjects); extern C_PROTO_3(KmObject* scan_kmobjects, char*, char*, int); extern C_PROTO_7(int set_action, char*, int, int, char*, char*, int, int); extern C_PROTO_3(void set_variable, BrObject*, char*, char*); +KEEP,KLINK_H /* klink.h: demand linking of special routines */ #define KLINK_H1 EXTERN \ +SEQ,KLINK_H1 KLINK_H1 EXTERN struct { SUBROUTINE *user_exit_F; /* set by KUEXIT */ SUBROUTINE *user_quit_F; /* set by KUQUIT */ SUBROUTINE *user_break_F; /* set by KUBREK */ SUBROUTINE *user_edit_F; /* set by KUEUSR */ SUBROUTINE *user_comis_F; /* set by KUCOMV */ SUBROUTINE *user_sigma_F; /* set by KUSIGM */ SUBROUTINE *user_grfl_F; /* set by KUGRFL */ SUBROUTINE *user_term_F; /* set by KUTERM */ SUBROUTINE *user_input_F; /* set by KUSER */ SUBROUTINE *user_locate_F; /* set by KUMLOC */ /* indirect calls to avoid linking Motif */ IntFunc *disp_panel_C; /* display command panel (km_display_cmdpan) */ IntFunc *disp_kpanel_C; /* display KUIP panel (km_display_kpanel) */ IntFunc *close_kpanel_C; /* close KUIP panel (km_close_kpanel) */ IntFunc *disp_text_C; /* display text widget (km_display_sctext) */ IntFunc *disp_choice_C; /* display a choice of commands (?) */ IntFunc *disp_clean_C; /* clean before action (km_destroy_all_popup)*/ IntFunc *disp_flush_C; /* flush event queue (FlushEvents) */ IntFunc *disp_busy_C; /* show busy cursor (km_all_cursor) */ IntFunc *disp_exit_C; /* ask confirmation for exit */ IntFunc *disp_quit_C; /* ask confirmation for exit */ IntFunc *disp_select_C; /* select from a number of buttons */ IntFunc *disp_cmd_list_C; /* display list of commands (km_print_list) */ CharFunc *disp_prompt_C; /* prompt for input */ CharFunc *disp_passwd_C; /* prompt for password input */ /* indirect calls to avoid linking HIGZ without style G */ IntFunc *higz_init_C; /* initialize menu mode */ SUBROUTINE *higz_menu_F; /* IGMENU */ } kjmpaddr; +KEEP,KFLAG_H typedef enum { KmMACRO_COMMAND = 0, /* don't look for macros */ KmMACRO_AUTO, /* look for macros before commands */ KmMACRO_AUTOREVERSE /* look for macros after commands */ } KmMacOrder; typedef enum { KmSTYLE_A = 0x0001, /* Alpha menus */ KmSTYLE_C = 0x0002, /* Command line */ KmSTYLE_G = 0x0004, /* Graphics menus */ KmSTYLE_M = 0x0008, /* Model Human Interface */ KmSTYLE_U = 0x0010, /* User */ KmSTYLE_XM = 0x0020, /* Motif/X11 */ KmSTYLE_major = 0x00FF, /* A..X are mutually exclusive */ KmSTYLE_xL = 0x0100, /* Alpha Letter menus */ KmSTYLE_xP = 0x0200, /* Panel style GP or MP */ KmSTYLE_xS = 0x0400, /* Graphics with Software fonts */ KmSTYLE_xW = 0x0800 /* Graphics with shadowed Width */ } KmStyleFlag; typedef enum { KmTIMING_OFF, /* no timing */ KmTIMING_ON, /* time typed commands */ KmTIMING_ALL /* time individual commands inside macro */ } KmTiming; EXTERN struct { LOGICAL f77_true; /* value of .TRUE. */ LOGICAL f77_false; /* value of .FALSE. */ int do_exit; /* set by KXEXIT */ int do_quit; /* set by KXQUIT */ char *curr_prompt; /* current prompt string */ char *last_cmd; /* last command for $LAST */ KmTiming timing; /* timing on/off/all */ time_t real_time; /* real time at last timing off */ clock_t user_time; /* CPU time at last timing off */ int in_macro; /* command executed in macro */ int in_application; /* application mode is active */ int appl_called; /* application is executing */ char *appl_exit; /* string which leaves application mode */ KmCommand *appl_cmd; /* command which handles application */ char appl_file[256]; /* temporary file to pass application text */ FILE *appl_stream; /* C stream used for writing appl_file */ int appl_luno; /* Fortran logical unit opened for appl_file */ char help_file[256]; /* temporary file to view help text */ char uhlp_file[256]; /* temporary file to get user help text */ int uhlp_luno; /* Fortran logical unit opened for user help */ int in_motif; /* Motif mode is active */ int action_nesting; /* levels of nested ku_exec() calls */ int echo_command; /* echo commands in Motif mode */ char *echo_prompt; /* prompt string for echo commands */ KmStyleFlag style; /* input mode */ int keep_fcase; /* flag if no case conversion for filenames */ int use_kxterm; /* flag if kxterm should be used */ int use_server; /* flag if edit server should be used */ int editor_exit; /* flag set if edit server sent SIGUSR1 */ char *editor_cbuf; /* buffer of for edit servers commands */ char *macro_path; /* MACRO/DEFAULT search path */ KmMacOrder macro_search; /* MACRO/DEFAULT search order */ int temp_vectors; /* number of ?SIGMA vectors */ char init_wdir[256]; /* initial working directory */ int vread_luno; /* Fortran logical unit for VECTOR/READ */ int vwrite_luno; /* Fortran logical unit for VECTOR/WRITE */ } kc_flags; EXTERN struct { char *set_break; /* SET_SHOW/BREAK */ char set_columns[8]; /* SET_SHOW/COLUMNS */ char *set_command; /* SET_SHOW/COMMAND */ char *set_filecase; /* SET_SHOW/FILECASE */ char *set_host_editor; /* SET_SHOW/HOST_EDITOR */ char *set_host_psviewer; /* SET_SHOW/HOST_PSVIEWER */ char *set_host_pager; /* SET_SHOW/HOST_PAGER */ char *set_host_shell; /* SET_SHOW/HOST_SHELL */ char *set_prompt; /* SET_SHOW/PROMPT */ char *set_recall_style; /* SET_SHOW/RECALL_STYLE */ char set_recording[8]; /* SET_SHOW/RECORDING */ char *set_root; /* SET_SHOW/ROOT */ char *set_style; /* SET_SHOW/STYLE */ char *set_timing; /* SET_SHOW/TIMING */ char *help_edit; /* HELP edit mode */ char *defaults_path; /* MACRO/DEFAULTS search path */ char *defaults_order; /* MACRO/DEFAULTS search order */ int idle_time; /* IDLE timer in seconds */ char *idle_cmd; /* IDLE command */ char **set_print_cmds; /* SET_SHOW/HOST_PRINTER commands */ char **set_print_exts; /* ... depending on file extension */ } kc_value; typedef struct { int top; int left; int width; int height; } KmWindowDsc; EXTERN struct { KmWindowDsc edit_pad; /* coordinates for edit window */ KmWindowDsc help_pad; /* coordinates for readonly window */ int voffset; /* vertical offset */ int hoffset; /* horizontal offset */ int shift_max; /* maximum number of shifted pads */ int shift_now; /* current shift count */ int shift_dir; /* shift direction +/-1 */ int is_a_pad; /* flag if running in an Apollo DM pad */ int is_a_tty; /* flag if stdin and stdout at terminal */ int use_getline; /* flag for using getline() or normal read */ int use_no_echo; /* flag for using no echo in password prompt */ int term_width; /* terminal width in columns */ int kuwhag_called; /* allow style G */ float sgylen; float sgsize; float sgyspa; float sgbord; int panel_rows; /* number of rows in style GP panel */ int *panel_cols; /* number of columns in each row */ char ***panel_keys; /* key labels */ char *panel_keynum; /* value of $KEYNUM */ char *panel_keyval; /* value of $KEYVAL */ char ***panel_icons; /* key icons */ } kc_window; extern C_PROTO_1(char* style_name, KmStyleFlag); +KEEP,KMENU_H /* kmenu.h: data structures for menu and command definitions */ #define KMENU_H1 \ +SEQ,KMENU_H1 KMENU_H1 #define KMENU_H2 \ +SEQ,KMENU_H2 KMENU_H2 #define KMENU_H3 \ +SEQ,KMENU_H3 KMENU_H3 #define KMENU_H4 \ +SEQ,KMENU_H4 KMENU_H4 #define KMENU_H5 \ +SEQ,KMENU_H5 KMENU_H5 /* * temporary fix until we can reserve an extra word in KmCommand structure * to count keyboard and macro commands separately */ #define XCOUNT_SHIFT 10 #define XCOUNT_OFFSET (1 << XCOUNT_SHIFT) #define XCOUNT_MASK (XCOUNT_OFFSET - 1) extern C_PROTO_2(void check_version, int, int); extern C_PROTO_0(void check_edit_server); extern C_PROTO_3(int exec_cmd_string, char*, int, int(*)()); extern C_PROTO_1(int exec_decoded_cmd, KmCommand*); extern C_PROTO_1(KmMenu* find_submenu, char*); extern C_PROTO_2(char* fmt_cmd_help, KmCommand*, int); extern C_PROTO_0(void menu_style); extern C_PROTO_2(void print_cmd_list, KmCommand**, char*); extern C_PROTO_1(void reset_arg_list, KmCommand*); extern C_PROTO_1(KmMenu** root_menu_list, char*); extern C_PROTO_2(KmCommand* search_command, char*, KmCommand***); +KEEP,KHASH_H /* khash.h: hash table management */ typedef struct _HashArray { char *name; /* symbol name */ void *value; /* symbol value */ } HashArray; typedef struct _HashEntry { struct _HashEntry *next; /* link to next entry */ char *name; /* symbol name */ void *value; /* symbol value */ } HashEntry; typedef struct { int size; /* table size should be a prime number */ HashEntry **entries; /* pointer to array of size entries */ int nentries; /* number of entries */ int copy; /* flag if strdup/free(value) should be used */ } HashTable; #define ALIAS_TABLE_SIZE 97 /* should be a prime */ EXTERN struct { int translate; /* flag if translation wanted */ int substitutions; /* how many more before recursive alarm */ HashTable *arg_table; /* Argument alias table */ HashTable *cmd_table; /* Command alias table */ HashTable *var_table; /* macro variables */ } kc_alias; #define PAWID_TABLE_SIZE 97 static HashTable *kmpawid; /* list of panels with their name */ extern C_PROTO_2(HashTable* hash_create, int, int); extern C_PROTO_1(void hash_clear, HashTable*); extern C_PROTO_1(void hash_destroy, HashTable*); extern C_PROTO_3(void hash_insert, HashTable*, const char*, void*); extern C_PROTO_2(void hash_remove, HashTable*, const char*); extern C_PROTO_2(void* hash_lookup, HashTable*, const char*); extern C_PROTO_1(int hash_entries, HashTable*); extern C_PROTO_1(HashArray* hash_array, HashTable*); extern C_PROTO_1(int match_paren, char*); extern C_PROTO_1(char* repl_variable, char*); extern C_PROTO_2(char* repl_sysfun, char*, int); extern C_PROTO_1(char* subst_arg_alias, char*); extern C_PROTO_1(char* subst_cmd_alias, char*); extern C_PROTO_1(char* subst_var_alias, char*); extern C_PROTO_2(char* subst_sysfun, char*, int); extern C_PROTO_1(char* var_value, char*); +KEEP,MKTERM. #define ESCAPE "#@" typedef void (*KxtermActionProc)( #ifndef NO_PROTOTYPES char** /* params */, int /* num_params */ #endif ); typedef struct _KxtermActionsRec{ char *string; KxtermActionProc proc; } KxtermActionsRec; typedef KxtermActionsRec *KxtermActionList; extern C_PROTO_1(void kxterm_add_actions, KxtermActionList); extern C_PROTO_1(void handle_kxterm_action, char *); extern C_PROTO_1(void send_kxterm_cmd, char**); extern C_PROTO_1(void send_single_kxterm_cmd, char*); +DECK,hkuip_94b,if=94b. +KEEP,KHAIX370 #ifndef AIX370 # define AIX370 #endif +KEEP,KHAPOFTN #ifndef APOLLO_FTN # define APOLLO_FTN #endif +KEEP,KHIBMVM #ifndef IBMVM # define IBMVM #endif +KEEP,KHIBMMVS #ifndef IBMMVS # define IBMMVS #endif +KEEP,KHNEWLIB #ifndef NEWLIB # define NEWLIB #endif +KEEP,KSYS_H /* ksys.h: system dependent defines */ /* update version if structures have changed */ #define KUIP_VERSION 921023 /* identify system if not possible from preprocessor defines */ +SEQ,KHAIX370,IF=AIX370 +SEQ,KHAPOFTN,IF=APOFTN +SEQ,KHIBMVM ,IF=IBMVM +SEQ,KHIBMMVS,IF=IBMMVS +SEQ,KHNEWLIB,IF=NEWLIB #ifdef AIX370 # define MACHINE_NAME "IBMAIX" # define UNIX # define F77_EXTERN_INDIRECT #endif #if defined(apollo) || defined(__apollo) # define MACHINE_NAME "APOLLO" # define APOLLO # define UNIX # include # include # include # include # include # include # ifdef APOLLO_FTN /* using /com/ftn instead of /bin/f77 */ # define F77_CHAR_LEN_IND # define F77_CHAR_LEN_TYPE short # define F77_EXTERN_LOWERCASE # endif # define F77_EXTERN_INDIRECT # define F77_COMMON(name) name __attribute((__section(name))) # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define NO_DIRENT_H # define TERMIO_BSD /* for getline we must compile under bsd4.3 */ #endif #if defined(__convexc__) # define CONVEX # define MACHINE_NAME "CONVEX" # define UNIX # define F77_BLOCK(name,NAME) _##name##_ # define F77_ARG_CONSTANT # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ # define USE_EDIT_SERVER #endif #ifdef CRAY # define MACHINE_NAME "CRAY" # define UNIX # include # define F77_EXTERN_UPPERCASE # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define HAVE_STRCASECMP # define NO_EDIT_SERVER #endif #if defined(__hpux) # define MACHINE_NAME "HPUX" # define HPUX # define UNIX # ifndef _HPUX_SOURCE # define _HPUX_SOURCE # endif # define FATAL_SIGFPE /* needs f77 +T and ON REAL UNDERFLOW IGNORE */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRRSTR # define HAVE_SELECT # define SELECT_CAST(fds) (int*)fds #endif #ifdef _IBMR2 # define IBMRT # define MACHINE_NAME "IBMRT" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # include # define HAVE_SELECT # define BROKEN_F77_IO #endif #ifdef IBMVM # define ARG_STYLE_CMS # define MACHINE_NAME "IBM" # define OS_NAME "VM" # ifndef IBM370 # define IBM370 # endif # define KmTimeStamp TimeStamp typedef char TimeStamp[24]; extern int get_stamp(char*,TimeStamp*); # define same_stamp(stamp1,stamp2) (strcmp(*(stamp1),*(stamp2)) == 0) #endif #ifdef IBMMVS # define MACHINE_NAME "IBMMVS" # define OS_NAME "MVS" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBM370 # define F77_ARG_CONSTANT # define F77_CHAR_LEN_IND /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_EXTERN_INDIRECT # define F77_EXTERN_UPPERCASE # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_V7 # define ALLOC_MIN_BYTES 128 # define STUPID_MALLOC #endif #ifdef linux # define LINUX # define MACHINE_NAME "LINUX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT #endif #ifdef MSDOS # define MACHINE_NAME "IBMPC" # define OS_NAME "MSDOS" # define UNIX # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define SIGNAL_V7 # define SLASHES "\\/" # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ #endif #ifdef WIN32 # define WINNT # ifdef _ALPHA_ # define MACHINE_NAME "ALPHA" # else # define MACHINE_NAME "IBMPC" # endif # define OS_NAME "WINNT" # define UNIX # define MSDOS # include # include # include # include # define text_mode__() # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define NO_UNISTD_H # define SIGNAL_V7 # define SLASHES "\\" #endif #ifdef NeXT # define MACHINE_NAME "NEXT" # define UNIX # define getcwd(path,maxlen) getwd(path) # define F77_BLOCK(lc,uc) lc # define F77_EXTERN_INDIRECT /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_XXXX_USE_LEN(x) ,286716 /* don't know if value matters */ # define HAVE_MEMMOVE # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define NO_DIRENT_H # define NO_UNISTD_H # define SIGNAL_BSD # define TERMIO_BSD # define GETPGRP_BSD /* BSD getpgrp(pid) vs. POSIX getpgrp(void) */ #endif #ifdef __osf__ # define UNIX # ifdef __alpha # define ALPHA # define MACHINE_NAME "ALPHA" # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT # define BROKEN_F77_IO #endif #if defined(__sgi) # define MACHINE_NAME "SGI" # define SGI # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT #endif #if defined(sun) || defined(__sun) # define SUN # define UNIX # ifdef Solaris2 # define MACHINE_NAME "SOLARIS" # define SOLARIS # define HAVE_MEMMOVE # define HAVE_SELECT # define HAVE_STRCASECMP # define HAVE_VFORK # else # define MACHINE_NAME "SUN" # define HAVE_SELECT # define HAVE_STRCASECMP # define HAVE_VFORK # include # define MATCH_RE_COMP /* use re_comp/re_exec */ # define GETPGRP_BSD /* BSD getpgrp(pid) vs. POSIX getpgrp(void) */ # endif #endif #if defined(__ultrix) # define MACHINE_NAME "DECS" # define ULTRIX # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_VFORK # define NEED_STRDUP # define TERMIO_BSD # define GETPGRP_BSD /* BSD getpgrp(pid) vs. POSIX getpgrp(void) */ # define BROKEN_F77_IO #endif #ifdef vms # define OS_NAME "VMS" # ifdef __ALPHA # define ALPHA # define MACHINE_NAME "ALPHA" # else # define MACHINE_NAME "VAX" # define ConCat(con,cat) con/**/cat # endif # include # include # include /* lib$... prototypes */ # include # include # include # include # include # include # include # include # include /* sys$... prototypes */ # include # include # include # include # include # ifndef R_OK /* no access() modes in unixio.h on VAX/VMS */ # define F_OK 0 # define X_OK 1 # define W_OK 2 # define R_OK 4 # endif # define ARG_STYLE_VMS # define F77_EXTERN_LOWERCASE # define HAVE_MEMMOVE # define HAVE_STAT_H # define HAVE_VFORK /* actually have only vfork */ # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_BSD # define sigmask(sig) (1L << (sig-1)) /* should be in signal.h */ # define USE_EDIT_SERVER /* only for TPU/DISPLAY=MOTIF */ # if defined(VAXC) && !defined(__DECC) # define STUPID_MALLOC # endif # define fix_descriptor(dsc,str,n) \ do { \ dsc.dsc$b_dtype = DSC$K_DTYPE_T; \ dsc.dsc$b_class = DSC$K_CLASS_S; \ dsc.dsc$a_pointer = str; \ dsc.dsc$w_length = n; \ } while( 0 ) # define var_descriptor(dsc,str) \ do { \ dsc.dsc$b_dtype = DSC$K_DTYPE_T; \ dsc.dsc$b_class = DSC$K_CLASS_S; \ dsc.dsc$a_pointer = str; \ dsc.dsc$w_length = strlen( dsc.dsc$a_pointer ); \ } while( 0 ) #endif /* vms */ #include #include #include #ifndef NO_FCNTL_H #include #endif #include /* contains strtod() and strtol() on some systems */ #include #include #include #ifdef DBMALLOC #include "dbmalloc.h" /* debug malloc */ extern char* getenv(const char*); extern double strtod(const char*, char**); #else #include #endif #include #ifndef NO_UNISTD_H #include #endif #ifndef HAVE_VFORK # define vfork fork #endif #ifdef UNIX /* also defined for MSDOS and Windows/NT*/ # ifndef OS_NAME # define OS_NAME "UNIX" # endif # include # include # ifndef NO_SYS_TIME_H # include /* struct timeval */ # endif # ifndef MSDOS # include # ifdef TERMIO_BSD # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ # define HAVE_SELECT # endif # if !defined(TERMIO_BSD) && !defined(TERMIO_SYSV) # define TERMIO_POSIX # endif # if defined(HAVE_SELECT) && !defined(SELECT_CAST) # define SELECT_CAST(fds) fds # endif # include # ifndef NO_DIRENT_H /* POSIX opendir() */ # include # else /* BSD opendir() */ # include /* plus */ # define dirent direct /* struct dirent... */ # ifndef S_IRUSR # define S_IRUSR (S_IREAD) /* read permission, owner */ # define S_IWUSR (S_IWRITE) /* write permission, owner */ # define S_IXUSR (S_IEXEC) /* execute/search permission, owner */ # endif # endif # endif # define HAVE_STAT_H # ifndef NO_EDIT_SERVER # define USE_EDIT_SERVER # ifndef F_LOCK /* BSD file locking */ # include # define lockf(fd,op,offs) flock(fd,op) # define F_LOCK LOCK_EX # define F_ULOCK LOCK_UN # endif # endif # ifndef SLASHES # define SLASHES "/" # endif #endif #ifdef SUN # ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 1000000 /* missing in time.h */ # define difftime(t1,t0) ((double)(t1-t0)) # define raise(sig) kill(getpid(),sig) # endif #endif #ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 100 /* missing in VAX/VMS time.h */ #endif #ifdef HAVE_STAT_H # define KmTimeStamp struct stat # define get_stamp(path,stamp) stat(path,stamp) # define same_stamp(stamp1,stamp2) ((stamp2)->st_mtime == (stamp1)->st_mtime) #endif #ifndef KmTimeStamp # define KmTimeStamp int # define get_stamp(path,stamp) (*(stamp) = checksum(path)) # define same_stamp(stamp1,stamp2) (*(stamp1) == *(stamp2)) #endif #ifdef MATCH_RE_COMP extern char *re_comp(); extern int re_exec(); #else extern char *regcmp(); extern char *regex(); #endif /* command line arguments recognized by KUARGS */ #if !defined(ARG_STYLE_CMS) && !defined(ARG_STYLE_VMS) # define ARG_STYLE_UNIX #endif #ifndef MACHINE_NAME # define MACHINE_NAME "UNKNOWN" /* value returned by $MACHINE */ #endif #ifndef OS_NAME # define OS_NAME "UNKNOWN" /* value returned by $OS */ #endif /* #define EXTERN must be in one routine to allocate space for globals */ #ifndef EXTERN # define EXTERN extern #endif /* * Preprocessor syntax for token concatenation */ #ifndef ConCat # define ConCat(con,cat) con##cat #endif /* * Prototyping for C functions */ #define C_PROTO_0(name) \ name(void) #define C_PROTO_1(name,arg1) \ name(arg1) #define C_PROTO_2(name,arg1,arg2) \ name(arg1,arg2) #define C_PROTO_3(name,arg1,arg2,arg3) \ name(arg1,arg2,arg3) #define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name(arg1,arg2,arg3,arg4) #define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name(arg1,arg2,arg3,arg4,arg5) #define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name(arg1,arg2,arg3,arg4,arg5,arg6) #define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7) #define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) #define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) #define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) #define C_DECL_1(name,t1,p1) \ name(t1 p1) #define C_DECL_2(name,t1,p1,t2,p2) \ name(t1 p1,t2 p2) #define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name(t1 p1,t2 p2,t3 p3) #define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name(t1 p1,t2 p2,t3 p3,t4 p4) #define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5) #define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6) #define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7) #define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8) #define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,t9 p9) #define C_DECL_13(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,\ t9,p9,t10,p10,t11,p11,t12,p12,t13,p13) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,\ t9 p9,t10 p10,t11 p11,t12 p12,t13 p13) typedef int IntFunc(); typedef char* CharFunc(); typedef char** pCharFunc(); +KEEP,KSTRING_H. #include #ifdef __cplusplus extern "C" { #endif /* * quasi-standard functions missing in some C-libraries */ extern void* memmove( void* dst, const void* src, size_t n ); #if !defined(__convexc__) extern int strcasecmp( const char* str1, const char* str2 ); extern int strncasecmp( const char* str1, const char* str2, size_t n ); #endif extern char* strrstr( const char* str1, const char* str2 ); #define strdup Strdup /* prototype without const */ extern char* strdup( const char* str ); /* * convenience functions from kkern.c */ extern char* str0dup( const char* str ); extern char* str2dup( const char* str1, const char* str2 ); extern char* str3dup( const char* str1, const char* str2, const char* str3 ); extern char* str4dup( const char* str1, const char* str2, const char* str3, const char* str4 ); extern char* str5dup( const char* str1, const char* str2, const char* str3, const char* str4, const char* str5 ); extern char* strndup( const char* buf, size_t n ); extern char* stridup( int i ); extern char* mstrcat( char* ptr, const char* str ); extern char* mstr2cat( char* ptr, const char* str1, const char* str2 ); extern char* mstr3cat( char* ptr, const char* str1, const char* str2, const char* str3); extern char* mstr4cat( char* ptr, const char* str1, const char* str2, const char* str3, const char* str4 ); extern char* mstrncat( char* ptr, const char* buf, size_t n ); extern char* mstrccat( char* ptr, char c, size_t n ); extern char* mstricat( char* ptr, int i ); extern char* strrpbrk( const char* str1, const char* str2 ); extern char* strqtok( char* str ); extern char* strlower( char* str ); extern char* strupper( char* str ); extern char* strtrim( char* str ); extern char* struntab( char* str ); extern char* strfromd( double d, size_t prec ); extern char* strfromi( int i, size_t prec ); extern int shsystem( const char* shell, const char* cmd ); extern int checksum( const char* path ); extern char* fexpand( const char* fname, const char* ftype ); extern char* fsearch( const char* fname, const char* ftype, const char* path ); extern char* fsymlink( const char* path ); extern char* fstrdup( const char* buf, size_t len ); extern char* fstr0dup( const char* buf, size_t len ); extern char* fstrtrim( const char* buf, size_t len ); extern char* fstr0trim( const char* buf, size_t len ); extern size_t fstrlen( const char* buf, size_t len ); extern size_t fstrset( char* buf, size_t len, const char* str ); extern double fstrtod( const char* str, char** tail ); extern int fstrtoi( const char* str, char** tail ); extern char* fstrvec( char** pstr, size_t n, size_t* len ); extern size_t mstrlen( char** pstr, size_t n ); #ifdef __cplusplus } #endif +KEEP,KUSER_H. #define KUMAC_UNWIND -30041961 /* error status to quit macro execution */ #ifdef __cplusplus extern "C" { #endif /* * C-interface functions */ extern char* k_getar(void); extern void k_setar( size_t, char** ); extern char* k_userid(void); extern void ku_alfa(void); extern char* ku_appl( int* luno, int* inmacro ); extern int ku_bool( const char* expr ); extern int ku_close( int luno ); extern void ku_cmdl( const char* template ); extern int ku_edit( const char* path, int use_server ); extern char* ku_eval( const char* expr ); extern int ku_exec( const char* cmd ); extern int ku_exel( const char* cmd ); extern char* ku_expr( const char* expr ); extern char* ku_getc(void); extern char* ku_gete(void); extern char* ku_getf(void); extern int ku_geti(void); extern char* ku_getl(void); extern double ku_getr(void); extern char* ku_gets(void); extern char* ku_fcase( char* path ); extern char* ku_home( const char* fname, const char* ftype ); extern char* ku_inps( const char* prompt ); extern int ku_inqf( const char* path ); extern int ku_intr( int enable ); extern void ku_last( const char* cmd ); extern int ku_math( const char* expr, double* result ); extern int ku_more( const char* question, const char* line ); extern int ku_npar(void); extern int ku_open( int luno, const char* path, const char* mode ); extern void ku_pad( const char* path, int delete ); extern char* ku_path(void); extern void ku_piaf( int socket, void(*sync)() ); extern char* ku_proc( const char* prompt, const char* dfault ); extern char* ku_prof( const char* prompt, const char* dfault ); extern int ku_proi( const char* prompt, int dfault ); extern char* ku_prop( const char* prompt ); extern double ku_pror( const char* prompt, double dfault ); extern char* ku_pros( const char* prompt, const char* dfault ); extern char** ku_qenv(void); extern char* ku_qexe( const char* fname ); extern int ku_qkey(void); extern int ku_qmac( const char* mname ); extern int ku_read( int luno, char* buf, size_t len ); extern int ku_sapp( const char* path, const char* exit ); extern void ku_shut(void); extern void ku_sibr(void); extern void ku_spy( const char* option ); extern int ku_stop( int set ); extern void ku_time( time_t, clock_t ); extern void ku_trap( int enable, int traceback ); extern int ku_vqaddr( const char* vname ); extern int ku_vtype( const char* vname ); extern int ku_vvalue( const char* vname, double* value ); extern void ku_whag(void); extern void ku_what( void(*styleG)() ); extern void ku_write( int, const char* line ); extern int km_icon( const char*, const char* ); #ifdef __cplusplus } #endif +KEEP,KPROTO_H extern char* clean_word( char* ); extern char* format_prompt( const char* ); extern char* getline( const char* ); extern void gl_config( const char*, int ); extern void gl_histadd( const char* ); extern void gl_setwidth( int ); extern char* input_line( const char*, char ); extern void leave_kuip(void); extern int len_alias( const char*, int ); extern int len_sysfun( const char* ); extern int len_vector( const char* ); extern char* quote_string( char*, int ); extern void reset_break(void); extern char* split_at_semicolon( char* ); extern void k_parse_args( const char*, char**, int* ); #ifndef vms extern void signal_handler( int ); #else extern int signal_handler( const void*, const void* ); extern int control_C_ast( int ); #endif +KEEP,KUIP_H +SEQ,KSYS_H +SEQ,KSTRING_H +SEQ,KUSER_H +SEQ,KPROTO_H +KEEP,KFOR_H /* kfor.h: Fortran-C interface */ /* * Fortran data types */ typedef int INTEGER; typedef int LOGICAL; typedef float REAL; typedef double DBLPREC; typedef struct { REAL re; REAL im; } COMPLEX; typedef INTEGER INT_FUNCTION(); typedef INT_FUNCTION *INT_FUNCPTR; typedef void (*SUBRPTR)(); typedef void SUBROUTINE(); #ifdef IBM370 #pragma linkage(SUBROUTINE,FORTRAN) #pragma linkage(INT_FUNCTION,FORTRAN) #pragma map(__CTOF,"@@CTOF") extern INTEGER __CTOF( INT_FUNCPTR, ... ); #endif typedef union _EQUIV_INT_REAL { INTEGER i; LOGICAL l; REAL r; } EQUIV_INT_REAL; /* * Mapping of C-routine name for Fortran CALL SUB * * #define F77_EXTERN_LOWERCASE ==> void sub() * #define F77_EXTERN_UPPERCASE ==> void SUB() * otherwise ==> void sub_() */ #ifdef F77_EXTERN_UPPERCASE # define F77_NAME(name,NAME) NAME #else # ifdef F77_EXTERN_LOWERCASE # define F77_NAME(name,NAME) name # else # define F77_NAME(name,NAME) ConCat(name,_) # endif #endif #ifndef F77_BLOCK # define F77_BLOCK(name,NAME) F77_NAME(name,NAME) #endif #ifndef F77_COMMON # define F77_COMMON(name) name #endif /* * Routine address in CALL SUB(FUN) ; EXTERNAL FUN * * #define F77_EXTERN_INDIRECT ==> void (**fun)(); * otherwise ==> void (*fun)(); */ #ifdef F77_EXTERN_INDIRECT # define F77_EXTERN_ARG(e) ConCat(e,_ptr) # define F77_EXTERN_DCL(e) SUBROUTINE **ConCat(e,_ptr); # define F77_EXTERN_DEF(e) SUBROUTINE *e = *ConCat(e,_ptr); #else # define F77_EXTERN_ARG(e) e # define F77_EXTERN_DCL(e) SUBROUTINE *e; # define F77_EXTERN_DEF(e) #endif #define F77_EXTERN2ARG(e1,e2) F77_EXTERN_ARG(e1),F77_EXTERN_ARG(e2) #define F77_EXTERN2DCL(e1,e2) F77_EXTERN_DCL(e1) F77_EXTERN_DCL(e2) #define F77_EXTERN2DEF(e1,e2) F77_EXTERN_DEF(e1) F77_EXTERN_DEF(e2) #define F77_EXTERN3ARG(e1,e2,e3) F77_EXTERN_ARG(e1),F77_EXTERN2ARG(e2,e3) #define F77_EXTERN3DCL(e1,e2,e3) F77_EXTERN_DCL(e1) F77_EXTERN2DCL(e2,e3) #define F77_EXTERN3DEF(e1,e2,e3) F77_EXTERN_DEF(e1) F77_EXTERN2DEF(e2,e3) #define F77_EXTERN4ARG(e1,e2,e3,e4) F77_EXTERN_ARG(e1),F77_EXTERN3ARG(e2,e3,e4) #define F77_EXTERN4DCL(e1,e2,e3,e4) F77_EXTERN_DCL(e1) F77_EXTERN3DCL(e2,e3,e4) #define F77_EXTERN4DEF(e1,e2,e3,e4) F77_EXTERN_DEF(e1) F77_EXTERN3DEF(e2,e3,e4) #ifdef F77_ARG_CONSTANT /* * If the Fortran compiler (e.g. VSFORTRAN and Convex fc without -sa option) * uses constant argument blocks we have to make a private copy in case the * routine uses the arguments as local variables. */ # define F77_XXXX_ARG_PTR(t,x) ConCat(x,_ptr) # define F77_XXXX_ARG_DCL(t,x) t *ConCat(x,_ptr); # define F77_XXXX_ARG_DEF(t,x) t *x = ConCat(x,_ptr); #else # define F77_XXXX_ARG_PTR(t,x) x # define F77_XXXX_ARG_DCL(t,x) t *x; # define F77_XXXX_ARG_DEF(t,x) #endif #define F77_REAL_ARG_PTR(r) F77_XXXX_ARG_PTR(REAL,r) #define F77_REAL_ARG_DCL(r) F77_XXXX_ARG_DCL(REAL,r) #define F77_REAL_ARG_DEF(r) F77_XXXX_ARG_DEF(REAL,r) #define F77_INTG_ARG_PTR(i) F77_XXXX_ARG_PTR(INTEGER,i) #define F77_INTG_ARG_DCL(i) F77_XXXX_ARG_DCL(INTEGER,i) #define F77_INTG_ARG_DEF(i) F77_XXXX_ARG_DEF(INTEGER,i) #define F77_INTG_ARG2PTR(i1,i2) F77_INTG_ARG_PTR(i1),F77_INTG_ARG_PTR(i2) #define F77_INTG_ARG2DCL(i1,i2) F77_INTG_ARG_DCL(i1) F77_INTG_ARG_DCL(i2) #define F77_INTG_ARG2DEF(i1,i2) F77_INTG_ARG_DEF(i1) F77_INTG_ARG_DEF(i2) #define F77_INTG_ARG3PTR(i1,i2,i3) F77_INTG_ARG_PTR(i1),F77_INTG_ARG2PTR(i2,i3) #define F77_INTG_ARG3DCL(i1,i2,i3) F77_INTG_ARG_DCL(i1) F77_INTG_ARG2DCL(i2,i3) #define F77_INTG_ARG3DEF(i1,i2,i3) F77_INTG_ARG_DEF(i1) F77_INTG_ARG2DEF(i2,i3) #define F77_INTG_ARG4PTR(i1,i2,i3,i4) F77_INTG_ARG_PTR(i1), \ F77_INTG_ARG3PTR(i2,i3,i4) #define F77_INTG_ARG4DCL(i1,i2,i3,i4) F77_INTG_ARG_DCL(i1) \ F77_INTG_ARG3DCL(i2,i3,i4) #define F77_INTG_ARG4DEF(i1,i2,i3,i4) F77_INTG_ARG_DEF(i1) \ F77_INTG_ARG3DEF(i2,i3,i4) /* * Access to Fortran CHARACTER arguments */ #ifdef vms /* VMS string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) struct dsc$descriptor_s *ConCat(s,_ptr); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr)->dsc$a_pointer; \ int ConCat(len_,s) = ConCat(s,_ptr)->dsc$w_length; # define F77_CHAR_DEF_DSC(s,p,l) struct dsc$descriptor_s ConCat(s,_dsc); # define F77_CHAR_ASS_DSC(s,p,l) ConCat(s,_dsc).dsc$w_length = l; \ ConCat(s,_dsc).dsc$b_dtype = DSC$K_DTYPE_T;\ ConCat(s,_dsc).dsc$b_class = DSC$K_CLASS_S;\ ConCat(s,_dsc).dsc$a_pointer = (char*)p; # define F77_CHAR_USE_PTR(s,p,l) &ConCat(s,_dsc) # define F77_CHAR_USE_LEN(s,p,l) #else #ifdef CRAY /* Cray string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) _fcd ConCat(s,_ptr); # define F77_CHAR_ARG_DEF(s) char *s = _fcdtocp(ConCat(s,_ptr)); \ int ConCat(len_,s) = _fcdlen(ConCat(s,_ptr)); # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) _cptofcd(p,l) # define F77_CHAR_USE_LEN(s,p,l) #else /* length passed as additional argument */ # ifdef F77_CHAR_LEN_IND /* length passed by reference */ # define F77_CHAR_LEN_STAR(len) *len # else # define F77_CHAR_LEN_STAR(len) len # endif # ifndef F77_CHAR_LEN_TYPE # define F77_CHAR_LEN_TYPE int # endif # ifdef F77_ARG_CONSTANT # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) , ConCat(s,_len) # define F77_CHAR_ARG_DCL(s) char *ConCat(s,_ptr); \ F77_CHAR_LEN_TYPE F77_CHAR_LEN_STAR(ConCat(s,_len)); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr); \ int ConCat(len_,s) = F77_CHAR_LEN_STAR(ConCat(s,_len)); # else # ifdef F77_CHAR_LEN_IND # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(s,_len) # define F77_CHAR_ARG_DCL(s) char *s; \ F77_CHAR_LEN_TYPE F77_CHAR_LEN_STAR(ConCat(s,_len)); # define F77_CHAR_ARG_DEF(s) \ int ConCat(len_,s) = F77_CHAR_LEN_STAR(ConCat(s,_len)); # else # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(len_,s) # define F77_CHAR_ARG_DCL(s) char *s; int ConCat(len_,s); # define F77_CHAR_ARG_DEF(s) # endif # endif # if defined(F77_CHAR_LEN_IND) # define F77_CHAR_DEF_DSC(s,p,l) F77_CHAR_LEN_TYPE ConCat(s,_dsc) = l; # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , &ConCat(s,_dsc) # else # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , l # endif #endif #endif #ifndef F77_XXXX_ARG_LEN /* length argument of non-CHARACTER arguments */ # define F77_XXXX_ARG_LEN(x) /* nil */ # define F77_XXXX_USE_LEN(x) /* nil */ #endif #define F77_CHAR_ARG2PTR(c1,c2) \ F77_CHAR_ARG_PTR(c1),F77_CHAR_ARG_PTR(c2) #define F77_CHAR_ARG2LEN(c1,c2) \ F77_CHAR_ARG_LEN(c1) F77_CHAR_ARG_LEN(c2) #define F77_XXXX_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(c1) F77_XXXX_ARG_LEN(c2) #define F77_CHAR_ARG2DCL(c1,c2) \ F77_CHAR_ARG_DCL(c1) F77_CHAR_ARG_DCL(c2) #define F77_CHAR_ARG2DEF(c1,c2) \ F77_CHAR_ARG_DEF(c1) F77_CHAR_ARG_DEF(c2) #define F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG2PTR(c1,c2),F77_CHAR_ARG_PTR(c3) #define F77_CHAR_ARG3LEN(c1,c2,c3) \ F77_CHAR_ARG2LEN(c1,c2) F77_CHAR_ARG_LEN(c3) #define F77_XXXX_ARG3LEN(c1,c2,c3) \ F77_XXXX_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(c3) #define F77_CHAR_ARG3DCL(c1,c2,c3) \ F77_CHAR_ARG2DCL(c1,c2) F77_CHAR_ARG_DCL(c3) #define F77_CHAR_ARG3DEF(c1,c2,c3) \ F77_CHAR_ARG2DEF(c1,c2) F77_CHAR_ARG_DEF(c3) #define F77_CHAR_ARG4PTR(c1,c2,c3,c4) \ F77_CHAR_ARG3PTR(c1,c2,c3),F77_CHAR_ARG_PTR(c4) #define F77_CHAR_ARG4LEN(c1,c2,c3,c4) \ F77_CHAR_ARG3LEN(c1,c2,c3) F77_CHAR_ARG_LEN(c4) #define F77_XXXX_ARG4LEN(c1,c2,c3,c4) \ F77_XXXX_ARG3LEN(c1,c2,c3) F77_XXXX_ARG_LEN(c4) #define F77_CHAR_ARG4DCL(c1,c2,c3,c4) \ F77_CHAR_ARG3DCL(c1,c2,c3) F77_CHAR_ARG_DCL(c4) #define F77_CHAR_ARG4DEF(c1,c2,c3,c4) \ F77_CHAR_ARG3DEF(c1,c2,c3) F77_CHAR_ARG_DEF(c4) #define F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_CHAR_ARG_PTR(c5) #define F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) F77_CHAR_ARG_LEN(c5) #define F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_CHAR_ARG_DCL(c5) #define F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_CHAR_ARG_DEF(c5) /* * Fortran-calls-C interface * * To define a C function called by Fortran CALL SUB(A,B,C): * * #define Sub F77_NAME(sub,SUB) * #pragma linkage(SUB,FORTRAN) // for IBM C/370 compiler * * F77_ENTRY_xyz(Sub,a,b,c) // opening { contained in macro * // body ... * } * * Each character in xyz declares the type of the corresponding parameter: * * C = CHARACTER * E = EXTERNAL * I = INTEGER * R = REAL * * If a parameter PAR is declared as CHARACTER the macro defines: * * char *PAR; // pointer to string (not terminated by \0 !!!) * int len_PAR; // length of string as defined by Fortran's LEN(PAR) * * The names PAR_dsc and PAR_ptr are reserved for internal use. * * Note: The function body follows the F77_ENTRY_... macro call directly. * The opening { is generated by the macro. */ #define F77_ENTRY_C(name,c1) \ name( F77_CHAR_ARG_PTR(c1) F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CC(name,c1,c2) \ name( F77_CHAR_ARG2PTR(c1,c2) F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_C3(name,c1,c2,c3) \ name( F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG3LEN(c1,c2,c3) ) \ F77_CHAR_ARG3DCL(c1,c2,c3) \ { F77_CHAR_ARG3DEF(c1,c2,c3) #define F77_ENTRY_C5(name,c1,c2,c3,c4,c5) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) #define F77_ENTRY_C4E(name,c1,c2,c3,c4,e5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_EXTERN_ARG(e5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_EXTERN_DCL(e5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_EXTERN_DEF(e5) #define F77_ENTRY_C4I(name,c1,c2,c3,c4,i5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_INTG_ARG_PTR(i5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_INTG_ARG_DCL(i5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_INTG_ARG_DEF(i5) #define F77_ENTRY_C5E(name,c1,c2,c3,c4,c5,e6) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5),F77_EXTERN_ARG(e6) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) F77_EXTERN_DCL(e6) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) F77_EXTERN_DEF(e6) #define F77_ENTRY_CCE(name,c1,c2,e3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN_ARG(e3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN_DCL(e3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN_DEF(e3) #define F77_ENTRY_CCEE(name,c1,c2,e3,e4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN2ARG(e3,e4) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN2DCL(e3,e4) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN2DEF(e3,e4) #define F77_ENTRY_CCI(name,c1,c2,i3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG_PTR(i3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_INTG_ARG_DCL(i3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_INTG_ARG_DEF(i3) #define F77_ENTRY_CCIC(name,c1,c2,i3,c4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG_PTR(i3),F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(i3) F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG3DCL(c1,c2,c4) F77_INTG_ARG_DCL(i3) \ { F77_CHAR_ARG3DEF(c1,c2,c4) F77_INTG_ARG_DEF(i3) #define F77_ENTRY_CCI3(name,c1,c2,i3,i4,i5) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG3PTR(i3,i4,i5) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_INTG_ARG3DCL(i3,i4,i5) \ { F77_CHAR_ARG2DEF(c1,c2) F77_INTG_ARG3DEF(i3,i4,i5) #define F77_ENTRY_CCIRCC(name,c1,c2,i3,r4,c5,c6) \ name( F77_CHAR_ARG2PTR(c1,c2), \ F77_INTG_ARG_PTR(i3),F77_REAL_ARG_PTR(r4),F77_CHAR_ARG2PTR(c5,c6) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG2LEN(i3,r4) F77_CHAR_ARG2LEN(c5,c6) ) \ F77_CHAR_ARG4DCL(c1,c2,c5,c6) \ F77_INTG_ARG_DCL(i3) F77_REAL_ARG_DCL(r4) \ { F77_CHAR_ARG4DEF(c1,c2,c5,c6) \ F77_INTG_ARG_DEF(i3) F77_REAL_ARG_DEF(r4) \ #define F77_ENTRY_CE(name,c1,e2) \ name( F77_CHAR_ARG_PTR(c1),F77_EXTERN_ARG(e2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_EXTERN_DCL(e2) \ { F77_CHAR_ARG_DEF(c1) F77_EXTERN_DEF(e2) #define F77_ENTRY_CI(name,c1,i2) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG_PTR(i2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_INTG_ARG_DCL(i2) \ { F77_CHAR_ARG_DEF(c1) F77_INTG_ARG_DEF(i2) #define F77_ENTRY_CICI(name,c1,i2,c3,i4) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG_PTR(i2), \ F77_CHAR_ARG_PTR(c3),F77_INTG_ARG_PTR(i4) \ F77_CHAR_ARG_LEN(c1) F77_XXXX_ARG_LEN(i2) \ F77_CHAR_ARG_LEN(c3) ) \ F77_CHAR_ARG2DCL(c1,c3) F77_INTG_ARG2DCL(i2,i4) \ { F77_CHAR_ARG2DEF(c1,c3) F77_INTG_ARG2DEF(i2,i4) #define F77_ENTRY_CII(name,c1,i2,i3) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG2PTR(i2,i3) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_INTG_ARG2DCL(i2,i3) \ { F77_CHAR_ARG_DEF(c1) F77_INTG_ARG2DEF(i2,i3) #define F77_ENTRY_CIIC(name,c1,i2,i3,c4) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG2PTR(i2,i3),F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG_LEN(c1) F77_XXXX_ARG2LEN(i2,i3) F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG2DCL(c1,c4) F77_INTG_ARG2DCL(i2,i3) \ { F77_CHAR_ARG2DEF(c1,c4) F77_INTG_ARG2DEF(i2,i3) #define F77_ENTRY_CR(name,c1,r2) \ name( F77_CHAR_ARG_PTR(c1),F77_REAL_ARG_PTR(r2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_REAL_ARG_DCL(r2) \ { F77_CHAR_ARG_DEF(c1) F77_REAL_ARG_DEF(r2) #define F77_ENTRY_E(name,e1) \ name( F77_EXTERN_ARG(e1) ) \ F77_EXTERN_DCL(e1) \ { F77_EXTERN_DEF(e1) #define F77_ENTRY_E4(name,e1,e2,e3,e4) \ name( F77_EXTERN4ARG(e1,e2,e3,e4) ) \ F77_EXTERN4DCL(e1,e2,e3,e4) \ { F77_EXTERN4DEF(e1,e2,e3,e4) #define F77_ENTRY_IC(name,i1,c2) \ name( F77_INTG_ARG_PTR(i1),F77_CHAR_ARG_PTR(c2) \ F77_XXXX_ARG_LEN(i1) F77_CHAR_ARG_LEN(c2) ) \ F77_INTG_ARG_DCL(i1) F77_CHAR_ARG_DCL(c2) \ { F77_INTG_ARG_DEF(i1) F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_ICI(name,i1,c2,i3) \ name( F77_INTG_ARG_PTR(i1), F77_CHAR_ARG_PTR(c2),F77_INTG_ARG_PTR(i3) \ F77_XXXX_ARG_LEN(i1) F77_CHAR_ARG_LEN(c2) ) \ F77_INTG_ARG2DCL(i1,i3) F77_CHAR_ARG_DCL(c2) \ { F77_INTG_ARG2DEF(i1,i3) F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_IIC(name,i1,i2,c3) \ name( F77_INTG_ARG2PTR(i1,i2),F77_CHAR_ARG_PTR(c3) \ F77_XXXX_ARG2LEN(i1,i2) F77_CHAR_ARG_LEN(c3) ) \ F77_INTG_ARG2DCL(i1,i2) F77_CHAR_ARG_DCL(c3) \ { F77_INTG_ARG2DEF(i1,i2) F77_CHAR_ARG_DEF(c3) #define F77_ENTRY_I3C(name,i1,i2,i3,c4) \ name( F77_INTG_ARG3PTR(i1,i2,i3),F77_CHAR_ARG_PTR(c4) \ F77_XXXX_ARG3LEN(i1,i2,i3) F77_CHAR_ARG_LEN(c4) ) \ F77_INTG_ARG3DCL(i1,i2,i3) F77_CHAR_ARG_DCL(c4) \ { F77_INTG_ARG3DEF(i1,i2,i3) F77_CHAR_ARG_DEF(c4) #define F77_ENTRY_I4CCC(name,i1,i2,i3,i4,c5,c6,c7) \ name( F77_INTG_ARG4PTR(i1,i2,i3,i4),F77_CHAR_ARG3PTR(c5,c6,c7) \ F77_XXXX_ARG4LEN(i1,i2,i3,i4) F77_CHAR_ARG3LEN(c5,c6,c7) ) \ F77_INTG_ARG4DCL(i1,i2,i3,i4) F77_CHAR_ARG3DCL(c5,c6,c7) \ { F77_INTG_ARG4DEF(i1,i2,i3,i4) F77_CHAR_ARG3DEF(c5,c6,c7) #define F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_DEF_DSC(s1,p1,l1) F77_CHAR_DEF_DSC(s2,p2,l2) #define F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS_DSC(s1,p1,l1) F77_CHAR_ASS_DSC(s2,p2,l2) #define F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_PTR(s1,p1,l1),F77_CHAR_USE_PTR(s2,p2,l2) #define F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_LEN(s1,p1,l1) F77_CHAR_USE_LEN(s2,p2,l2) #define F77_XXXX_USE2LEN(x1,x2) \ F77_XXXX_USE_LEN(x1) F77_XXXX_USE_LEN(x2) #define F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_DEF_DSC(s3,p3,l3) #define F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_ASS_DSC(s3,p3,l3) #define F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2),F77_CHAR_USE_PTR(s3,p3,l3) #define F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) F77_CHAR_USE_LEN(s3,p3,l3) #define F77_XXXX_USE3LEN(x1,x2,x3) \ F77_XXXX_USE2LEN(x1,x2) F77_XXXX_USE_LEN(x3) #define F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_DEF_DSC(s4,p4,l4) #define F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_ASS_DSC(s4,p4,l4) #define F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3),F77_CHAR_USE_PTR(s4,p4,l4) #define F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_USE_LEN(s4,p4,l4) #define F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_XXXX_USE3LEN(x1,x2,x3) F77_XXXX_USE_LEN(x4) #define F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) F77_XXXX_USE_LEN(x5) #define F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) \ F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) F77_XXXX_USE_LEN(x6) #define F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) \ F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) F77_XXXX_USE_LEN(x7) #define F77_XXXX_USE8LEN(x1,x2,x3,x4,x5,x6,x7,x8) \ F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) F77_XXXX_USE_LEN(x8) EXTERN INTEGER F77_i0; /* dummy */ #ifdef IBM370 #pragma linkage(K77C,FORTRAN) #define F77_IFUN_C(i0,name,p1,l1) do { \ i0 = K77C(&name,p1,l1); } while(0) #else #define F77_IFUN_C(i0,name,p1,l1) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1) \ F77_CHAR_USE_LEN(s1,p1,l1) \ ); } while(0) #endif #define F77_CALL_C(name,p1,l1) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_C(F77_i0,_p0_,p1,l1); \ } while(0) #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ i0 = K77CC(&name,p1,l1,p2,l2); } while(0) #else #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_CC(F77_i0,_p0_,p1,l1,p2,l2); \ } while(0) #ifdef IBM370 #pragma linkage(K77C3,FORTRAN) #define F77_IFUN_C3(i0,name,p1,l1,p2,l2,p3,l3) do { \ i0 = K77C3(&name,p1,l1,p2,l2,p3,l3); } while(0) #else #define F77_IFUN_C3(i0,name,p1,l1,p2,l2,p3,l3) do { \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ i0 = (*name)( \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_C3(F77_i0,_p0_,p1,l1,p2,l2,p3,l3); \ } while(0) #ifdef IBM370 #pragma linkage(K77C7,FORTRAN) #define F77_IFUN_C7(i0,name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ i0 = K77C7(&name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); } while(0) #else #define F77_IFUN_C7(i0,name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ i0 = (*name)( \ F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4), \ F77_CHAR_USE3PTR(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ ); } while(0) #endif #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_C7(F77_i0,_p0_,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); \ } while(0) #ifdef IBM370 #pragma linkage(K77CCx,FORTRAN) #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77CCx(&F77,p1,l1,p2,l2,x3); } while(0) #else #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCxx,FORTRAN) #define F77_IFUN_CCxx(i0,name,p1,l1,p2,l2,x3,x4) do { \ i0 = K77CCxx(&name,p1,l1,p2,l2,x3,x4); } while(0) #else #define F77_IFUN_CCxx(i0,name,p1,l1,p2,l2,x3,x4) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CCxx(name,p1,l1,p2,l2,x3,x4) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_CCxx(F77_i0,_p0_,p1,l1,p2,l2,x3,x4); \ } while(0) #ifdef IBM370 #pragma linkage(K77CCx3,FORTRAN) #define F77_IFUN_CCx3(i0,name,p1,l1,p2,l2,x3,x4,x5) do { \ i0 = K77CCx3(&name,p1,l1,p2,l2,x3,x4,x5); } while(0) #else #define F77_IFUN_CCx3(i0,name,p1,l1,p2,l2,x3,x4,x5) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4,x5 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_CCx3(F77_i0,_p0_,p1,l1,p2,l2,x3,x4,x5); \ } while(0) #ifdef IBM370 #pragma linkage(K77Cx,FORTRAN) #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ i0 = K77Cx(&name,p1,l1,x2); } while(0) #else #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1), \ x2 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ ); } while(0) #endif #define F77_CALL_Cx(name,p1,l1,x2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_Cx(F77_i0,_p0_,p1,l1,x2); \ } while(0) #ifdef IBM370 #pragma linkage(K77CxC,FORTRAN) #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77CxC(&F77,p1,l1,x2,p3,l3); } while(0) #else #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s3,p3,l3) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2, \ F77_CHAR_USE_PTR(s3,p3,l3) \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ F77_CHAR_USE_LEN(s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cxx,FORTRAN) #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ SUBROUTINE *F77 = name; \ K77Cxx(&F77,p1,l1,x2,x3); } while(0) #else #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2,x3 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE2LEN(x2,x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xC,FORTRAN) #define F77_CALL_xC(name,x1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77xC(&F77,x1,p2,l2); } while(0) #else #define F77_CALL_xC(name,x1,p2,l2) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCCx,FORTRAN) #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ SUBROUTINE *F77 = name; \ K77xCCx(&F77,x1,p2,l2,p3,l3,x4); } while(0) #else #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ name( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3), \ x4 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x4) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCC,FORTRAN) #define F77_IFUN_xCC(i0,name,x1,p2,l2,p3,l3) do { \ i0 = K77xCC(&name,x1,p2,l2,p3,l3); } while(0) #else #define F77_IFUN_xCC(i0,name,x1,p2,l2,p3,l3) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ i0 = (*name)( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #define F77_CALL_xCC(name,x1,p2,l2,p3,l3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_xCC(F77_i0,_p0_,x1,p2,l2,p3,l3); \ } while(0) #ifdef IBM370 #pragma linkage(K77xCx,FORTRAN) #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ i0 = K77xCx(&name,x1,p2,l2,x3); } while(0) #else #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_xCx(F77_i0,_p0_,x1,p2,l2,x3); \ } while(0) #ifdef IBM370 #pragma linkage(K77x4C,FORTRAN) #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ SUBROUTINE *F77 = name; \ K77x4C(&F77,x1,x2,x3,x4,p5,l5); } while(0) #else #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77x4Cxx,FORTRAN) #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ SUBROUTINE *F77 = name; \ K77x4Cxx(&F77,x1,x2,x3,x4,p5,l5,x6,x7); } while(0) #else #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5), \ x6,x7 \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ F77_XXXX_USE2LEN(x6,x7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(KIGMENU,FORTRAN) /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 */ #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ SUBROUTINE *F77 = name; \ KIGMENU(&F77,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N); } while(0) #else #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ F77_CHAR_DEF_DSC(sb,b,B) \ F77_CHAR_DEF_DSC(sh,h,H) \ F77_CHAR_DEF3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_DEF_DSC(sn,n,N) \ F77_CHAR_ASS_DSC(sb,b,B) \ F77_CHAR_ASS_DSC(sh,h,H) \ F77_CHAR_ASS3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_ASS_DSC(sn,n,N) \ name( a, \ F77_CHAR_USE_PTR(sb,b,B), \ c,d,e,f,g, \ F77_CHAR_USE_PTR(sh,h,H), \ i, \ F77_CHAR_USE3PTR(sj,j,J,sk,k,K,sl,l,L), \ m, \ F77_CHAR_USE_PTR(sn,n,N) \ F77_XXXX_USE_LEN(a) \ F77_CHAR_USE_LEN(sb,b,B) \ F77_XXXX_USE5LEN(c,d,e,f,g) \ F77_CHAR_USE_LEN(sh,h,H) \ F77_XXXX_USE_LEN(i) \ F77_CHAR_USE3LEN(sj,j,J,sk,k,K,sl,l,L) \ F77_XXXX_USE_LEN(m) \ F77_CHAR_USE_LEN(sn,n,N) \ ); } while(0) #endif #ifdef IBM370 #define F77_IFUN_x(i0,name,x1) i0 = __CTOF(name,x1) #else #define F77_IFUN_x(i0,name,x1) i0 = (*name)(x1) #endif #ifdef IBM370 #define F77_IFUN_xx(i0,name,x1,x2) i0 = __CTOF(name,x1,x2) #else #define F77_IFUN_xx(i0,name,x1,x2) i0 = (*name)(x1,x2) #endif #ifdef IBM370 #pragma linkage(K77xCx8,FORTRAN) #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ i0 = K77xCx8(&name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10); } while(0) #else #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3,x4,x5,x6,x7,x8,x9,x10 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE8LEN(x3,x4,x5,x6,x7,x8,x9,x10) \ ); } while(0) #endif extern LOGICAL ku_true( int return_true ); /* * routines called by Fortran */ #define Errrun F77_NAME(errrun,ERRRUN) #define Fmemcpy F77_NAME(fmemcpy,FMEMCPY) #define Getarg F77_NAME(getarg,GETARG) extern SUBROUTINE Getarg; #define Goparm F77_NAME(goparm,GOPARM) extern SUBROUTINE Goparm; #define Iclrwk F77_NAME(iclrwk,ICLRWK) extern SUBROUTINE Iclrwk; #define Iginit F77_NAME(iginit,IGINIT) extern SUBROUTINE Iginit; #define Igmenu F77_NAME(igmenu,IGMENU) extern SUBROUTINE Igmenu; #define Igrng F77_NAME(igrng,IGRNG) extern SUBROUTINE Igrng; #define Igsse F77_NAME(igsse,IGSSE) extern SUBROUTINE Igsse; #define Igsrap F77_NAME(igsrap,IGSRAP) extern SUBROUTINE Igsrap; #define Igwkty F77_NAME(igwkty,IGWKTY) extern SUBROUTINE Igwkty; #define Kcexec F77_NAME(kcexec,KCEXEC) #define Kdialo F77_NAME(kdialo,KDIALO) extern SUBROUTINE Kdialo; #define Kgetar F77_NAME(kgetar,KGETAR) #define Kiargc F77_NAME(kiargc,KIARGC) extern INT_FUNCTION Kiargc; #define Kibres F77_NAME(kibres,KIBRES) extern SUBROUTINE Kibres; #define Kiclos F77_NAME(kiclos,KICLOS) extern SUBROUTINE Kiclos; #define Kicomv F77_NAME(kicomv,KICOMV) #define Kierrf F77_NAME(kierrf,KIERRF) extern SUBROUTINE Kierrf; #define Kiinit F77_NAME(kiinit,KIINIT) extern SUBROUTINE Kiinit; #define Kilun F77_NAME(kilun,KILUN) extern SUBROUTINE Kilun; #define Kimtch F77_NAME(kimtch,KIMTCH) extern SUBROUTINE Kimtch; #define Kipawc F77_NAME(kipawc,KIPAWC) #define Kipiaf F77_NAME(kipiaf,KIPIAF) #define Kiprmt F77_NAME(kiprmt,KIPRMT) #define Kirtim F77_NAME(kirtim,KIRTIM) #define Kisigm F77_NAME(kisigm,KISIGM) #define Kivect F77_NAME(kivect,KIVECT) #define Kmbrset F77_NAME(kmbrset,KMBRSET) #define Kmvsed F77_NAME(kmvsed,KMVSED) extern SUBROUTINE Kmvsed; #define Kmvspg F77_NAME(kmvspg,KMVSPG) extern SUBROUTINE Kmvspg; #define Kmvssh F77_NAME(kmvssh,KMVSSH) extern SUBROUTINE Kmvssh; #define Ksvpar F77_NAME(ksvpar,KSVPAR) #define Kuach F77_NAME(kuach,KUACH) #define Kuact F77_NAME(kuact,KUACT) #define Kualfa F77_NAME(kualfa,KUALFA) #define Kuappl F77_NAME(kuappl,KUAPPL) #define Kuargs F77_NAME(kuargs,KUARGS) #define Kubrek F77_NAME(kubrek,KUBREK) #define Kubrof F77_NAME(kubrof,KUBROF) #define Kubron F77_NAME(kubron,KUBRON) #define Kuclos F77_NAME(kuclos,KUCLOS) extern SUBROUTINE Kuclos; #define Kucmd F77_NAME(kucmd,KUCMD) #define Kucmdl F77_NAME(kucmdl,KUCMDL) #define Kucomv F77_NAME(kucomv,KUCOMV) #define Kuedit F77_NAME(kuedit,KUEDIT) #define Kuesvr F77_NAME(kuesvr,KUESVR) #define Kueusr F77_NAME(kueusr,KUEUSR) #define Kuexec F77_NAME(kuexec,KUEXEC) #define Kuexel F77_NAME(kuexel,KUEXEL) #define Kuexit F77_NAME(kuexit,KUEXIT) #define Kufcas F77_NAME(kufcas,KUFCAS) #define Kufdef F77_NAME(kufdef,KUFDEF) #define Kugetc F77_NAME(kugetc,KUGETC) #define Kugete F77_NAME(kugete,KUGETE) #define Kugetf F77_NAME(kugetf,KUGETF) #define Kugeti F77_NAME(kugeti,KUGETI) #define Kugetl F77_NAME(kugetl,KUGETL) #define Kugetr F77_NAME(kugetr,KUGETR) #define Kugets F77_NAME(kugets,KUGETS) #define Kugrfl F77_NAME(kugrfl,KUGRFL) #define Kuguid F77_NAME(kuguid,KUGUID) #define Kuhelp F77_NAME(kuhelp,KUHELP) #define Kuhome F77_NAME(kuhome,KUHOME) #define Kuidf1 F77_NAME(kuidf1,KUIDF1) extern SUBROUTINE Kuidf1; #define Kuidf2 F77_NAME(kuidf2,KUIDF2) extern SUBROUTINE Kuidf2; #define Kuidfm F77_NAME(kuidfm,KUIDFM) #define Kuinim F77_NAME(kuinim,KUINIM) #define Kuinit F77_NAME(kuinit,KUINIT) #define Kuinps F77_NAME(kuinps,KUINPS) #define Kuinqf F77_NAME(kuinqf,KUINQF) extern SUBROUTINE Kuinqf; #define Kulun F77_NAME(kulun,KULUN) #define Kumloc F77_NAME(kumloc,KUMLOC) #define Kumout F77_NAME(kumout,KUMOUT) #define Kundpv F77_NAME(kundpv,KUNDPV) #define Kunpar F77_NAME(kunpar,KUNPAR) #define Kunwg F77_NAME(kunwg,KUNWG) #define Kuopen F77_NAME(kuopen,KUOPEN) extern SUBROUTINE Kuopen; #define Kupad F77_NAME(kupad,KUPAD) #define Kupar F77_NAME(kupar,KUPAR) #define Kupath F77_NAME(kupath,KUPATH) #define Kupatl F77_NAME(kupatl,KUPATL) #define Kuproc F77_NAME(kuproc,KUPROC) #define Kuprof F77_NAME(kuprof,KUPROF) #define Kuproi F77_NAME(kuproi,KUPROI) #define Kuprop F77_NAME(kuprop,KUPROP) #define Kupror F77_NAME(kupror,KUPROR) #define Kupros F77_NAME(kupros,KUPROS) #define Kumess F77_NAME(kumess,KUMESS) #define Kupval F77_NAME(kupval,KUPVAL) #define Kuqcas F77_NAME(kuqcas,KUQCAS) #define Kuqenv F77_NAME(kuqenv,KUQENV) #define Kuqexe F77_NAME(kuqexe,KUQEXE) #define Kuqkey F77_NAME(kuqkey,KUQKEY) #define Kuqsvr F77_NAME(kuqsvr,KUQSVR) #define Kuquit F77_NAME(kuquit,KUQUIT) #define Kuqvar F77_NAME(kuqvar,KUQVAR) #define Kuread F77_NAME(kuread,KUREAD) extern SUBROUTINE Kuread; #define Kusapp F77_NAME(kusapp,KUSAPP) #define Kuser F77_NAME(kuser,KUSER) #define Kuserid F77_NAME(kuserid,KUSERID) #define Kusibr F77_NAME(kusibr,KUSIBR) #define Kusigm F77_NAME(kusigm,KUSIGM) #define Kuspy F77_NAME(kuspy,KUSPY) #define Kustat F77_NAME(kustat,KUSTAT) #define Kustop F77_NAME(kustop,KUSTOP) #define Kuterm F77_NAME(kuterm,KUTERM) #define Kutime F77_NAME(kutime,KUTIME) #define Kutim0 F77_NAME(kutim0,KUTIM0) extern SUBROUTINE Kutim0; #define Kutrue F77_NAME(kutrue,KUTRUE) #define Kuvar F77_NAME(kuvar,KUVAR) #define Kuvcre F77_NAME(kuvcre,KUVCRE) extern SUBROUTINE Kuvcre; #define Kuvdel F77_NAME(kuvdel,KUVDEL) extern SUBROUTINE Kuvdel; #define Kuvect F77_NAME(kuvect,KUVECT) extern SUBROUTINE Kuvect; #define Kuvnam F77_NAME(kuvnam,KUVNAM) #define Kuwhag F77_NAME(kuwhag,KUWHAG) #define Kuwham F77_NAME(kuwham,KUWHAM) #define Kuwhat F77_NAME(kuwhat,KUWHAT) #define Kuwrit F77_NAME(kuwrit,KUWRIT) extern SUBROUTINE Kuwrit; #define Kxcrv2 F77_NAME(kxcrv2,KXCRV2) extern SUBROUTINE Kxcrv2; #define Macdef F77_NAME(macdef,MACDEF) extern SUBROUTINE Macdef; #define Mdmenu F77_NAME(mdmenu,MDMENU) #define Mhi_close F77_NAME(mhi_close,MHI_CLOSE) extern SUBROUTINE Mhi_close; #define Mhi_open F77_NAME(mhi_open,MHI_OPEN) extern SUBROUTINE Mhi_open; #define Mzwipe F77_NAME(mzwipe,MZWIPE) extern SUBROUTINE Mzwipe; #define Traceq F77_NAME(traceq,TRACEQ) extern SUBROUTINE Traceq; #define Xuflow F77_NAME(xuflow,XUFLOW) extern SUBROUTINE Xuflow; #ifdef IBM370 # pragma linkage(ERRRUN,FORTRAN) # pragma linkage(FMEMCPY,FORTRAN) # pragma linkage(GOPARM,FORTRAN) # pragma linkage(ICLRWK,FORTRAN) # pragma linkage(IGINIT,FORTRAN) # pragma linkage(IGMENU,FORTRAN) # pragma linkage(IGRNG,FORTRAN) # pragma linkage(IGSSE,FORTRAN) # pragma linkage(IGSRAP,FORTRAN) # pragma linkage(IGWKTY,FORTRAN) # pragma linkage(KCEXEC,FORTRAN) # pragma linkage(KDIALO,FORTRAN) # pragma linkage(KGETAR,FORTRAN) # pragma linkage(KIBRES,FORTRAN) # pragma linkage(KICLOS,FORTRAN) # pragma linkage(KICOMV,FORTRAN) # pragma linkage(KIERRF,FORTRAN) # pragma linkage(KIINIT,FORTRAN) # pragma linkage(KILUN,FORTRAN) # pragma linkage(KIMTCH,FORTRAN) # pragma linkage(KIPAWC,FORTRAN) # pragma linkage(KIPIAF,FORTRAN) # pragma linkage(KIPRMT,FORTRAN) # pragma linkage(KIRTIM,FORTRAN) # pragma linkage(KISIGM,FORTRAN) # pragma linkage(KIVECT,FORTRAN) # pragma linkage(KMBRSET,FORTRAN) # pragma linkage(KMVSED,FORTRAN) # pragma linkage(KMVSPG,FORTRAN) # pragma linkage(KMVSSH,FORTRAN) # pragma linkage(KSVPAR,FORTRAN) # pragma linkage(KUACH,FORTRAN) # pragma linkage(KUACT,FORTRAN) # pragma linkage(KUALFA,FORTRAN) # pragma linkage(KUAPPL,FORTRAN) # pragma linkage(KUARGS,FORTRAN) # pragma linkage(KUBREK,FORTRAN) # pragma linkage(KUBROF,FORTRAN) # pragma linkage(KUBRON,FORTRAN) # pragma linkage(KUCLOS,FORTRAN) # pragma linkage(KUCMD,FORTRAN) # pragma linkage(KUCMDL,FORTRAN) # pragma linkage(KUCOMV,FORTRAN) # pragma linkage(KUEDIT,FORTRAN) # pragma linkage(KUESVR,FORTRAN) # pragma linkage(KUEUSR,FORTRAN) # pragma linkage(KUEXEC,FORTRAN) # pragma linkage(KUEXEL,FORTRAN) # pragma linkage(KUEXIT,FORTRAN) # pragma linkage(KUFCAS,FORTRAN) # pragma linkage(KUFDEF,FORTRAN) # pragma linkage(KUGETC,FORTRAN) # pragma linkage(KUGETE,FORTRAN) # pragma linkage(KUGETF,FORTRAN) # pragma linkage(KUGETI,FORTRAN) # pragma linkage(KUGETL,FORTRAN) # pragma linkage(KUGETR,FORTRAN) # pragma linkage(KUGETS,FORTRAN) # pragma linkage(KUGRFL,FORTRAN) # pragma linkage(KUGUID,FORTRAN) # pragma linkage(KUHELP,FORTRAN) # pragma linkage(KUHOME,FORTRAN) # pragma linkage(KUIDF1,FORTRAN) # pragma linkage(KUIDF2,FORTRAN) # pragma linkage(KUIDFM,FORTRAN) # pragma linkage(KUINIM,FORTRAN) # pragma linkage(KUINIT,FORTRAN) # pragma linkage(KUINPS,FORTRAN) # pragma linkage(KUINQF,FORTRAN) # pragma linkage(KULUN,FORTRAN) # pragma linkage(KUMLOC,FORTRAN) # pragma linkage(KUMOUT,FORTRAN) # pragma linkage(KUNDPV,FORTRAN) # pragma linkage(KUNPAR,FORTRAN) # pragma linkage(KUNWG,FORTRAN) # pragma linkage(KUOPEN,FORTRAN) # pragma linkage(KUPAD,FORTRAN) # pragma linkage(KUPAR,FORTRAN) # pragma linkage(KUPATH,FORTRAN) # pragma linkage(KUPATL,FORTRAN) # pragma linkage(KUPROC,FORTRAN) # pragma linkage(KUPROF,FORTRAN) # pragma linkage(KUPROI,FORTRAN) # pragma linkage(KUPROP,FORTRAN) # pragma linkage(KUPROR,FORTRAN) # pragma linkage(KUPROS,FORTRAN) # pragma linkage(KUPVAL,FORTRAN) # pragma linkage(KUQCAS,FORTRAN) # pragma linkage(KUQENV,FORTRAN) # pragma linkage(KUQEXE,FORTRAN) # pragma linkage(KUQKEY,FORTRAN) # pragma linkage(KUQSVR,FORTRAN) # pragma linkage(KUQUIT,FORTRAN) # pragma linkage(KUQVAR,FORTRAN) # pragma linkage(KUREAD,FORTRAN) # pragma linkage(KUSAPP,FORTRAN) # pragma linkage(KUSIBR,FORTRAN) # pragma linkage(KUSIGM,FORTRAN) # pragma linkage(KUSPY,FORTRAN) # pragma linkage(KUSTAT,FORTRAN) # pragma linkage(KUSTOP,FORTRAN) # pragma linkage(KUTERM,FORTRAN) # pragma linkage(KUTIME,FORTRAN) # pragma linkage(KUTIM0,FORTRAN) # pragma linkage(KUTRUE,FORTRAN) # pragma linkage(KUSER,FORTRAN) # pragma linkage(KUVAR,FORTRAN) # pragma linkage(KUVCRE,FORTRAN) # pragma linkage(KUVDEL,FORTRAN) # pragma linkage(KUVECT,FORTRAN) # pragma linkage(KUVNAM,FORTRAN) # pragma linkage(KUWHAG,FORTRAN) # pragma linkage(KUWHAM,FORTRAN) # pragma linkage(KUWHAT,FORTRAN) # pragma linkage(KUWRIT,FORTRAN) # pragma linkage(KXCRV2,FORTRAN) # pragma linkage(MACDEF,FORTRAN) # pragma linkage(MDMENU,FORTRAN) # pragma linkage(MHI_CLOSE,FORTRAN) # pragma linkage(MHI_OPEN,FORTRAN) # pragma linkage(MZWIPE,FORTRAN) # pragma linkage(TRACEQ,FORTRAN) # pragma linkage(XUFLOW,FORTRAN) #endif #define MAXCMD 512 /* max length of a command line */ #define MAXEDT 32 /* max length of names in edit server */ #define MAXLEV 10 /* max levels of command name path */ #define MAXSVR 20 /* max number of edit server processes */ /* * The PAWC common is referenced through a pointer to allow the use of * dynamic common blocks on IBM systems. */ #define Pawc kc_pawc EXTERN struct COMMON_PAWC { INTEGER NWPAR; INTEGER IXPAWC; INTEGER IHBOOK; INTEGER IXHIGZ; INTEGER IXKUIP; INTEGER IFENCE[5]; INTEGER LQ[8]; INTEGER DATA[999]; } *Pawc; #define IQ(n) Pawc->DATA[n-1] #define Q(n) (((REAL*)(Pawc->DATA))[n-1]) +KEEP,KCOM_H /* kcom.h: Fortran COMMON blocks */ #define Kcparc F77_BLOCK(kcparc,KCPARC) EXTERN struct { char PARLST[512]; /* interface block for KUSER */ char CLIST[80]; char NOALIN[512]; char COMAND[80]; char CHLAST[512]; char NONPOS[512]; } F77_COMMON(Kcparc); #define Kcutil F77_BLOCK(kcutil,KCUTIL) EXTERN struct { INTEGER NCMD; INTEGER IWD; INTEGER LUNFIL; INTEGER LPRMPT; LOGICAL TIMING; LOGICAL TRACE; INTEGER CALMOD; INTEGER NVADD; INTEGER IREPET; INTEGER IREFAC; INTEGER IBRAK; LOGICAL TIMALL; INTEGER LENTER; LOGICAL UNIQUE; INTEGER LENMUL; LOGICAL MULTFL; LOGICAL HISTOK; LOGICAL NOHIST; INTEGER LENMUM; LOGICAL FILCAS; LOGICAL MEXEFL; } F77_COMMON(Kcutil); #define Kcvect F77_BLOCK(kcvect,KCVECT) EXTERN struct { INTEGER NUMVEC; /* number of vectors stored */ INTEGER TOTPAV; INTEGER GETPAV; LOGICAL TVECFL; } F77_COMMON(Kcvect); #define Kcwork F77_BLOCK(kcwork,KCWORK) EXTERN struct { REAL VECTOR[100]; /* vector '?' */ } F77_COMMON(Kcwork); #define Quest F77_BLOCK(quest,QUEST) EXTERN struct { INTEGER DATA[100]; } F77_COMMON(Quest); #define IQUEST(n) Quest.DATA[n-1] #define Sikuip F77_BLOCK(sikuip,SIKUIP) EXTERN struct { char CHSIGM[80]; /* command string passed to SIGMA */ } F77_COMMON(Sikuip); +KEEP,KSIG_H /* ksig.h: signal and break handling */ /* * Available signal handling package * * #define SIGNAL_POSIX ==> sigaction() for Unix * #define SIGNAL_BSD ==> sigvec() for VMS and NeXT * #define SIGNAL_V7 ==> signal() */ #if !defined(SIGNAL_BSD) && !defined(SIGNAL_V7) # define SIGNAL_POSIX #else # define sigjmp_buf jmp_buf # define sigsetjmp(buf,save) setjmp(buf) # define siglongjmp(buf,val) longjmp(buf,val) # ifdef vms # define sv_flags sv_onstack # endif #endif EXTERN struct { int trap_enabled; /* flag if exceptions should be trapped */ int intr_enabled; /* flag if ^C delivery is allowed */ int intr_pending; /* flag if ^C happened while disabled */ int intr_count; /* count number of consecutive ^C interrupts */ int traceback; /* print traceback on signal */ char *error_msg; /* messages is handler cannot do print */ int soft_intr; /* flag to stop at a convenient point */ int jump_set; /* flag if stack has been setup */ sigjmp_buf stack; int sockfd; /* socket descriptor and routine to */ void (*piaf_sync)(); /* resynchronize Piaf communication */ } kc_break; +DECK,hkuip_95a,if=95a,96a,97a,98,99,2000,00. +KEEP,KHAIX370 #ifndef AIX370 # define AIX370 #endif +KEEP,KHAPOFTN #ifndef APOLLO_FTN # define APOLLO_FTN #endif +KEEP,KHIBMVM #ifndef IBMVM # define IBMVM #endif +KEEP,KHIBMMVS #ifndef IBMMVS # define IBMMVS #endif +KEEP,KHNEWLIB #ifndef NEWLIB # define NEWLIB #endif +KEEP,KSYS_H /* ksys.h: system dependent defines */ /* update version if structures have changed */ #define KUIP_VERSION 921023 /* identify system if not possible from preprocessor defines */ +SEQ,KHAIX370,IF=AIX370 +SEQ,KHAPOFTN,IF=APOFTN +SEQ,KHIBMVM ,IF=IBMVM +SEQ,KHIBMMVS,IF=IBMMVS +SEQ,KHNEWLIB,IF=NEWLIB #ifdef AIX370 # define MACHINE_NAME "IBMAIX" # define UNIX # define F77_EXTERN_INDIRECT #endif #if defined(apollo) || defined(__apollo) # define MACHINE_NAME "APOLLO" # define APOLLO # define UNIX # include # include # include # include # include # include # ifdef APOLLO_FTN /* using /com/ftn instead of /bin/f77 */ # define F77_CHAR_LEN_IND # define F77_CHAR_LEN_TYPE short # define F77_EXTERN_LOWERCASE # endif # define F77_EXTERN_INDIRECT # define F77_COMMON(name) name __attribute((__section(name))) # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define NO_DIRENT_H # define TERMIO_BSD /* for getline we must compile under bsd4.3 */ #endif #if defined(__convexc__) # define CONVEX # define MACHINE_NAME "CONVEX" # define UNIX # define F77_BLOCK(name,NAME) _##name##_ # define F77_ARG_CONSTANT # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define FATAL_SIGFPE # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ # define USE_EDIT_SERVER #endif #ifdef CRAY # define MACHINE_NAME "CRAY" # define UNIX # include # define F77_EXTERN_UPPERCASE # ifndef EXTERN # define EXTERN /* essential for accessing COMMON blocks */ # endif # define HAVE_STRCASECMP # define NO_EDIT_SERVER #endif #if defined(__hpux) # define MACHINE_NAME "HPUX" # define HPUX # define UNIX # ifndef _HPUX_SOURCE # define _HPUX_SOURCE # endif # define FATAL_SIGFPE /* needs f77 +T and ON REAL UNDERFLOW IGNORE */ # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_STRRSTR # define HAVE_SELECT # define SELECT_CAST(fds) (int*)fds #endif #ifdef _IBMR2 # define IBMRT # define MACHINE_NAME "IBMRT" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # include # define HAVE_SELECT # define BROKEN_F77_IO #endif #ifdef IBMVM # define ARG_STYLE_CMS # define MACHINE_NAME "IBM" # define OS_NAME "VM" # ifndef IBM370 # define IBM370 # endif # define KmTimeStamp TimeStamp typedef char TimeStamp[24]; extern int get_stamp(char*,TimeStamp*); # define same_stamp(stamp1,stamp2) (strcmp(*(stamp1),*(stamp2)) == 0) #endif #ifdef IBMMVS # define MACHINE_NAME "IBMMVS" # define OS_NAME "MVS" # ifndef IBM370 # define IBM370 # endif #endif #ifdef IBM370 # define F77_ARG_CONSTANT # define F77_CHAR_LEN_IND /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_EXTERN_INDIRECT # define F77_EXTERN_UPPERCASE # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_V7 # define ALLOC_MIN_BYTES 128 # define STUPID_MALLOC #endif #ifdef linux # define LINUX # define MACHINE_NAME "LINUX" # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT #endif #ifdef MSDOS # define MACHINE_NAME "IBMPC" # define OS_NAME "MSDOS" # define UNIX # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define SIGNAL_V7 # define SLASHES "\\/" # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ #endif #ifdef WIN32 # define WINNT # ifdef _ALPHA_ # define MACHINE_NAME "ALPHA" # else # define MACHINE_NAME "IBMPC" # endif # define OS_NAME "WINNT" # define UNIX # define MSDOS # include # include # include # include # define text_mode__() # define NO_EDIT_SERVER # define NO_SOCKET_H # define NO_SYS_TIME_H # define NO_UNISTD_H # define SIGNAL_V7 # define SLASHES "\\" #endif #ifdef NeXT # define MACHINE_NAME "NEXT" # define UNIX # define getcwd(path,maxlen) getwd(path) # define F77_BLOCK(lc,uc) lc # define F77_EXTERN_INDIRECT /* each parameter has a length argument ! */ # define F77_XXXX_ARG_LEN(x) F77_CHAR_ARG_LEN(x) # define F77_XXXX_USE_LEN(x) ,286716 /* don't know if value matters */ # define HAVE_MEMMOVE # define HAVE_VFORK # define MATCH_RE_COMP /* use re_comp/re_exec */ # define NO_DIRENT_H # define NO_UNISTD_H # define SIGNAL_BSD # define TERMIO_BSD # define GETPGRP_BSD /* BSD getpgrp(pid) vs. POSIX getpgrp(void) */ #endif #ifdef __osf__ # define UNIX # ifdef __alpha # define ALPHA # define MACHINE_NAME "ALPHA" # endif # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT # define BROKEN_F77_IO #endif #if defined(__sgi) # define MACHINE_NAME "SGI" # define SGI # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_SELECT #endif #if defined(sun) || defined(__sun) # define SUN # define UNIX # if defined(Solaris2) || defined(__svr4__) # define MACHINE_NAME "SOLARIS" # define SOLARIS # define HAVE_MEMMOVE # define HAVE_SELECT # define HAVE_STRCASECMP # define HAVE_VFORK # else # define MACHINE_NAME "SUN" # define HAVE_SELECT # define HAVE_STRCASECMP # define HAVE_VFORK # include # define MATCH_RE_COMP /* use re_comp/re_exec */ # define GETPGRP_BSD /* BSD getpgrp(pid) vs. POSIX getpgrp(void) */ # endif #endif #if defined(__ultrix) # define MACHINE_NAME "DECS" # define ULTRIX # define UNIX # define HAVE_MEMMOVE # define HAVE_STRCASECMP # define HAVE_VFORK # define NEED_STRDUP # define TERMIO_BSD # define GETPGRP_BSD /* BSD getpgrp(pid) vs. POSIX getpgrp(void) */ # define BROKEN_F77_IO #endif #ifdef vms # define OS_NAME "VMS" # ifdef __ALPHA # define ALPHA # define MACHINE_NAME "ALPHA" # else # define MACHINE_NAME "VAX" # define ConCat(con,cat) con/**/cat # endif # include # include # include /* lib$... prototypes */ # include # include # include # include # include # include # include # include # include /* sys$... prototypes */ # include # include # include # include # include # ifndef R_OK /* no access() modes in unixio.h on VAX/VMS */ # define F_OK 0 # define X_OK 1 # define W_OK 2 # define R_OK 4 # endif # define ARG_STYLE_VMS # define F77_EXTERN_LOWERCASE # define HAVE_MEMMOVE # define HAVE_STAT_H # define HAVE_VFORK /* actually have only vfork */ # define NO_FCNTL_H # define NO_UNISTD_H # define SIGNAL_BSD # define sigmask(sig) (1L << (sig-1)) /* should be in signal.h */ # define USE_EDIT_SERVER /* only for TPU/DISPLAY=MOTIF */ # if defined(VAXC) && !defined(__DECC) # define STUPID_MALLOC # endif # define fix_descriptor(dsc,str,n) \ do { \ dsc.dsc$b_dtype = DSC$K_DTYPE_T; \ dsc.dsc$b_class = DSC$K_CLASS_S; \ dsc.dsc$a_pointer = str; \ dsc.dsc$w_length = n; \ } while( 0 ) # define var_descriptor(dsc,str) \ do { \ dsc.dsc$b_dtype = DSC$K_DTYPE_T; \ dsc.dsc$b_class = DSC$K_CLASS_S; \ dsc.dsc$a_pointer = str; \ dsc.dsc$w_length = strlen( dsc.dsc$a_pointer ); \ } while( 0 ) #endif /* vms */ #include #include #include #ifndef NO_FCNTL_H #include #endif #include /* contains strtod() and strtol() on some systems */ #include #include #include #ifdef DBMALLOC #include "dbmalloc.h" /* debug malloc */ extern char* getenv(const char*); extern double strtod(const char*, char**); #else #include #endif #include #ifndef NO_UNISTD_H #include #endif #ifndef HAVE_VFORK # define vfork fork #endif #ifdef UNIX /* also defined for MSDOS and Windows/NT*/ # ifndef OS_NAME # define OS_NAME "UNIX" # endif # include # include # ifndef NO_SYS_TIME_H # include /* struct timeval */ # endif # ifndef MSDOS # include # ifdef TERMIO_BSD # define TERMIO_MAP_NL /* need to map NL to NL-CR on output */ # define HAVE_SELECT # endif # if !defined(TERMIO_BSD) && !defined(TERMIO_SYSV) # define TERMIO_POSIX # endif # if defined(HAVE_SELECT) && !defined(SELECT_CAST) # define SELECT_CAST(fds) fds # endif # include # ifndef NO_DIRENT_H /* POSIX opendir() */ # include # else /* BSD opendir() */ # include /* plus */ # define dirent direct /* struct dirent... */ # ifndef S_IRUSR # define S_IRUSR (S_IREAD) /* read permission, owner */ # define S_IWUSR (S_IWRITE) /* write permission, owner */ # define S_IXUSR (S_IEXEC) /* execute/search permission, owner */ # endif # endif # endif # define HAVE_STAT_H # ifndef NO_EDIT_SERVER # define USE_EDIT_SERVER # ifndef F_LOCK /* BSD file locking */ # include # define lockf(fd,op,offs) flock(fd,op) # define F_LOCK LOCK_EX # define F_ULOCK LOCK_UN # endif # endif # ifndef SLASHES # define SLASHES "/" # endif #endif #ifdef SUN # ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 1000000 /* missing in time.h */ # define difftime(t1,t0) ((double)(t1-t0)) # define raise(sig) kill(getpid(),sig) # endif #endif #ifndef CLOCKS_PER_SEC # define CLOCKS_PER_SEC 100 /* missing in VAX/VMS time.h */ #endif #ifdef HAVE_STAT_H # define KmTimeStamp struct stat # define get_stamp(path,stamp) stat(path,stamp) # define same_stamp(stamp1,stamp2) ((stamp2)->st_mtime == (stamp1)->st_mtime) #endif #ifndef KmTimeStamp # define KmTimeStamp int # define get_stamp(path,stamp) (*(stamp) = checksum(path)) # define same_stamp(stamp1,stamp2) (*(stamp1) == *(stamp2)) #endif #ifdef MATCH_RE_COMP extern char *re_comp(); extern int re_exec(); #else extern char *regcmp(); extern char *regex(); #endif /* command line arguments recognized by KUARGS */ #if !defined(ARG_STYLE_CMS) && !defined(ARG_STYLE_VMS) # define ARG_STYLE_UNIX #endif #ifndef MACHINE_NAME # define MACHINE_NAME "UNKNOWN" /* value returned by $MACHINE */ #endif #ifndef OS_NAME # define OS_NAME "UNKNOWN" /* value returned by $OS */ #endif /* #define EXTERN must be in one routine to allocate space for globals */ #ifndef EXTERN # define EXTERN extern #endif /* * Preprocessor syntax for token concatenation */ #ifndef ConCat # define ConCat(con,cat) con##cat #endif /* * Prototyping for C functions */ #define C_PROTO_0(name) \ name(void) #define C_PROTO_1(name,arg1) \ name(arg1) #define C_PROTO_2(name,arg1,arg2) \ name(arg1,arg2) #define C_PROTO_3(name,arg1,arg2,arg3) \ name(arg1,arg2,arg3) #define C_PROTO_4(name,arg1,arg2,arg3,arg4) \ name(arg1,arg2,arg3,arg4) #define C_PROTO_5(name,arg1,arg2,arg3,arg4,arg5) \ name(arg1,arg2,arg3,arg4,arg5) #define C_PROTO_6(name,arg1,arg2,arg3,arg4,arg5,arg6) \ name(arg1,arg2,arg3,arg4,arg5,arg6) #define C_PROTO_7(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7) #define C_PROTO_8(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8) #define C_PROTO_9(name,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) \ name(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9) #define C_PROTO_13(name,a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) \ name(a1,a2,a3,a4,a5,a6,a7,a8,a9,b0,b1,b2,b3) #define C_DECL_1(name,t1,p1) \ name(t1 p1) #define C_DECL_2(name,t1,p1,t2,p2) \ name(t1 p1,t2 p2) #define C_DECL_3(name,t1,p1,t2,p2,t3,p3) \ name(t1 p1,t2 p2,t3 p3) #define C_DECL_4(name,t1,p1,t2,p2,t3,p3,t4,p4) \ name(t1 p1,t2 p2,t3 p3,t4 p4) #define C_DECL_5(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5) #define C_DECL_6(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6) #define C_DECL_7(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7) #define C_DECL_8(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8) #define C_DECL_9(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,t9,p9)\ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,t9 p9) #define C_DECL_13(name,t1,p1,t2,p2,t3,p3,t4,p4,t5,p5,t6,p6,t7,p7,t8,p8,\ t9,p9,t10,p10,t11,p11,t12,p12,t13,p13) \ name(t1 p1,t2 p2,t3 p3,t4 p4,t5 p5,t6 p6,t7 p7,t8 p8,\ t9 p9,t10 p10,t11 p11,t12 p12,t13 p13) typedef int IntFunc(); typedef char* CharFunc(); typedef char** pCharFunc(); +KEEP,KSTRING_H. #include #ifdef __cplusplus extern "C" { #endif /* * quasi-standard functions missing in some C-libraries */ extern void* memmove( void* dst, const void* src, size_t n ); #if !defined(__convexc__) extern int strcasecmp( const char* str1, const char* str2 ); extern int strncasecmp( const char* str1, const char* str2, size_t n ); #endif extern char* strrstr( const char* str1, const char* str2 ); #define strdup Strdup /* prototype without const */ extern char* strdup( const char* str ); /* * convenience functions from kkern.c */ extern char* str0dup( const char* str ); extern char* str2dup( const char* str1, const char* str2 ); extern char* str3dup( const char* str1, const char* str2, const char* str3 ); extern char* str4dup( const char* str1, const char* str2, const char* str3, const char* str4 ); extern char* str5dup( const char* str1, const char* str2, const char* str3, const char* str4, const char* str5 ); extern char* strndup( const char* buf, size_t n ); extern char* stridup( int i ); extern char* mstrcat( char* ptr, const char* str ); extern char* mstr2cat( char* ptr, const char* str1, const char* str2 ); extern char* mstr3cat( char* ptr, const char* str1, const char* str2, const char* str3); extern char* mstr4cat( char* ptr, const char* str1, const char* str2, const char* str3, const char* str4 ); extern char* mstrncat( char* ptr, const char* buf, size_t n ); extern char* mstrccat( char* ptr, char c, size_t n ); extern char* mstricat( char* ptr, int i ); extern char* strrpbrk( const char* str1, const char* str2 ); extern char* strqtok( char* str ); extern char* strlower( char* str ); extern char* strupper( char* str ); extern char* strtrim( char* str ); extern char* struntab( char* str ); extern char* strfromd( double d, size_t prec ); extern char* strfromi( int i, size_t prec ); extern char* strblk0( char* str ); extern int shsystem( const char* shell, const char* cmd ); extern int checksum( const char* path ); extern char* fexpand( const char* fname, const char* ftype ); extern char* fsearch( const char* fname, const char* ftype, const char* path ); extern char* fsymlink( const char* path ); extern char* fstrdup( const char* buf, size_t len ); extern char* fstr0dup( const char* buf, size_t len ); extern char* fstrtrim( const char* buf, size_t len ); extern char* fstr0trim( const char* buf, size_t len ); extern size_t fstrlen( const char* buf, size_t len ); extern size_t fstrset( char* buf, size_t len, const char* str ); extern double fstrtod( const char* str, char** tail ); extern int fstrtoi( const char* str, char** tail ); extern char* fstrvec( char** pstr, size_t n, size_t* len ); extern size_t mstrlen( char** pstr, size_t n ); #ifdef __cplusplus } #endif +KEEP,KUSER_H. #define KUMAC_UNWIND -30041961 /* error status to quit macro execution */ #ifdef __cplusplus extern "C" { #endif /* * C-interface functions */ extern char* k_getar(void); extern void k_setar( size_t, char** ); extern char* k_userid(void); extern void ku_alfa(void); extern char* ku_appl( int* luno, int* inmacro ); extern int ku_bool( const char* expr ); extern int ku_close( int luno ); extern void ku_cmdl( const char* template ); extern int ku_edit( const char* path, int use_server ); extern char* ku_eval( const char* expr ); extern int ku_exec( const char* cmd ); extern int ku_exel( const char* cmd ); extern char* ku_expr( const char* expr ); extern char* ku_getc(void); extern char* ku_gete(void); extern char* ku_getf(void); extern int ku_geti(void); extern char* ku_getl(void); extern double ku_getr(void); extern char* ku_gets(void); extern char* ku_fcase( char* path ); extern char* ku_home( const char* fname, const char* ftype ); extern char* ku_inps( const char* prompt ); extern int ku_inqf( const char* path ); extern int ku_intr( int enable ); extern void ku_last( const char* cmd ); extern int ku_match( const char* string, const char* pattern, int ignore_case ); extern int ku_math( const char* expr, double* result ); extern int ku_more( const char* question, const char* line ); extern int ku_npar(void); extern int ku_open( int luno, const char* path, const char* mode ); extern void ku_pad( const char* path, int delete ); extern char* ku_path(void); extern void ku_piaf( int socket, void(*sync)() ); extern char* ku_proc( const char* prompt, const char* dfault ); extern char* ku_prof( const char* prompt, const char* dfault ); extern int ku_proi( const char* prompt, int dfault ); extern char* ku_prop( const char* prompt ); extern double ku_pror( const char* prompt, double dfault ); extern char* ku_pros( const char* prompt, const char* dfault ); extern char** ku_qenv(void); extern char* ku_qexe( const char* fname ); extern int ku_qkey(void); extern int ku_qmac( const char* mname ); extern int ku_read( int luno, char* buf, size_t len ); extern int ku_sapp( const char* path, const char* exit ); extern void ku_shut(void); extern void ku_sibr(void); extern void ku_spy( const char* option ); extern int ku_stop( int set ); extern void ku_time( time_t, clock_t ); extern void ku_trap( int enable, int traceback ); extern int ku_vqaddr( const char* vname ); extern int ku_vtype( const char* vname ); extern int ku_vvalue( const char* vname, double* value ); extern void ku_whag(void); extern void ku_what( void(*styleG)() ); extern void ku_write( int, const char* line ); extern int km_icon( const char*, const char* ); #ifdef __cplusplus } #endif +KEEP,KPROTO_H extern char* clean_word( char* ); extern char* format_prompt( const char* ); extern char* getline( const char* ); extern void gl_config( const char*, int ); extern void gl_histadd( const char* ); extern void gl_setwidth( int ); extern char* input_line( const char*, char ); extern void leave_kuip(void); extern int len_alias( const char*, int ); extern int len_sysfun( const char* ); extern int len_vector( const char* ); extern char* quote_string( char*, int ); extern void reset_break(void); extern char* split_at_semicolon( char* ); extern void k_parse_args( const char*, char**, int* ); #ifndef vms extern void signal_handler( int ); #else extern int signal_handler( const void*, const void* ); extern int control_C_ast( int ); #endif +KEEP,KUIP_H +SEQ,KSYS_H +SEQ,KSTRING_H +SEQ,KUSER_H +SEQ,KPROTO_H +KEEP,KFOR_H /* kfor.h: Fortran-C interface */ /* * Fortran data types */ typedef int INTEGER; typedef int LOGICAL; typedef float REAL; typedef double DBLPREC; typedef struct { REAL re; REAL im; } COMPLEX; typedef INTEGER INT_FUNCTION(); typedef INT_FUNCTION *INT_FUNCPTR; typedef void (*SUBRPTR)(); typedef void SUBROUTINE(); #ifdef IBM370 #pragma linkage(SUBROUTINE,FORTRAN) #pragma linkage(INT_FUNCTION,FORTRAN) #pragma map(__CTOF,"@@CTOF") extern INTEGER __CTOF( INT_FUNCPTR, ... ); #endif typedef union _EQUIV_INT_REAL { INTEGER i; LOGICAL l; REAL r; } EQUIV_INT_REAL; /* * Mapping of C-routine name for Fortran CALL SUB * * #define F77_EXTERN_LOWERCASE ==> void sub() * #define F77_EXTERN_UPPERCASE ==> void SUB() * otherwise ==> void sub_() */ #ifdef F77_EXTERN_UPPERCASE # define F77_NAME(name,NAME) NAME #else # ifdef F77_EXTERN_LOWERCASE # define F77_NAME(name,NAME) name # else # define F77_NAME(name,NAME) ConCat(name,_) # endif #endif #ifndef F77_BLOCK # define F77_BLOCK(name,NAME) F77_NAME(name,NAME) #endif #ifndef F77_COMMON # define F77_COMMON(name) name #endif /* * Routine address in CALL SUB(FUN) ; EXTERNAL FUN * * #define F77_EXTERN_INDIRECT ==> void (**fun)(); * otherwise ==> void (*fun)(); */ #ifdef F77_EXTERN_INDIRECT # define F77_EXTERN_ARG(e) ConCat(e,_ptr) # define F77_EXTERN_DCL(e) SUBROUTINE **ConCat(e,_ptr); # define F77_EXTERN_DEF(e) SUBROUTINE *e = *ConCat(e,_ptr); #else # define F77_EXTERN_ARG(e) e # define F77_EXTERN_DCL(e) SUBROUTINE *e; # define F77_EXTERN_DEF(e) #endif #define F77_EXTERN2ARG(e1,e2) F77_EXTERN_ARG(e1),F77_EXTERN_ARG(e2) #define F77_EXTERN2DCL(e1,e2) F77_EXTERN_DCL(e1) F77_EXTERN_DCL(e2) #define F77_EXTERN2DEF(e1,e2) F77_EXTERN_DEF(e1) F77_EXTERN_DEF(e2) #define F77_EXTERN3ARG(e1,e2,e3) F77_EXTERN_ARG(e1),F77_EXTERN2ARG(e2,e3) #define F77_EXTERN3DCL(e1,e2,e3) F77_EXTERN_DCL(e1) F77_EXTERN2DCL(e2,e3) #define F77_EXTERN3DEF(e1,e2,e3) F77_EXTERN_DEF(e1) F77_EXTERN2DEF(e2,e3) #define F77_EXTERN4ARG(e1,e2,e3,e4) F77_EXTERN_ARG(e1),F77_EXTERN3ARG(e2,e3,e4) #define F77_EXTERN4DCL(e1,e2,e3,e4) F77_EXTERN_DCL(e1) F77_EXTERN3DCL(e2,e3,e4) #define F77_EXTERN4DEF(e1,e2,e3,e4) F77_EXTERN_DEF(e1) F77_EXTERN3DEF(e2,e3,e4) #ifdef F77_ARG_CONSTANT /* * If the Fortran compiler (e.g. VSFORTRAN and Convex fc without -sa option) * uses constant argument blocks we have to make a private copy in case the * routine uses the arguments as local variables. */ # define F77_XXXX_ARG_PTR(t,x) ConCat(x,_ptr) # define F77_XXXX_ARG_DCL(t,x) t *ConCat(x,_ptr); # define F77_XXXX_ARG_DEF(t,x) t *x = ConCat(x,_ptr); #else # define F77_XXXX_ARG_PTR(t,x) x # define F77_XXXX_ARG_DCL(t,x) t *x; # define F77_XXXX_ARG_DEF(t,x) #endif #define F77_REAL_ARG_PTR(r) F77_XXXX_ARG_PTR(REAL,r) #define F77_REAL_ARG_DCL(r) F77_XXXX_ARG_DCL(REAL,r) #define F77_REAL_ARG_DEF(r) F77_XXXX_ARG_DEF(REAL,r) #define F77_INTG_ARG_PTR(i) F77_XXXX_ARG_PTR(INTEGER,i) #define F77_INTG_ARG_DCL(i) F77_XXXX_ARG_DCL(INTEGER,i) #define F77_INTG_ARG_DEF(i) F77_XXXX_ARG_DEF(INTEGER,i) #define F77_INTG_ARG2PTR(i1,i2) F77_INTG_ARG_PTR(i1),F77_INTG_ARG_PTR(i2) #define F77_INTG_ARG2DCL(i1,i2) F77_INTG_ARG_DCL(i1) F77_INTG_ARG_DCL(i2) #define F77_INTG_ARG2DEF(i1,i2) F77_INTG_ARG_DEF(i1) F77_INTG_ARG_DEF(i2) #define F77_INTG_ARG3PTR(i1,i2,i3) F77_INTG_ARG_PTR(i1),F77_INTG_ARG2PTR(i2,i3) #define F77_INTG_ARG3DCL(i1,i2,i3) F77_INTG_ARG_DCL(i1) F77_INTG_ARG2DCL(i2,i3) #define F77_INTG_ARG3DEF(i1,i2,i3) F77_INTG_ARG_DEF(i1) F77_INTG_ARG2DEF(i2,i3) #define F77_INTG_ARG4PTR(i1,i2,i3,i4) F77_INTG_ARG_PTR(i1), \ F77_INTG_ARG3PTR(i2,i3,i4) #define F77_INTG_ARG4DCL(i1,i2,i3,i4) F77_INTG_ARG_DCL(i1) \ F77_INTG_ARG3DCL(i2,i3,i4) #define F77_INTG_ARG4DEF(i1,i2,i3,i4) F77_INTG_ARG_DEF(i1) \ F77_INTG_ARG3DEF(i2,i3,i4) /* * Access to Fortran CHARACTER arguments */ #ifdef vms /* VMS string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) struct dsc$descriptor_s *ConCat(s,_ptr); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr)->dsc$a_pointer; \ int ConCat(len_,s) = ConCat(s,_ptr)->dsc$w_length; # define F77_CHAR_DEF_DSC(s,p,l) struct dsc$descriptor_s ConCat(s,_dsc); # define F77_CHAR_ASS_DSC(s,p,l) ConCat(s,_dsc).dsc$w_length = l; \ ConCat(s,_dsc).dsc$b_dtype = DSC$K_DTYPE_T;\ ConCat(s,_dsc).dsc$b_class = DSC$K_CLASS_S;\ ConCat(s,_dsc).dsc$a_pointer = (char*)p; # define F77_CHAR_USE_PTR(s,p,l) &ConCat(s,_dsc) # define F77_CHAR_USE_LEN(s,p,l) #else #ifdef CRAY /* Cray string descriptors */ # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) # define F77_CHAR_ARG_DCL(s) _fcd ConCat(s,_ptr); # define F77_CHAR_ARG_DEF(s) char *s = _fcdtocp(ConCat(s,_ptr)); \ int ConCat(len_,s) = _fcdlen(ConCat(s,_ptr)); # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) _cptofcd(p,l) # define F77_CHAR_USE_LEN(s,p,l) #else /* length passed as additional argument */ # ifdef F77_CHAR_LEN_IND /* length passed by reference */ # define F77_CHAR_LEN_STAR(len) *len # else # define F77_CHAR_LEN_STAR(len) len # endif # ifndef F77_CHAR_LEN_TYPE # define F77_CHAR_LEN_TYPE int # endif # ifdef F77_ARG_CONSTANT # define F77_CHAR_ARG_PTR(s) ConCat(s,_ptr) # define F77_CHAR_ARG_LEN(s) , ConCat(s,_len) # define F77_CHAR_ARG_DCL(s) char *ConCat(s,_ptr); \ F77_CHAR_LEN_TYPE F77_CHAR_LEN_STAR(ConCat(s,_len)); # define F77_CHAR_ARG_DEF(s) char *s = ConCat(s,_ptr); \ int ConCat(len_,s) = F77_CHAR_LEN_STAR(ConCat(s,_len)); # else # ifdef F77_CHAR_LEN_IND # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(s,_len) # define F77_CHAR_ARG_DCL(s) char *s; \ F77_CHAR_LEN_TYPE F77_CHAR_LEN_STAR(ConCat(s,_len)); # define F77_CHAR_ARG_DEF(s) \ int ConCat(len_,s) = F77_CHAR_LEN_STAR(ConCat(s,_len)); # else # define F77_CHAR_ARG_PTR(s) s # define F77_CHAR_ARG_LEN(s) , ConCat(len_,s) # define F77_CHAR_ARG_DCL(s) char *s; int ConCat(len_,s); # define F77_CHAR_ARG_DEF(s) # endif # endif # if defined(F77_CHAR_LEN_IND) # define F77_CHAR_DEF_DSC(s,p,l) F77_CHAR_LEN_TYPE ConCat(s,_dsc) = l; # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , &ConCat(s,_dsc) # else # define F77_CHAR_DEF_DSC(s,p,l) # define F77_CHAR_ASS_DSC(s,p,l) # define F77_CHAR_USE_PTR(s,p,l) p # define F77_CHAR_USE_LEN(s,p,l) , l # endif #endif #endif #ifndef F77_XXXX_ARG_LEN /* length argument of non-CHARACTER arguments */ # define F77_XXXX_ARG_LEN(x) /* nil */ # define F77_XXXX_USE_LEN(x) /* nil */ #endif #define F77_CHAR_ARG2PTR(c1,c2) \ F77_CHAR_ARG_PTR(c1),F77_CHAR_ARG_PTR(c2) #define F77_CHAR_ARG2LEN(c1,c2) \ F77_CHAR_ARG_LEN(c1) F77_CHAR_ARG_LEN(c2) #define F77_XXXX_ARG2LEN(c1,c2) \ F77_XXXX_ARG_LEN(c1) F77_XXXX_ARG_LEN(c2) #define F77_CHAR_ARG2DCL(c1,c2) \ F77_CHAR_ARG_DCL(c1) F77_CHAR_ARG_DCL(c2) #define F77_CHAR_ARG2DEF(c1,c2) \ F77_CHAR_ARG_DEF(c1) F77_CHAR_ARG_DEF(c2) #define F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG2PTR(c1,c2),F77_CHAR_ARG_PTR(c3) #define F77_CHAR_ARG3LEN(c1,c2,c3) \ F77_CHAR_ARG2LEN(c1,c2) F77_CHAR_ARG_LEN(c3) #define F77_XXXX_ARG3LEN(c1,c2,c3) \ F77_XXXX_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(c3) #define F77_CHAR_ARG3DCL(c1,c2,c3) \ F77_CHAR_ARG2DCL(c1,c2) F77_CHAR_ARG_DCL(c3) #define F77_CHAR_ARG3DEF(c1,c2,c3) \ F77_CHAR_ARG2DEF(c1,c2) F77_CHAR_ARG_DEF(c3) #define F77_CHAR_ARG4PTR(c1,c2,c3,c4) \ F77_CHAR_ARG3PTR(c1,c2,c3),F77_CHAR_ARG_PTR(c4) #define F77_CHAR_ARG4LEN(c1,c2,c3,c4) \ F77_CHAR_ARG3LEN(c1,c2,c3) F77_CHAR_ARG_LEN(c4) #define F77_XXXX_ARG4LEN(c1,c2,c3,c4) \ F77_XXXX_ARG3LEN(c1,c2,c3) F77_XXXX_ARG_LEN(c4) #define F77_CHAR_ARG4DCL(c1,c2,c3,c4) \ F77_CHAR_ARG3DCL(c1,c2,c3) F77_CHAR_ARG_DCL(c4) #define F77_CHAR_ARG4DEF(c1,c2,c3,c4) \ F77_CHAR_ARG3DEF(c1,c2,c3) F77_CHAR_ARG_DEF(c4) #define F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_CHAR_ARG_PTR(c5) #define F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) F77_CHAR_ARG_LEN(c5) #define F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_CHAR_ARG_DCL(c5) #define F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) \ F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_CHAR_ARG_DEF(c5) /* * Fortran-calls-C interface * * To define a C function called by Fortran CALL SUB(A,B,C): * * #define Sub F77_NAME(sub,SUB) * #pragma linkage(SUB,FORTRAN) // for IBM C/370 compiler * * F77_ENTRY_xyz(Sub,a,b,c) // opening { contained in macro * // body ... * } * * Each character in xyz declares the type of the corresponding parameter: * * C = CHARACTER * E = EXTERNAL * I = INTEGER * R = REAL * * If a parameter PAR is declared as CHARACTER the macro defines: * * char *PAR; // pointer to string (not terminated by \0 !!!) * int len_PAR; // length of string as defined by Fortran's LEN(PAR) * * The names PAR_dsc and PAR_ptr are reserved for internal use. * * Note: The function body follows the F77_ENTRY_... macro call directly. * The opening { is generated by the macro. */ #define F77_ENTRY_C(name,c1) \ name( F77_CHAR_ARG_PTR(c1) F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) \ { F77_CHAR_ARG_DEF(c1) #define F77_ENTRY_CC(name,c1,c2) \ name( F77_CHAR_ARG2PTR(c1,c2) F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) \ { F77_CHAR_ARG2DEF(c1,c2) #define F77_ENTRY_C3(name,c1,c2,c3) \ name( F77_CHAR_ARG3PTR(c1,c2,c3) \ F77_CHAR_ARG3LEN(c1,c2,c3) ) \ F77_CHAR_ARG3DCL(c1,c2,c3) \ { F77_CHAR_ARG3DEF(c1,c2,c3) #define F77_ENTRY_C5(name,c1,c2,c3,c4,c5) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) #define F77_ENTRY_C4E(name,c1,c2,c3,c4,e5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_EXTERN_ARG(e5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_EXTERN_DCL(e5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_EXTERN_DEF(e5) #define F77_ENTRY_C4I(name,c1,c2,c3,c4,i5) \ name( F77_CHAR_ARG4PTR(c1,c2,c3,c4),F77_INTG_ARG_PTR(i5) \ F77_CHAR_ARG4LEN(c1,c2,c3,c4) ) \ F77_CHAR_ARG4DCL(c1,c2,c3,c4) F77_INTG_ARG_DCL(i5) \ { F77_CHAR_ARG4DEF(c1,c2,c3,c4) F77_INTG_ARG_DEF(i5) #define F77_ENTRY_C5E(name,c1,c2,c3,c4,c5,e6) \ name( F77_CHAR_ARG5PTR(c1,c2,c3,c4,c5),F77_EXTERN_ARG(e6) \ F77_CHAR_ARG5LEN(c1,c2,c3,c4,c5) ) \ F77_CHAR_ARG5DCL(c1,c2,c3,c4,c5) F77_EXTERN_DCL(e6) \ { F77_CHAR_ARG5DEF(c1,c2,c3,c4,c5) F77_EXTERN_DEF(e6) #define F77_ENTRY_CCE(name,c1,c2,e3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN_ARG(e3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN_DCL(e3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN_DEF(e3) #define F77_ENTRY_CCEE(name,c1,c2,e3,e4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_EXTERN2ARG(e3,e4) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_EXTERN2DCL(e3,e4) \ { F77_CHAR_ARG2DEF(c1,c2) F77_EXTERN2DEF(e3,e4) #define F77_ENTRY_CCI(name,c1,c2,i3) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG_PTR(i3) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_INTG_ARG_DCL(i3) \ { F77_CHAR_ARG2DEF(c1,c2) F77_INTG_ARG_DEF(i3) #define F77_ENTRY_CCIC(name,c1,c2,i3,c4) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG_PTR(i3),F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG2LEN(c1,c2) F77_XXXX_ARG_LEN(i3) F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG3DCL(c1,c2,c4) F77_INTG_ARG_DCL(i3) \ { F77_CHAR_ARG3DEF(c1,c2,c4) F77_INTG_ARG_DEF(i3) #define F77_ENTRY_CCI3(name,c1,c2,i3,i4,i5) \ name( F77_CHAR_ARG2PTR(c1,c2),F77_INTG_ARG3PTR(i3,i4,i5) \ F77_CHAR_ARG2LEN(c1,c2) ) \ F77_CHAR_ARG2DCL(c1,c2) F77_INTG_ARG3DCL(i3,i4,i5) \ { F77_CHAR_ARG2DEF(c1,c2) F77_INTG_ARG3DEF(i3,i4,i5) #define F77_ENTRY_CCIRCC(name,c1,c2,i3,r4,c5,c6) \ name( F77_CHAR_ARG2PTR(c1,c2), \ F77_INTG_ARG_PTR(i3),F77_REAL_ARG_PTR(r4),F77_CHAR_ARG2PTR(c5,c6) \ F77_CHAR_ARG2LEN(c1,c2) \ F77_XXXX_ARG2LEN(i3,r4) F77_CHAR_ARG2LEN(c5,c6) ) \ F77_CHAR_ARG4DCL(c1,c2,c5,c6) \ F77_INTG_ARG_DCL(i3) F77_REAL_ARG_DCL(r4) \ { F77_CHAR_ARG4DEF(c1,c2,c5,c6) \ F77_INTG_ARG_DEF(i3) F77_REAL_ARG_DEF(r4) \ #define F77_ENTRY_CE(name,c1,e2) \ name( F77_CHAR_ARG_PTR(c1),F77_EXTERN_ARG(e2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_EXTERN_DCL(e2) \ { F77_CHAR_ARG_DEF(c1) F77_EXTERN_DEF(e2) #define F77_ENTRY_CI(name,c1,i2) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG_PTR(i2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_INTG_ARG_DCL(i2) \ { F77_CHAR_ARG_DEF(c1) F77_INTG_ARG_DEF(i2) #define F77_ENTRY_CICI(name,c1,i2,c3,i4) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG_PTR(i2), \ F77_CHAR_ARG_PTR(c3),F77_INTG_ARG_PTR(i4) \ F77_CHAR_ARG_LEN(c1) F77_XXXX_ARG_LEN(i2) \ F77_CHAR_ARG_LEN(c3) ) \ F77_CHAR_ARG2DCL(c1,c3) F77_INTG_ARG2DCL(i2,i4) \ { F77_CHAR_ARG2DEF(c1,c3) F77_INTG_ARG2DEF(i2,i4) #define F77_ENTRY_CII(name,c1,i2,i3) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG2PTR(i2,i3) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_INTG_ARG2DCL(i2,i3) \ { F77_CHAR_ARG_DEF(c1) F77_INTG_ARG2DEF(i2,i3) #define F77_ENTRY_CIIC(name,c1,i2,i3,c4) \ name( F77_CHAR_ARG_PTR(c1),F77_INTG_ARG2PTR(i2,i3),F77_CHAR_ARG_PTR(c4) \ F77_CHAR_ARG_LEN(c1) F77_XXXX_ARG2LEN(i2,i3) F77_CHAR_ARG_LEN(c4) ) \ F77_CHAR_ARG2DCL(c1,c4) F77_INTG_ARG2DCL(i2,i3) \ { F77_CHAR_ARG2DEF(c1,c4) F77_INTG_ARG2DEF(i2,i3) #define F77_ENTRY_CR(name,c1,r2) \ name( F77_CHAR_ARG_PTR(c1),F77_REAL_ARG_PTR(r2) \ F77_CHAR_ARG_LEN(c1) ) \ F77_CHAR_ARG_DCL(c1) F77_REAL_ARG_DCL(r2) \ { F77_CHAR_ARG_DEF(c1) F77_REAL_ARG_DEF(r2) #define F77_ENTRY_E(name,e1) \ name( F77_EXTERN_ARG(e1) ) \ F77_EXTERN_DCL(e1) \ { F77_EXTERN_DEF(e1) #define F77_ENTRY_E4(name,e1,e2,e3,e4) \ name( F77_EXTERN4ARG(e1,e2,e3,e4) ) \ F77_EXTERN4DCL(e1,e2,e3,e4) \ { F77_EXTERN4DEF(e1,e2,e3,e4) #define F77_ENTRY_IC(name,i1,c2) \ name( F77_INTG_ARG_PTR(i1),F77_CHAR_ARG_PTR(c2) \ F77_XXXX_ARG_LEN(i1) F77_CHAR_ARG_LEN(c2) ) \ F77_INTG_ARG_DCL(i1) F77_CHAR_ARG_DCL(c2) \ { F77_INTG_ARG_DEF(i1) F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_ICI(name,i1,c2,i3) \ name( F77_INTG_ARG_PTR(i1), F77_CHAR_ARG_PTR(c2),F77_INTG_ARG_PTR(i3) \ F77_XXXX_ARG_LEN(i1) F77_CHAR_ARG_LEN(c2) ) \ F77_INTG_ARG2DCL(i1,i3) F77_CHAR_ARG_DCL(c2) \ { F77_INTG_ARG2DEF(i1,i3) F77_CHAR_ARG_DEF(c2) #define F77_ENTRY_IIC(name,i1,i2,c3) \ name( F77_INTG_ARG2PTR(i1,i2),F77_CHAR_ARG_PTR(c3) \ F77_XXXX_ARG2LEN(i1,i2) F77_CHAR_ARG_LEN(c3) ) \ F77_INTG_ARG2DCL(i1,i2) F77_CHAR_ARG_DCL(c3) \ { F77_INTG_ARG2DEF(i1,i2) F77_CHAR_ARG_DEF(c3) #define F77_ENTRY_I3C(name,i1,i2,i3,c4) \ name( F77_INTG_ARG3PTR(i1,i2,i3),F77_CHAR_ARG_PTR(c4) \ F77_XXXX_ARG3LEN(i1,i2,i3) F77_CHAR_ARG_LEN(c4) ) \ F77_INTG_ARG3DCL(i1,i2,i3) F77_CHAR_ARG_DCL(c4) \ { F77_INTG_ARG3DEF(i1,i2,i3) F77_CHAR_ARG_DEF(c4) #define F77_ENTRY_I4CCC(name,i1,i2,i3,i4,c5,c6,c7) \ name( F77_INTG_ARG4PTR(i1,i2,i3,i4),F77_CHAR_ARG3PTR(c5,c6,c7) \ F77_XXXX_ARG4LEN(i1,i2,i3,i4) F77_CHAR_ARG3LEN(c5,c6,c7) ) \ F77_INTG_ARG4DCL(i1,i2,i3,i4) F77_CHAR_ARG3DCL(c5,c6,c7) \ { F77_INTG_ARG4DEF(i1,i2,i3,i4) F77_CHAR_ARG3DEF(c5,c6,c7) #define F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_DEF_DSC(s1,p1,l1) F77_CHAR_DEF_DSC(s2,p2,l2) #define F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS_DSC(s1,p1,l1) F77_CHAR_ASS_DSC(s2,p2,l2) #define F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_PTR(s1,p1,l1),F77_CHAR_USE_PTR(s2,p2,l2) #define F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE_LEN(s1,p1,l1) F77_CHAR_USE_LEN(s2,p2,l2) #define F77_XXXX_USE2LEN(x1,x2) \ F77_XXXX_USE_LEN(x1) F77_XXXX_USE_LEN(x2) #define F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_DEF_DSC(s3,p3,l3) #define F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) F77_CHAR_ASS_DSC(s3,p3,l3) #define F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2),F77_CHAR_USE_PTR(s3,p3,l3) #define F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) F77_CHAR_USE_LEN(s3,p3,l3) #define F77_XXXX_USE3LEN(x1,x2,x3) \ F77_XXXX_USE2LEN(x1,x2) F77_XXXX_USE_LEN(x3) #define F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_DEF_DSC(s4,p4,l4) #define F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_ASS_DSC(s4,p4,l4) #define F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3),F77_CHAR_USE_PTR(s4,p4,l4) #define F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) F77_CHAR_USE_LEN(s4,p4,l4) #define F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_XXXX_USE3LEN(x1,x2,x3) F77_XXXX_USE_LEN(x4) #define F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) F77_XXXX_USE_LEN(x5) #define F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) \ F77_XXXX_USE5LEN(x1,x2,x3,x4,x5) F77_XXXX_USE_LEN(x6) #define F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) \ F77_XXXX_USE6LEN(x1,x2,x3,x4,x5,x6) F77_XXXX_USE_LEN(x7) #define F77_XXXX_USE8LEN(x1,x2,x3,x4,x5,x6,x7,x8) \ F77_XXXX_USE7LEN(x1,x2,x3,x4,x5,x6,x7) F77_XXXX_USE_LEN(x8) EXTERN INTEGER F77_i0; /* dummy */ #ifdef IBM370 #pragma linkage(K77C,FORTRAN) #define F77_IFUN_C(i0,name,p1,l1) do { \ i0 = K77C(&name,p1,l1); } while(0) #else #define F77_IFUN_C(i0,name,p1,l1) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1) \ F77_CHAR_USE_LEN(s1,p1,l1) \ ); } while(0) #endif #define F77_CALL_C(name,p1,l1) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_C(F77_i0,_p0_,p1,l1); \ } while(0) #ifdef IBM370 #pragma linkage(K77CC,FORTRAN) #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ i0 = K77CC(&name,p1,l1,p2,l2); } while(0) #else #define F77_IFUN_CC(i0,name,p1,l1,p2,l2) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2) \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CC(name,p1,l1,p2,l2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_CC(F77_i0,_p0_,p1,l1,p2,l2); \ } while(0) #ifdef IBM370 #pragma linkage(K77C3,FORTRAN) #define F77_IFUN_C3(i0,name,p1,l1,p2,l2,p3,l3) do { \ i0 = K77C3(&name,p1,l1,p2,l2,p3,l3); } while(0) #else #define F77_IFUN_C3(i0,name,p1,l1,p2,l2,p3,l3) do { \ F77_CHAR_DEF3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS3DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ i0 = (*name)( \ F77_CHAR_USE3PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ F77_CHAR_USE3LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #define F77_CALL_C3(name,p1,l1,p2,l2,p3,l3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_C3(F77_i0,_p0_,p1,l1,p2,l2,p3,l3); \ } while(0) #ifdef IBM370 #pragma linkage(K77C7,FORTRAN) #define F77_IFUN_C7(i0,name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ i0 = K77C7(&name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); } while(0) #else #define F77_IFUN_C7(i0,name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ F77_CHAR_DEF4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_DEF3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_ASS4DSC(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_ASS3DSC(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ i0 = (*name)( \ F77_CHAR_USE4PTR(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4), \ F77_CHAR_USE3PTR(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ F77_CHAR_USE4LEN(s1,p1,l1,s2,p2,l2,s3,p3,l3,s4,p4,l4) \ F77_CHAR_USE3LEN(s5,p5,l5,s6,p6,l6,s7,p7,l7) \ ); } while(0) #endif #define F77_CALL_C7(name,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_C7(F77_i0,_p0_,p1,l1,p2,l2,p3,l3,p4,l4,p5,l5,p6,l6,p7,l7); \ } while(0) #ifdef IBM370 #pragma linkage(K77CCx,FORTRAN) #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ SUBROUTINE *F77 = name; \ K77CCx(&F77,p1,l1,p2,l2,x3); } while(0) #else #define F77_CALL_CCx(name,p1,l1,p2,l2,x3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ name( F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77CCxx,FORTRAN) #define F77_IFUN_CCxx(i0,name,p1,l1,p2,l2,x3,x4) do { \ i0 = K77CCxx(&name,p1,l1,p2,l2,x3,x4); } while(0) #else #define F77_IFUN_CCxx(i0,name,p1,l1,p2,l2,x3,x4) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CCxx(name,p1,l1,p2,l2,x3,x4) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_CCxx(F77_i0,_p0_,p1,l1,p2,l2,x3,x4); \ } while(0) #ifdef IBM370 #pragma linkage(K77CCx3,FORTRAN) #define F77_IFUN_CCx3(i0,name,p1,l1,p2,l2,x3,x4,x5) do { \ i0 = K77CCx3(&name,p1,l1,p2,l2,x3,x4,x5); } while(0) #else #define F77_IFUN_CCx3(i0,name,p1,l1,p2,l2,x3,x4,x5) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s2,p2,l2) \ F77_CHAR_ASS2DSC(s1,p1,l1,s2,p2,l2) \ i0 = (*name)( \ F77_CHAR_USE2PTR(s1,p1,l1,s2,p2,l2), \ x3,x4,x5 \ F77_CHAR_USE2LEN(s1,p1,l1,s2,p2,l2) \ ); } while(0) #endif #define F77_CALL_CCx3(name,p1,l1,p2,l2,x3,x4,x5) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_CCx3(F77_i0,_p0_,p1,l1,p2,l2,x3,x4,x5); \ } while(0) #ifdef IBM370 #pragma linkage(K77Cx,FORTRAN) #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ i0 = K77Cx(&name,p1,l1,x2); } while(0) #else #define F77_IFUN_Cx(i0,name,p1,l1,x2) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ i0 = (*name)( \ F77_CHAR_USE_PTR(s1,p1,l1), \ x2 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ ); } while(0) #endif #define F77_CALL_Cx(name,p1,l1,x2) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_Cx(F77_i0,_p0_,p1,l1,x2); \ } while(0) #ifdef IBM370 #pragma linkage(K77CxC,FORTRAN) #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ SUBROUTINE *F77 = name; \ K77CxC(&F77,p1,l1,x2,p3,l3); } while(0) #else #define F77_CALL_CxC(name,p1,l1,x2,p3,l3) do { \ F77_CHAR_DEF2DSC(s1,p1,l1,s3,p3,l3) \ F77_CHAR_ASS2DSC(s1,p1,l1,s3,p3,l3) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2, \ F77_CHAR_USE_PTR(s3,p3,l3) \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE_LEN(x2) \ F77_CHAR_USE_LEN(s3,p3,l3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77Cxx,FORTRAN) #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ SUBROUTINE *F77 = name; \ K77Cxx(&F77,p1,l1,x2,x3); } while(0) #else #define F77_CALL_Cxx(name,p1,l1,x2,x3) do { \ F77_CHAR_DEF_DSC(s1,p1,l1) \ F77_CHAR_ASS_DSC(s1,p1,l1) \ name( F77_CHAR_USE_PTR(s1,p1,l1), \ x2,x3 \ F77_CHAR_USE_LEN(s1,p1,l1) \ F77_XXXX_USE2LEN(x2,x3) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xC,FORTRAN) #define F77_CALL_xC(name,x1,p2,l2) do { \ SUBROUTINE *F77 = name; \ K77xC(&F77,x1,p2,l2); } while(0) #else #define F77_CALL_xC(name,x1,p2,l2) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ name( x1, \ F77_CHAR_USE_PTR(s2,p2,l2) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCCx,FORTRAN) #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ SUBROUTINE *F77 = name; \ K77xCCx(&F77,x1,p2,l2,p3,l3,x4); } while(0) #else #define F77_CALL_xCCx(name,x1,p2,l2,p3,l3,x4) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ name( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3), \ x4 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x4) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77xCC,FORTRAN) #define F77_IFUN_xCC(i0,name,x1,p2,l2,p3,l3) do { \ i0 = K77xCC(&name,x1,p2,l2,p3,l3); } while(0) #else #define F77_IFUN_xCC(i0,name,x1,p2,l2,p3,l3) do { \ F77_CHAR_DEF2DSC(s2,p2,l2,s3,p3,l3) \ F77_CHAR_ASS2DSC(s2,p2,l2,s3,p3,l3) \ i0 = (*name)( x1, \ F77_CHAR_USE2PTR(s2,p2,l2,s3,p3,l3) \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE2LEN(s2,p2,l2,s3,p3,l3) \ ); } while(0) #endif #define F77_CALL_xCC(name,x1,p2,l2,p3,l3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_xCC(F77_i0,_p0_,x1,p2,l2,p3,l3); \ } while(0) #ifdef IBM370 #pragma linkage(K77xCx,FORTRAN) #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ i0 = K77xCx(&name,x1,p2,l2,x3); } while(0) #else #define F77_IFUN_xCx(i0,name,x1,p2,l2,x3) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE_LEN(x3) \ ); } while(0) #endif #define F77_CALL_xCx(name,x1,p2,l2,x3) do { \ INT_FUNCPTR _p0_ = (INT_FUNCPTR)name; \ F77_IFUN_xCx(F77_i0,_p0_,x1,p2,l2,x3); \ } while(0) #ifdef IBM370 #pragma linkage(K77x4C,FORTRAN) #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ SUBROUTINE *F77 = name; \ K77x4C(&F77,x1,x2,x3,x4,p5,l5); } while(0) #else #define F77_CALL_x4C(name,x1,x2,x3,x4,p5,l5) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5) \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(K77x4Cxx,FORTRAN) #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ SUBROUTINE *F77 = name; \ K77x4Cxx(&F77,x1,x2,x3,x4,p5,l5,x6,x7); } while(0) #else #define F77_CALL_x4Cxx(name,x1,x2,x3,x4,p5,l5,x6,x7) do { \ F77_CHAR_DEF_DSC(s5,p5,l5) \ F77_CHAR_ASS_DSC(s5,p5,l5) \ name( x1,x2,x3,x4, \ F77_CHAR_USE_PTR(s5,p5,l5), \ x6,x7 \ F77_XXXX_USE4LEN(x1,x2,x3,x4) \ F77_CHAR_USE_LEN(s5,p5,l5) \ F77_XXXX_USE2LEN(x6,x7) \ ); } while(0) #endif #ifdef IBM370 #pragma linkage(KIGMENU,FORTRAN) /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 */ #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ SUBROUTINE *F77 = name; \ KIGMENU(&F77,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N); } while(0) #else #define F77_CALL_xCx5CxC3xC(name,a,b,B,c,d,e,f,g,h,H,i,j,J,k,K,l,L,m,n,N) do {\ F77_CHAR_DEF_DSC(sb,b,B) \ F77_CHAR_DEF_DSC(sh,h,H) \ F77_CHAR_DEF3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_DEF_DSC(sn,n,N) \ F77_CHAR_ASS_DSC(sb,b,B) \ F77_CHAR_ASS_DSC(sh,h,H) \ F77_CHAR_ASS3DSC(sj,j,J,sk,k,K,sl,l,L) \ F77_CHAR_ASS_DSC(sn,n,N) \ name( a, \ F77_CHAR_USE_PTR(sb,b,B), \ c,d,e,f,g, \ F77_CHAR_USE_PTR(sh,h,H), \ i, \ F77_CHAR_USE3PTR(sj,j,J,sk,k,K,sl,l,L), \ m, \ F77_CHAR_USE_PTR(sn,n,N) \ F77_XXXX_USE_LEN(a) \ F77_CHAR_USE_LEN(sb,b,B) \ F77_XXXX_USE5LEN(c,d,e,f,g) \ F77_CHAR_USE_LEN(sh,h,H) \ F77_XXXX_USE_LEN(i) \ F77_CHAR_USE3LEN(sj,j,J,sk,k,K,sl,l,L) \ F77_XXXX_USE_LEN(m) \ F77_CHAR_USE_LEN(sn,n,N) \ ); } while(0) #endif #ifdef IBM370 #define F77_IFUN_x(i0,name,x1) i0 = __CTOF(name,x1) #else #define F77_IFUN_x(i0,name,x1) i0 = (*name)(x1) #endif #ifdef IBM370 #define F77_IFUN_xx(i0,name,x1,x2) i0 = __CTOF(name,x1,x2) #else #define F77_IFUN_xx(i0,name,x1,x2) i0 = (*name)(x1,x2) #endif #ifdef IBM370 #pragma linkage(K77xCx8,FORTRAN) #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ i0 = K77xCx8(&name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10); } while(0) #else #define F77_IFUN_xCx8(i0,name,x1,p2,l2,x3,x4,x5,x6,x7,x8,x9,x10) do { \ F77_CHAR_DEF_DSC(s2,p2,l2) \ F77_CHAR_ASS_DSC(s2,p2,l2) \ i0 = (*name)( x1, \ F77_CHAR_USE_PTR(s2,p2,l2), \ x3,x4,x5,x6,x7,x8,x9,x10 \ F77_XXXX_USE_LEN(x1) \ F77_CHAR_USE_LEN(s2,p2,l2) \ F77_XXXX_USE8LEN(x3,x4,x5,x6,x7,x8,x9,x10) \ ); } while(0) #endif extern LOGICAL ku_true( int return_true ); /* * routines called by Fortran */ #define Errrun F77_NAME(errrun,ERRRUN) #define Fmemcpy F77_NAME(fmemcpy,FMEMCPY) #define Getarg F77_NAME(getarg,GETARG) extern SUBROUTINE Getarg; #define Goparm F77_NAME(goparm,GOPARM) extern SUBROUTINE Goparm; #define Iclrwk F77_NAME(iclrwk,ICLRWK) extern SUBROUTINE Iclrwk; #define Iginit F77_NAME(iginit,IGINIT) extern SUBROUTINE Iginit; #define Igmenu F77_NAME(igmenu,IGMENU) extern SUBROUTINE Igmenu; #define Igrng F77_NAME(igrng,IGRNG) extern SUBROUTINE Igrng; #define Igsse F77_NAME(igsse,IGSSE) extern SUBROUTINE Igsse; #define Igsrap F77_NAME(igsrap,IGSRAP) extern SUBROUTINE Igsrap; #define Igwkty F77_NAME(igwkty,IGWKTY) extern SUBROUTINE Igwkty; #define Kcexec F77_NAME(kcexec,KCEXEC) #define Kdialo F77_NAME(kdialo,KDIALO) extern SUBROUTINE Kdialo; #define Kgetar F77_NAME(kgetar,KGETAR) #define Kiargc F77_NAME(kiargc,KIARGC) extern INT_FUNCTION Kiargc; #define Kibres F77_NAME(kibres,KIBRES) extern SUBROUTINE Kibres; #define Kiclos F77_NAME(kiclos,KICLOS) extern SUBROUTINE Kiclos; #define Kicomv F77_NAME(kicomv,KICOMV) #define Kierrf F77_NAME(kierrf,KIERRF) extern SUBROUTINE Kierrf; #define Kiinit F77_NAME(kiinit,KIINIT) extern SUBROUTINE Kiinit; #define Kilun F77_NAME(kilun,KILUN) extern SUBROUTINE Kilun; #define Kipawc F77_NAME(kipawc,KIPAWC) #define Kipiaf F77_NAME(kipiaf,KIPIAF) #define Kiprmt F77_NAME(kiprmt,KIPRMT) #define Kirtim F77_NAME(kirtim,KIRTIM) #define Kisigm F77_NAME(kisigm,KISIGM) #define Kivect F77_NAME(kivect,KIVECT) #define Kmbrset F77_NAME(kmbrset,KMBRSET) #define Kmvsed F77_NAME(kmvsed,KMVSED) extern SUBROUTINE Kmvsed; #define Kmvspg F77_NAME(kmvspg,KMVSPG) extern SUBROUTINE Kmvspg; #define Kmvssh F77_NAME(kmvssh,KMVSSH) extern SUBROUTINE Kmvssh; #define Ksvpar F77_NAME(ksvpar,KSVPAR) #define Kuach F77_NAME(kuach,KUACH) #define Kuact F77_NAME(kuact,KUACT) #define Kualfa F77_NAME(kualfa,KUALFA) #define Kuappl F77_NAME(kuappl,KUAPPL) #define Kuargs F77_NAME(kuargs,KUARGS) #define Kubrek F77_NAME(kubrek,KUBREK) #define Kubrof F77_NAME(kubrof,KUBROF) #define Kubron F77_NAME(kubron,KUBRON) #define Kuclos F77_NAME(kuclos,KUCLOS) extern SUBROUTINE Kuclos; #define Kucmd F77_NAME(kucmd,KUCMD) #define Kucmdl F77_NAME(kucmdl,KUCMDL) #define Kucomv F77_NAME(kucomv,KUCOMV) #define Kuedit F77_NAME(kuedit,KUEDIT) #define Kuesvr F77_NAME(kuesvr,KUESVR) #define Kueusr F77_NAME(kueusr,KUEUSR) #define Kuexec F77_NAME(kuexec,KUEXEC) #define Kuexel F77_NAME(kuexel,KUEXEL) #define Kuexit F77_NAME(kuexit,KUEXIT) #define Kufcas F77_NAME(kufcas,KUFCAS) #define Kufdef F77_NAME(kufdef,KUFDEF) #define Kugetc F77_NAME(kugetc,KUGETC) #define Kugete F77_NAME(kugete,KUGETE) #define Kugetf F77_NAME(kugetf,KUGETF) #define Kugeti F77_NAME(kugeti,KUGETI) #define Kugetl F77_NAME(kugetl,KUGETL) #define Kugetr F77_NAME(kugetr,KUGETR) #define Kugets F77_NAME(kugets,KUGETS) #define Kugrfl F77_NAME(kugrfl,KUGRFL) #define Kuguid F77_NAME(kuguid,KUGUID) #define Kuhelp F77_NAME(kuhelp,KUHELP) #define Kuhome F77_NAME(kuhome,KUHOME) #define Kuidf1 F77_NAME(kuidf1,KUIDF1) extern SUBROUTINE Kuidf1; #define Kuidf2 F77_NAME(kuidf2,KUIDF2) extern SUBROUTINE Kuidf2; #define Kuidfm F77_NAME(kuidfm,KUIDFM) #define Kuinim F77_NAME(kuinim,KUINIM) #define Kuinit F77_NAME(kuinit,KUINIT) #define Kuinps F77_NAME(kuinps,KUINPS) #define Kuinqf F77_NAME(kuinqf,KUINQF) extern SUBROUTINE Kuinqf; #define Kulun F77_NAME(kulun,KULUN) #define Kumloc F77_NAME(kumloc,KUMLOC) #define Kumout F77_NAME(kumout,KUMOUT) #define Kundpv F77_NAME(kundpv,KUNDPV) #define Kunpar F77_NAME(kunpar,KUNPAR) #define Kunwg F77_NAME(kunwg,KUNWG) #define Kuopen F77_NAME(kuopen,KUOPEN) extern SUBROUTINE Kuopen; #define Kupad F77_NAME(kupad,KUPAD) #define Kupar F77_NAME(kupar,KUPAR) #define Kupath F77_NAME(kupath,KUPATH) #define Kupatl F77_NAME(kupatl,KUPATL) #define Kuproc F77_NAME(kuproc,KUPROC) #define Kuprof F77_NAME(kuprof,KUPROF) #define Kuproi F77_NAME(kuproi,KUPROI) #define Kuprop F77_NAME(kuprop,KUPROP) #define Kupror F77_NAME(kupror,KUPROR) #define Kupros F77_NAME(kupros,KUPROS) #define Kumess F77_NAME(kumess,KUMESS) #define Kupval F77_NAME(kupval,KUPVAL) #define Kuqcas F77_NAME(kuqcas,KUQCAS) #define Kuqenv F77_NAME(kuqenv,KUQENV) #define Kuqexe F77_NAME(kuqexe,KUQEXE) #define Kuqkey F77_NAME(kuqkey,KUQKEY) #define Kuqsvr F77_NAME(kuqsvr,KUQSVR) #define Kuquit F77_NAME(kuquit,KUQUIT) #define Kuqvar F77_NAME(kuqvar,KUQVAR) #define Kuread F77_NAME(kuread,KUREAD) extern SUBROUTINE Kuread; #define Kusapp F77_NAME(kusapp,KUSAPP) #define Kuser F77_NAME(kuser,KUSER) #define Kuserid F77_NAME(kuserid,KUSERID) #define Kusibr F77_NAME(kusibr,KUSIBR) #define Kusigm F77_NAME(kusigm,KUSIGM) #define Kuspy F77_NAME(kuspy,KUSPY) #define Kustat F77_NAME(kustat,KUSTAT) #define Kustop F77_NAME(kustop,KUSTOP) #define Kuterm F77_NAME(kuterm,KUTERM) #define Kutime F77_NAME(kutime,KUTIME) #define Kutim0 F77_NAME(kutim0,KUTIM0) extern SUBROUTINE Kutim0; #define Kutrue F77_NAME(kutrue,KUTRUE) #define Kuvar F77_NAME(kuvar,KUVAR) #define Kuvcre F77_NAME(kuvcre,KUVCRE) extern SUBROUTINE Kuvcre; #define Kuvdel F77_NAME(kuvdel,KUVDEL) extern SUBROUTINE Kuvdel; #define Kuvect F77_NAME(kuvect,KUVECT) extern SUBROUTINE Kuvect; #define Kuvnam F77_NAME(kuvnam,KUVNAM) #define Kuwhag F77_NAME(kuwhag,KUWHAG) #define Kuwham F77_NAME(kuwham,KUWHAM) #define Kuwhat F77_NAME(kuwhat,KUWHAT) #define Kuwrit F77_NAME(kuwrit,KUWRIT) extern SUBROUTINE Kuwrit; #define Kxcrv2 F77_NAME(kxcrv2,KXCRV2) extern SUBROUTINE Kxcrv2; #define Macdef F77_NAME(macdef,MACDEF) extern SUBROUTINE Macdef; #define Mdmenu F77_NAME(mdmenu,MDMENU) #define Mhi_close F77_NAME(mhi_close,MHI_CLOSE) extern SUBROUTINE Mhi_close; #define Mhi_open F77_NAME(mhi_open,MHI_OPEN) extern SUBROUTINE Mhi_open; #define Mzwipe F77_NAME(mzwipe,MZWIPE) extern SUBROUTINE Mzwipe; #define Traceq F77_NAME(traceq,TRACEQ) extern SUBROUTINE Traceq; #define Xuflow F77_NAME(xuflow,XUFLOW) extern SUBROUTINE Xuflow; #ifdef IBM370 # pragma linkage(ERRRUN,FORTRAN) # pragma linkage(FMEMCPY,FORTRAN) # pragma linkage(GOPARM,FORTRAN) # pragma linkage(ICLRWK,FORTRAN) # pragma linkage(IGINIT,FORTRAN) # pragma linkage(IGMENU,FORTRAN) # pragma linkage(IGRNG,FORTRAN) # pragma linkage(IGSSE,FORTRAN) # pragma linkage(IGSRAP,FORTRAN) # pragma linkage(IGWKTY,FORTRAN) # pragma linkage(KCEXEC,FORTRAN) # pragma linkage(KDIALO,FORTRAN) # pragma linkage(KGETAR,FORTRAN) # pragma linkage(KIBRES,FORTRAN) # pragma linkage(KICLOS,FORTRAN) # pragma linkage(KICOMV,FORTRAN) # pragma linkage(KIERRF,FORTRAN) # pragma linkage(KIINIT,FORTRAN) # pragma linkage(KILUN,FORTRAN) # pragma linkage(KIPAWC,FORTRAN) # pragma linkage(KIPIAF,FORTRAN) # pragma linkage(KIPRMT,FORTRAN) # pragma linkage(KIRTIM,FORTRAN) # pragma linkage(KISIGM,FORTRAN) # pragma linkage(KIVECT,FORTRAN) # pragma linkage(KMBRSET,FORTRAN) # pragma linkage(KMVSED,FORTRAN) # pragma linkage(KMVSPG,FORTRAN) # pragma linkage(KMVSSH,FORTRAN) # pragma linkage(KSVPAR,FORTRAN) # pragma linkage(KUACH,FORTRAN) # pragma linkage(KUACT,FORTRAN) # pragma linkage(KUALFA,FORTRAN) # pragma linkage(KUAPPL,FORTRAN) # pragma linkage(KUARGS,FORTRAN) # pragma linkage(KUBREK,FORTRAN) # pragma linkage(KUBROF,FORTRAN) # pragma linkage(KUBRON,FORTRAN) # pragma linkage(KUCLOS,FORTRAN) # pragma linkage(KUCMD,FORTRAN) # pragma linkage(KUCMDL,FORTRAN) # pragma linkage(KUCOMV,FORTRAN) # pragma linkage(KUEDIT,FORTRAN) # pragma linkage(KUESVR,FORTRAN) # pragma linkage(KUEUSR,FORTRAN) # pragma linkage(KUEXEC,FORTRAN) # pragma linkage(KUEXEL,FORTRAN) # pragma linkage(KUEXIT,FORTRAN) # pragma linkage(KUFCAS,FORTRAN) # pragma linkage(KUFDEF,FORTRAN) # pragma linkage(KUGETC,FORTRAN) # pragma linkage(KUGETE,FORTRAN) # pragma linkage(KUGETF,FORTRAN) # pragma linkage(KUGETI,FORTRAN) # pragma linkage(KUGETL,FORTRAN) # pragma linkage(KUGETR,FORTRAN) # pragma linkage(KUGETS,FORTRAN) # pragma linkage(KUGRFL,FORTRAN) # pragma linkage(KUGUID,FORTRAN) # pragma linkage(KUHELP,FORTRAN) # pragma linkage(KUHOME,FORTRAN) # pragma linkage(KUIDF1,FORTRAN) # pragma linkage(KUIDF2,FORTRAN) # pragma linkage(KUIDFM,FORTRAN) # pragma linkage(KUINIM,FORTRAN) # pragma linkage(KUINIT,FORTRAN) # pragma linkage(KUINPS,FORTRAN) # pragma linkage(KUINQF,FORTRAN) # pragma linkage(KULUN,FORTRAN) # pragma linkage(KUMLOC,FORTRAN) # pragma linkage(KUMOUT,FORTRAN) # pragma linkage(KUNDPV,FORTRAN) # pragma linkage(KUNPAR,FORTRAN) # pragma linkage(KUNWG,FORTRAN) # pragma linkage(KUOPEN,FORTRAN) # pragma linkage(KUPAD,FORTRAN) # pragma linkage(KUPAR,FORTRAN) # pragma linkage(KUPATH,FORTRAN) # pragma linkage(KUPATL,FORTRAN) # pragma linkage(KUPROC,FORTRAN) # pragma linkage(KUPROF,FORTRAN) # pragma linkage(KUPROI,FORTRAN) # pragma linkage(KUPROP,FORTRAN) # pragma linkage(KUPROR,FORTRAN) # pragma linkage(KUPROS,FORTRAN) # pragma linkage(KUPVAL,FORTRAN) # pragma linkage(KUQCAS,FORTRAN) # pragma linkage(KUQENV,FORTRAN) # pragma linkage(KUQEXE,FORTRAN) # pragma linkage(KUQKEY,FORTRAN) # pragma linkage(KUQSVR,FORTRAN) # pragma linkage(KUQUIT,FORTRAN) # pragma linkage(KUQVAR,FORTRAN) # pragma linkage(KUREAD,FORTRAN) # pragma linkage(KUSAPP,FORTRAN) # pragma linkage(KUSIBR,FORTRAN) # pragma linkage(KUSIGM,FORTRAN) # pragma linkage(KUSPY,FORTRAN) # pragma linkage(KUSTAT,FORTRAN) # pragma linkage(KUSTOP,FORTRAN) # pragma linkage(KUTERM,FORTRAN) # pragma linkage(KUTIME,FORTRAN) # pragma linkage(KUTIM0,FORTRAN) # pragma linkage(KUTRUE,FORTRAN) # pragma linkage(KUSER,FORTRAN) # pragma linkage(KUVAR,FORTRAN) # pragma linkage(KUVCRE,FORTRAN) # pragma linkage(KUVDEL,FORTRAN) # pragma linkage(KUVECT,FORTRAN) # pragma linkage(KUVNAM,FORTRAN) # pragma linkage(KUWHAG,FORTRAN) # pragma linkage(KUWHAM,FORTRAN) # pragma linkage(KUWHAT,FORTRAN) # pragma linkage(KUWRIT,FORTRAN) # pragma linkage(KXCRV2,FORTRAN) # pragma linkage(MACDEF,FORTRAN) # pragma linkage(MDMENU,FORTRAN) # pragma linkage(MHI_CLOSE,FORTRAN) # pragma linkage(MHI_OPEN,FORTRAN) # pragma linkage(MZWIPE,FORTRAN) # pragma linkage(TRACEQ,FORTRAN) # pragma linkage(XUFLOW,FORTRAN) #endif #define MAXCMD 512 /* max length of a command line */ #define MAXEDT 32 /* max length of names in edit server */ #define MAXLEV 10 /* max levels of command name path */ #define MAXSVR 20 /* max number of edit server processes */ /* * The PAWC common is referenced through a pointer to allow the use of * dynamic common blocks on IBM systems. */ #define Pawc kc_pawc EXTERN struct COMMON_PAWC { INTEGER NWPAR; INTEGER IXPAWC; INTEGER IHBOOK; INTEGER IXHIGZ; INTEGER IXKUIP; INTEGER IFENCE[5]; INTEGER LQ[8]; INTEGER DATA[999]; } *Pawc; #define IQ(n) Pawc->DATA[n-1] #define Q(n) (((REAL*)(Pawc->DATA))[n-1]) +KEEP,KCOM_H /* kcom.h: Fortran COMMON blocks */ #define Kcparc F77_BLOCK(kcparc,KCPARC) EXTERN struct { char PARLST[512]; /* interface block for KUSER */ char CLIST[80]; char NOALIN[512]; char COMAND[80]; char CHLAST[512]; char NONPOS[512]; } F77_COMMON(Kcparc); #define Kcutil F77_BLOCK(kcutil,KCUTIL) EXTERN struct { INTEGER NCMD; INTEGER IWD; INTEGER LUNFIL; INTEGER LPRMPT; LOGICAL TIMING; LOGICAL TRACE; INTEGER CALMOD; INTEGER NVADD; INTEGER IREPET; INTEGER IREFAC; INTEGER IBRAK; LOGICAL TIMALL; INTEGER LENTER; LOGICAL UNIQUE; INTEGER LENMUL; LOGICAL MULTFL; LOGICAL HISTOK; LOGICAL NOHIST; INTEGER LENMUM; LOGICAL FILCAS; LOGICAL MEXEFL; } F77_COMMON(Kcutil); #define Kcvect F77_BLOCK(kcvect,KCVECT) EXTERN struct { INTEGER NUMVEC; /* number of vectors stored */ INTEGER TOTPAV; INTEGER GETPAV; LOGICAL TVECFL; } F77_COMMON(Kcvect); #define Kcwork F77_BLOCK(kcwork,KCWORK) EXTERN struct { REAL VECTOR[100]; /* vector '?' */ } F77_COMMON(Kcwork); #define Quest F77_BLOCK(quest,QUEST) EXTERN struct { INTEGER DATA[100]; } F77_COMMON(Quest); #define IQUEST(n) Quest.DATA[n-1] #define Sikuip F77_BLOCK(sikuip,SIKUIP) EXTERN struct { char CHSIGM[80]; /* command string passed to SIGMA */ } F77_COMMON(Sikuip); +KEEP,KSIG_H /* ksig.h: signal and break handling */ /* * Available signal handling package * * #define SIGNAL_POSIX ==> sigaction() for Unix * #define SIGNAL_BSD ==> sigvec() for VMS and NeXT * #define SIGNAL_V7 ==> signal() */ #if !defined(SIGNAL_BSD) && !defined(SIGNAL_V7) # define SIGNAL_POSIX #else # define sigjmp_buf jmp_buf # define sigsetjmp(buf,save) setjmp(buf) # define siglongjmp(buf,val) longjmp(buf,val) # ifdef vms # define sv_flags sv_onstack # endif #endif EXTERN struct { int trap_enabled; /* flag if exceptions should be trapped */ int intr_enabled; /* flag if ^C delivery is allowed */ int intr_pending; /* flag if ^C happened while disabled */ int intr_count; /* count number of consecutive ^C interrupts */ int traceback; /* print traceback on signal */ char *error_msg; /* messages is handler cannot do print */ int soft_intr; /* flag to stop at a convenient point */ int jump_set; /* flag if stack has been setup */ sigjmp_buf stack; int sockfd; /* socket descriptor and routine to */ void (*piaf_sync)(); /* resynchronize Piaf communication */ } kc_break; +DECK,kuip_h. +seq,kuip_h. +DECK,kfor_h. +seq,kfor_h. +DECK,kcom_h. +seq,kcom_h. +DECK,ksig_h. +seq,ksig_h. +PATCH,MAIN,IF=MAIN_N,MAIN_K. +DECK,mn_main. PROGRAM MN_MAIN +SELF,IF=UNIX,IF=HPUX. CALL ERRREC +SELF. +SELF,IF=MAIN_K. CALL MN_CALL +SELF,IF=MAIN_N. CALL MN_FIT +SELF. END +PATCH,MAIN_CC,T=XCC,IF=MAIN_CC. +DECK,mn_main. +SELF,IF=PATCHY5. +INCLUDE,KUIP_H +INCLUDE,KFOR_H +INCLUDE,KCOM_H +INCLUDE,KSIG_H. +SELF,IF=-PATCHY5. +SEQ,KUIP_H +SEQ,KFOR_H +SEQ,KCOM_H +SEQ,KSIG_H. +SELF. main (argc, argv) int argc; char **argv; { void errrec(); void mn_call(void); +self,if=unix,if=hpux. errrec_ (); +self. mn_call (); exit (0); } +DECK,mn_call. void mn_call(void) { void m_start_(); int what_loop(void); void m_stop_(); m_start_ (); ku_trap( 1, -1); /* Install signal handler */ while( 1 ) { if( what_loop() == 1 ) break; else { /* this branch is for VMS exceptions only */ reset_break(); } } m_stop_ (); kc_break.jump_set = 0; ku_trap( 0, -1 ); /* remove signal handler */ ku_shut(); /* clean up the mess */ } int what_loop() { void m_run_(); #ifdef vms /* * The signal handler calls LIB$SIG_TO_RET which lets what_loop return * the error number ( 1 == SS$_NORMAL ) */ +SELF,IF=93D. VAXC$ESTABLISH( vms_signal_handler ); +SELF,IF=-93D. VAXC$ESTABLISH( signal_handler ); +SELF. #endif /* catch exceptions saving signal mask */ if( sigsetjmp( kc_break.stack, 1 ) != 0 ) { /* saving signal mask */ /* longjmp happened */ reset_break(); } kc_break.jump_set = 1; m_run_ (); kc_break.intr_count = 0; /* reset the ^C counter */ return 1; } +PATCH,MN_FIT. +DECK,hyf909. SUBROUTINE HYF909(INAME,ITYPE,IX,IDESC) DIMENSION IX(1) MAXI=999999999 MAXPOS=0 DO K=1,300 J=K-25 1 IF(IX(J+25).NE.0) THEN J=IX(J+25) IF(MOD(IX(J+1),10).EQ.ITYPE) THEN NAME=IX(J+1)/10 IF(NAME.GT.INAME.AND.NAME.LT.MAXI) THEN MAXI=NAME MAXPOS=J ENDIF GOTO 1 ENDIF ENDIF ENDDO INAME=MAXI IF(INAME.EQ.999999999) INAME=0 IDESC=MAXPOS RETURN END +DECK,hyfet. C--------------------------------- SUBROUTINE HYFET(NAME,ITYPE,NUMCAL,NUMBIN, * XYLO,XYHI,WTUNDR,WTINSD,WTOVER,TITLE,IERR) C DIMENSION NUMBIN(2),XYLO(2),XYHI(2) CHARACTER*(*) TITLE C +CDE,MNSCR. INTEGER IPTR,ISPACE(1),IDESC EQUIVALENCE(SCRATCH(1),IPTR) EQUIVALENCE(SCRATCH(2),ISPACE) EQUIVALENCE(SCRATCH(3),IDESC) C COMMON/MNSCR/IPTR,ISPACE(1),IDESC REAL SPACE(1) EQUIVALENCE (SPACE,ISPACE) C NAMEX=NAME*10+ITYPE NN1=NAMEX*17 IDESC=NN1-(NN1/300)*300-24 IERR=1 1 IDESC=ISPACE(IPTR+IDESC+25) IF(IDESC.EQ.0) RETURN IF(ISPACE(IPTR+IDESC+1).NE.NAMEX) GOTO 1 IERR=0 IF(ITYPE.EQ.1) THEN NUMBIN(1)=ISPACE(IPTR+IDESC+5) XYLO(1)=SPACE(IPTR+IDESC+3) XYHI(1)=XYLO(1)+NUMBIN(1)*SPACE(IPTR+IDESC+4) NUMCAL=ISPACE(IPTR+IDESC+10) WTUNDR=SPACE(IPTR+IDESC+12) WTOVER=SPACE(IPTR+IDESC+13) WTINSD=SPACE(IPTR+IDESC+11)-(WTUNDR+WTOVER) JT=ISPACE(IPTR+IDESC+7) ELSEIF(ITYPE.EQ.2) THEN NUMBIN(1)=ISPACE(IPTR+IDESC+5) NUMBIN(2)=ISPACE(IPTR+IDESC+8) XYLO(1)=SPACE(IPTR+IDESC+3) XYLO(2)=SPACE(IPTR+IDESC+6) XYHI(1)=XYLO(1)+NUMBIN(1)*SPACE(IPTR+IDESC+4) XYHI(2)=XYLO(2)+NUMBIN(2)*SPACE(IPTR+IDESC+7) NUMCAL=ISPACE(IPTR+IDESC+16) WTUNDR=0. WTOVER=SPACE(IPTR+IDESC+18) WTINSD=SPACE(IPTR+IDESC+17)-(WTUNDR+WTOVER) JT=ISPACE(IPTR+IDESC+11) ENDIF TITLE=' ' IF(JT.GT.0) THEN MK=0 JT=JT+IPTR 33 MK=MK+4 JT=JT+1 WRITE(TITLE(MK-3:MK),'(A4)') ISPACE(JT) IF(INDEX(TITLE(MK-3:MK),';').EQ.0) GOTO 33 JT=INDEX(TITLE(1:MK),';') TITLE(JT:)=' ' ENDIF END +DECK,hyfnxt. C--------------------------------- SUBROUTINE HYFNXT(INAME,ITYPE) C +CDE,MNSCR. INTEGER IPTR,ISPACE(1),IDESC EQUIVALENCE(SCRATCH(1),IPTR) EQUIVALENCE(SCRATCH(2),ISPACE) EQUIVALENCE(SCRATCH(3),IDESC) C COMMON/MNSCR/IPTR,ISPACE(1),IDESC REAL SPACE(1) EQUIVALENCE (SPACE,ISPACE) C CALL HYF909(INAME,ITYPE,ISPACE(IPTR+1),IDESC) RETURN END +DECK,hyread. SUBROUTINE HYREAD(IUNIT,IERR) C C ROUTINE FOR READING IN CHRIS RIPPICH'S HYBRID PLOTS C C C COMMON/MNSCR/IPTR,ISPACE(1) +CDE,MNSCR. INTEGER IPTR,ISPACE(1) EQUIVALENCE(SCRATCH(1),IPTR) EQUIVALENCE(SCRATCH(2),ISPACE) CCC COMMON/CXYHYZ/IX(300),NSPACE,NSTR,NEXT,NFIRST DIMENSION IX(304) C READ(IUNIT,ERR=99) IX NEXT=IX(303) CALL MN_ROM(NEXT,NGOT,IPTR) IF(NGOT.LT.NEXT.OR.IPTR.LE.0) GOTO 99 DO K=1,304 ISPACE(IPTR+K)=IX(K) ENDDO READ(IUNIT,ERR=99) (ISPACE(IPTR+K),K=305,NEXT) IERR=0 RETURN 99 IERR=1 RETURN END +DECK,hyupak. C------------------------------ SUBROUTINE HYUPAK(RDAT,WATMIN,WATMAX) C +CDE,MNSCR. INTEGER IPTR,ISPACE(1),IDESC EQUIVALENCE(SCRATCH(1),IPTR) EQUIVALENCE(SCRATCH(2),ISPACE) EQUIVALENCE(SCRATCH(3),IDESC) C COMMON/MNSCR/IPTR,ISPACE(1),IDESC REAL SPACE(1) EQUIVALENCE (SPACE,ISPACE) C CALL HYUPK1(RDAT,ISPACE(IPTR+1),ISPACE(IPTR+1),IDESC, * WATMIN,WATMAX) RETURN END +DECK,hyupk1. SUBROUTINE HYUPK1(RDAT,IX,X,IDESC,WATMIN,WATMAX) DIMENSION RDAT(1),IX(1),X(1) C ITYP=MOD(IX(IDESC+1),10) C C IF(ITYP.EQ.+1) THEN IP=IX(IDESC+6) NP=IX(IDESC+5) DO K=1,NP RDAT(K)=X(IP+K) ENDDO C ELSE C IP=IX(IDESC+10) C IF(IP.LT.0) THEN IP=-IP NP=IX(IDESC+9) DO K=1,NP RDAT(K)=X(IP+K) ENDDO C ELSE C NX=IX(IDESC+5) NY=IX(IDESC+8) NP=NX*NY DO K=1,NX*NY RDAT(K)=0. ENDDO 33 IF(IP.EQ.0) GOTO 34 IP1=IP+3 IP2=IP+IX(IP+1)*3 DO K=IP1,IP2,3 IBXY=IX(K) IBY=IBXY/1000 IBX=2*(IBXY-IBY*1000) RDAT((IBY-1)*NX+IBX+1)=X(K+1) RDAT((IBY-1)*NX+IBX+2)=X(K+2) ENDDO IP=IX(IP+2) GOTO 33 ENDIF ENDIF C 34 WATMIN=RDAT(1) WATMAX=RDAT(1) DO K=2,NP WATMIN=AMIN1(WATMIN,RDAT(K)) WATMAX=AMAX1(WATMAX,RDAT(K)) ENDDO RETURN END +DECK,mn_avf. SUBROUTINE MN_AVF(IDELIM) C implicit none C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNCMD. +CDE,MNLUN. C integer mpntmx PARAMETER (MPNTMX=20000) C COMMON/MNSCR/BUFDAT(MPNTMX) +CDE,MNSCR. REAL BUFDAT(MPNTMX) EQUIVALENCE(SCRATCH(1),BUFDAT(1)) C INTEGER IBFDAT(MPNTMX) EQUIVALENCE (BUFDAT,IBFDAT) C integer mavef PARAMETER (MAVEF=6) CHARACTER*1 AVENAM(MAVEF) C INTEGER IDBIN(2) REAL ADLO(2),ADHI(2) REAL ACONT(3**2) C CHARACTER*32 TNDEF(2) C CHARACTER*80 TITLE CHARACTER*132 ATEXT INTEGER IDLST1(MHSTMX),IDLST2(MHSTMX) LOGICAL QZERO * integer idelim,njunk,ndhis0,ierr,nidl,nidr,ida1,idb1,ida2,idb2 + ,nnid,ida,idb,lena,lent,lnblnk + ,idf,il,it,ntype,nbinx,nbiny,nnum,ndim,nwppt,nwrd,nbppt,nbppta + ,nwave,ibmsk,ii,jj,ncpos,indx,ind,ntmode,nh,nptrh,nptrd,nwh + ,n1,n2,n3,n4,npnt,nwpt,nline,nxb,nyb,nnxy,nptb,nptr + ,nw1,nw2,nb1,nshft,ient,nwdat,nwtot,nhdate,nhtime,nsdate,nstime real xflo,yflo,dfx,dfy,xxlo,xxhi,yylo,yyhi,x,dx,ee,dee + ,edlo,edhi,edent * integer inttyq,inttyp,nchscn real reltyp external inttyq,inttyp,nchscn,reltyp C DATA AVENAM/'*','/','+','%','&',' '/ DATA TNDEF/'X', 'Y'/ C +SELF,IF=UNIX,IF=LINUX. CALL MN_ERR('MN_AVF','Avehist files not supported under Linux') RETURN +SELF,IF=-UNIX,-LINUX. C IF(IDELIM.EQ.0) THEN NJUNK = INTTYQ(.TRUE.,IDELIM) CALL RESTYQ ENDIF C NDHIS0 = NDHIS C IF(FIL_AV.EQ.' ' .OR. 1 (IDELIM.GT.0 .AND. IDELIM.NE.ICHAR(':'))) THEN CALL MN_FIL(2,LUNAIN,FIL_AV,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 ELSE REWIND LUNAIN ENDIF C NIDL = 0 NIDR = 0 QZERO = .FALSE. 2000 CONTINUE CALL WAITYQ('Give histogram number(s): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 8000 IF(NNID.GT.1) THEN CALL M_EMSG('MN_AVF','AVEHST does not know about' // 1 ' secondary identifiers') CALL MN_ERR('MN_AVF','It will be ignored') ENDIF C IF(NIDL.GE.100) THEN CALL M_EMSG('MN_AVF','Ran out of space to store plot' // 1 ' numbers to get') CALL MN_ERR('MN_AVF' + ,'Issue AVE_FETCH command again to get more plots.') GOTO 2200 ENDIF C IF(IDA1.EQ.0 .OR. IDA1.NE.IDA2) QZERO = .TRUE. NIDL = NIDL + 1 IDLST1(NIDL) = IDA1 IDLST2(NIDL) = IDA2 IF(IDELIM.GE.0) GOTO 2000 2200 CONTINUE IF(NIDL.LE.0) GOTO 8000 C C READ IN THE DATA C IDB = NDIDB 2500 CONTINUE READ(LUNAIN,'(A)',ERR=9100,END=2461) ATEXT LENA = LNBLNK(ATEXT) GOTO 2465 2461 CONTINUE IF(.NOT.QZERO) CALL MN_MES(LUNTTO,'ME',' End of file reached') GOTO 8000 C C SEE IF THIS IS THE HISTOGRAM DEFINITION CARD C 2465 CONTINUE C C Data - with a compressed file it can start in column 1 C IF(ATEXT(1:1).EQ.' ' .OR. + (ATEXT(1:1).GE.'0' .AND. ATEXT(1:1).LE.'9') .OR. + ATEXT(1:1).EQ.'-') THEN GOTO 2500 C C COMMENT CARD C ELSEIF(ATEXT(1:1).EQ.';') THEN GOTO 2500 ENDIF C C CARD MUST BE A HISTOGRAM DEFINITION CARD C CALL QUOTYP(ATEXT(2:LENA)) IDF = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 CALL RESTYP CICB READ(ATEXT(2:),*,ERR=9100) IDF IF(IDLST1(1).NE.0) THEN DO 2470 IL=1,NIDL IF(IDLST1(IL).EQ.0 .OR. 1 (IDF.GE.IDLST1(IL) .AND. IDF.LE.IDLST2(IL))) THEN GOTO 2550 ENDIF 2470 CONTINUE GOTO 2500 ENDIF 2550 CONTINUE C C SEE IF THIS HISTOGRAM TYPE IS SUPPORTED C NTYPE = 0 DO 2560 IT=1,MAVEF-1 IF(ATEXT(1:1).EQ.AVENAM(IT)) THEN NTYPE = IT GOTO 2570 ENDIF 2560 CONTINUE CALL MN_ERR('MN_AVF','Histogram type ' // ATEXT(1:1) // + ' not supported') GOTO 6000 2570 CONTINUE C C TYPE 1 IS A HISTOGRAM WITHOUT ERROR BARS C TYPE 2 IS A HISTOGRAM WITH ERROR BARS C TYPE 3 IS A HISTOGRAM WITH ERROR BARS C TYPE 4 IS A VARIABLE BINNED HISTOGRAM C TYPE 5 IS A SCATTER PLOT C IF(NTYPE.LE.3) THEN C '(I,F,F,I,A)' 2600 IDA = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(IDA.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2600 2610 XFLO = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(XFLO.EQ.0.0 .AND. NCHSCN().EQ.0) GOTO 2610 2620 DFX = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(DFX.EQ.0.0 .AND. NCHSCN().EQ.0) GOTO 2620 2630 NBINX = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(NBINX.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2630 CICB READ(ATEXT(2:),*,ERR=9100) IDA,XFLO,DFX,NBINX NNUM = 4 NDIM = 1 NWPPT = 2 NWRD = NWPPT*NBINX ELSEIF(NTYPE.EQ.4) THEN C '(1X,I12,I12,A)' 2700 IDA = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(IDA.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2700 2710 NBINX = INTTYP(.TRUE.,IDELIM) IF(NBINX.LE.0 .AND. IDELIM.GT.0) GOTO 9100 IF(NBINX.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2710 CICB READ(ATEXT(2:),*,ERR=9100) IDA,NBINX NNUM = 2 NDIM = -1 NWPPT = 4 NWRD = NWPPT*NBINX ELSEIF(NTYPE.EQ.5) THEN 2800 IDA = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(IDA.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2800 2810 XFLO = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(XFLO.EQ.0.0 .AND. NCHSCN().EQ.0) GOTO 2810 2820 DFX = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(DFX.EQ.0.0 .AND. NCHSCN().EQ.0) GOTO 2820 2830 NBINX = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(NBINX.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2830 2840 YFLO = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(YFLO.EQ.0.0 .AND. NCHSCN().EQ.0) GOTO 2840 2850 DFY = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(DFY.EQ.0.0 .AND. NCHSCN().EQ.0) GOTO 2850 2860 NBINY = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(NBINY.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2860 2870 NBPPTA = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(NBPPTA.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2870 2880 NWAVE = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 9100 IF(NWAVE.EQ.0 .AND. NCHSCN().EQ.0) GOTO 2880 CICB READ(ATEXT(2:),*,ERR=9100) IDA,XFLO,DFX,NBINX,YFLO,DFY,NBINY CICB 1 ,NBPPTA,NWAVE NNUM = 9 NDIM = 2 NWPPT = 2 NWRD = NWPPT*NBINX*NBINY IBMSK = 0 DO 2900 II=1,NBPPTA IBMSK = IBSET(IBMSK,II-1) 2900 CONTINUE ENDIF C C CLEAR OUT THE TYPSCN BUFFER C CALL ZERTYP('.FALSE.') C C CHECK THAT I HAVE ENOUGH INTERMEDIATE STORAGE SPACE C IF(NTYPE.EQ.1) THEN NWAVE = NBINX+2 ELSEIF(NTYPE.EQ.2 .OR. NTYPE.EQ.3) THEN NWAVE = 2*(NBINX+2) ELSEIF(NTYPE.EQ.4) THEN NWAVE = 4*(NBINX+2) ENDIF IF(NWAVE.GT.MPNTMX) THEN WRITE(TXTERR,'('' I do not have enough intermediate'' 1 ,'' storage space to read in histogram'',I6)') IDA CALL MN_ERR('MN_AVF',TXTERR) GOTO 6000 ENDIF C C FIND OUT WHERE THE TITLE STARTS C NCPOS = 1 DO 2920 II=1,NNUM INDX = INDEX(ATEXT(NCPOS:),',') IF(NTYPE.EQ.4 .AND. INDX.EQ.0) INDX = 25 IF(INDX.GT.0) NCPOS = NCPOS + INDX 2920 CONTINUE C C CALL MN_SPC(ATEXT(NCPOS:),TITLE) TITLE = ATEXT(NCPOS:) C C GET RID OF MULTIPLE 0'S IN SLICE C IF(INDEX(TITLE,'Slice').GT.0) THEN 2950 CONTINUE IND = INDEX(TITLE,'00 ') IF(IND.EQ.0) THEN LENT = LNBLNK(TITLE) IF(TITLE(LENT-1:LENT).EQ.'00') THEN TITLE = TITLE(1:LENT-1) GOTO 2950 ENDIF ELSE IF(IND.GT.5) THEN TITLE = TITLE(1:IND-1) // TITLE(IND+1:) GOTO 2950 ENDIF ENDIF C C FIND OUT WHERE TO STORE THE HISTOGRAM C NBPPT = 0 NTMODE = 0 CALL MN_HNW(IDA,IDB,NDIM,NWRD,NH,NPTRH,NPTRD,NWH,NBPPT,NTMODE) IF(NH.LE.0) GOTO 8000 C C READ IN THE ENTRIES C 3000 CONTINUE IF(NTYPE.EQ.1) THEN N1 = 1 N2 = NBINX+2 READ(LUNAIN,*,ERR=3100,END=3200) (BUFDAT(II),II=N1,N2) NPNT = NBINX NWPT = NBINX XXLO = XFLO XXHI = XFLO + FLOAT(NBINX)*DFX ELSEIF(NTYPE.EQ.2 .OR. NTYPE.EQ.3) THEN N1 = 1 N2 = NBINX + 2 N3 = NBINX + 2 + 1 N4 = 2 * (NBINX+2) READ(LUNAIN,*,ERR=3100,END=3200) (BUFDAT(II),II=N1,N2) 1 ,(BUFDAT(II),II=N3,N4) NPNT = NBINX NWPT = NBINX XXLO = XFLO XXHI = XFLO + FLOAT(NBINX)*DFX ELSEIF(NTYPE.EQ.4) THEN N1 = 1 N2 = 4*NBINX READ(LUNAIN,*,ERR=3100,END=3200) (BUFDAT(II),II=N1,N2) NPNT = NBINX NWPT = NBINX XXLO = 1.0E+12 XXHI = -1.0E+12 ELSEIF(NTYPE.EQ.5) THEN N1 = 1 N2 = NWAVE C READ(LUNAIN,*) IBFDAT C READ(LUNAIN,*,ERR=3100,END=3200) (IBFDAT(II),II=N1,N2) NLINE = (NWAVE-1)/8 + 1 DO 3060 II=1,NLINE N1 = (II-1)*8 + 1 N2 = MIN0(NWAVE,II*8) READ(LUNAIN,'(8(1X,Z8,1X))',ERR=3100,END=3200) 1 (IBFDAT(JJ),JJ=N1,N2) C WRITE(LUNTTO,'(1X,I4,'':'',8(Z8,'',''))') C 1 N1,(IBFDAT(JJ),JJ=N1,N2) 3060 CONTINUE NPNT = NBINX * NBINY NWPT = (NBINX+2) * (NBINY+2) XXLO = XFLO XXHI = XFLO + FLOAT(NBINX)*DFX YYLO = YFLO YYHI = YFLO + FLOAT(NBINY)*DFY ENDIF GOTO 3300 3100 CONTINUE WRITE(TXTERR,'(''Error reading in histogram'',I6)') IDA CALL MN_ERR('MN_AVF',TXTERR) GOTO 6000 3200 CONTINUE WRITE(TXTERR,'('' MN_AVF: End of file reached'' 1 ,'' reading in histogram'',I6)') IDA CALL MN_ERR('MN_AVF',TXTERR) GOTO 8000 3300 CONTINUE EDLO = 1.0E+30 EDHI = -1.0E+30 EDENT = 0.0 NYB = -1 NXB = 0 NNXY = 0 DO 5000 II=1,NWPT NPTB = NWPPT*(II-1) NPTR = NPTRD + NPTB - 1 IF(NTYPE.LE.3) THEN X = XXLO + (FLOAT(II-1)+0.5)*DFX DX = 0.5 * DFX EE = BUFDAT(II) IF(NTYPE.EQ.1) THEN DEE = SQRT(ABS(EE)) ELSE DEE = BUFDAT(II+NBINX+2) ENDIF IF(NDIM.LT.0) THEN RDAT(NPTR+1) = X RDAT(NPTR+2) = EE RDAT(NPTR+3) = DX RDAT(NPTR+4) = DEE ELSE RDAT(NPTR+1) = EE RDAT(NPTR+2) = DEE ENDIF ELSEIF(NTYPE.EQ.4) THEN X = BUFDAT(NPTB+1) DX = 0.5*BUFDAT(NPTB+2) EE = BUFDAT(NPTB+3) DEE = BUFDAT(NPTB+4) RDAT(NPTR+1) = X RDAT(NPTR+2) = EE RDAT(NPTR+3) = DX RDAT(NPTR+4) = DEE XXLO = AMIN1(XXLO,X-DX) XXHI = AMAX1(XXHI,X+DX) ELSEIF(NTYPE.EQ.5) THEN NYB = NYB + 1 IF(NYB.GT.NBINY+1) THEN NXB = NXB + 1 NYB = 0 ENDIF NW1 = NBPPTA*(II-1)/32 + 1 NW2 = (NBPPTA*II-1)/32 + 1 NB1 = MOD(NBPPTA*(II-1),32) + 1 NSHFT = NB1 - 1 IENT = ISHFT(IBFDAT(NW1),-NSHFT) IF(NW2.NE.NW1) THEN NSHFT = 32 - NB1 + 1 IENT = IOR(IENT,ISHFT(IBFDAT(NW2),NSHFT)) ENDIF IENT = IAND(IENT,IBMSK) EE = FLOAT(IENT) DEE = SQRT(ABS(EE)) IF(NXB.GT.0 .AND. NXB.LE.NBINX .AND. 1 NYB.GT.0 .AND. NYB.LE.NBINY) THEN NNXY = NBINX*(NYB-1) + NXB NPTR = NPTRD + NWPPT*(NNXY-1) - 1 RDAT(NPTR+1) = EE RDAT(NPTR+2) = DEE ELSE GOTO 5000 ENDIF ENDIF EDENT = EDENT + EE EDLO = AMIN1(EDLO,EE-DEE) EDHI = AMAX1(EDHI,EE+DEE) 5000 CONTINUE C C WRITE(LUNTTO,'('' Histogram'',I7,I4,'' Data for'',I6 C 1,'' points read in'')') IDA,IDB,NPNT NIDR = NIDR + 1 C NWDAT = NWPPT * NPNT NWTOT = NWH + NWDAT C IDBIN(1) = NBINX ADLO(1) = XXLO ADHI(1) = XXHI IF(IABS(NDIM).GT.1) THEN IDBIN(2) = NBINY ADLO(2) = YYLO ADHI(2) = YYHI ENDIF C NHDATE = 0 NHTIME = 0 NSDATE = 0 NSTIME = 0 CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB,NDIM,NWPPT,NPNT + ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE,FIL_AV,' ',TNDEF) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C 6000 CONTINUE IF(NIDR.LT.NIDL .OR. QZERO) GOTO 2500 C 8000 CONTINUE C C CLEAR OUT THE TYPSCN BUFFER C CALL ZERTYP('.FALSE.') C C CHECK THAT I GOT THE HISTOGRAMS I WANTED C NNID = 1 CALL MN_HNG('MN_AVF',NNID,NDHIS0,NIDL,IDLST1,IDLST2,IDB,IDB) C 9000 CONTINUE RETURN C 9100 CONTINUE CALL MN_ERR('MN_AVF','Error reading in histograms') C C CLEAR OUT THE TYPSCN BUFFER C CALL ZERTYP('.FALSE.') C RETURN +SELF. END +DECK,mn_bsb. SUBROUTINE MN_BSB(MMODE,IDELIM,IERR) C C MAKE A BACKGROUND SUBTRACTED HISTOGRAM C NMODE = 1 make a normal background subtracted plot C NMODE = 2 same as 1 but make a signed chi difference C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFIT. +CDE,MNINF. +CDE,MNFUN. +CDE,MNCMD. +CDE,MNLUN. C INTEGER JDAF(MFITMX),JDBF(MFITMX) INTEGER IDBINF(2) REAL ADLOF(2),ADHIF(2) C CHARACTER*80 TEXT CHARACTER*80 TITLE LOGICAL QERRL,QERRH DATA IDBB/0/ C IERR = 0 NMODE = MMODE C C CALCULATE THE BACKGROUND SUBTRACTED FUNCTION C IF(.NOT.QSBACK) THEN CALL MN_ERR('MN_BSB','You must first SET BACKGROUND to' // + ' specify the background function(s)') IERR = 1 GOTO 9000 ENDIF C DO 1000 NH=1,NHFIT NDFUN = NDFUN + 1 JDBF(NH) = -(980 + NDFUN) CALL MN_FFL(IBCKF,1,NH,JDAF(NH),JDBF(NH)) WRITE(TXTMES,'('' Plot'',I7,I4,'':'')') 1 IDFITA(NH),IDFITB(NH) CALL MN_MES(LUNTTO,'ME',TXTMES) C C GET THE SECONDARY ID FOR THE BACKGROUND C IF(QRFILE .OR. IDELIM.EQ.0 .OR. 1 IDFITA(NH).NE.IDBCKA(NH) .OR. + IDFITB(NH).EQ.IDBCKB(NH) .OR. + IDBCKB(NH).LE.0) THEN IDBB = NDIDB + 1 TEXT = 'Give secondary ID for background' // 1 ' subtracted histogram (= ):' WRITE(TEXT(61:63),'(I3)') IDBB LENT = LENOCC(TEXT) CALL WAITYQ(TEXT(1:LENT+1)) CALL MN_SEC(IDBB,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 IDBCKB(NH) = IDBB ENDIF IDBCKA(NH) = IDFITA(NH) WRITE(TXTMES 1 ,'('' Background subtracted plot will be stored as plot'' 1 ,I7,I4)') IDBCKA(NH),IDBCKB(NH) CALL MN_MES(LUNTTO,'M',TXTMES) WRITE(TXTMES 1 ,'('' Background function will be stored as plot '' 1 ,I7,I4)') JDAF(NH),JDBF(NH) CALL MN_MES(LUNTTO,'ME',TXTMES) 1000 CONTINUE C C FIND OUT WHAT SORT OF SUBTRACTION TO DO C IF(NMODE.LE.0 .OR. NMODE.GT.2) THEN NMODE = 1 4000 CONTINUE CALL WAITYQ('Simple subtraction (1) or divide by' // 1 ' background also (2) ( = 1): ') NVAL = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 4100 IF(IERR.NE.0) GOTO 9000 IF(NVAL.EQ.0 .OR. IABS(NVAL).GT.2) THEN WRITE(TXTERR,'(1X,I4,'' is not a valid mode'')') CALL MN_ERR('MN_BSB',TXTERR) GOTO 9000 ENDIF NMODE = NVAL 4100 CONTINUE ENDIF C C NOW SUBTRACT BACKGROUND C DO 6000 NH=1,NHFIT C C GET THE FUNCTION HISTOGRAM C IDAF = JDAF(NH) IDBF = JDBF(NH) CALL MN_HGT(IDAF,IDBF,NHF) NPTRHF = NPTRH NPTRDF = NPTRD NDIMF = NDIM NWPPTF = NWPPT NPNTF = NPNT CALL UCOPY_i(IDBIN,IDBINF,IABS(NDIMF)) CALL UCOPY_r(ADLO,ADLOF,IABS(NDIMF)) CALL UCOPY_r(ADHI,ADHIF,IABS(NDIMF)) CALL AMNOFF(NDIMF,NWPPTF,NOFFF,NOFFLF,NOFFHF,QERRL,QERRH) C C GET THE DATA HISTOGRAM C IDA = IDFITA(NH) IDB = IDFITB(NH) NPTRHU = IFPTRH(NH) NPTRDU = IFPTRD(NH) CALL MN_FGT(IDA,IDB,NHF) NDIMU = NDIM NWPPTU = NWPPT NPNTU = NPNT C IF(IABS(NDIM).NE.1) THEN CALL MN_ERR('MN_BSB' + ,'Background subtraction only works for 1-d histograms') GOTO 9000 ENDIF C C AMNOFF is not correct for fitted histograms C NOFFU = IABS(NDIMU) + 1 NOFFLU = 2*(IABS(NDIMU) + 1) NOFFHU = 3*(IABS(NDIMU) + 1) QERRL = NWPPTU.GT.1*(IABS(NDIMU)+1) QERRH = NWPPTU.GT.2*(IABS(NDIMU)+1) C IDAB = IDBCKA(NH) IDBB = IDBCKB(NH) TITLE = 'Histogram Background Subtracted' WRITE(TITLE(11:22),'(I8,I4)') IDA,IDB C C GET THE STORAGE SPACE FOR THE NEW HISTOGRAM C IF(IABS(NDIMU).EQ.1) THEN NDIM2 = NDIMU NWPPT2 = NWPPTU ELSE NDIM2 = 2 NWPPT2 = 1 IF(QERRL) NWPPT2 = 2 IF(QERRH) NWPPT2 = 3 ENDIF CALL AMNOFF(NDIM2,NWPPT2,NOFF2,NOFFL2,NOFFH2,QERRL,QERRH) C NWRD2 = NPNTU*NWPPT2 NBPPT2 = 32 NTMOD2 = NTMODE CALL MN_HNW(IDAB,IDBB,NDIM2,NWRD2,NH2,NPTRH2,NPTRD2,NWH2 1 ,NBPPT2,NTMOD2) IF(NH2.LE.0) GOTO 9000 C CALL AMNOFF(NDIM2,NWPPT2,NOFF2,NOFFL2,NOFFH2,QERRL,QERRH) C IF(NDIMU.EQ.NDIM2 .AND. NWPPTU.EQ.NWPPT2) + CALL UCOPY_r(RFIT(NPTRDU),RDAT(NPTRD2),NPNTU*NWPPTU) C EDENT2 = 0.0 EDLO2 = 1.0E+30 EDHI2 = -1.0E+30 YERRL = 0.0 YERRH = 0.0 DO 5500 II=1,NPNT NPTR1 = NPTRDU + NWPPTU*(II-1) - 1 NPTR2 = NPTRD2 + NWPPT2*(II-1) - 1 NPTRF = NPTRDF + NWPPTF*(II-1) - 1 YFIT = RFIT(NPTR1+NOFFU) IF(QERRL) YERRL = RFIT(NPTR1+NOFFLU) IF(QERRH) YERRH = RFIT(NPTR1+NOFFHU) YFUN = RDAT(NPTRF+NOFFF) IF(NMODE.EQ.1) THEN YDAT = YFIT - YFUN ELSE IF(YFUN.EQ.0.0) THEN YDAT = 0.0 YERRL = 0.0 YERRL = 0.0 ELSE YDAT = YFIT/YFUN - 1.0 IF(QERRL) YERRL = YERRL / YFUN IF(QERRH) YERRH = YERRH / YFUN ENDIF ENDIF IF(.NOT.QERRH) YERRH = YERRL EDENT2 = EDENT2 + YDAT EDLO2 = AMIN1(EDLO2,YDAT-YERRL) EDHI2 = AMAX1(EDHI2,YDAT+YERRH) RDAT(NPTR2+NOFF2) = YDAT IF(QERRL) RDAT(NPTR2+NOFFL2) = YERRL IF(QERRH) RDAT(NPTR2+NOFFH2) = YERRH 5500 CONTINUE C IF(NDIM2.EQ.1) THEN ACONT(2) = EDENT ELSEIF(NDIM2.EQ.2) THEN ACONT(5) = EDENT ENDIF C C FILL IN THE HEADER C NWTOT = NWH2 + NWRD2 CALL M_RTIM(NHDAT2,NHTIM2) NSDAT2 = NSDATE NSTIM2 = NSTIME CALL MN_HDU(RDAT(NPTRH2),NWTOT,NWH2,NWRD2,IDAB,IDBB 1 ,NDIM2,NWPPT2,NPNTU,NHDAT2,NHTIM2,NSDAT2,NSTIM2,NTMOD2 + ,EDENT2,EDLO2,EDHI2,IDBINF,ADLOF,ADHIF,NBPPT2,ACONT) CALL MN_PTU(NH2,NWTOT,IDAB,IDBB,NPTRH2,NPTRD2,TITLE 1 ,'Generated internally',' ',TFNAM(1,NH)) CALL MN_MSU(IDAB,IDBB,NDIM2,NWH2,NH2) 6000 CONTINUE C 9000 CONTINUE RETURN END +DECK,mn_cdf. SUBROUTINE MN_CDF(IDELIM) C C READS IN A SERIES OF DATA POINTS FROM A FILE C THE ORDER CARD OR THE CURRENT SET OF ORDER PARAMETERS C DEFINE THE NUMBER OF WORDS PER POINT C Times can also be interpretted. Recognized forms and the ORDER name are: C DATE yymmdd C TIME hhmmss or hhmm (first occurence is used to find out which it is) C VAXTIME char*23 C CAN ALSO BE USED TO READ IN AN NTUPLE C THE NTUPLE CARD MUST BE PRESENT AND THE ORDER CARD NOT C THE NTUPLE CARD MUST CONTAIN THE NUMBER OF DIMENSIONS AND THE C VARIABLE NAMES C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNTYQ. +CDE,MNCMD. +CDE,MNCMT. +CDE,MNTIM. +CDE,MNLUN. C integer mcrd PARAMETER (MCRD=9) CHARACTER*10 CRDNAM(MCRD) C integer mpntmx PARAMETER (MPNTMX=100 000) +CDE,MNSCR. REAL BUFDAT(MPNTMX) EQUIVALENCE(SCRATCH(1),BUFDAT(1)) C INTEGER IDBIN(MDIMMX) REAL ADLO(MDIMMX),ADHI(MDIMMX) REAL ACONT(3) CHARACTER*10 TCOMM CHARACTER*32 TNAME(MDIMMX),TNDEF(2) C INTEGER IDLSTA(100),IDLSTB(100) C CHARACTER*255 TCARD,TCRD2 CHARACTER*133 TEXT CHARACTER*80 TITLE CHARACTER*23 CTIME,CTIME1,CTIME2 CHARACTER*1 TMODE LOGICAL QOPEN,QXERR,QYERR,QXERRL,QXERRH,QYERRL,QYERRH LOGICAL QCID,QCTIT,QCLIM,QCNTU,QCORD,QCTIM,QTIME,QMAX,QEND,QEOF REAL RNUM(MDIMMX) INTEGER IXREF(MDIMMX) INTEGER NNUM,NDUMMY * integer idelim,ndhis0,ierr,nidl,idtref,itmref,idbref + ,lent,lenc,lnblnk + ,jcmd,ida,idb,istr,nchar,nval,ndim,nchr,ii,nwppt + ,npntmx,nord,i,j,npnt,maxnum,nloop,nchr1,nchr2,idate,itime + ,idbtim,nptr,nwrd,nbppt,ntmode,nh,nptrh,nptrd,nwh + ,nptr1,nptr2,nn,nwdat,nwtot,nhdate,nhtime,nsdate,nstime,nnid real rval,xxlo,xxhi,x,y,dxl,dxh,dyl,dyh,edlo,edhi,edent + ,x00,x01,x10,x11 * integer icmtyp,istrng,inttyp,isltyp,isttyp real reltyp,am_tdif external icmtyp,istrng,inttyp,isltyp,isttyp,reltyp,am_tdif C DATA CRDNAM/'ID', 'TITLE', 'LIMIT', 1 'DATA', 'END', 'ORDER', 'NTUPLE', 'TIME', ' '/ DATA TNDEF/'X', 'Y'/ C NDHIS0 = NDHIS C QOPEN = .FALSE. CALL MN_FIL(2,LUNDIN,FIL_DT,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 QOPEN = .TRUE. C NIDL = 0 C C Set up the reference time and time mode C TMODE = TIMNAM(NMTIME)(1:1) IDTREF = NDTREF ITMREF = NTMREF IDBREF = 0 IF(IDTREF.NE.0 .OR. ITMREF.NE.0) CALL M_PKTS(IDTREF,ITMREF,IDBREF) C QCID = .FALSE. QCTIT = .FALSE. QCLIM = .FALSE. QCNTU = .FALSE. QCORD = .FALSE. QCTIM = .FALSE. QMAX = .FALSE. TCARD = ' ' C 2500 CONTINUE READ(LUNDIN,'(A)',ERR=9100,END=9200) TEXT C IF(TEXT(1:1).EQ.TSCOMM .OR. TEXT(1:2).EQ.' '//TSCOMM) THEN GOTO 2500 ENDIF C LENT = LNBLNK(TEXT) IF(LENT.LE.0) GOTO 2500 C IF(TCARD.EQ.' ') THEN TCARD = TEXT ELSE LENC = LNBLNK(TCARD) TCRD2 = TCARD(1:LENC) // TEXT(1:LENT) TCARD = TCRD2 ENDIF LENC = LNBLNK(TCARD) IF(TCARD(LENC:LENC).EQ.TSCONT) THEN TCRD2 = TCARD(1:LENC-1) TCARD = TCRD2 GOTO 2500 ENDIF C CALL QUOTYP(TCARD // ' ') 2600 CONTINUE QEND = .FALSE. QEOF = .FALSE. JCMD = ICMTYP(.TRUE.,IDELIM,CRDNAM) COMND2 = ' ' IF(JCMD.GT.0) COMND2 = CRDNAM(JCMD) C C SEE IF WE HAVE STARTED READING DATA ALREADY C IF(JCMD.EQ.0) THEN CALL RESTYP RVAL = RELTYP(.TRUE.,IDELIM) IF(RVAL.NE.0.0 .OR. IDELIM.LE.0) THEN CALL RESTYP GOTO 3000 ENDIF ENDIF IF(IDELIM.GT.0 .OR. JCMD.EQ.0) THEN CALL MN_DCK(IDELIM,JCMD,MCRD,CRDNAM,IERR) IF(IERR.EQ.2) CALL MN_UNK('MN_CDF') GOTO 9000 ENDIF C C READ IN THE NUMBERS OR TEXT IF APPROPRIATE C TCARD = ' ' NNUM = 0 IF(COMND2.EQ.'ID' .OR. COMND2.EQ.'LIMIT') THEN IF(IDELIM.LT.0) THEN CALL MN_ERR('MN_CDF','Error in ' // COMND2 // + ' card.') GOTO 9000 ENDIF 2620 CONTINUE RVAL = RELTYP(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 2625 IF(IERR.GT.0) GOTO 9000 NNUM = NNUM + 1 RNUM(NNUM) = RVAL IF(NNUM.LT.2 .AND. IDELIM.EQ.0) GOTO 2620 ENDIF 2625 CONTINUE C C IDENTIFIER CARD C IF(COMND2.EQ.'ID') THEN QCID = .TRUE. IDA = NINT(RNUM(1)) IF(NNUM.GT.1) THEN IDB = NINT(RNUM(2)) IF(IDB.LT.0 .OR. IDB.GE.1000) THEN WRITE(TXTERR,'(1X,I4,'' is not valid as a secondary'' 1 ,'' ID'')') IDB CALL M_EMSG('MN_CDF',TXTERR) WRITE(TXTERR,'('' It will be set to'',I4)') NDIDB CALL M_EMSG('MN_CDF',TXTERR) IDB = NDIDB ENDIF ELSE IDB = NDIDB ENDIF C C TITLE CARD C ELSEIF(COMND2.EQ.'TITLE') THEN QCTIT = .TRUE. IF(IDELIM.LT.0) THEN WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' Error in '',A,'' card.'' 1 ,'' No title given'')') IDA,IDB,COMND2 CALL M_EMSG('MN_CDF',TXTERR) GOTO 2500 ENDIF ISTR = ISTRNG(.TRUE.,TEXT,NCHAR) CALL ZERTYP('.FALSE.') TITLE = TEXT(1:NCHAR) C C LIMITS C ELSEIF(COMND2.EQ.'LIMIT') THEN IF(NNUM.LT.2) THEN CALL M_EMSG('MN_CDF','Must specify lower and upper' // + ' limits on LIMIT card') GOTO 2500 ENDIF QCLIM = .TRUE. XXLO = RNUM(1) XXHI = RNUM(2) IF(XXHI.LE.XXLO) THEN WRITE(TXTERR,'(''Error in specified limits'',2G11.4 1 ,'' They will be ignored'')') XXLO,XXHI CALL M_EMSG('MN_CDF',TXTERR) XXLO = 0.0 XXHI = 0.0 ENDIF C C SIGNAL BEGINNING OF DATA POINTS C ELSE IF(COMND2.EQ.'DATA') THEN GOTO 3000 C C SIGNAL END OF DATA - NOT VALID AS I AM NOT READING DATA POINTS C ELSE IF(COMND2.EQ.'END') THEN CALL M_EMSG('MN_CDF','END card not valid here. I am not' // + ' reading in data points') C C DEFINE THE ORDER OF THE VARIABLES C ELSE IF(COMND2.EQ.'ORDER') THEN QCORD = .TRUE. CALL M_SORD(1,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C C Define the time mode and the reference time C ELSE IF(COMND2.EQ.'TIME') THEN QCTIM = .TRUE. CALL M_STIM(1,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C TMODE = TIMNAM(NMTIME) IDTREF = NDTREF ITMREF = NTMREF IDBREF = 0 IF(IDTREF.NE.0 .OR. ITMREF.NE.0) + CALL M_PKTS(IDTREF,ITMREF,IDBREF) C C NTUPLE CARD C ELSE IF(COMND2.EQ.'NTUPLE') THEN QCNTU = .TRUE. IF(IDELIM.LT.0) THEN CALL MN_ERR('MN_CDF','Error in ' // COMND2 // + ' card. No dimension given') GOTO 9000 ENDIF NVAL = INTTYP(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 NDIM = NVAL C C GET THE VARIABLE NAMES C NNUM = 0 NDUMMY = 0 CALL VZERO_i(IXREF,20) DO 2640 II=1,NDIM 2630 CONTINUE NCHR = ISLTYP(.TRUE.,IDELIM,TCOMM) NNUM = NNUM + 1 CALL M_LUPC(TCOMM(1:NCHR),TNAME(II)) IF(TNAME(II).EQ.'DUMMY' .AND. IDELIM.GE.0) THEN NDUMMY = NDUMMY + 1 GOTO 2630 ELSE IXREF(NNUM) = II ENDIF IF(IDELIM.LT.0) GOTO 2645 2640 CONTINUE 2645 CONTINUE IF(NNUM.LT.NDIM+NDUMMY) THEN WRITE(TXTERR,'(''Not enough variable'' 1 ,'' names given for Ntuple'',I7,I4)') IDA,IDB CALL MN_ERR('MN_CDF',TXTERR) GOTO 9000 ENDIF ENDIF GOTO 2500 C C FINISHED READING THE DATA CARDS C CHECK WHAT I HAVE SPECIFIED AND SET REST TO DEFAULT C 3000 CONTINUE IF(.NOT.QCID) THEN CALL M_EMSG('MN_CDF','You have not given ID card.' // + ' The histogram id will be set to 1') IDA = 1 IDB = NDIDB ENDIF NIDL = NIDL + 1 IF(NIDL.GT.100) THEN CALL M_EMSG('MN_CDF','Ran out of room to keep track' // + ' of which plots have been fetched') CALL M_EMSG('MN_CDF','This does not affect the fetch') NIDL = 100 ENDIF IDLSTA(NIDL) = IDA IDLSTB(NIDL) = IDB C IF(.NOT.QCTIT) THEN TITLE = ' ' ENDIF C IF(.NOT.QCLIM) THEN XXLO = 0.0 XXHI = 0.0 ENDIF C IF(.NOT.QCNTU) THEN TNAME(1) = TNDEF(1) TNAME(2) = TNDEF(2) ENDIF C QTIME = .FALSE. IF(QCNTU) THEN IF(QCORD) THEN CALL M_EMSG('MN_CDF','ORDER card is invalid' // + ' for an Ntuple. It will be ignored') ENDIF NDIM = -IABS(NDIM) NWPPT = IABS(NDIM) NPNTMX = MPNTMX / IABS(NDIM) C C USE THE ORDER TO SET UP A CROSS-REFERENCE TABLE FOR THE NUMBERS C ELSE NDIM = -1 CALL VZERO_i(IXREF(1),20) NORD = 0 DO 3100 I=1,20 IF(IORDMN(I).LE.0) GOTO 3110 DO 3090 J=1,MORD-1 IF(IORDMN(I).EQ.J) THEN IF(J.LE.4) THEN IXREF(I) = J ELSEIF(J.LE.8) THEN IXREF(I) = J - 2 ELSEIF(J.LE.12) THEN IXREF(I) = J - 6 ELSEIF(J.EQ.MDUMMY) THEN IXREF(I) = 0 C All date and time formats ELSEIF(J.GT.MDUMMY) THEN QTIME = .TRUE. IXREF(I) = -(J-MDUMMY) ENDIF GOTO 3091 ENDIF 3090 CONTINUE 3091 CONTINUE IF(IXREF(I).NE.0) NORD = NORD + 1 3100 CONTINUE 3110 CONTINUE NWPPT = 2 * ((NORD - 1) / 2 + 1) NPNTMX = MPNTMX / NWPPT ENDIF C NPNT = 0 MAXNUM = 0 QXERR = .FALSE. QYERR = .FALSE. QXERRL = .FALSE. QXERRH = .FALSE. QYERRL = .FALSE. QYERRH = .FALSE. CALL VZERO_r(BUFDAT,MPNTMX) C C DON'T READ IN THE NEXT LINE IF WE HAVE ALREADY STARTED READING DATA C IF(JCMD.EQ.0) GOTO 4100 C 4000 CONTINUE READ(LUNDIN,'(A)',ERR=4040,END=4050) TCARD GOTO 4100 4040 CONTINUE CALL MN_ERR('MN_CDF','Error reading in data cards ***') GOTO 5000 4050 CONTINUE QEOF = .TRUE. GOTO 5000 4100 CONTINUE CALL QUOTYP(TCARD // ' ') TCARD = ' ' C C EXTRACT THE DATA C NNUM = 0 4200 CONTINUE C C SEE IF WE ARE STARTING A NEW PLOT C JCMD = ICMTYP(.TRUE.,IDELIM,CRDNAM) IF(IDELIM.EQ.ICHAR(TSCOMM)) GOTO 4250 COMND2 = ' ' IF(JCMD.GT.0) THEN COMND2 = CRDNAM(JCMD) IF(COMND2.NE.'END') THEN CALL RESTYP ELSE QEND = .TRUE. ENDIF GOTO 5000 ELSE CALL RESTYP ENDIF C C Dummy C IF(IXREF(NNUM+1).EQ.0) THEN NCHR = ISTTYP(.TRUE.,IDELIM,TEXT) C C Normal number C ELSEIF(QCNTU .OR. IXREF(NNUM+1).GT.0) THEN RVAL = RELTYP(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.GT.0) THEN IF(IERR.EQ.2 .AND. IDELIM.GE.0) GOTO 4200 IF(IERR.EQ.2 .AND. IDELIM.LT.0) GOTO 4250 GOTO 9000 ENDIF C C See if this entry is supposed to be a time C ELSEIF(.NOT.QCNTU) THEN NLOOP = 0 4220 CONTINUE NLOOP = NLOOP + 1 IF(IXREF(NNUM+1).EQ.-6) THEN NCHR1 = ISTTYP(.TRUE.,IDELIM,CTIME1) NCHR2 = ISTTYP(.TRUE.,IDELIM,CTIME2) CTIME = ' ' IF(NCHR1.GT.0 .AND. NCHR2.GT.0) + CTIME = CTIME1(1:NCHR1) // ' ' // CTIME2(1:NCHR2) CALL M_VTIM(CTIME,IDATE,ITIME) ELSE NVAL = INTTYP(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.GT.0) THEN IF(IERR.EQ.2 .AND. IDELIM.GE.0) GOTO 4200 IF(IERR.EQ.2 .AND. IDELIM.LT.0) GOTO 4250 GOTO 9000 ENDIF ENDIF C IF(IXREF(NNUM+1).EQ.-1) THEN IF(NLOOP.EQ.1) IDATE = NVAL IF(NLOOP.EQ.2) ITIME = NVAL ELSEIF(IXREF(NNUM+1).EQ.-2) THEN IDATE = NVAL ITIME = 0 ELSEIF(IXREF(NNUM+1).EQ.-3) THEN IDATE = 800101 ITIME = NVAL ELSEIF(IXREF(NNUM+1).EQ.-4) THEN IF(NLOOP.EQ.1) IDATE = NVAL IF(NLOOP.EQ.2) ITIME = NVAL*100 ELSEIF(IXREF(NNUM+1).EQ.-5) THEN IDATE = 800101 ITIME = NVAL*100 ENDIF IF(NLOOP.EQ.1 .AND. + (IXREF(NNUM+1).EQ.-1 .OR. IXREF(NNUM+1).EQ.-4)) GOTO 4220 C *ICB IF(IDATE.LT.800101 .OR. IDATE.GT.1991231 .OR. IF(IDATE.LT.000101 .OR. IDATE.GT.991231 .OR. + ITIME.LT.0 .OR. ITIME.GT.240000) THEN CALL M_EMSG('MN_CDF','Bad time found in card:') CALL MN_ERR('MN_CDF',TCARD) GOTO 9000 ENDIF CALL M_PKTS(IDATE,ITIME,IDBTIM) C C Store the first point as the reference time if no TIME card C and reference time has not been set C IF(IDTREF.EQ.0 .AND. ITMREF.EQ.0 .AND. NPNT.EQ.0) THEN IDTREF = IDATE ITMREF = ITIME IDBREF = IDBTIM ENDIF RVAL = AM_TDIF(IDBREF,IDBTIM,TMODE) ENDIF C NNUM = NNUM + 1 RNUM(NNUM) = RVAL IF(IDELIM.EQ.0) GOTO 4200 C 4250 CONTINUE C IF(NNUM.LE.0) GOTO 4000 NPNT = NPNT + 1 C IF(NPNT.GT.NPNTMX) THEN IF(.NOT.QMAX) THEN WRITE(TXTERR,'(''I only have temporary storage space'' + ,'' for'',I5,'' points.'')') NPNTMX CALL M_EMSG('MN_CDF',TXTERR) CALL M_EMSG('MN_CDF','I will ignore the rest') ENDIF QMAX = .TRUE. NPNT = NPNTMX GOTO 4000 ENDIF NPTR = NWPPT*(NPNT-1) C IF(QCNTU) THEN IF(NNUM.NE.IABS(NDIM)+NDUMMY) THEN WRITE(TXTERR,'(''Point'',I6,'' has'',I4 + ,'' numbers when I was expecting'',I4,''+'',I4)') + NPNT,NNUM,IABS(NDIM),NDUMMY CALL M_EMSG('MN_CDF',TXTERR) CALL M_EMSG('MN_CDF','It will be ignored') NPNT = NPNT - 1 GOTO 4000 ENDIF DO I=1,NNUM IF(IXREF(I).GT.0) THEN BUFDAT(NPTR + IXREF(I)) = RNUM(I) ENDIF ENDDO ELSE MAXNUM = MAX0(MAXNUM,NNUM) X = 0.0 Y = 0.0 DXL = 0.0 DXH = 0.0 DYL = 0.0 DYH = 0.0 DO 4300 I=1,NNUM IF(IXREF(I).EQ.0) GOTO 4300 C C Time is always assumed to be the x-axis C IF(IXREF(I).GT.0) THEN BUFDAT(NPTR + IXREF(I)) = RNUM(I) ELSE BUFDAT(NPTR + 1) = RNUM(I) ENDIF IF(IXREF(I).EQ.1 .OR. IXREF(I).LT.0) THEN X = RNUM(I) ELSE IF(IXREF(I).EQ.3) THEN QXERR = .TRUE. QXERRL = .TRUE. ELSE IF(IXREF(I).EQ.4) THEN QYERR = .TRUE. QYERRL = .TRUE. ELSE IF(IXREF(I).EQ.5) THEN QXERRH = .TRUE. ELSE IF(IXREF(I).EQ.6) THEN QYERRH = .TRUE. ENDIF 4300 CONTINUE C IF((XXLO.NE.0.0 .OR. XXHI.NE.0.0) .AND. + (X.LT.XXLO .OR. X.GT.XXHI)) THEN WRITE(TXTERR,'(''Point'',2(1PG11.4) + ,'' outside given limits'',2(1PG11.4))') + X,Y,XXLO,XXHI CALL M_EMSG('MN_CDF',TXTERR) CALL M_EMSG('MN_CDF','It will be ignored') NPNT = NPNT - 1 GOTO 4000 ENDIF ENDIF GOTO 4000 C C READ IN ALL THE DATA CHECK IT OUT AND FILL THE HEADER C 5000 CONTINUE WRITE(TXTMES,'('' Plot'',I7,I4 + ,'' Data for'',I6,'' points read in'')') + IDA,IDB,NPNT CALL MN_MES(LUNTTO,'ME',TXTMES) C C BOOK THE NEW HISTOGRAM AND ESTABLISH POINTERS C NWRD = NWPPT * NPNT NBPPT = 0 NTMODE = 0 IF(QTIME) THEN if(tmode.eq.'D') then ntmode = 1 elseif(tmode.eq.'H') then ntmode = 2 elseif(tmode.eq.'M') then ntmode = 3 else ntmode = 4 endif ENDIF CALL MN_HNW(IDA,IDB,NDIM,NWRD,NH,NPTRH,NPTRD,NWH,NBPPT,NTMODE) C C CHECK THAT THE ERRORS ARE DONE PROPERLY C IF(NPNT.GT.0 .AND. .NOT.QCNTU .AND. + NWPPT.GE.4 .AND. .NOT.QYERR) THEN CALL MN_MES(LUNTTO,'ME' + ,' Errors are square root of the number of entries') ENDIF C EDLO = 1.0E+30 EDHI = -1.0E+30 EDENT = 0.0 CALL VZERO_i(IDBIN,MDIMMX) CALL VFILL(ADLO,MDIMMX,1.0E+30) CALL VFILL(ADHI,MDIMMX,-1.0E+30) call vzero_r(acont,3) DXL = 0.0 DYL = 0.0 DXH = 0.0 DYH = 0.0 DO 5200 II=1,NPNT NPTR1 = NWPPT*(II-1) NPTR2 = NPTRD + NWPPT*(II-1) - 1 IF(QCNTU) THEN CALL UCOPY_r(BUFDAT(NPTR1+1),RDAT(NPTR2+1),NWPPT) EDENT = EDENT + 1.0 EDLO = 0.0 EDHI = 1.0 DO 5150 NN=1,IABS(NDIM) ADLO(NN) = AMIN1(ADLO(NN),BUFDAT(NPTR1+NN)) ADHI(NN) = AMAX1(ADHI(NN),BUFDAT(NPTR1+NN)) 5150 CONTINUE ELSE X = BUFDAT(NPTR1 + 1) Y = BUFDAT(NPTR1 + 2) IF(NWPPT.GT.2) THEN DXL = BUFDAT(NPTR1 + 3) DYL = BUFDAT(NPTR1 + 4) ENDIF DXH = DXL DYH = DYL IF(NWPPT.GT.4) THEN IF(QXERRH) DXH = BUFDAT(NPTR1 + 5) IF(QYERRH) DYH = BUFDAT(NPTR1 + 6) ELSE DXH = DXL DYH = DYL ENDIF C IF(.NOT.QXERR) THEN IF(II.EQ.1) X00 = X IF(II.EQ.2) X01 = X IF(II.EQ.NPNT-1) X10 = X IF(II.EQ.NPNT) X11 = X ENDIF C IF(NWPPT.GT.2 .AND. .NOT.QYERR) THEN DYL = SQRT(ABS(Y)) IF(NWPPT.GT.4) DYH = DYL ENDIF C RDAT(NPTR2 + 1) = X RDAT(NPTR2 + 2) = Y IF(NWPPT.GT.2) THEN RDAT(NPTR2 + 3) = DXL RDAT(NPTR2 + 4) = DYL ENDIF IF(NWPPT.GT.4) THEN RDAT(NPTR2 + 5) = DXH RDAT(NPTR2 + 6) = DYH ENDIF C ADLO(1) = AMIN1(ADLO(1),X-DXL) ADHI(1) = AMAX1(ADHI(1),X+DXH) EDENT = EDENT + Y EDLO = AMIN1(EDLO,Y-DYL) EDHI = AMAX1(EDHI,Y+DYH) acont(2) = acont(2) + y ENDIF 5200 CONTINUE C C Set up the plot limits when no errors are given C or for time plots put them 5% outside the range found C IF(QTIME) THEN ADLO(1) = ADLO(1) - 0.05*(ADHI(1)-ADLO(1)) ADHI(1) = ADHI(1) + 0.05*(ADHI(1)-ADLO(1)) C ELSEIF(.NOT.QXERR .AND. NPNT.GT.1) THEN IF(ABS(X00-ADLO(1)).LT.1.0E-6*ADLO(1)) + ADLO(1) = ADLO(1) - 0.5*ABS(X01 - X00) IF(ABS(X11-ADHI(1)).LT.1.0E-6*ADHI(1)) + ADHI(1) = ADHI(1) + 0.5*ABS(X11 - X10) ENDIF C IF(.NOT.QCNTU .AND. (XXLO.NE.0.0 .OR. XXHI.NE.0.0)) THEN ADLO(1) = XXLO ADHI(1) = XXHI ENDIF C NWDAT = NWPPT * NPNT NWTOT = NWH + NWDAT NHDATE = 0 NHTIME = 0 NSDATE = 0 NSTIME = 0 IF(QTIME) THEN NSDATE = IDTREF NSTIME = ITMREF ENDIF CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB,NDIM,NWPPT,NPNT + ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE,FIL_DT,' ',TNAME) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C C READ IN NEXT SET OF DATA POINTS IF THERE IS ONE C QCID = .FALSE. QCTIT = .FALSE. QCLIM = .FALSE. QCNTU = .FALSE. QCORD = .FALSE. QCTIM = .FALSE. QMAX = .FALSE. TCARD = ' ' IF(.NOT.QEOF .AND. QEND) GOTO 2500 IF(.NOT.QEOF .AND. .NOT.QEND) GOTO 2600 C 9000 CONTINUE GOTO 9900 C 9100 CONTINUE CALL MN_ERR('MN_CDF','Error reading in data.') GOTO 9900 C 9200 CONTINUE CALL MN_MES(LUNTTO,'ME',' MN_CDF: End of file reading in data.') GOTO 9900 C 9900 CONTINUE IF(QOPEN) CLOSE(UNIT=LUNDIN) cif IF(QIF.AND.IFIIFL.GT.0.AND.IERR.NE.0)IFIIFL= IFIIFL - 1 C C CHECK THAT I GOT THE HISTOGRAMS I WANTED C NNID = 2 CALL MN_HNG('MN_CDF',NNID,NDHIS0,NIDL,IDLSTA,IDLSTA,IDLSTB,IDLSTB) C C Clear out the TYPSCN buffer C CALL ZERTYQ('.FALSE.') C RETURN END +DECK,mn_cds. SUBROUTINE MN_CDS(IDELIM) C C STORES A SERIES OF DATA POINTS IN A FILE C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCWN. +CDE,MNCMD. +CDE,MNLUN. C CHARACTER*80 FILNAM CHARACTER*133 TTMP LOGICAL QERRL,QERRH,QRNGE,QZERO REAL RVAL(10) integer ltmp,lent integer lnblnk external lnblnk C LUN = 0 CALL MN_FIL(-3,LUN,FILNAM,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C 1000 CONTINUE CALL WAITYQ('Give histogram number: ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 8000 QZERO = .FALSE. IF(NNID.EQ.1 .AND. IDA1.EQ.0) QZERO = .TRUE. QRNGE = IDA1.NE.IDA1 .OR. IDB1.NE.IDB2 C C If storing single plots, check that they exist C IF(.NOT.QZERO .AND. .NOT.QRNGE) THEN CALL MN_HGT(IDA1,IDB1,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Plot'',I7,I4,'' does not exist'')' + ,IOSTAT=IOERR) IDA1,IDB1 CALL MN_ERR('MN_CDS',TXTERR) GOTO 8000 ENDIF ENDIF C DO 3000 NH=1,NDHIS IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) GOTO 3000 IDA = IDIDA(NH) IDB = IDIDB(NH) IF((NNID.EQ.1 .AND. IDA1.EQ.0) .OR. + (NNID.EQ.2 .AND. IDA1.EQ.0 .AND. + IDB.GE.IDB1 .AND. IDB.LE.IDB2) .OR. 1 (IDA.GE.IDA1 .AND. IDA.LE.IDA2 .AND. 1 IDB.GE.IDB1 .AND. IDB.LE.IDB2)) THEN CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_CDS',TXTERR) GOTO 8000 ENDIF C IF(NDIM.GT.1 .OR. NDIM.LT.-10) THEN IF(NDIM.GT.1) THEN WRITE(TXTERR,'(''Plot'',I7,I4 + ,'' is not 1-dimensional.'' + ,'' It will not be stored.'')' + ,IOSTAT=IOERR) IDA,IDB ELSE WRITE(TXTERR,'(''Ntuple'',I7,I4 + ,'' has more than 10 variables.'' + ,'' It will not be stored.'')' + ,IOSTAT=IOERR) IDA,IDB ENDIF CALL MN_ERR('MN_CDS',TXTERR) GOTO 3000 ENDIF C IF(.NOT.QRFILE .AND. NPNT.GT.1000) THEN IF(IDELIM.EQ.0) THEN ISTR = ISTRNQ(.TRUE.,TTMP,NCHAR) ENDIF WRITE(TXTMES,'('' Plot'',I7,I4 + ,'' has more than 1000 points'')') CALL MN_MES(LUNTTO,'ME',TXTMES) TXTMES = + 'Hit to store, q to quit, any character to skip' CALL MN_CRT(0,TXTMES,IERR) IF(IDELIM.EQ.0 .AND. NCHAR.GT.0) THEN CALL QUOTYQ(TTMP(:NCHAR)) ENDIF IF(IERR.NE.0) GOTO 3000 ENDIF C CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) IF(NDIM.GT.0) THEN DX = 0.5 * (ADHI(1) - ADLO(1)) / FLOAT(IDBIN(1)) ENDIF C WRITE(LUN,'('' ID '',I7,I4)') IDA,IDB WRITE(LUN,'('' TITLE '',A72)') TDTIT(NH)(1:72) IF(IABS(NDIM).EQ.1) THEN WRITE(LUN,'('' LIMIT '',G15.6,1X,G15.6)') + ADLO(1),ADHI(1) IF(QERRH) THEN WRITE(LUN,'('' ORDER X Y DNX DNY DPX DPY'')') ELSE IF(QERRL) THEN WRITE(LUN,'('' ORDER X Y DX DY'')') ELSE WRITE(LUN,'('' ORDER X Y'')') ENDIF ELSE ND = IABS(NDIM) ttmp = ' NTUPLE' write(ttmp(9:),'(I3)') nd ltmp = 11 do i=1,nd lent = lnblnk(tdnam(i,nh)) write(ttmp(ltmp+1:),'(1x,a)') tdnam(i,nh)(:lent) ltmp = ltmp + lent + 1 enddo write(lun,'(1x,A)') ttmp(:ltmp) *ICB WRITE(LUN,'('' NTUPLE'',I4,1X,10(A,1X))') *ICB + ND,(TDNAM(II,NH),II=1,ND) ENDIF WRITE(LUN,'('' DATA'')') C C Initialize the Ntuple reading C IF(NDIM.LT.-1) THEN nvcwn = 0 CALL M_NTPPNT(IDA,IDB,0,IERR,RVAL) IF(IERR.NE.0) THEN WRITE(LUN,'('' END'')') GOTO 3000 ENDIF ENDIF C DO 2900 I=1,NPNT NPTR = NPTRD + NWPPT*(I-1) - 1 IF(IABS(NDIM).EQ.1) THEN IF(NDIM.GT.0) THEN X = ADLO(1) + 2.0*FLOAT(I-1)*DX + DX DXL = DX DXH = DX ELSE X = RDAT(NPTR + 1) IF(QERRL) DXL = RDAT(NPTR + NOFF + 1) IF(QERRH) DXH = RDAT(NPTR + NOFFL + 1) ENDIF Y = RDAT(NPTR + NOFF) IF(QERRL) DYL = RDAT(NPTR + NOFFL) IF(QERRH) DYH = RDAT(NPTR + NOFFH) C IF(QERRH) THEN WRITE(LUN,'(1X,6(1PG13.6,1X))') X,Y,DXL,DYL + ,DXH,DYH ELSE IF(QERRL) THEN WRITE(LUN,'(1X,6(1PG13.6,1X))') X,Y,DXL,DYL ELSE WRITE(LUN,'(1X,6(1PG13.6,1X))') X,Y ENDIF ELSE CALL M_NTPPNT(IDA,IDB,I,IERR,RVAL) IF(IERR.NE.0) THEN WRITE(LUN,'('' END'')') GOTO 3000 ENDIF WRITE(LUN,'(10(1X,1PG12.5))') (RVAL(II),II=1,ND) ENDIF 2900 CONTINUE C WRITE(LUN,'('' END'')') ENDIF 3000 CONTINUE IF(IDELIM.EQ.0) GOTO 1000 C 8000 CONTINUE CLOSE(UNIT=LUN) CALL CLEO_FRELUN(LUN,'MN_FIL') C 9000 CONTINUE END +DECK,mn_cin. C SUBROUTINE MN_CIN(NCERR) C C SEES IF COMMAND IS AN INTERNALLY DEFINED COMMAND C implicit none * +CDE,MNCMD. +CDE,MNTYQ. * integer ncerr * integer icmd,idelim,ierr * integer icmtyq external icmtyq C NCERR = 0 C CALL WAITYQ('Give command: ') ICMD = ICMTYQ(.TRUE.,IDELIM,OPRNAM) COMND1 = ' ' IF(ICMD.GT.0) COMND1 = OPRNAM(ICMD) CALL MN_DCK(IDELIM,ICMD,NOPR,OPRNAM,IERR) C IF(ICMD.LT.0 .OR. IERR.NE.0) THEN NCERR = IERR GOTO 9000 ENDIF C CALL TYQOPN(ICMD,IDELIM) C 9000 CONTINUE RETURN END +DECK,mn_cmd. SUBROUTINE MN_CMD(NCFLG,NCERR) C C CHECKS IF THE COMMAND IS A KNOWN STANDARD COMMAND C NCFLG = -1 CALLED FROM COMAND C NCFLG = +1 CALLED FROM MN_CMI C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFIT. +CDE,MNFUN. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNTYQ. +CDE,MNGRN. +CDE,MNTMP. +CDE,MNLUN. CICB?? +CDE,MINCOM. C INTEGER MCMD,MCMD1 PARAMETER (MCMD = 120, MCMD1 = 55) CHARACTER*10 CMDNAM(MCMD),CMDNM1(MCMD1),CMDNM2(MCMD-MCMD1) EQUIVALENCE(CMDNAM(1), CMDNM1(1)) EQUIVALENCE(CMDNAM(MCMD1+1),CMDNM2(1)) C INTEGER MREAD,MWRIT PARAMETER (MREAD=3) CHARACTER*10 REDNAM(MREAD) PARAMETER (MWRIT=3) CHARACTER*10 WRTNAM(MWRIT) C INTEGER NCFLG,NCERR C CHARACTER*255 TXT1,TXT2 CHARACTER*50 FILNAM C INTEGER ICMD,JCMD,NCMD,IDELIM,IERR,NMODE,NPAR,LUN,IOERR + ,N1,N2,I,LENT,NCMMOD,NTYPFL,NDERR,NDEV,NNID,NDHIS0 + ,IDA,IDB,IDA1,IDB1,IDA2,IDB2 + ,NCHAR,NCHR,IDUM C INTEGER ICMTYQ,INTTYQ,ISTTYQ,IQSTYQ,LNBLNK EXTERNAL ICMTYQ,INTTYQ,ISTTYQ,IQSTYQ C DATA CMDNM1/ 1 'HELP', 'FUNCTION', 'COMIS', 'MESSAGE', 'WAIT', 2 'HB_OPEN', 'OPEN', 'READ', 3 'FETCH', 'HB_FETCH', 'HB3_FETCH', 4 'AVE_FETCH', 'SCT_FETCH', 'DAT_FETCH','MN_FETCH', 'HY_FETCH', 5 'WRITE', 'STORE', 'HB_STORE', 'DAT_STORE', 'MN_STORE', 6 'HISTOGRAM', 'PLOT', 'OVERLAY', 'EXTRACT', 'LEGO', 7 'DISPLAY', 'SURFACE', 'IGTABLE', '2DIM', 8 'NTUPLE', 'SCAN', 'MERGE', 9 'SET', 'SHOW', 'COMMENT', 'KEY', 'DRAW', A 'CLEAR', 'REDRAW', 'CAPTURE', 'HARDCOPY', B 'CLOSE', 'HCLOSE', 'HB_MN_FIT', C 'DIRECTORY', 'INDEX', 'HINDEX', 'DBG_INDEX', 'PRINT', D 'PARTITION', 'COPY', 'RENAME', 'DELETE', 'TITLE' Z / DATA CMDNM2/ 1 'HCOPY', 'HRENAME', 'HDELETE', 'HMAKE', 'HMERGE', 2 'LDIRECTORY','ZDIRECTORY','CDIRECTORY','MDIRECTORY','WDIRECTORY', 3 'ADD', 'SUBTRACT', 'MULTIPLY', 'DIVIDE', 'EFFICIENCY', 4 'NORMALIZE', 'SCALE', 'AVERAGE', 'STAT', 5 'XSHIFT', 'XSCALE', 'YSHIFT', 'YSCALE', 6 'ZSHIFT', 'ZSCALE', 7 'REBIN', 'SUM', 'INTEGRATE', 8 'CALCULATE', 'DEPOSIT', 'EXAMINE', 'REMOVE', 9 'BOOK', 'FILL', 'DUMP', 'SQUEEZE', A 'CUT', 'NO_CUT', 'PROJECT', 'WINDOW', 'NO_WINDOW', B 'EXECUTE', 'RETURN', 'DEFINE', 'UNDEFINE', 'INQUIRE', C 'SHELL', 'SPAWN', 'EDIT', 'ATTACH', D 'SMOOTH', 'SPLINE', E 'DO', 'ENDDO', 'IF', 'ELIF', 'PARSE', F 'CALL_COMIS','ALIAS', 'UNALIAS', G 'DATABASE', 'DB_HISTORY','DB_SNAP', H 'DBG_BREAK', Z ' '/ C DATA REDNAM/'DATA','COMMAND',' '/ C DATA WRTNAM/'DATA','LOG',' '/ C NCERR = 0 C CALL WAITYQ('Give command: ') ICMD = ICMTYQ(.TRUE.,IDELIM,CMDNAM) COMND1 = ' ' IF(ICMD.GT.0) COMND1 = CMDNAM(ICMD) CALL MN_DCK(IDELIM,ICMD,MCMD,CMDNAM,IERR) IF(ICMD.LT.0 .OR. IERR.NE.0) THEN NCERR = IERR GOTO 9000 ENDIF C C DO AN OPERATION ON A FUNCTION C IF(COMND1.EQ.'FUNCTION') THEN CALL MN_FUN C C READ IN A LIST OF COMMANDS FROM A FILE C OR DATA TO FIT FROM A FILE C ELSEIF(COMND1.EQ.'READ' .OR. COMND1.EQ.'EXECUTE') THEN cif IF(QIF) IFIIFL = IFIIFL + 1 IF(COMND1.EQ.'EXECUTE') THEN JCMD = 2 COMND2 = 'COMMAND' GOTO 2210 ENDIF 2200 CONTINUE CALL WAITYQ('Read in data, commands or ?: ') JCMD = ICMTYQ(.TRUE.,IDELIM,REDNAM) IF(JCMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN CALL QUOTYQ(COMND1) IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 2200 ENDIF C COMND2 = ' ' IF(JCMD.GT.0) COMND2 = REDNAM(JCMD) 2210 CONTINUE IF(JCMD.LE.0 .OR. IDELIM.GT.0) THEN CALL MN_DCK(IDELIM,JCMD,MREAD,REDNAM,IERR) IF(IERR.EQ.2) CALL MN_UNK('MN_CMD') GOTO 9000 ELSEIF(COMND2.EQ.'DATA') THEN CALL MN_CDF(IDELIM) ELSEIF(COMND2.EQ.'COMMAND') THEN NMODE = -1 CALL TYQOPN(NMODE,IDELIM) ELSE CALL MN_ERR('MN_CMD','Command not valid here') ENDIF C C Get the value of a parameter C ELSEIF(COMND1.EQ.'INQUIRE') THEN NPAR = 0 CALL TYQINQ(NPAR,IDELIM) C C START A DO LOOP C ELSEIF(COMND1.EQ.'DO') THEN CALL M_LOOP(IDELIM,IERR) C C ENDDO command - Do nothing. It should not even get here C The only time it does get here is if there is an END command somewhere C C ELSEIF(COMND1.EQ.'ENDDO') THEN C CALL M_EMSG('MN_CMD','ENDDO command found in MN_CMD') C CALL M_EMSG('MN_CMD','This should have been caught earlier') C CALL MN_ERR('MN_CMD','Report this error to the author please') C GOTO 9000 C C Evaluate an IF block or an ELSEIF block C ELSEIF(COMND1.EQ.'IF' .or. COMND1.EQ.'ELIF')THEN IF(.NOT.QRFILE) THEN CALL MN_ERR('MN_CMD','Command only valid' // 1 ' inside a file or an internally defined command') GOTO 9000 ENDIF CALL M_IFPRS(IERR) IF(IERR.NE.0)THEN QIF(NTDEP) = .FALSE. IIFLV(NTDEP) = 0 IF(IERR .EQ. 5) THEN CALL MN_ERR('MN_CMD','Too many nested IFs.') ENDIF ELSE QIF(NTDEP) = .TRUE. ENDIF C C Should never see ELSE or ENDIF, as these are taken care of in TYQRED. C C C Open an HBOOK4 histogram file C ELSEIF(COMND1.EQ.'OPEN' .OR. COMND1.EQ.'HB_OPEN') THEN NMODE = -4 CALL MN_HBF(IDELIM,NMODE) C C Fetch an HBOOK version 4 histogram C ELSEIF(COMND1.EQ.'FETCH' .OR. COMND1.EQ.'HB_FETCH') THEN NMODE = 4 CALL MN_HBF(IDELIM,NMODE) C C Fetch an HBOOK version 3 histogram C ELSEIF(COMND1.EQ.'HB3_FETCH') THEN NMODE = 3 CALL MN_HBF(IDELIM,NMODE) C C READ IN AVEHST FORMAT HISTOGRAMS C ELSEIF(COMND1.EQ.'AVE_FETCH') THEN CALL MN_AVF(IDELIM) C C READ IN AVEHST SCATTER PLOTS C ELSEIF(COMND1.EQ.'SCT_FETCH') THEN CALL MN_SCF(IDELIM) C C READ IN DATA CARDS WHICH SPECIFY A HISTOGRAM C ELSEIF(COMND1.EQ.'DAT_FETCH') THEN CALL MN_CDF(IDELIM) C C READ IN N-DIMENSIONAL HISTOGRAMS C ELSEIF(COMND1.EQ.'MN_FETCH') THEN CALL MN_MNF(IDELIM) C C READ IN HYBRID HISTOGRAMS C ELSEIF(COMND1.EQ.'HY_FETCH') THEN CALL MN_HYF(IDELIM) C C STORE THE HISTOGRAMS C ELSEIF(COMND1.EQ.'STORE' .OR. COMND1.EQ.'HB_STORE') THEN CALL MN_HBS(IDELIM) C C WRITE OUT SOMETHING C ELSEIF(COMND1.EQ.'WRITE') THEN 2600 CONTINUE CALL WAITYQ('Write data, log or ?: ') JCMD = ICMTYQ(.TRUE.,IDELIM,WRTNAM) COMND2 = ' ' IF(JCMD.GT.0) COMND2 = WRTNAM(JCMD) IF(JCMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN CALL QUOTYQ(COMND1) IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 2600 ELSEIF(JCMD.LE.0 .OR. IDELIM.GT.0) THEN CALL MN_DCK(IDELIM,JCMD,MWRIT,WRTNAM,IERR) IF(IERR.EQ.2) CALL MN_UNK('MN_CMD') GOTO 9000 ELSEIF(COMND2.EQ.'DATA') THEN CALL MN_CDS(IDELIM) C C WRITE THE LAST N COMMANDS TO A FILE C ELSEIF(COMND2.EQ.'LOG') THEN LUN = 0 CALL MN_FIL(-23,LUN,FILNAM,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C TXT1 = 'Give number of commands to write (= ): ' IF(QTLOOP) THEN WRITE(TXT1(40:42),'(I3)',IOSTAT=IOERR) MTCMD ELSE WRITE(TXT1(40:42),'(I3)',IOSTAT=IOERR) NTCMD ENDIF CALL WAITYQ(TXT1(1:45)) NCMD = INTTYQ(.TRUE.,IDELIM) IF(NCMD.LE.0 .OR. IDELIM.GT.0) THEN IF(QTLOOP) THEN NCMD = MTCMD ELSE NCMD = NTCMD ENDIF ENDIF C NCMD = MIN0(NCMD,MTCMD) N1 = NTCMD - NCMD + 1 N2 = NTCMD IF(N1.LT.0 .AND. QTLOOP) THEN N1 = N1 + MTCMD DO 2660 I=N1,MTCMD LENT= LNBLNK(TXTCMD(I)) WRITE(LUN,'(A)',IOSTAT=IOERR) TXTCMD(I)(1:LENT) 2660 CONTINUE N1 = 1 ENDIF DO 2670 I=N1,N2 LENT= LNBLNK(TXTCMD(I)) WRITE(LUN,'(A)',IOSTAT=IOERR) TXTCMD(I)(1:LENT) 2670 CONTINUE C CLOSE(UNIT=LUN) CALL CLEO_FRELUN(LUN,'MN_FIL') ENDIF C C WRITE OUT DATA CARDS C ELSEIF(COMND1.EQ.'DAT_STORE') THEN CALL MN_CDS(IDELIM) C C STORE AN N-DIMENSIONAL HISTOGRAM C ELSEIF(COMND1.EQ.'MN_STORE') THEN CALL MN_MNS C C EITHER PLOT A HISTOGRAM OR ADD ANOTHER HISTOGRAM TO THE PLOT C ELSEIF(COMND1.EQ.'HISTOGRAM' .OR. + COMND1.EQ.'PLOT' .OR. COMND1.EQ.'OVERLAY' .OR. + COMND1.EQ.'EXTRACT' .OR. + COMND1.EQ.'LEGO' .OR. COMND1.EQ.'SURFACE' .OR. + COMND1.EQ.'DISPLAY' .OR. + COMND1.EQ.'IGTABLE' .OR. COMND1.EQ.'2DIM' .OR. + COMND1.EQ.'BOOK' .OR. COMND1.EQ.'FILL' .OR. + COMND1.EQ.'DUMP') THEN CALL MN_HIS C C Do an operation on an Ntuple C ELSEIF(COMND1.EQ.'NTUPLE' .OR. + COMND1.EQ.'SCAN' .OR. COMND1.EQ.'MERGE') THEN CALL MN_NTP C C Update all Mn_Fit histograms from the HBOOK histograms C ELSEIF(COMND1.EQ.'HB_MN_FIT') THEN IF(IDELIM.EQ.0) THEN CALL WAITYQ('Give histogram number(s): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 ELSE IDA1 = 0 IDA2 = 0 ENDIF IDB = NDIDB NDHIS0 = NDHIS CALL M_HBMN(IDA1,IDA2,IDB,4) NNID = 1 CALL MN_HNG('M_NTPSCN',NNID,NDHIS0,1,IDA1,IDA2,IDB,IDB) C C SET AN OPTION OR VALUE FOR PLOT C ELSEIF(COMND1.EQ.'SET') THEN CALL MN_SET(IDELIM) C C Show the SET values. If MN_SHW does not have the parameter it passes it C to MN_SET. C ELSEIF(COMND1.EQ.'SHOW') THEN CALL MN_SHW(' ') C C Call a COMIS subroutine C ELSEIF(COMND1.EQ.'CALL_COMIS') THEN CALL M_CALL C C INVOKE COMIS C ELSEIF(COMND1.EQ.'COMIS') THEN CALL CSPAUS('Entering COMIS') C C ADD A COMMENT TO A HISTOGRAM C ELSEIF(COMND1.EQ.'COMMENT') THEN NCMMOD = 1 CALL MN_COM(NCMMOD,IDELIM) C C GIVE A KEY TO THE MEANING OF SYMBOLS C ELSEIF(COMND1.EQ.'KEY') THEN NCMMOD = 2 CALL MN_COM(NCMMOD,IDELIM) C C REDRAW THE LAST PLOT C ELSEIF(COMND1.EQ.'REDRAW') THEN NTYPFL = 2 IF(QDFIT) NTYPFL = -2 CALL MN_DRW(NTYPFL,NDERR) C C CAPTURE A NEW OUTPUT DEVICE C ELSEIF(COMND1.EQ.'CAPTURE') THEN NDEV = 0 CALL M_CAPT(0,NDEV,IDELIM,IERR) C C MAKE A HARD COPY C ELSEIF(COMND1.EQ.'HARDCOPY') THEN NTYPFL = 3 IF(QDFIT) NTYPFL = -3 CALL M_HARD(NTYPFL,IDELIM) C C CLOSE THE CURRENT HARDCOPY DEVICES C ELSEIF(COMND1.EQ.'CLOSE') THEN CALL TVHCLS(0) CALL MN_TOF(.FALSE.) C C Close all current open histogram files C ELSEIF(COMND1.EQ.'HCLOSE') THEN CALL M_HCLS C C GIVE AN INDEX OF HISTOGRAMS READ IN C ELSEIF(COMND1.EQ.'DIRECTORY' .OR. COMND1.EQ.'INDEX' .OR. + COMND1.EQ.'DBG_INDEX') THEN NNID = 0 IDA1 = 0 IDB1 = 0 IDA2 = 0 IDB2 = 0 FILNAM = ' ' IF(IDELIM.EQ.0) THEN CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 ENDIF C IF(COMND1.EQ.'DBG_INDEX') THEN NMODE = 1 ELSE NMODE = 0 ENDIF C C TURN OFF AND ON BREAK ENABLE AND TEKTRONIX MODE C CALL MN_TOF(.FALSE.) CALL MN_IDX(IDA1,IDA2,IDB1,IDB2,NNID,NMODE) C C GET HBOOK INDEX C ELSEIF(COMND1.EQ.'HINDEX') THEN WRITE(LUNDMP,'(/,'' The following HBOOK histograms are'' 1 ,'' just available for plotting:'')') CALL MN_TOF(.FALSE.) CALL HOUTPU(LUNDMP) CALL HINDEX CALL HOUTPU(LUNTTO) C C PRINT A HISTOGRAM ON THE DUMP DEVICE C ELSEIF(COMND1.EQ.'PRINT') THEN CALL WAITYQ('Give histogram number: ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 CALL MN_TOF(.FALSE.) CALL HOUTPU(LUNDMP) NMODE = 0 CALL MN_PRN(IDA1,IDA2,IDB1,IDB2,NNID,NMODE) CALL HOUTPU(LUNTTO) C C TAKE OUT PART OF A HISTOGRAM C ELSEIF(COMND1.EQ.'PARTITION') THEN CALL MN_PRT C C COPY OR RENAME A HISTOGRAM C ELSEIF(COMND1.EQ.'COPY' .OR. COMND1.EQ.'RENAME' .OR. 2 COMND1.EQ.'HCOPY' .OR. COMND1.EQ.'HRENAME') THEN CALL M_HCOP(IDELIM) C C DELETE A HISTOGRAM C ELSEIF(COMND1.EQ.'DELETE' .OR. COMND1.EQ.'HDELETE') THEN CALL M_HDEL(IDELIM) C C NEW TITLE C ELSEIF(COMND1.EQ.'TITLE') THEN CALL M_HTIT(IDELIM) C C MAKE AN HBOOK HISTOGRAM FROM AN MN_FIT HISTOGRAM C ELSEIF(COMND1.EQ.'HMAKE') THEN CALL WAITYQ('Give histogram number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA.LE.0) GOTO 9000 CALL MN_HBN(IDA,IDB,IERR) IF(IERR.NE.0) THEN CALL MN_ERR('MN_CMD','Error making HBOOK plot') ENDIF C C Change the current HBOOK directory C ELSEIF(COMND1.EQ.'CDIRECTORY') THEN CALL M_CDIR(IDELIM,1,IERR) C C List the contents of the current directory and change the C directory if necessary C ELSEIF(COMND1.EQ.'LDIRECTORY' .OR. COMND1.EQ.'ZDIRECTORY') THEN CALL M_LDIR(COMND1) C C Make a new directory in memory C ELSEIF(COMND1.EQ.'MDIRECTORY') THEN CALL M_MDIR(IDELIM) C C Print the statistics of the HBOOK input file C ELSEIF(COMND1.EQ.'STAT') THEN CALL M_HSTAT(IDELIM) C C Set the working directory for file opening C ELSEIF(COMND1.EQ.'WDIRECTORY') THEN CALL M_SPWD(IDELIM,1,IERR) C C Call HMERGE to merge RZ files C ELSEIF(COMND1.EQ.'HMERGE') THEN CALL M_HMERGE(IDELIM,IERR) C C DO HISTOGRAM OPERATIONS C ELSEIF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. + COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. + COMND1.EQ.'EFFICIENCY' .OR. COMND1.EQ.'AVERAGE' .OR. + COMND1.EQ.'NORMALIZE' .OR. COMND1.EQ.'SCALE' .OR. + COMND1.EQ.'XSHIFT' .OR. COMND1.EQ.'XSCALE' .OR. + COMND1.EQ.'YSHIFT' .OR. COMND1.EQ.'YSCALE' .OR. + COMND1.EQ.'ZSHIFT' .OR. COMND1.EQ.'ZSCALE') THEN CALL MN_OPR C C REBIN A HISTOGRAM C ELSEIF(COMND1.EQ.'REBIN') THEN CALL MN_PRT C C Sum a histogram or integrate a function over a range C ELSEIF(COMND1.EQ.'SUM' .OR. COMND1.EQ.'INTEGRATE') THEN CALL MN_SUM(COMND1,IDELIM) C C CALCULATE AN EXPRESSION C ELSEIF(COMND1.EQ.'DEPOSIT' .OR. COMND1.EQ.'CALCULATE') THEN 5800 CONTINUE CALL WAITYQ('Give expression or ?: ') NCHAR = ISTTYQ(.TRUE.,IDELIM,TXT1) IF(NCHAR.LE.0) GOTO 9000 IF(TXT1(1:1).EQ.'?') THEN CALL QUOTYQ('DEPOSIT') IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 5800 ELSE CALL RESTYQ ENDIF CALL MN_CLC C C EXAMINE THE VALUE OF A REGISTER, PARAMETER ETC. C ELSE IF(COMND1.EQ.'EXAMINE') THEN CALL MN_EXM(IDELIM) C C Remove a variable C ELSE IF(COMND1.EQ.'REMOVE') THEN CALL M_REMV(IDELIM) C C MAKE CUTS ON A HISTOGRAM C ELSEIF(COMND1.EQ.'CUT') THEN CALL MN_CUT(0,IDELIM) C C REMOVE CUTS ON A HISTOGRAM C ELSEIF(COMND1.EQ.'NO_CUT') THEN CALL MN_CUT(1,IDELIM) C C MAKE A PROJECTION OF A HISTOGRAM C ELSEIF(COMND1.EQ.'PROJECT') THEN IDA = 0 IDB = 0 comnd2 = comnd1 comnd1 = 'NTUPLE' CALL MN_PRJ(0,IDA,IDB) C C DO SEVERAL PLOTS PER PAGE C ELSEIF(COMND1.EQ.'WINDOW') THEN CALL MN_WND(1,IDELIM,.FALSE.,IDUM,IDUM) C C TURN OFF WINDOWING C ELSEIF(COMND1.EQ.'NO_WINDOW') THEN CALL MN_WND(-1,IDELIM,.FALSE.,IDUM,IDUM) C C DRAW SOMETHING ON THE PICTURE C ELSEIF(COMND1.EQ.'DRAW') THEN CALL MN_LDW(IDELIM) C C COMPRESS THE DATA ARRAY C ELSEIF(COMND1.EQ.'SQUEEZE') THEN CALL MN_SQZ C C CLEAR THE OUTPUT SCREEN C Also remove any comments and keys and store the picture cordinates C the usual registers C ELSEIF(COMND1.EQ.'CLEAR') THEN CALL M_CLEAR(IERR) C C COMMANDS FOR SPAWNING SUBPROCESSES AND EDTING FILES FROM WITHIN C MN_FIT C ELSEIF(COMND1.EQ.'SPAWN' .OR. COMND1.EQ.'SHELL' .OR. 1 COMND1.EQ.'ATTACH' .OR. COMND1.EQ.'EDIT') THEN CALL MN_SPW(COMND1,IDELIM) C C Smooth or spline fit a histogram. C ELSEIF(COMND1.EQ.'SMOOTH' .OR. COMND1.EQ.'SPLINE') THEN CALL MN_SPL(IDELIM) C C Write a message to the current output device C ELSEIF(COMND1.EQ.'MESSAGE') THEN CALL WAITYQ('Give the message: ') TXT1 = ' ' NCHR = IQSTYQ(.TRUE.,IDELIM,TXT1) NCHR = MAX0(NCHR,1) TXT2 = ' ' // TXT1(1:NCHR) CALL MN_TVL(TXT2,TXT1) CALL MN_MES(LUNDMP,'ME',TXT1) C C Make a command line that also includes formatting C ELSEIF(COMND1.EQ.'PARSE') THEN CALL WAITYQ('Give the command: ') TXT1 = ' ' NCHR = IQSTYQ(.TRUE.,IDELIM,TXT1) TXT2 = TXT1(:NCHR) CALL MN_TVL(TXT2,TXT1) NCHR = LNBLNK(TXT1) IF(NCHR.GT.0) CALL QUOTYQ(TXT1(:NCHR)) C C Wait C ELSEIF(COMND1.EQ.'WAIT') THEN CALL M_WAIT(IDELIM) C C DEFINE A NEW COMMAND C ELSEIF(COMND1.EQ.'DEFINE' .OR. COMND1.EQ.'UNDEFINE') THEN CALL M_DEFI(IDELIM,COMND1) C C Define or undefine an alias C ELSEIF(COMND1.EQ.'ALIAS' .OR. COMND1.EQ.'UNALIAS') THEN CALL M_ALIAS(IDELIM) C C Get some information out of the database C ELSEIF(COMND1.EQ.'DATABASE' .OR. COMND1.EQ.'DB_HISTORY' .OR. + COMND1.EQ.'DB_SNAP') THEN CALL M_DBASE(IDELIM) C C Generate a break or other arithmetic fault to check they work C ELSEIF(COMND1.EQ.'DBG_BREAK') THEN CALL M_DBGBRK C ELSE NCERR = 1 IF(NCFLG.EQ.0) THEN WRITE(TXTERR,'(''Command: '',A 1 ,'' not valid here'')') COMND1(1:LNBLNK(COMND1)) CALL MN_ERR('MN_CMD',TXTERR) ENDIF ENDIF C 9000 CONTINUE END +DECK,mn_cmi. SUBROUTINE MN_CMI(ICMD,IDELIM,IEXIT) C IMPLICIT NONE C +CDE,MNCMD. +CDE,MNTYQ. +CDE,MNLUN. C INTEGER ICMD,IDELIM,IEXIT C INTEGER MMNF PARAMETER (MMNF=5) CHARACTER*10 MNFNAM(MMNF) CHARACTER*10 TCOMM INTEGER IERR,NCFLG,NCERR INTEGER ICMTYP,ICMTYQ,JCMD C logical qwait EXTERNAL ICMTYQ C DATA MNFNAM/ 1 'HELP', 'EXIT', 'QUIT', 'FIT', Z ' '/ data qwait/.true./ C IEXIT = 0 C 2000 CONTINUE CALL WAITYQ('MN_CMD> ') ICMD = ICMTYQ(qwait,IDELIM,MNFNAM) IF(ICMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 2000 ENDIF COMND1 = ' ' IF(ICMD.GT.0) COMND1 = MNFNAM(ICMD) CALL MN_DCK(IDELIM,ICMD,MMNF,MNFNAM,IERR) IF(ICMD.LT.0 .OR. (IERR.NE.0 .AND. IERR.NE.2)) THEN GOTO 2000 ENDIF C C To exit you must type at least 'EXI' otherwise it will be passed C on to the standard list of commands C IF(COMND1.EQ.'EXIT') THEN TCOMM = ' ' CALL ICMSTR(TCOMM) IF(TCOMM(1:3).NE.'EXI') COMND1 = ' ' ENDIF C C To quit you must type at least 'QUI' otherwise it will be passed C on to the standard list of commands C IF(COMND1.EQ.'QUIT') THEN TCOMM = ' ' CALL ICMSTR(TCOMM) IF(TCOMM(1:3).NE.'QUI') COMND1 = ' ' ENDIF C C NO COMMAND GIVEN C IF(ICMD.LT.0) THEN GOTO 2000 C C HELP C ELSE IF(COMND1.EQ.'HELP') THEN CALL MN_HLP(IDELIM,IERR) C C STOP C ELSEIF(COMND1.EQ.'EXIT' .OR. COMND1.EQ.'QUIT') THEN TCOMM = ' ' CALL ICMSTR(TCOMM) IF((COMND1.EQ.'EXIT' .AND. + (QRFILE .OR. TCOMM(1:3).NE.'EXI')) .OR. + (COMND1.EQ.'QUIT' .AND. + (QRFILE .OR. TCOMM(1:3).NE.'QUI'))) THEN CALL UNITYP(LUNTTI,LUNTTO) CALL WAITYP('Do you really want to exit [Y/N*]? ') JCMD = ICMTYP(.TRUE.,IDELIM,LOGNAM) IF(JCMD.LE.0 .OR. IDELIM.GT.0) THEN JCMD = 2 ENDIF CALL UNITYP(LUNCMD,LUNTTO) IF(MOD(JCMD,2).EQ.0) GOTO 2000 ENDIF C IF(COMND1.EQ.'EXIT') THEN CALL TVEND IEXIT = 1 ELSE IEXIT = 2 ENDIF GOTO 9000 C C FIT HISTOGRAM(S) C ELSEIF(COMND1.EQ.'FIT') THEN CALL M_FITC(IDELIM,IERR) C C SEE IF COMMAND IS A STANDARD COMMAND C ELSE CALL RESTYQ NCFLG = 1 CALL MN_CMD(NCFLG,NCERR) C C NOW SEE IF COMMAND IS AN INTERNALLY DEFINED COMMAND C IF(NOPR.GT.0 .AND. NCERR.EQ.2) THEN CALL RESTYQ CALL MN_CIN(NCERR) ENDIF C C CHECK FOR UNKNOWN COMMAND C IF(NCERR.EQ.2) CALL MN_UNK('MN_CMI') ENDIF C GOTO 2000 C 9000 CONTINUE END +DECK,mn_cmp. SUBROUTINE MN_CMP (NCMMOD,IDA,IDB) C C SUBROUTINE TO LIST THE EXISTING COMMENTS OR KEYS C NCMMOD = 1 MEANS COMMENTS C NCMMOD = 2 MEANS KEYS C IDA = 0 MEANS ALL PLOTS C IDA = -1 MEANS NO PLOTS, SO USE FIRST C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNLUN. C INTEGER NCMMOD,IDA,IDB C INTEGER NP,NPLT1,NPLT2,IDA2,IDB2,LENC INTEGER NNCMT,NC,NDUM,IERR,IDELIM REAL RDUM C IF(IDA.GT.0) THEN DO 1000 NP=1,NHPLT IF(IPLTIA(NP).EQ.IDA .AND. IPLTIB(NP).EQ.IDB) THEN NPLT1 = NP NPLT2 = NP GOTO 1010 ENDIF 1000 CONTINUE WRITE(TXTERR,'('' Plot'',I7,I4 1 ,'' is not being plotted'')') IDA,IDB CALL MN_ERR('MN_CMP',TXTERR) GOTO 9000 1010 CONTINUE ELSEIF(IDA.EQ.0) THEN NPLT1 = 1 NPLT2 = NHPLT ELSE NPLT1 = 1 NPLT2 = 1 ENDIF C DO 3000 NP=NPLT1,NPLT2 IF(IDA.GE.0) THEN IDA2 = IPLTIA(NP) IDB2 = IPLTIB(NP) IF(IPLTFL(NP).NE.1) GOTO 3000 IF(NCMMOD.EQ.1) THEN NNCMT = NPLTCM(NP) IF(NNCMT.LE.0) GOTO 9000 WRITE(TXTMES,'('' Plot'',I7,I4 1 ,'' The following comments exist:'')') IDA2,IDB2 ELSE NNCMT = NPLTKY(NP) IF(NNCMT.LE.0) GOTO 9000 WRITE(TXTMES,'('' Plot'',I7,I4 1 ,'' The following keys exist:'')') IDA2,IDB2 ENDIF ELSE IF(NCMMOD.EQ.1) THEN NNCMT = NPLTCM(NP) IF(NNCMT.LE.0) GOTO 9000 WRITE(TXTMES,'( 1 '' The following comments exist:'')') ELSE NNCMT = NPLTKY(NP) IF(NNCMT.LE.0) GOTO 9000 WRITE(TXTMES,'( 1 '' The following keys exist:'')') ENDIF ENDIF CALL MN_MES(LUNTTO,'I',TXTMES) C DO 2500 NC=1,NNCMT IF(NCMMOD.EQ.1) THEN WRITE(TXTMES,'('' Comment'',I3,'':'')') NC CALL MN_MES(LUNTTO,'I',TXTMES) LENC = max0(1,MIN0(72,IPLTCM(NC,NP))) WRITE(TXTMES,'('' Text: '',A)') + TPLTCM(NC,NP)(1:LENC) CALL MN_MES(LUNTTO,'I',TXTMES) CALL MN_ENM(IDELIM,'SHOW',' ',9,TCOMMN,ICOMMN + ,RPLTCM(1,NC,NP),NDUM,RDUM,IERR) ELSE WRITE(TXTMES,'('' Key'',I3,'':'')') NC CALL MN_MES(LUNTTO,'I',TXTMES) LENC = max0(1,MIN0(57,IPLTKY(NC,NP))) WRITE(TXTMES,'('' Symbol: '',I5,'' Text: '',A)') 4 LPLTKY(NC,NP),TPLTKY(NC,NP)(1:LENC) CALL MN_MES(LUNTTO,'I',TXTMES) CALL MN_ENM(IDELIM,'SHOW',' ',11,TCOMMN,ICOMMN + ,RPLTKY(1,NC,NP),NDUM,RDUM,IERR) ENDIF 2500 CONTINUE CALL MN_MES(LUNTTO,'E',' ') 3000 CONTINUE C 9000 CONTINUE RETURN END +DECK,mn_cnv. SUBROUTINE MN_CNV(TXTI,TXTO,NCHAR) C CHARACTER*(*) TXTI,TXTO CHARACTER*255 TXTT C LOGICAL QLOW C CHARACTER*1 TALUPP(26),TALLOW(26) DATA TALUPP/'A','B','C','D','E','F','G','H','I','J' 1 ,'K','L','M','N','O','P','Q','R','S','T' 2 ,'U','V','W','X','Y','Z'/ DATA TALLOW/'a','b','c','d','e','f','g','h','i','j' 1 ,'k','l','m','n','o','p','q','r','s','t' 2 ,'u','v','w','x','y','z'/ C QLOW = .FALSE. C TXTT = ' ' LTXTI = LEN(TXTI) LTXTT = LEN(TXTT) C K = 0 DO 1000 I=1,LTXTI IF(TXTI(I:I).EQ.'$') GOTO 1001 DO J=1,26 IF(TXTI(I:I).EQ.TALLOW(J)) THEN IF(QLOW) THEN K = K + 1 TXTT(K:K) = TALUPP(J) IF(K.EQ.LTXTT) GOTO 1001 ELSE QLOW = .TRUE. K = K + 1 TXTT(K:K) = '<' IF(K.EQ.LTXTT) GOTO 1001 K = K + 1 TXTT(K:K) = TALUPP(J) IF(K.EQ.LTXTT) GOTO 1001 ENDIF GOTO 1000 ENDIF ENDDO IF(QLOW) THEN QLOW = .FALSE. K = K + 1 TXTT(K:K) = '>' IF(K.EQ.LTXTT) GOTO 1001 ENDIF K = K + 1 TXTT(K:K) = TXTI(I:I) IF(K.EQ.LTXTT) GOTO 1001 1000 CONTINUE 1001 CONTINUE C IF(K.LT.LTXTT .AND. QLOW) THEN K = K + 1 TXTT(K:K) = '>' ENDIF C C MAKE SURE A $ IS THE LAST CHARACTER C IF(K.LT.LTXTT) THEN DO 2000 L=LTXTT,1,-1 IF(TXTT(L:L).NE.' ') THEN K = L + 1 TXTT(K:K) = '$' GOTO 2010 ENDIF 2000 CONTINUE 2010 CONTINUE ENDIF C TXTO = TXTT C RETURN END +DECK,mn_com. SUBROUTINE MN_COM(NCMMOD,IDELIM) C C PUT COMMENTS ON THE PICTURE C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNLUN. +CDE,MNFLG. C PARAMETER (MEDIT=6) CHARACTER*10 EDTNAM(MEDIT) C CHARACTER*80 THELP,THEAD,TEXT,CTEXT LOGICAL QNEW,QCHGE,QDEL,QLIST,QCHGED,QEXIT C REAL RNUM(20) C CHARACTER*9 TTPRMT(2),TPRMPT INTEGER IPRMPT(2) CHARACTER*14 TTNAME(2),TNAME LOGICAL QUMOUS C DATA EDTNAM/'END', 'NEW', 'CHANGE', 'DELETE', 1 'LIST', ' '/ DATA TTPRMT/'COMMENT> ','KEY> '/ DATA IPRMPT/9,5/ DATA TTNAME/'comment','key definition'/ C IF(NCMMOD.LE.0 .OR. NCMMOD.GT.2) THEN CALL MN_ERR('MN_COM','Error in option. Please report' // + ' to Ian C. Brock') GOTO 9000 ENDIF TPRMPT = TTPRMT(NCMMOD) NPRMPT = IPRMPT(NCMMOD) TNAME = TTNAME(NCMMOD) NNAME = MNLLEN(TNAME) QEXIT = IDELIM.EQ.0 C CALL ICMSYM(TCMSYM) QCHGED = .FALSE. NCCHAR = 0 NCSYMB = 0 CTEXT = ' ' X = -1.0 Y = -1.0 CSIZE = 0.4 ANGLE = 0.0 IF(NCMMOD.EQ.1) THEN IOPT = 1 ELSE IOPT = -1 ENDIF CICB QUMOUS = QMOUSE .AND. .NOT.QRFILE QUMOUS = QMOUSE IF(QUMOUS .AND. NCMMOD.EQ.1) IOPT = 0 JMODE = 0 C C Set default font, colour and thicknesses C NCOL = ICOLS(11) NCOLT = ICOLS(11) THICK = ATHKS(9) XUNIT = TSZES(5) NFONT = IFNTS(3) C 1000 CONTINUE QNEW = .TRUE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .FALSE. C NPLTOT = 0 C IF(NHPLT.LE.0) THEN NPLT = 1 NPLTOT = 0 IF((NCMMOD.EQ.1 .AND. NPLTCM(1).GT.0) .OR. 1 (NCMMOD.EQ.2 .AND. NPLTKY(1).GT.0)) QNEW = .FALSE. C WRITE(LUNTTO,'('' No plots have been made, so I'' C 1 ,'' cannot add comments'')') C GOTO 9000 ELSE DO 200 NP=1,NHPLT IF(IPLTFL(NP).EQ.1 .OR. IPLTFL(NP).EQ.3) THEN NPLT = NP NPLTOT = NPLTOT + 1 IF((NCMMOD.EQ.1 .AND. NPLTCM(NP).GT.0) .OR. 1 (NCMMOD.EQ.2 .AND. NPLTKY(NP).GT.0)) THEN QNEW = .FALSE. ENDIF ENDIF 200 CONTINUE ENDIF C NCOMM = 0 IF((QRFILE .AND. NPLTOT.GT.0) .OR. + NPLTOT.GT.1 .OR. + (QDFIT .AND. NHFIT.GT.1)) THEN IF(IDELIM.NE.0 .AND. .NOT.QRFILE) THEN CALL MN_MES(LUNTTO,'M',' The following histograms are' // + ' being plotted:') DO 1250 NP=1,NHPLT IF(IPLTIA(NP).GT.0 .AND. + (IPLTFL(NP).EQ.1 .OR. IPLTFL(NP).EQ.3)) THEN WRITE(TXTMES,'('' Histogram'',I7,I4)') + IPLTIA(NP),IPLTIB(NP) CALL MN_MES(LUNTTO,'M',TXTMES) NPLT = NP ENDIF 1250 CONTINUE CALL MN_MES(LUNTTO,'E',' ') ENDIF 1300 CONTINUE CALL WAITYQ(TPRMPT(1:NPRMPT) // 'Give histogram ID: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(IDELIM.LT.0 .AND. NNID.LE.0) GOTO 9000 IF(IDA.LE.0 .OR. NNID.LE.0) THEN CALL MN_ERR('MN_COM','Error specifying the plot number') GOTO 9000 ENDIF 1350 CONTINUE C DO 1400 NP=1,NHPLT IF(IPLTIA(NP).EQ.IDA .AND. IPLTIB(NP).EQ.IDB .AND. 1 (IPLTFL(NP).EQ.1 .OR. IPLTFL(NP).EQ.3)) THEN NPLT = NP IF(NCMMOD.EQ.1) THEN NNCMT = NPLTCM(NP) ELSE NNCMT = NPLTKY(NP) ENDIF GOTO 1900 ENDIF 1400 CONTINUE WRITE(TEXT,'(''Histogram'',I7,I4,'' does not exist'')') 1 IDA,IDB CALL MN_ERR('MN_COM',TEXT) GOTO 9000 ELSE IF(NHPLT.GT.0) THEN IDA = IPLTIA(1) IDB = IPLTIB(1) ELSE IDA = -1 IDB = 0 ENDIF C 1900 CONTINUE IF(QEXIT) QEXIT = IDELIM.EQ.0 CICB IF(.NOT.QRFILE .AND. QNEW) GOTO 3000 C 2000 CONTINUE CALL WAITYQ(TPRMPT(1:NPRMPT) // ' Give command or ?: ') JCMD = ICMTYQ(.TRUE.,IDELIM,EDTNAM) COMND2 = ' ' IF(JCMD.GT.0) COMND2 = EDTNAM(JCMD) IF(JCMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN CALL MN_MES(LUNTTO,'M',' List of valid commands:') CALL MN_MES(LUNTTO,'M',' ? to get this help') CALL MN_MES(LUNTTO,'M' + ,' NEW for a new ' // TNAME(1:NNAME)) CALL MN_MES(LUNTTO,'M' + ,' CHANGE to change an existing ' // TNAME(1:NNAME)) CALL MN_MES(LUNTTO,'M' + ,' DELETE to delete an existing ' // TNAME(1:NNAME)) CALL MN_MES(LUNTTO,'M' + ,' LIST to list the existing ' // TNAME(1:NNAME)) CALL MN_MES(LUNTTO,'E' + ,' END or to exit') GOTO 2000 ELSEIF(JCMD.LT.0) THEN GOTO 9000 ELSEIF(JCMD.EQ.0 .OR. IDELIM.GT.0) THEN CALL MN_DCK(IDELIM,JCMD,MEDIT,EDTNAM,IERR) IF(QRFILE) THEN GOTO 9000 ELSE GOTO 2000 ENDIF ELSEIF(COMND2.EQ.'END') THEN GOTO 9000 ELSEIF(COMND2.EQ.'NEW') THEN QNEW = .TRUE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .FALSE. GOTO 3000 ELSEIF(COMND2.EQ.'CHANGE') THEN QNEW = .FALSE. QCHGE = .TRUE. QDEL = .FALSE. QLIST = .FALSE. ELSEIF(COMND2.EQ.'DELETE') THEN QNEW = .FALSE. QCHGE = .FALSE. QDEL = .TRUE. QLIST = .FALSE. ELSEIF(COMND2.EQ.'LIST') THEN QNEW = .FALSE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .TRUE. ELSE CALL MN_ERR('MN_COM','Command not valid here') GOTO 2000 ENDIF C IF(NCMMOD.EQ.1) THEN NNCMT = NPLTCM(NPLT) ELSE NNCMT = NPLTKY(NPLT) ENDIF IF((QCHGE .AND. (QRFILE .OR. NNCMT.GT.1)) .OR. 1 QLIST .OR. QDEL) THEN IF(QLIST .OR. IDELIM.LT.0) CALL MN_CMP(NCMMOD,IDA,IDB) IF(QLIST) GOTO 2000 C 2600 CONTINUE CALL WAITYQ(TPRMPT(1:NPRMPT) // 'Give number to change: ') NCOMM = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NCOMM,IDELIM,IERR) IF(IERR.EQ.2) GOTO 9000 IF(IERR.GT.0) GOTO 2000 IF((QDEL .AND. NCOMM.LT.0) .OR. + (.NOT.QDEL .AND. NCOMM.LE.0) .OR. + (NCOMM.GT.NNCMT .AND. + (.NOT.QDEL .OR. (QDEL .AND. NNCMT.GT.0)))) THEN WRITE(TEXT,'(''Error in '',A,'' number'',I4)') 1 TNAME(1:NNAME),NCOMM CALL MN_ERR('MN_COM',TEXT) GOTO 2000 ENDIF ELSE NCOMM = 1 ENDIF C IF(QDEL) THEN IF(NCOMM.EQ.0) THEN IF(NCMMOD.EQ.1) THEN NPLTCM(NPLT) = 0 ELSE NPLTKY(NPLT) = 0 ENDIF ELSE IF(NCMMOD.EQ.1) THEN NPLTCM(NPLT) = NPLTCM(NPLT) - 1 ELSE NPLTKY(NPLT) = NPLTKY(NPLT) - 1 ENDIF WRITE(TEXT,'(1X,A,1X,I4,'' deleted'')') 1 TNAME(1:NNAME),NCOMM CALL MN_MES(LUNTTO,'ME',TEXT) DO 2700 IC=NCOMM,NNCMT-1 IF(NCMMOD.EQ.1) THEN IPLTCM(IC,NPLT) = IPLTCM(IC+1,NPLT) TPLTCM(IC,NPLT) = TPLTCM(IC+1,NPLT) CALL UCOPY_r(RPLTCM(1,IC+1,NPLT),RPLTCM(1,IC,NPLT),11) ELSE IPLTKY(IC,NPLT) = IPLTKY(IC+1,NPLT) TPLTKY(IC,NPLT) = TPLTKY(IC+1,NPLT) LPLTKY(IC,NPLT) = LPLTKY(IC+1,NPLT) CALL UCOPY_r(RPLTKY(1,IC+1,NPLT),RPLTKY(1,IC,NPLT),11) ENDIF 2700 CONTINUE ENDIF GOTO 8000 ENDIF C 3000 CONTINUE IF(QNEW) THEN IF(NCMMOD.EQ.1) THEN NCOMM = NPLTCM(NPLT) + 1 IF(NCOMM.GT.MCPLT) THEN WRITE(TXTERR,'(''No more room for comments'' 1 ,'' in plot'',I7,I4)') IPLTIA(NPLT),IPLTIB(NPLT) CALL MN_ERR('MN_COM',TXTERR) GOTO 9000 ENDIF IPLTCM(NCOMM,NPLT) = 0 TPLTCM(NCOMM,NPLT) = ' ' RPLTCM(1,NCOMM,NPLT) = X RPLTCM(2,NCOMM,NPLT) = Y RPLTCM(3,NCOMM,NPLT) = CSIZE RPLTCM(4,NCOMM,NPLT) = ANGLE RPLTCM(5,NCOMM,NPLT) = FLOAT(IOPT) RPLTCM(6,NCOMM,NPLT) = FLOAT(JMODE) RPLTCM(7,NCOMM,NPLT) = FLOAT(NFONT) RPLTCM(8,NCOMM,NPLT) = FLOAT(NCOL) RPLTCM(9,NCOMM,NPLT) = THICK ELSE NCOMM = NPLTKY(NPLT) + 1 IF(NCOMM.GT.MCPLT) THEN WRITE(TXTERR,'(''No more room for keys'' 1 ,''in plot'',I7,I4)') IPLTIA(NPLT),IPLTIB(NPLT) CALL MN_ERR('MN_COM',TXTERR) GOTO 9000 ENDIF LPLTKY(NCOMM,NPLT) = NCSYMB IPLTKY(NCOMM,NPLT) = 0 TPLTKY(NCOMM,NPLT) = ' ' RPLTKY(1,NCOMM,NPLT) = X RPLTKY(2,NCOMM,NPLT) = Y RPLTKY(3,NCOMM,NPLT) = CSIZE RPLTKY(4,NCOMM,NPLT) = ANGLE RPLTKY(5,NCOMM,NPLT) = FLOAT(IOPT) RPLTKY(6,NCOMM,NPLT) = FLOAT(JMODE) RPLTKY(7,NCOMM,NPLT) = FLOAT(NFONT) RPLTKY(8,NCOMM,NPLT) = FLOAT(NCOL) RPLTKY(9,NCOMM,NPLT) = THICK RPLTKY(10,NCOMM,NPLT)= XUNIT RPLTKY(11,NCOMM,NPLT)= float(ncolt) ENDIF ENDIF C IF(QCHGE) THEN IF(NCMMOD.EQ.1) THEN NCCHAR = IPLTCM(NCOMM,NPLT) CTEXT = TPLTCM(NCOMM,NPLT) X = RPLTCM(1,NCOMM,NPLT) Y = RPLTCM(2,NCOMM,NPLT) CSIZE = RPLTCM(3,NCOMM,NPLT) ANGLE = RPLTCM(4,NCOMM,NPLT) IOPT = NINT(RPLTCM(5,NCOMM,NPLT)) JMODE = NINT(RPLTCM(6,NCOMM,NPLT)) NFONT = NINT(RPLTCM(7,NCOMM,NPLT)) NCOL = NINT(RPLTCM(8,NCOMM,NPLT)) THICK = RPLTCM(9,NCOMM,NPLT) ELSE NCSYMB = LPLTKY(NCOMM,NPLT) NCCHAR = IPLTKY(NCOMM,NPLT) CTEXT = TPLTKY(NCOMM,NPLT) X = RPLTKY(1,NCOMM,NPLT) Y = RPLTKY(2,NCOMM,NPLT) CSIZE = RPLTKY(3,NCOMM,NPLT) ANGLE = RPLTKY(4,NCOMM,NPLT) IOPT = NINT(RPLTKY(5,NCOMM,NPLT)) JMODE = NINT(RPLTKY(6,NCOMM,NPLT)) NFONT = NINT(RPLTKY(7,NCOMM,NPLT)) NCOL = NINT(RPLTKY(8,NCOMM,NPLT)) THICK = RPLTKY(9,NCOMM,NPLT) XUNIT = RPLTKY(10,NCOMM,NPLT) NCOLt = NINT(RPLTKY(11,NCOMM,NPLT)) ENDIF ENDIF C IF(NCMMOD.EQ.2) THEN IF(QCHGE .AND. + (IDELIM.LT.0 .AND. .NOT.QRFILE)) THEN WRITE(TEXT,'('' Current symbol number:'',I4)') NCSYMB CALL MN_MES(LUNTTO,'M',TEXT) CALL MN_MES(LUNTTO,'ME',' Hit to keep same number') ENDIF C CALL WAITYQ(TPRMPT(1:NPRMPT) // 'Give symbol number: ') NVAL = INTTYQ(.TRUE.,IDELIM) IF(IDELIM.EQ.ICHAR('=')) GOTO 3200 CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 3200 IF(IERR.NE.0) THEN IF(NVAL.EQ.0) CALL MN_ERR('MN_COM' + ,'0 is not a valid symbol number') GOTO 9000 ENDIF NCSYMB = NVAL ENDIF C 3200 CONTINUE THEAD = ' ' CALL MN_ETX(0,IDELIM,THEAD,CTEXT,TEXT,IERR) IF(IERR.NE.0) GOTO 9000 CTEXT = TEXT NCCHAR = MNLLEN(CTEXT) * * Loop twice over the drawing of the comment/key if I am using the * mouse to position it. First loop is the position, second loop is * the extra parameters. * IF(QUMOUS) THEN NLOOP = 2 ELSE NLOOP = 1 ENDIF C DO IL=1,NLOOP IF(NCMMOD.EQ.1) THEN THELP = 'COMMENT' IF(QUMOUS .AND. IL.EQ.1) THEN CALL MN_ENM(IDELIM,THELP,THEAD,10,TPOSN,IPOSN 1 ,RPLTCM(1,NCOMM,NPLT),NNUM,RNUM,IERR) ELSEIF(QUMOUS) THEN CALL MN_ENM(IDELIM,THELP,THEAD,7,TCOMMN(3),ICOMMN(3) 1 ,RPLTCM(3,NCOMM,NPLT),NNUM,RNUM(3),IERR) NNUM = NNUM + 2 ELSE CALL MN_ENM(IDELIM,THELP,THEAD,9,TCOMMN,ICOMMN 1 ,RPLTCM(1,NCOMM,NPLT),NNUM,RNUM,IERR) ENDIF ELSE THELP = 'KEY' IF(QUMOUS .AND. IL.EQ.1) THEN CALL MN_ENM(IDELIM,THELP,THEAD,10,TPOSN,IPOSN 1 ,RPLTKY(1,NCOMM,NPLT),NNUM,RNUM,IERR) ELSEIF(QUMOUS) THEN CALL MN_ENM(IDELIM,THELP,THEAD,9,TCOMMN(3),ICOMMN(3) 1 ,RPLTKY(3,NCOMM,NPLT),NNUM,RNUM(3),IERR) NNUM = NNUM + 2 ELSE CALL MN_ENM(IDELIM,THELP,THEAD,11,TCOMMN,ICOMMN 1 ,RPLTKY(1,NCOMM,NPLT),NNUM,RNUM,IERR) ENDIF ENDIF IF(IERR.NE.0) GOTO 9000 C 4000 CONTINUE C DO 4500 II=1,NNUM IF(II.EQ.1) THEN X = RNUM(II) ELSEIF(II.EQ.2) THEN Y = RNUM(II) ELSEIF(II.EQ.3) THEN CSIZE = RNUM(II) ELSEIF(II.EQ.4) THEN ANGLE = RNUM(II) ELSEIF(II.EQ.5) THEN IOPT = NINT(RNUM(II)) ELSEIF(II.EQ.6) THEN JMODE = NINT(RNUM(II)) ELSEIF(II.EQ.7) THEN NFONT = NINT(RNUM(II)) ELSEIF(II.EQ.8) THEN NCOL = NINT(RNUM(II)) ncolt = ncol ELSEIF(II.EQ.9) THEN THICK = RNUM(II) ELSEIF(II.EQ.10) THEN XUNIT = RNUM(II) ELSEIF(II.EQ.11) THEN NCOLt = NINT(RNUM(II)) ENDIF 4500 CONTINUE C IF(NCMMOD.EQ.2) IOPT = -1 5000 CONTINUE C IF(NCCHAR.GT.0) THEN CALL MN_TON(IERR) IF(IERR.NE.0) GOTO 5100 C C Create a segment C NSEGM = (NPLT-1)*100 + (NCMMOD-1)*40 + 20 + NCOMM IF(.NOT.QNEW) CALL M_DLSG(NSEGM) CALL M_CRSG(NSEGM) C C GET PLOT POSITIONS FOR THE PLOT THE COMMENT IS ASSOCIATED WITH C IF(NHPLT.GT.0) THEN CALL MN_PPP(IDA,IDB,IERR) ENDIF CALL MN_CTR(X,Y,XX,YY,1,JMODE) IF(NCMMOD.EQ.1) THEN CALL MN_TXT(XX,YY,CTEXT,CSIZE,ANGLE,IOPT + ,NFONT,NCOL,THICK) ELSE CALL MN_KEY(NCSYMB,XX,YY,CTEXT,CSIZE,ANGLE,IOPT 1 ,NFONT,NCOL,THICK,XUNIT,ncolt) ENDIF CALL TVSHOW C C Close the segment C CALL M_CLSG(NSEGM) C CALL MN_TOF(.TRUE.) 5100 CONTINUE ENDIF ENDDO C IF(NCOMM.LE.0 .OR. NPLT.LE.0) THEN WRITE(TXTERR,'(''Error specifying plot or comment'' 1 ,'' numbers'',2I4)') NPLT,NCOMM CALL MN_ERR('MN_COM',TXTERR) C ELSE IF(NCMMOD.EQ.1) THEN IF(QNEW) NPLTCM(NPLT) = NCOMM IPLTCM(NCOMM,NPLT) = NCCHAR TPLTCM(NCOMM,NPLT) = CTEXT RPLTCM(1,NCOMM,NPLT) = X RPLTCM(2,NCOMM,NPLT) = Y RPLTCM(3,NCOMM,NPLT) = CSIZE RPLTCM(4,NCOMM,NPLT) = ANGLE RPLTCM(5,NCOMM,NPLT) = FLOAT(IOPT) RPLTCM(6,NCOMM,NPLT) = FLOAT(JMODE) RPLTCM(7,NCOMM,NPLT) = FLOAT(NFONT) RPLTCM(8,NCOMM,NPLT) = FLOAT(NCOL) RPLTCM(9,NCOMM,NPLT) = THICK ELSE IF(NCMMOD.EQ.2) THEN IF(QNEW) NPLTKY(NPLT) = NCOMM LPLTKY(NCOMM,NPLT) = NCSYMB IPLTKY(NCOMM,NPLT) = NCCHAR TPLTKY(NCOMM,NPLT) = CTEXT RPLTKY(1,NCOMM,NPLT) = X RPLTKY(2,NCOMM,NPLT) = Y RPLTKY(3,NCOMM,NPLT) = CSIZE RPLTKY(4,NCOMM,NPLT) = ANGLE RPLTKY(5,NCOMM,NPLT) = FLOAT(IOPT) RPLTKY(6,NCOMM,NPLT) = FLOAT(JMODE) RPLTKY(7,NCOMM,NPLT) = FLOAT(NFONT) RPLTKY(8,NCOMM,NPLT) = FLOAT(NCOL) RPLTKY(9,NCOMM,NPLT) = THICK RPLTKY(10,NCOMM,NPLT)= XUNIT RPLTKY(11,NCOMM,NPLT)= FLOAT(NCOLt) ENDIF C IF(.NOT.QRFILE) THEN IF(NCMMOD.EQ.1) THEN CALL WAITYP('Move or change comment [Y/N]? ') ELSE CALL WAITYP('Move or change key [Y/N]? ') ENDIF JCMD = ICMTYP(.TRUE.,IDELIM,LOGNAM) IF(MOD(JCMD,2).EQ.1) THEN QNEW = .FALSE. QCHGE = .TRUE. GOTO 3000 ELSE IF(QCHGE) QCHGED = .TRUE. ENDIF ENDIF C 8000 CONTINUE IF(.NOT.QEXIT) GOTO 2000 C 9000 CONTINUE IF(QCHGED) CALL MN_MES(LUNTTO,'ME' 1 ,' Give command REDRAW to remove the old text') CALL ICMSYM(TSPSYM) C END +DECK,mn_csi. SUBROUTINE MN_CSI C C INITIALIZE COMIS STORAGE SPACE C AND SET UP THE UNITS NEEDED FOR COMIS C ALSO DEFINE ADDRESSES OF ROUTINES AND COMMON BLOCKS THAT CAN BE USED C implicit none C C Mn_Fit routines C EXTERNAL XMNCLC, XMNCNT, XMNFRG, XMNHIS, XMNRD3, XMNRES + ,XMNC2D, XMNDFUN external smctrl,smqhan,smrmed,smrmen,smsort DOUBLE PRECISION XMNCLC, XMNCNT, XMNFRG, XMNHIS, XMNRD3, XMNRES + ,XMNC2D, XMNDFUN EXTERNAL RMNCLC, RMNCNT, RMNFRG, RMNHIS, RMNRD3, RMNRES + ,RMNC2D, RMNDFUN REAL RMNCLC, RMNCNT, RMNFRG, RMNHIS, RMNRD3, RMNRES + ,RMNC2D, RMNDFUN C C CERN routines in PAW C * EXTERNAL HBOOK1,HBOOK2,HBOOKN,HFILL,HF1,HPRINT,HDELET,HRESET EXTERNAL HFITGA,HFITPO,HFITEX,HPROJ1,HPROJ2,HFN,HGFIT EXTERNAL HROPEN,PAOPEN,PACLOS,PAREAD,PAWRIT,HCDIR,HGIVEN EXTERNAL HBFUN1,HBFUN2,HRNDM1,HRNDM2,HBARX,HBARY EXTERNAL HPAK,HPAKE,HUNPAK,HGIVE,HGN,HGNF,HGNPAR,HF2,HFF1,HFF2 EXTERNAL HRIN,HROUT,HI,HIE,HIX,HIJ,HIF,HIDALL,HNOENT,HX,HXY EXTERNAL HTITLE,HCOPY,HSTATI,HBPROF,HOPERA,HIDOPT,HDERIV EXTERNAL HMAXIM,HMINIM,HMAX,HMIN,HSUM,HNORMA,HREND,HRENDC EXTERNAL HEXIST,HRGET,HRPUT,HSCR,HFIND,HCX,HCXY,HLABEL EXTERNAL HBPROX,HBPROY,HBANDX,HBANDY,HBSLIX,HBSLIY EXTERNAL HBOOKB,HBSTAT,HDIFF,HUNPKE,HREBIN,HERROR,HPROF2 EXTERNAL HOUTPU,HERMES,HISTDO,HFUNC,HXI,HIJXY,HXYIJ EXTERNAL HSPLI1,HSPLI2,HMDIR,HLDIR,HRDIR,HLOCAT,HFITH,HFITV,HFINAM EXTERNAL HBNT,HBNAME,HBNAMC,HFNT,HFNTB,HGNT,HGNTF,HGNTV,HBSET EXTERNAL HGNTB,HNBENT,HVXIST,HLPOS,HFC1 ** EXTERNAL HMCINI,HMCMLL EXTERNAL FZIN,FZOUT,FZFILE,FZENDI,FZENDO,MZLOGL EXTERNAL HPLOT,HPLSYM,HPLERR,HPLEGO,HPLNT,HPLSUR,HPLSOF,HPLFRA EXTERNAL HPLABL,HPLSET,HPLGIV,HPLOC,HPLTOC,HPLNEW,HPLOPT EXTERNAL MNEMAT,MNERRS,MNSTAT EXTERNAL KUGETV,KUDPAR,KUVECT,KILEXP,KUTIME,KUEXEL,KUPROS EXTERNAL KUNWG,KUCMD,KUGUID,KUNDPV,KUPAR,KUPVAL,KUACT EXTERNAL IPL,IPM,IFA,IGTEXT,IGBOX,IGAXIS,IGPIE,IGRAPH,IGHIST EXTERNAL IGARC,IGLBL,IGRNG,IGMETA,IGSA,IGSET,IRQLC,IRQST,ISCR EXTERNAL ISELNT,ISFAIS,ISFASI,ISLN,ISMK,ISVP,ISWN,ITX,ICLRWK EXTERNAL IGPAVE,IGTERM EXTERNAL RZCDIR,RZLDIR,RZFILE,RZEND,RZIN,RZOUT,RZVIN,RZVOUT EXTERNAL RZOPEN,RZIODO,RZCLOS,RZQUOT EXTERNAL VZERO,UCOPY,RNDM,RANNOR,LENOCC,CLTOU,CUTOL,TIMED EXTERNAL SBIT0,SBIT1,SBYT,JBIT,JBYT,UCTOH,UHTOC,PROB,FREQ EXTERNAL DENLAN,DSTLAN,DIFLAN,XM1LAN,XM2LAN,RANLAN +SELF,IF=-IBM. EXTERNAL ERF,ERFC +SELF,IF=IBM. INTRINSIC ERF,ERFC +SELF. C C Extra CERN routines for Mn_Fit C EXTERNAL BINSIZ REAL GAMMA DOUBLE PRECISION DERF,DERFC,DFREQ,DGAMMA EXTERNAL DERF,DERFC,DFREQ,GAMMA,DGAMMA external ranmar,rmarin,rmarut,rmmar,rmmaq external ranecu,ranecq external ranlux,rluxgo,rluxat,rluxin,rluxut external rnorml,rnormx +SELF,IF=-94B,IF=-95A,IF=-96A. external funlxp,funlux +SELF. external radapt,rgs56p C +CDE,MNPAR. +CDE,MNUSR. +CDE,MNTPL. +CDE,MNCWN. +CDE,MNPRS. +CDE,MNDBG. C real cs common/comis/cs(10000) C Common block from FUNRAN real fint common /funint/ fint C real p(1) double precision z(1) integer lunpm,lunfil,lunlog,lunmap,lunedt C LUNPM = 81 LUNFIL = 82 LUNLOG = 83 LUNMAP = 84 LUNEDT = 85 CALL CLEO_LOKLUN(LUNPM,'MN_CSI') CALL CLEO_LOKLUN(LUNFIL,'MN_CSI') CALL CLEO_LOKLUN(LUNLOG,'MN_CSI') CALL CLEO_LOKLUN(LUNMAP,'MN_CSI') CALL CLEO_LOKLUN(LUNEDT,'MN_CSI') CALL CSSETL(LUNPM,LUNFIL,LUNLOG,LUNMAP,LUNEDT) CALL CSINIT(10000) C C Mn_Fit Common Blocks C CALL CSCOM('MNUSR,PAWIDN,MNTPL1,MNREGI,MNDBG,PAWCR4,PAWCR8#' + ,XMINNM,IDNEVT,ID,REGIS(0),QDEBUG,ar4(1),zr8(1),P,P,P) CALL CSCOMC('MNTPL2,PAWCCH#' + ,TITLE,CCH(1),P,P,P,P,P,P,P,P) C C CERNLIB common blocks C CALL CSCOM('FUNINT#' + ,FINT,P,P,P,P,P,P,P,P,P) C C Mn_Fit routines C CALL CSEXT('XMNCLC.D,XMNCNT.D,XMNFRG.D,XMNHIS.D,XMNRD3.D#' + ,XMNCLC,XMNCNT,XMNFRG,XMNHIS,XMNRD3 + ,Z,Z,Z,Z,Z) CALL CSEXT('XMNRES.D,XMNC2D.D,XMNDFUN.D#' + ,XMNRES,XMNC2D,XMNDFUN + ,Z,Z,Z,Z,Z,Z,Z) CALL CSEXT('RMNCLC.R,RMNCNT.R,RMNFRG.R,RMNHIS.R,RMNRD3.R#' + ,RMNCLC,RMNCNT,RMNFRG,RMNHIS,RMNRD3 + ,P,P,P,P,P) CALL CSEXT('RMNRES.R,RMNC2D.R,RMNDFUN.R#' + ,RMNRES,RMNC2D,RMNDFUN + ,P,P,P,P,P,P,P) call csext('SMCTRL,SMQHAN,SMRMED,SMRMEN,SMSORT#' + ,SMCTRL,SMQHAN,SMRMED,SMRMEN,SMSORT + ,P,P,P,P,P) C C Paw, Zebra, Hbook, Hplot, Cernlib routines C CALL CSEXT('HBOOK1,HBOOK2,HBOOKN,HFILL,HF1,HPRINT,HDELET,HRESET#' +, HBOOK1,HBOOK2,HBOOKN,HFILL,HF1,HPRINT,HDELET,HRESET +, P,P) CALL CSEXT('HFITGA,HFITPO,HFITEX,HPROJ1,HPROJ2,HFN,HGNPAR#' +, HFITGA,HFITPO,HFITEX,HPROJ1,HPROJ2,HFN,HGNPAR +, P,P,P) CALL CSEXT('HROPEN,PAOPEN,PACLOS,PAREAD,PAWRIT,HCDIR,HGIVEN#' +, HROPEN,PAOPEN,PACLOS,PAREAD,PAWRIT,HCDIR,HGIVEN +, P,P,P) CALL CSEXT('HPAK,HPAKE,HUNPAK,HGIVE,HGN,HGNF,HF2,HFF1,HFF2#' +, HPAK,HPAKE,HUNPAK,HGIVE,HGN,HGNF,HF2,HFF1,HFF2 +, P) CALL CSEXT( + 'HMAXIM,HMINIM,HMAX.R,HMIN.R,HSUM.R,HNORMA,HREND,HREND#' +, HMAXIM,HMINIM,HMAX,HMIN,HSUM,HNORMA,HREND,HRENDC,P,P) CALL CSEXT('HI.R,HIE.R,HIX,HIJ.R,HIF.R,HIDALL,HNOENT,HX.R,HXY.R#' +, HI,HIE,HIX,HIJ,HIF,HIDALL,HNOENT,HX,HXY,P) CALL CSEXT('HRIN,HROUT,HCOPY,HBPROF,HOPERA,HIDOPT,HDERIV,HGFIT#' +, HRIN,HROUT,HCOPY,HBPROF,HOPERA,HIDOPT,HDERIV,HGFIT +, P,P) CALL CSEXT('HEXIST.L,HRGET,HRPUT,HSCR,HFIND,HCX.R,HCXY.R,HLABEL#' +, HEXIST,HRGET,HRPUT,HSCR,HFIND,HCX,HCXY,HLABEL,P,P) CALL CSEXT('HBPROX,HBPROY,HBANDX,HBANDY,HBSLIX,HBSLIY#' +, HBPROX,HBPROY,HBANDX,HBANDY,HBSLIX,HBSLIY,P,P,P,P) CALL CSEXT('HBOOKB,HBSTAT,HDIFF,HUNPKE,HREBIN,HERROR,HPROF2#' +, HBOOKB,HBSTAT,HDIFF,HUNPKE,HREBIN,HERROR,HPROF2 +, P,P,P) CALL CSEXT('HOUTPU,HERMES,HISTDO,HFUNC,HXI,HIJXY,HXYIJ,HFINAM#' +, HOUTPU,HERMES,HISTDO,HFUNC,HXI,HIJXY,HXYIJ,HFINAM,P,P) CALL CSEXT('HSTATI.R,HLPOS,HFC1#',HSTATI,HLPOS,HFC1,P,P,P,P,P,P,P) CALL CSEXT('HSPLI1,HSPLI2,HMDIR,HLDIR,HRDIR,HLOCAT,HFITH,HFITV#' +, HSPLI1,HSPLI2,HMDIR,HLDIR,HRDIR,HLOCAT,HFITH,HFITV +, P,P) CALL CSEXT('HTITLE,HBFUN1,HBFUN2,HRNDM1.R,HRNDM2,HBARX,HBARY#' +, HTITLE,HBFUN1,HBFUN2,HRNDM1,HRNDM2,HBARX,HBARY +, P,P,P) CALL CSEXT('HPLOT,HPLSYM,HPLERR,HPLEGO,HPLNT,'// + 'HPLSUR,HPLSOF,HPLFRA#' +, HPLOT,HPLSYM,HPLERR,HPLEGO,HPLNT,HPLSUR,HPLSOF,HPLFRA +, P,P) CALL CSEXT('HPLABL,HPLSET,HPLGIV,HPLOC,HPLTOC,HPLNEW,HPLOPT#' +, HPLABL,HPLSET,HPLGIV,HPLOC,HPLTOC,HPLNEW,HPLOPT,P,P,P) CALL CSEXT('HBNT,HBNAME,HBNAMC,HFNT,HFNTB,HGNT,HGNTF,HGNTV,HBSET#' +, HBNT,HBNAME,HBNAMC,HFNT,HFNTB,HGNT,HGNTF,HGNTV,HBSET +, P) CALL CSEXT('HGNTB,HNBENT,HVXIST#',HGNTB,HNBENT,HVXIST +, P,P,P,P,P,P,P) ** CALL CSEXT('HMCINI,HMCMLL#',HMCINI,HMCMLL,P,P,P,P,P,P,P,P) CALL CSEXT('MNEMAT,MNERRS,MNSTAT#',MNEMAT,MNERRS,MNSTAT +, P,P,P,P,P,P,P) CALL CSEXT('KUGETV,KUDPAR,KUVECT,KILEXP,KUTIME,KUEXEL,KUPROS#' +, KUGETV,KUDPAR,KUVECT,KILEXP,KUTIME,KUEXEL,KUPROS +, P,P,P) CALL CSEXT('KUNWG,KUCMD,KUGUID,KUNDPV,KUPAR,KUPVAL,KUACT#' +, KUNWG,KUCMD,KUGUID,KUNDPV,KUPAR,KUPVAL,KUACT,P,P,P) CALL CSEXT('IPL,IPM,IFA,IGTEXT,IGBOX,IGAXIS,IGPIE,IGRAPH,IGHIST#' +, IPL,IPM,IFA,IGTEXT,IGBOX,IGAXIS,IGPIE,IGRAPH,IGHIST +, P) CALL CSEXT('IGARC,IGLBL,IGRNG,IGMETA,IGSA,IGSET,IRQLC,IRQST,ISCR#' +, IGARC,IGLBL,IGRNG,IGMETA,IGSA,IGSET,IRQLC,IRQST,ISCR +, P) CALL CSEXT('ISELNT,ISFAIS,ISFASI,ISLN,ISMK,ISVP,ISWN,ITX,ICLRWK#' +, ISELNT,ISFAIS,ISFASI,ISLN,ISMK,ISVP,ISWN,ITX,ICLRWK +, P) CALL CSEXT('IGPAVE,IGTERM#',IGPAVE,IGTERM,P,P,P,P,P,P,P,P) CALL CSEXT('FZIN,FZOUT,FZFILE,FZENDI,FZENDO,MZLOGL#' +, FZIN,FZOUT,FZFILE,FZENDI,FZENDO,MZLOGL +, P,P,P,P) CALL CSEXT('RZCDIR,RZLDIR,RZFILE,RZEND,RZIN,RZOUT,RZVIN,RZVOUT#' +, RZCDIR,RZLDIR,RZFILE,RZEND,RZIN,RZOUT,RZVIN,RZVOUT +, P,P) CALL CSEXT('RZIODO,RZOPEN,RZCLOS,RZQUOT#' +, RZIODO,RZOPEN,RZCLOS,RZQUOT,P,P,P,P,P,P) CALL CSEXT('VZERO,UCOPY,RNDM.R,RANNOR,LENOCC.I,CLTOU,CUTOL#' +, VZERO,UCOPY,RNDM,RANNOR,LENOCC,CLTOU,CUTOL +, P,P,P) CALL CSEXT('SBIT0,SBIT1,SBYT,JBIT.I,JBYT.I,UCTOH,UHTOC,TIMED#' +, SBIT0,SBIT1,SBYT,JBIT,JBYT,UCTOH,UHTOC,TIMED +, P,P) CALL CSEXT('ERF.R,ERFC.R,FREQ.R,PROB.R,RANLAN.R#' +, ERF,ERFC,FREQ,PROB,RANLAN,P,P,P,P,P) CALL CSEXT('DENLAN.R,DSTLAN.R,DIFLAN.R,XM1LAN.R,XM2LAN.R#' +, DENLAN,DSTLAN,DIFLAN,XM1LAN,XM2LAN,P,P,P,P,P) C C Extra CERN routines for Mn_Fit C CALL CSEXT('BINSIZ,DERF.D,DERFC.D,DFREQ.D,GAMMA.R,DGAMMA.D#' + ,BINSIZ,DERF,DERFC,DFREQ,GAMMA,DGAMMA + ,P,P,P,P) CALL CSEXT('RANMAR,RMARIN,RMARUT,RMMAR,RMMAQ,RANECU,RANECQ#' + ,RANMAR,RMARIN,RMARUT,RMMAR,RMMAQ,RANECU,RANECQ + ,P,P,P) CALL CSEXT('RANLUX,RLUXGO,RLUXAT,RLUXIN,RLUXUT,RNORML,RNORMX#' + ,RANLUX,RLUXGO,RLUXAT,RLUXIN,RLUXUT,RNORML,RNORMX + ,P,P,P) +SELF,IF=-94B,IF=-95A,IF=-96A. CALL CSEXT('FUNLXP,FUNLUX#' + ,FUNLXP,FUNLUX + ,P,P,P,P,P,P,P,P) +SELF. CALL CSEXT('RADAPT,RGS56P#' + ,RADAPT,RGS56P + ,P,P,P,P,P,P,P,P) C END +DECK,mn_dfl. SUBROUTINE MN_DFL C C SETS DEFAULT VALUES FOR PARAMETERS C implicit none * +CDE,MNPAR. +CDE,MNFIT. +CDE,MNFUN. +CDE,MNHPJ. +CDE,MNPLT. +CDE,MNCWN. +CDE,MNCMD. +CDE,MNTYQ. +CDE,MNFLG. +CDE,MNGRN. +CDE,MNLUN. C QSEXCL = .TRUE. NSID = 2 NSHEAD = 2 NSFOOT = 0 TSFOOT = ' ' QSTEXT = .TRUE. QTUSER = .FALSE. QTGLBL = .FALSE. QSBOX = .FALSE. QLEGO = .FALSE. QDFIT = .FALSE. QDFUN = .FALSE. QMNCHGE = .TRUE. QPIPLT = .FALSE. qascal = .true. qatrim = .true. C C Do not use mouse for positioning things C QMOUSE = .FALSE. * * Automatically refetch Ntuples when they are to be projected * QAFETCH = .TRUE. C C Function Parameters C NFPNT = 500 C C Fit Display Parameters C NDMODE = 1 C C CWN variables C ncwn_x = 0 C C PICTURE AND PLOT SIZES AND MARGINS C SIZES(1) = SIZED(1) SIZES(2) = SIZED(2) AMRGS(1) = AMRGD(1) AMRGS(2) = AMRGD(2) WMRGS(1) = WMRGD(1) WMRGS(2) = WMRGD(2) HSZES(1) = HSZED(1) HSZES(2) = HSZED(2) WSZES(1) = WSZED(1) WSZES(2) = WSZED(2) C C LIMITS FOR PLOTS C CALL UCOPY_r(ALIMD(1,1),ALIMS(1,1),2*3) C C LEGO PLOT DEFAULT ANGLES C CALL UCOPY_r(ALEGD(1),ALEGS(1),10) C NSYMS = NSYMD NHATS = NHATD NPATS = NPATD C C Colours C CALL UCOPY_i(ICOLD,ICOLS,20) C C Line thicknesses C CALL UCOPY_r(ATHKD,ATHKS,10) C C Fonts C CALL UCOPY_i(IFNTD,IFNTS,10) C C TEXT AND SYMBOL SIZES C CALL UCOPY_r(TSZED,TSZES,10) C C Bin scaling and offsets C CALL UCOPY_r(ABIND,ABINS,10) C C DRAW LINE AT X OR Y = 0 AND SYMBOL C QZEROS(1) = QZEROD(1) IZEROS(1) = IZEROD(1) QZEROS(2) = QZEROD(2) IZEROS(2) = IZEROD(2) C C Draw a grid on the plot C IGRIDS(1,1) = IGRIDD(1,1) IGRIDS(2,1) = IGRIDD(2,1) IGRIDS(1,2) = IGRIDD(1,2) IGRIDS(2,2) = IGRIDD(2,2) IGRIDS(1,3) = IGRIDD(1,3) IGRIDS(2,3) = IGRIDD(2,3) C C WINDOWING, NUMBER OF WINDOWS AND THEIR SPACING C QWIND = .FALSE. IWIND(1) = 1 IWIND(2) = 1 WSPACE(1) = 2.0 WSPACE(2) = 2.0 IPWNDS(1) = IPWNDD(1) IPWNDS(2) = IPWNDD(2) C C DRAW FRAME ROUND THE PLOT C CALL QCOPY(QFRAMD(1,1),QFRAMS(1,1),10*3) C C SET NUMBER OF TICKS AND SIZES TO DEFAULT VALUES C CALL UCOPY_r(TICKD(1,1),TICKS(1,1),10*3) CALL QCOPY(QTICKD(1,1),QTICKS(1,1),10*3) C C SET SCALE PARAMETERS TO DEFAULT VALUES C ISMODS(1) = ISMODD(1) ISMODS(2) = ISMODD(2) ISMODS(3) = ISMODD(3) CALL UCOPY_r(SCALD(1,1),SCALS(1,1),10*3) CALL QCOPY(QSCALD(1,1),QSCALS(1,1),10*3) C C SET AXIS LABELS TO DEFAULT VALUES C CALL UCOPY_r(ALABLD(1,1),ALABLS(1,1),10*3) CALL QCOPY(QLABLD(1,1),QLABLS(1,1),10*3) ILABLS(1) = ILABLD(1) ILABLS(2) = ILABLD(2) ILABLS(3) = ILABLD(3) TLABLS(1) = TLABLD(1) TLABLS(2) = TLABLD(2) TLABLS(3) = TLABLD(3) C C SET TITLE POSITION TO DEFAULT VALUES C CALL UCOPY_r(TITLD(1),TITLS(1),10) CALL UCOPY_r(TITGD(1),TITGS(1),10) CALL QCOPY(QTITLD(1),QTITLS(1),10) C C SIZES FOR THE DISPLAY COMMAND C FSIZE(1) = FSIZED(1) FSIZE(2) = FSIZED(2) FAMRG(1) = FAMRGD(1) FAMRG(2) = FAMRGD(2) FHSZE(1) = FHSZED(1) FHSZE(2) = FHSZED(2) C CALL VZERO_i(NPLTCM,MHPLT) CALL VZERO_i(NPLTKY,MHPLT) NDRWLN = 0 C LUNDMP = LUNTTO C C Initialize stuff for interface to IGTABL C NIGPARS = NIGPARD CALL UCOPY_r(AIGPARD,AIGPARS,MIGPAR) TIGOPTS = TIGOPTD LIGOPTS = LIGOPTD C C Reset all HIGZ stuff to default and switch back to alphanumeric mode C Also make sure the normalization transformation is set properly C CICB CALL HPLOPT('* ',1) CICB CALL HPLSET('*',0.0) CICB CALL HPLOPT('TIC ',1) CALL IGSET('*',0.0) CALL TVRNG(.TRUE.,0.0,0.0,SIZES(1),SIZES(2)) CALL IGSA(0) C C Parameters for the special displays - implemented for L3 C CALL MN_DSD C RETURN END +DECK,mn_dmp. SUBROUTINE MN_DMP(IDA,IDB,LUN) * implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCWN. +CDE,MNCMD. +CDE,MNLUN. +cde,slate. C integer ida,idb,lun C INTEGER IBIN(MDIMMX) REAL AVAL(MDIMMX) CHARACTER*3 TBIN(3) character tcwn(5)*4,tmode(4)*5 C CHARACTER*255 TXT1,TXT2,CONCAT,CONCT0 integer nh,idh,ioerr,lent,lenf,lend,lenc,lenb,lnblnk integer nn,i,j,k,ii,jj,nuof,ierr,kcmd,idelim,nvline,nv1,nv2,nline + ,nltot,nlidx,nptr,n1,n2,m1,m2,np,nloop,nvar,nelem,nsub,nelem_max + ,npnt1,npnt2,nc1,nc2,nvsize,nt1 + ,nchfnd,nval,nv,nfact,ie(10) real xx,yy,dxx,dyy,rval C integer icmtyq,nchscn,ivltyq logical hntnew,qcwntp external hntnew,icmtyq,nchscn,ivltyq C DATA TBIN/'UND','INS','OVE'/ data tcwn/'REAL','INT','INT','LOG','CHAR'/ data tmode/'Days','Hours','Mins','Secs'/ C C GET THE POINTERS ETC C CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_DMP',TXTERR) GOTO 9000 ENDIF C WRITE(TXTMES,'('' Histogram'',I7,I4 + ,'' # of points'',I6,'' Dimension'',I5 + ,'' Date/Time'',1X,I6.6,''/'',I4.4)') + IDA,IDB,NPNT,NDIM,NHDATE,NHTIME CALL MN_MES(LUN,'I',TXTMES) WRITE(TXTMES,'('' # of words/point'',I4 + ,'' # of bits per word'',I3)') NWPPT,NBPPT CALL MN_MES(LUN,'I',TXTMES) WRITE(TXTMES,'('' Area'',F10.1 + ,'', Limits on # of entries (incl errors)'',2(1PG13.5))' + ,IOSTAT=IOERR) EDENT,EDLO,EDHI CALL MN_MES(LUN,'I',TXTMES) LENT = MAX0(LNBLNK(TDTIT(NH)),1) CALL MN_MES(LUN,'I',' Title: ' // TDTIT(NH)(1:LENT)) LENF = MAX0(LNBLNK(TDFIL(NH)),1) CALL MN_MES(LUN,'I',' File: ' // TDFIL(NH)(1:LENF)) LEND = MAX0(LNBLNK(TDDIR(NH)),1) CALL MN_MES(LUN,'I',' Directory: ' // TDDIR(NH)(1:LEND)) if(ntmode.ne.0) then write(txtmes, '('' Time mode:'',A + ,'', Reference time: '',i6.6,''/'',i6.6)',iostat=ioerr) + tmode(ntmode),nsdate,nstime CALL MN_MES(LUN,'I',txtmes) endif C DO 900 NN=NH-1,NH+1 C IF(NN.LE.0 .OR. NN.GT.NDHIS) GOTO 900 C IF(NN.EQ.NH-1) THEN C WRITE(LUN,'(/,'' Previous histogram'',I7,I4)') C 1 IDIDA(NN),IDIDB(NN) C ELSEIF(NN.EQ.NH) THEN C WRITE(LUN,'('' Present histogram'',I7,I4)') C 1 IDIDA(NN),IDIDB(NN) C ELSEIF(NN.EQ.NH+1) THEN C WRITE(LUN,'('' Next histogram'',I7,I4)') C 1 IDIDA(NN),IDIDB(NN) C ENDIF C NNHPT = IABS(IDPTRH(NN)) C WRITE(LUN,'('' Pointer to header'',I6,'' Data'',I6 C 1 ,/,'' Number of words'',I6,'' Header'',I6,'' Data'',I6)') C 1 ,IDPTRH(NN),IDPTRD(NN),NINT(RDAT(NNHPT)) C 1 ,NINT(RDAT(NNHPT+1)),NINT(RDAT(NNHPT+2)) C900 CONTINUE C C Set up the directories so that I can dump points for Ntuples C which are not in memory C qcwntp = .false. if(ndim.lt.0 .and. nwdat.eq.0 .and. npnt.gt.0) then call m_sdir(0,ierr) if(ierr.ne.0) goto 9000 idh = ida qcwntp = hntnew(idh) if(qcwntp) then * Seems to blow up on my DQM time history Ntuple! c call hprnt(idh) c txtmes = 'All CWN variables will be converted to real' c call mn_mes(luntto,'ME',txtmes) nvcwn = 0 call m_ntppnt(ida,idb,0,ierr,aval) *ICB else *ICB call hprntu(idh) endif endif C if(qcwntp .or. ndim.le.-3) then txtmes = ' List of Ntuple Variables:' call mn_mes(lun,'I',txtmes) if(qcwntp) then write(txtmes,'(1X,''Numb/Name'' + ,T30,''Type'',T40,''Block'',T50,''Definition'')') call mn_mes(lun,'I',txtmes) endif endif DO 1000 NN=1,IABS(NDIM) if(qcwntp) then lend = min0(35,lnblnk(cvdesc(nn))) call m_tsub(1,nh,ivsub(1,nn),ivsub(3,nn),ivelem(nn) + ,txt1,n1) n1 = max0(1,n1) lent = lnblnk(tdnam(nn,nh)) lenc = lnblnk(tcwn(ivtype(nn))) lenb = lnblnk(chblk(nn)) WRITE(TXTMES,'(1X,I4,''/'',A,A,T30,A,''*'',I2,'','' + ,T40,A,T50,A)') + nn,tdnam(nn,nh)(:lent),txt1(:n1) + ,tcwn(ivtype(nn))(:lenc),ivsize(nn),chblk(nn)(:lenb) *ICB + ,ivsub(1,nn),ivsub(2,nn),ivelem(nn) + ,cvdesc(nn)(:lend) CALL MN_MES(LUN,'I',TXTMES) elseif(ndim.gt.-3) then TXT1 = CONCAT(TDNAM(NN,NH),'axis:') lent = max(lnblnk(txt1),13) WRITE(TXTMES,'(1X,A,'' Number of bins'',I4 + ,'' Lower/upper limits'',2(1PG13.5))') + TXT1(:lent),IDBIN(NN),ADLO(NN),ADHI(NN) CALL MN_MES(LUN,'I',TXTMES) WRITE(TXTMES + ,'(15X,''Mean'',1PG13.5,'' Sigma'',1PG13.5)') + AMEAN(NN),ASIG(NN) CALL MN_MES(LUN,'I',TXTMES) else lent = max0(8,lnblnk(tdnam(nn,nh))) WRITE(TXTMES,'(1X,I4,''/'',A,'':'' + ,'' Lower/upper limits'',2(1PG13.5))') + nn,tdnam(nn,nh)(:lent),ADLO(NN),ADHI(NN) CALL MN_MES(LUN,'I',TXTMES) endif 1000 CONTINUE C C DUMP THE UNDERFLOWS AND OVERFLOWS C IF(.not.qcwntp .and. ndim.gt.-3 .and. ndim.le.3) THEN CALL MN_MES(LUN,'I',' Number of underflows and overflows:') NUOF = 3**IABS(NDIM) CALL MN_UOF(RDAT(NPTRH),ACONT) IBIN(1) = 0 IBIN(2) = 0 DO 1100 NN=3,IABS(NDIM) IBIN(NN) = 1 1100 CONTINUE DO 1300 I=1,NUOF,3 IBIN(2) = IBIN(2) + 1 IF(IBIN(2).GT.3) THEN DO 1220 NN=3,IABS(NDIM) IF(IBIN(NN-1).GT.3) THEN IBIN(NN-1) = 1 IBIN(NN) = IBIN(NN) + 1 ENDIF 1220 CONTINUE ENDIF C TXT1 = ' ' TXT1 = CONCAT(TDNAM(1,NH),'axis UND|INS|OVE') DO 1230 II=2,IABS(NDIM) TXT2 = CONCT0(TXT1,',') TXT1 = CONCAT(TXT2,TDNAM(II,NH)) TXT2 = CONCAT(TXT1,'axis') TXT1 = CONCAT(TXT2,TBIN(IBIN(II))) 1230 CONTINUE C LENT = LNBLNK(TXT1) WRITE(TXTMES,'(1X,A,2X,3I11)',IOSTAT=IOERR) TXT1(1:LENT) 1 ,(NINT(ACONT(JJ)),JJ=I,I+2) CALL MN_MES(LUN,'I',TXTMES) 1300 CONTINUE ENDIF CALL MN_MES(LUN,'E',' ') C C Find out which points to dump C call waityq( + 'Dump the points [Y/N] or give point numbers (=N)? ') kcmd = icmtyq(.true.,idelim,lognam) if(kcmd.lt.0) goto 9000 nchfnd = nchscn() if(kcmd.eq.0 .and. nchfnd.eq.0) goto 9000 if(kcmd.gt.0 .and. mod(kcmd,2).eq.0) goto 9000 if(mod(kcmd,2).eq.1) then npnt1 = 1 npnt2 = npnt else call restyq npnt1 = ivltyq(.true.,idelim) nchfnd = nchscn() if(idelim.gt.0) goto 9000 * if(npnt1.eq.0) then npnt1 = 1 npnt2 = npnt else npnt1 = max0(1,min0(npnt,iabs(npnt1))) npnt2 = npnt1 if(idelim.eq.0) then np = ivltyq(.true.,idelim) if(np.gt.0 .and. np.gt.npnt1) npnt2 = np endif endif endif C IF(NDIM.GT.2) THEN WRITE(TXTMES,'('' Point'',20X,''Entries'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(.not.qcwntp .and. NDIM.EQ.-1 .AND. NWPPT.EQ.1) THEN WRITE(TXTMES,'('' Point'',6X,''X'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(.not.qcwntp .and. NDIM.EQ.-1 .AND. NWPPT.EQ.2) THEN WRITE(TXTMES,'('' Point'',6X,''X'',10X 1 ,''Y'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(.not.qcwntp .and. NDIM.EQ.-1 .AND. NWPPT.EQ.4) THEN WRITE(TXTMES,'('' Point'',6X 1 ,''X +/- DX'',14X 1 ,''Y +/- DY'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(.not.qcwntp .and. NDIM.EQ.-1 .AND. NWPPT.EQ.6) THEN WRITE(TXTMES,'('' Point'',5X 1 ,''X -DX +DX'',14X 1 ,''Y -DY +DY'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(NDIM.EQ.1 .AND. NWPPT.EQ.4) THEN WRITE(TXTMES,'('' Point'',6X,''X'',10X,''Entries'' + ,17X,''Errors'',15X,''Weight'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(NDIM.EQ.1) THEN WRITE(TXTMES,'('' Point'',6X,''X'',10X,''Entries'')') CALL MN_MES(LUN,'IE',TXTMES) ELSEIF(NDIM.EQ.2) THEN WRITE(TXTMES,'(6X,''Point'',6X,''X'',11X,''Y'',19X + ,''Entries'')') CALL MN_MES(LUN,'IE',TXTMES) elseif(qcwntp) then txtmes = ' Name(Elem)' CALL MN_MES(LUN,'IE',TXTMES) ELSE NVLINE = 4 NLINE = (IABS(NDIM)-1) / NVLINE + 1 DO 1400 J=1,NLINE NV1 = NVLINE*(J-1) + 1 NV2 = MIN0(NVLINE*J,IABS(NDIM)) IF(J.EQ.1) THEN WRITE(TXTMES,'(1X,''Point/Var'',2X,4(I4,''/'',A12))' + ,iostat=ioerr) (II,TDNAM(II,NH),II=NV1,NV2) ELSE WRITE(TXTMES,'(12X,4(I4,''/'',A12))' + ,iostat=ioerr) (II,TDNAM(II,NH),II=NV1,NV2) ENDIF CALL MN_MES(LUN,'I',TXTMES) 1400 CONTINUE CALL MN_MES(LUN,'IE',' ') ENDIF C IBIN(1) = 0 DO 6100 NN=2,IABS(NDIM) IBIN(NN) = 1 6100 CONTINUE DXX = 0.0 DYY = 0.0 IF(NDIM.GT.0) THEN IF(IDBIN(1).GT.0) DXX = (ADHI(1)-ADLO(1))/FLOAT(IDBIN(1)) IF(NDIM.GT.1 .AND. IDBIN(2).GT.0) 1 DYY = (ADHI(2)-ADLO(2))/FLOAT(IDBIN(2)) ENDIF C IF(.not.qcwntp .and. IABS(NDIM).LE.1 .or. ndim.eq.2) THEN if(iabs(ndim).eq.1) then ibin(1) = npnt1 -1 else ibin(1) = mod(npnt1-1,idbin(1)) ibin(2) = (npnt1-1) / idbin(1) + 1 endif DO 6300 I=NPNT1,NPNT2 IBIN(1) = IBIN(1) + 1 IF(IBIN(1).GT.IDBIN(1)) THEN DO 6220 NN=2,IABS(NDIM) IF(IBIN(NN-1).GT.IDBIN(NN-1)) THEN IBIN(NN-1) = 1 IBIN(NN) = IBIN(NN) + 1 ENDIF 6220 CONTINUE ENDIF NPTR = NPTRD + NWPPT*(I-1) - 1 IF(NDIM.GT.0) THEN XX = ADLO(1) + FLOAT(IBIN(1)-1)*DXX + 0.5*DXX IF(NDIM.GT.1) YY = ADLO(2)+FLOAT(IBIN(2)-1)*DYY + 1 0.5*DYY ENDIF C IF(NDIM.EQ.-1 .AND. NWPPT.EQ.1) THEN WRITE(TXTMES,'(1X,I5,'':'',1(1PG13.5))',IOSTAT=IOERR) 1 I,RDAT(NPTR+1) ELSEIF((NDIM.EQ.-1 .AND. NWPPT.EQ.2) .OR. NDIM.EQ.-2) THEN WRITE(TXTMES,'(1X,I5,'':'',2(1PG13.5))',IOSTAT=IOERR) 1 I,RDAT(NPTR+1),RDAT(NPTR+2) ELSEIF(NDIM.EQ.-1 .AND. NWPPT.EQ.4) THEN WRITE(TXTMES,'(1X,I5,'':'',2(1PG13.5),2X,2(1PG13.5))' 1 ,IOSTAT=IOERR) I 1 ,RDAT(NPTR+1),RDAT(NPTR+3) 1 ,RDAT(NPTR+2),RDAT(NPTR+4) ELSEIF(NDIM.EQ.-1 .AND. NWPPT.EQ.6) THEN WRITE(TXTMES,'(1X,I5,'':'',3(1PG11.4),2X,3(1PG11.4))' 1 ,IOSTAT=IOERR) I 1 ,RDAT(NPTR+1),RDAT(NPTR+3),RDAT(NPTR+5) 1 ,RDAT(NPTR+2),RDAT(NPTR+4),RDAT(NPTR+6) ELSEIF(NDIM.EQ.1 .AND. NWPPT.EQ.1) THEN WRITE(TXTMES,'(1X,I5,'':'',1PG12.4,2X,1PG13.5)' 1 ,IOSTAT=IOERR) I,XX,RDAT(NPTR+1) ELSEIF(NDIM.EQ.1 .AND. NWPPT.EQ.2) THEN WRITE(TXTMES,'(1X,I5,'':'',1PG12.4 1 ,2X,1PG13.5,'' +/-'',1PG13.5))',IOSTAT=IOERR) 1 I,XX,RDAT(NPTR+1),RDAT(NPTR+2) ELSEIF(NDIM.EQ.1 .AND. NWPPT.EQ.3) THEN WRITE(TXTMES,'(1X,I5,'':'',1PG12.4 1 ,2X,1PG13.5,'' -'',1PG13.5,'' +'',1PG13.5))' + ,IOSTAT=IOERR) 1 I,XX,RDAT(NPTR+1),RDAT(NPTR+2),RDAT(NPTR+3) ELSEIF(NDIM.EQ.1 .AND. NWPPT.EQ.4) THEN WRITE(TXTMES,'(1X,I5,'':'',1PG12.4 1 ,2X,1PG13.5,'' -'',1PG13.5,'' +'',1PG13.5 + ,2X,1PG13.5))',IOSTAT=IOERR) 1 I,XX,RDAT(NPTR+1),RDAT(NPTR+2),RDAT(NPTR+3) + ,RDAT(NPTR+4) ELSEIF(NDIM.EQ.2 .AND. NWPPT.EQ.1) THEN WRITE(TXTMES,'(1X,I5,'','',I5,'':'',2(1PG12.4) 1 ,2X,1PG13.5)' 1 ,IOSTAT=IOERR) IBIN(1),IBIN(2),XX,YY,RDAT(NPTR+1) ELSEIF(NDIM.EQ.2 .AND. NWPPT.EQ.2) THEN WRITE(TXTMES,'(1X,I5,'','',I5,'':'',2(1PG12.4) 1 ,2X,1PG13.5,'' +/-'',1PG13.5)',IOSTAT=IOERR) 2 IBIN(1),IBIN(2),XX,YY 1 ,RDAT(NPTR+1),RDAT(NPTR+2) ELSEIF(NDIM.EQ.2 .AND. NWPPT.EQ.3) THEN WRITE(TXTMES,'(1X,I5,'','',I5,'':'',2(1PG12.4) 1 ,2X,1PG13.5,'' -'',1PG13.5,'' +'',1PG13.5)' + ,IOSTAT=IOERR) 2 IBIN(1),IBIN(2),XX,YY 1 ,RDAT(NPTR+1),RDAT(NPTR+2),RDAT(NPTR+3) ENDIF CALL MN_MES(LUN,'I',TXTMES) IF(I.LT.NPNT .AND. MOD(I,100).EQ.0) THEN CALL MN_CRT(1,'Hit for more' // + ' (q to quit, any character to stop):',IERR) IF(IERR.NE.0) GOTO 9000 ENDIF 6300 CONTINUE C C HISTOGRAMS WITH MORE THAN 2-DIMENSIONS ARE STORED IN I*2 FORMAT C ELSEIF(NDIM.GT.2) THEN IF(NWPPT.EQ.1) THEN NLINE = (npnt2-npnt1)/5 + 1 NPTR = 2*NPTRD - 1 DO 6200 I=1,NLINE N1 = 5*(I-1)+ npnt1 N2 = MIN0(5*I,NPNT2) WRITE(TXTMES,'(1X,I6,'':'',5(I8,1X))') 1 N1,(IDAT2(NPTR+JJ-1),JJ=N1,N2) CALL MN_MES(LUN,'I',TXTMES) IF(I.LT.NLINE .AND. MOD(I,100).EQ.0) THEN CALL MN_CRT(1,'Hit for more' // + ' (q to quit, any character to stop):',IERR) IF(IERR.NE.0) GOTO 9000 ENDIF 6200 CONTINUE ELSE NLINE = (NPNT2-npnt1)/2 + 1 DO 6250 I=1,NLINE N1 = 2*(I-1)+ npnt1 N2 = MIN0(2*I,NPNT2) M1 = 2*N1-1 M2 = 2*N2 WRITE(TXTMES,'(1X,I6,'':'' 1 ,2(1pG13.5,'' +/-'',1pG13.5,2X))') 2 N1,(RDAT(NPTRD+JJ-1),JJ=M1,M2) CALL MN_MES(LUN,'I',TXTMES) IF(I.LT.NLINE .AND. MOD(I,100).EQ.0) THEN CALL MN_CRT(1,'Hit for more' // + ' (q to quit, any character to stop):',IERR) IF(IERR.NE.0) GOTO 9000 ENDIF 6250 CONTINUE ENDIF C C Dump an Ntuple C ELSEif(qcwntp) then nvcwn = 0 call m_ntppnt(ida,idb,0,ierr,aval) DO np=NPNT1,npnt2 nltot = 0 call m_ntppnt(ida,idb,np,ierr,aval) if(ierr.ne.0) then write(txterr + ,'(''Error unpacking Ntuple'',i7)') idh call mn_err('MN_DMP',txterr) goto 9000 endif C write(txtmes,'('' Event'',I8)') np call mn_mes(lun,'i',txtmes) if(nvcwn.eq.0) then nloop = iabs(ndim) else nloop = nvcwn endif do i=1,nloop if(nvcwn.eq.0) then nvar = i else nvar = ivcwn(i) endif nelem = ivelem(i) nsub = ivsub(1,nvar) if(nsub.gt.0 .and. ivsub(2+nsub,nvar).lt.0) then nv = -ivsub(2+nsub,nvar) call m_ntpvar(nv,1,nval,rval,ierr) else nval = ivsub(2+nsub,nvar) endif * * Values per line * if(ivtype(nvar).eq.5 .and. ivsize(nvar).ge.12) then nvline = (65-1) / (ivsize(nvar)+1) + 1 else nvline = 4 endif * if(nsub.gt.0) then nelem = ivsub(2,nvar) * nval if(nsub.gt.1 .and. ivsub(3,nvar).lt.nvline) then nvline = ivsub(3,nvar) endif if(nsub.gt.1) then nlidx = (ivsub(3,nvar)-1) / nvline + 1 nline = ivsub(2,nvar)/ivsub(3,nvar)*nlidx*nval else nlidx = 1 nline = (nelem-1) / nvline + 1 endif else nlidx = 1 nline = (nelem-1) / nvline + 1 endif nelem_max = nelem nltot = nltot + nline nv = nvline nv1 = 1 - nv do j=1,nline nv1 = nv1 + nv nv = nvline if(nsub.gt.1 .and. mod(j,nlidx).eq.0) + nv = mod(ivsub(3,nvar)-1,nvline) + 1 nv2 = nv1 + nv - 1 nv2 = min0(nv2,nelem_max) * * 1st variable number * if(nsub.gt.0) then nfact = ivsub(2,nvar) nn = nv1 do k=ivsub(1,nvar),1,-1 ie(k) = (nn-1)/nfact + 1 nn = mod(nn-1,nfact) + 1 if(k.gt.1) then nfact = nfact / ivsub(1+k,nvar) else nfact = 1 endif enddo * txt1 = chcwn(i) n1 = lnblnk(txt1)+2 txt1(n1-1:n1-1) = '(' do k=1,ivsub(1,nvar) n2 = n1 + 4 call csetdi(ie(k),txt1,n1,n2) call cleft(txt1,n1,n2) n1 = n1 + nd if(k.lt.ivsub(1,nvar)) then txt1(n1:n1) = ',' n1 = n1 + 1 endif enddo txt1(n1:n1) = ')' else txt1 = chcwn(nvar) endif lent = lnblnk(txt1) *ICB nv1 = nvline*(j-1) + 1 *ICB nv2 = min0(nvline*j,nelem) if(ivtype(nvar).eq.1 .and. ivsize(nvar).eq.4) then write(txtmes,'(1x,a,'':'' + ,t30,4(1pg12.5,1x))') + txt1(:lent) + ,(ar4(ivposn(nvar)+ii-1),ii=nv1,nv2) elseif(ivtype(nvar).eq.1 .and. + ivsize(nvar).eq.8) then write(txtmes,'(1x,a,'':'' + ,t30,4(1pg12.5,1x))') + txt1(:lent) + ,(zr8(ivposn(nvar)+ii-1),ii=nv1,nv2) elseif(ivtype(nvar).eq.2 .or. + ivtype(nvar).eq.3) then write(txtmes,'(1x,a,'':'' + ,t30,4(i12,1x))') + txt1(:lent) + ,(ir4(ivposn(nvar)+ii-1),ii=nv1,nv2) elseif(ivtype(nvar).eq.4) then write(txtmes,'(1x,a,'':'' + ,t30,4(l12,1x))') + txt1(:lent) + ,(qr4(ivposn(nvar)+ii-1),ii=nv1,nv2) elseif(ivtype(nvar).eq.5) then lenc = max0(ivsize(nvar),12) write(txtmes,'(1x,a,'':'')') + txt1(:lent) do ii=nv1,nv2 nc1 = (ii-1) * ivsize(nvar)/4 + 1 nc2 = ii * ivsize(nvar)/4 nt1 = 30 + mod((ii-1),nvline)*(lenc+1) write(txtmes(nt1:),'(16a)') + (cch(ivposn(nvar)+jj-1),jj=nc1,nc2) enddo endif if(ivtype(nvar).ne.5) then nvsize = max0(ivsize(nvar),12) + 1 do ii=1,(nv2-nv1+1) n1 = 30 + nvsize*(ii-1) n2 = n1 + nvsize - 1 call cright(txtmes,n1,n2) enddo endif call mn_mes(lun,'i',txtmes) enddo enddo IF(NLINE.GT.1) CALL MN_MES(LUN,'I',' ') IF(np.LT.NPNT2 .AND. MOD(np-npnt1+1,10).EQ.0) THEN CALL MN_CRT(1,'Hit for more' // + ' (q to quit, any character to stop):',IERR) IF(IERR.NE.0) GOTO 9000 ENDIF enddo else nvcwn = 0 call m_ntppnt(ida,idb,0,ierr,aval) DO 7000 I=NPNT1,npnt2 call m_ntppnt(ida,idb,i,ierr,aval) if(ierr.ne.0) then write(txterr + ,'(''Error unpacking Ntuple'',i7)') idh call mn_err('MN_DMP',txterr) goto 9000 endif C do 6900 j=1,nline nv1 = nvline*(j-1) + 1 nv2 = min0(nvline*j,iabs(ndim)) if(j.eq.1) then write(txtmes,'(1x,i5,''/'',i4,'':'' + ,4(1pg13.6,4x))') + i,nv1,(aval(ii),ii=nv1,nv2) else write(txtmes,'(7x,i4,'':'' + ,4(1pg13.6,4x))') + nv1,(aval(ii),ii=nv1,nv2) endif nvsize = 17 do ii=1,(nv2-nv1+1) n1 = 13 + nvsize*(ii-1) n2 = n1 + nvsize - 1 call cright(txtmes,n1,n2) enddo call mn_mes(lun,'i',txtmes) 6900 continue IF(NLINE.GT.1) CALL MN_MES(LUN,'I',' ') IF(I.LT.NPNT .AND. MOD(I,100).EQ.0) THEN CALL MN_CRT(1,'Hit for more' // + ' (q to quit, any character to stop):',IERR) IF(IERR.NE.0) GOTO 9000 ENDIF 7000 CONTINUE ENDIF CALL MN_MES(LUN,'E',' ') C 9000 CONTINUE END +DECK,mn_drw. SUBROUTINE MN_DRW(NTYPFL,NDERR) C C MEANING OF FLAGS ARE: C -3 Hardcopy of fit plot C -2 Redraw of fit plot C -1 Plot the fit results C 0 Draw the latest plot C 1 Draw all the plots which are stored C 2 Redraw of a plot C 3 Hardcopy of a plot C C Segment numbers are defined as follows: C 100*(NP-1) + 1 Main plot (MN_PLT) C 100*(NP-1) + 11 Text in display C 100*(NP-1) + 20 + NCOMM Comments C 100*(NP-1) + 60 + NKEY Keys C 15000 + NDRAW Lines, arrows etc. C In addition LPDEV*1000 is added to all segment numbers to keep the C segment numbers for different workstations separate C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFIT. +CDE,MNFLG. +CDE,MNHPJ. +CDE,MNDBG. +CDE,MNLUN C INTEGER NTYPFL,NDERR C INTEGER NHP1,NHP2,NP,NOVEFL,IDA,IDB LOGICAL QMNHEX,QMNFEX,QEXIST C IF(QDEBUG) THEN WRITE(LUNTTO,'('' MN_DRW: Flag'',I4)') NTYPFL CALL MN_SHW('PLOT') ENDIF C NDERR = 0 C C DRAW THE RESULTS C IF(NTYPFL.EQ.0) THEN NHP1 = NHPLT NHP2 = NHPLT ELSE NHP1 = 1 NHP2 = NHPLT ENDIF C NHF = 0 C DO 3000 NP=NHP1,NHP2 IDA = IPLTIA(NP) IDB = IPLTIB(NP) NOVEFL = IPLTFL(NP) C C CHECK THAT THE PLOT EXISTS C NH = 0 QEXIST = QMNFEX(IDA,IDB,NH) .OR. QMNHEX(IDA,IDB,NH) IF(.NOT.QEXIST) THEN CALL MN_TOF(.FALSE.) WRITE(TXTERR,'('' Plot'',I7,I4,'' does not exist'')') 1 IDA,IDB CALL MN_ERR('MN_DRW',TXTERR) CALL MN_TON(IERR) GOTO 3000 ENDIF C IF((IABS(NTYPFL).EQ.0 .OR. IABS(NTYPFL).EQ.1) .AND. 1 NOVEFL.EQ.1) THEN C C DEFINE THE LAST PLOT TO BE THE DEFAULT C IF THE DEFAULT HAS NOT BEEN SET C IF(.NOT.QSHIST) THEN NIDADT = IDA NIDBDT = IDB NNHDT = NH ENDIF ENDIF C C IF THIS IS A NEW PLOT MAKE THE CURRENT SET OF SET C PARAMETERS THE USER PARAMETERS C IF ITS AN OVERLAY THEN USE THOSE FROM THE LAST PLOT C IF ITS A REDRAW OR HARDCOPY THEN GET THOSE FOR THIS PLOT C CALL MN_PSP(IABS(NTYPFL),NP,IERR) IF(IERR.NE.0) GOTO 3000 C C DRAW THE PLOT C CALL MN_PLH(IDA,IDB,NP,NTYPFL,NOVEFL,NDERR) IF(NDERR.NE.0) GOTO 8000 C C DISPLAY TEXT C IF(NTYPFL.LT.0 .AND. NCLRU.EQ.1) THEN NHF = NHF + 1 C C Create a segment C NSEGM = 100*(NP-1) + 11 CALL M_CRSG(NSEGM) C CALL MN_PLI(IDFITA(NHF),IDFITB(NHF)) C C Close the segment C CALL M_CLSG(NSEGM) ENDIF C C ADD ANY COMMENTS C IF(IDA.GT.0 .AND. + (NOVEFL.EQ.1 .OR. NOVEFL.EQ.3)) THEN C DO 2500 NC=1,NPLTCM(NP) C C Create a segment C NSEGM = 100*(NP-1) + 20 + NC CALL M_CRSG(NSEGM) C XX = RPLTCM(1,NC,NP) YY = RPLTCM(2,NC,NP) SZE = RPLTCM(3,NC,NP) ANGLE = RPLTCM(4,NC,NP) IOPT = NINT(RPLTCM(5,NC,NP)) JMODE = NINT(RPLTCM(6,NC,NP)) NFONT = NINT(RPLTCM(7,NC,NP)) NCOL = NINT(RPLTCM(8,NC,NP)) THICK = RPLTCM(9,NC,NP) CALL MN_CTR(XX,YY,XXX,YYY,1,JMODE) CALL MN_TXT(XXX,YYY,TPLTCM(NC,NP),SZE,ANGLE,IOPT 1 ,NFONT,NCOL,THICK) C C Close the segment C CALL M_CLSG(NSEGM) 2500 CONTINUE C C ADD ANY KEY EXPLANATIONS DO 2600 NC=1,NPLTKY(NP) C C Create a segment C NSEGM = 100*(NP-1) + 60 + NC CALL M_CRSG(NSEGM) C NCSYMB = LPLTKY(NC,NP) XX = RPLTKY(1,NC,NP) YY = RPLTKY(2,NC,NP) SZE = RPLTKY(3,NC,NP) ANGLE = RPLTKY(4,NC,NP) IOPT = NINT(RPLTKY(5,NC,NP)) JMODE = NINT(RPLTKY(6,NC,NP)) NFONT = NINT(RPLTKY(7,NC,NP)) NCOL = NINT(RPLTKY(8,NC,NP)) THICK = RPLTKY(9,NC,NP) XUNIT = RPLTKY(10,NC,NP) ncolt = nint(RPLTKY(11,NC,NP)) CALL MN_CTR(XX,YY,XXX,YYY,1,JMODE) CALL MN_KEY(NCSYMB,XXX,YYY,TPLTKY(NC,NP) 1 ,SZE,ANGLE,IOPT,NFONT,NCOL,THICK,XUNIT,ncolt) C C Close the segment C CALL M_CLSG(NSEGM) 2600 CONTINUE ENDIF C CALL TVSHOW C C STORE THE PLOT PARAMETERS FOR THIS PLOT C CALL MN_PST(NP) C C Add any drawing that should be done first C *ICB IF(IABS(NTYPFL).GT.1 .AND. NP.EQ.1 .AND. NDRWLN.GT.0) THEN *ICB CALL MN_LDP(0,.TRUE.,1,IDA,IDB) *ICB ENDIF 3000 CONTINUE C C Setup the page and draw the box round the plot C here if no plots have been made C if(nhplt.eq.0) then call mn_ton(ierr) call tvnext call m_spage endif * * Draw all items that should be drawn last that are in CM coords. * If no plots have been made draw all items. * IF(IABS(NTYPFL).GT.1 .AND. NDRWLN.GT.0) THEN IF(NHPLT.GT.0) THEN CALL MN_LDP(0,.TRUE.,11,0,0) ELSE CALL MN_LDP(0,.FALSE.,0,0,0) ENDIF ENDIF C C IF WE ARE JUST DOING LINES AND THERE ARE NO PLOTS THEN THE COMMENTS C AS IF THIS WERE THE FIRST PLOT SHOULD BE ADDED C IF(NHPLT.EQ.0) THEN NP = 1 DO 4500 NC=1,NPLTCM(NP) C C Create a segment C NSEGM = 100*(NP-1) + 20 + NC CALL M_CRSG(NSEGM) C XX = RPLTCM(1,NC,NP) YY = RPLTCM(2,NC,NP) SZE = RPLTCM(3,NC,NP) ANGLE = RPLTCM(4,NC,NP) IOPT = NINT(RPLTCM(5,NC,NP)) JMODE = NINT(RPLTCM(6,NC,NP)) NFONT = NINT(RPLTCM(7,NC,NP)) NCOL = NINT(RPLTCM(8,NC,NP)) THICK = RPLTCM(9,NC,NP) CALL MN_CTR(XX,YY,XXX,YYY,1,JMODE) CALL MN_TXT(XXX,YYY,TPLTCM(NC,NP),SZE,ANGLE,IOPT 1 ,NFONT,NCOL,THICK) C C Close the segment C CALL M_CLSG(NSEGM) 4500 CONTINUE ENDIF C CALL TVSHOW 8000 CONTINUE CALL MN_TOF(.TRUE.) C RETURN END +DECK,mn_erc. SUBROUTINE MN_ERC (IDA,IDB,NMODE,err) C C SUBROUTINE TO CHANGE THE ERRORS ON A HISTOGRAM C NMODE = 0 MEANS 0 ERRORS C NMODE = 1 MEANS ERRORS ARE SQAURE ROOT OF THE NUMBER OF ENTRIES C NMODE = 2 SAME AS 1, EXCEPT ERROR ON 0 IS 1 C NMODE = 3 means set all errors to value given C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNLUN. C integer ida,idb,nmode real err * integer nh,nerr,ii,nd,nwtot + ,nh2,nwh2,nwppt2,nwrd2,ntmod2,nptrh2,nptrd2,nptr2 + ,noff2,noffl2,noffh2 + ,nhdat2,nhtim2,nsdat2,nstim2 real edent2,edlo2,edhi2,x,dx,ee,dee LOGICAL QERRL,QERRH * real amne,amnp,amndpn external amne,amnp,amndpn C CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_ERC',TXTERR) GOTO 9000 ENDIF IF(NDIM.LT.-1) THEN CALL MN_ERR('MN_ERC','There are no errors for an Ntuple') GOTO 9000 ENDIF C C BOOK THE NEW HISTOGRAM C IF(NDIM.LT.0) THEN NWPPT2 = 2*(IABS(NDIM)+1) ELSE IF(NMODE.EQ.-1) THEN NWPPT2 = 1 ELSE NWPPT2 = 2 ENDIF ENDIF CALL MN_UOF(RDAT(NPTRH),ACONT) C NWRD2 = NWPPT2 * NPNT NBPPT = 32 NTMOD2 = NTMODE CALL MN_HNW(IDA,IDB,NDIM,NWRD2,NH2,NPTRH2,NPTRD2,NWH2 + ,NBPPT,NTMOD2) IF(NH2.LE.0) GOTO 9000 C C CALL AMNOFF FOR NEW PLOT C CALL AMNOFF(NDIM,NWPPT2,NOFF2,NOFFL2,NOFFH2,QERRL,QERRH) C C SET THE POINTERS TO THE FIRST PLOT POSITIVE AGAIN UNTIL THE C END OF THE SUBROUTINE C IDPTRH(NH) = IABS(IDPTRH(NH)) IDPTRD(NH) = IABS(IDPTRD(NH)) C EDENT2 = 0.0 EDLO2 = 1.0E+30 EDHI2 = -1.0E+30 NERR = 0 DO 6300 II=1,NPNT NPTR2 = NPTRD2 + NWPPT2*(II-1) - 1 C EE = AMNE(II,NH,NERR) IF(NMODE.LE.0) THEN DEE = 0.0 elseif(nmode.eq.3) then dee = err ELSE DEE = SQRT(ABS(EE)) IF(NMODE.EQ.2 .AND. EE.EQ.0.0) DEE = 1.0 ENDIF C IF(NDIM.LT.0) THEN DO 6200 ND=1,IABS(NDIM) X = AMNP(II,NH,ND,1,NERR) DX = AMNDPN(II,NH,ND,NERR) RDAT(NPTR2 + ND) = X RDAT(NPTR2 + NOFF2 + ND) = DX 6200 CONTINUE ENDIF C RDAT(NPTR2 + NOFF2) = EE IF(NMODE.NE.-1) THEN RDAT(NPTR2 + NOFFL2) = DEE ENDIF C EDLO2 = AMIN1(EDLO2,EE-DEE) EDHI2 = AMAX1(EDHI2,EE+DEE) EDENT2 = EDENT2 + EE 6300 CONTINUE C C NOW SET THE POINTERS NEGATIVE AGAIN AND UPDATE THE HEADER C IDPTRH(NH) = -IABS(IDPTRH(NH)) IDPTRD(NH) = -IABS(IDPTRD(NH)) C C Give the new plot the same date/time as the old one as only the C errors have changed C NHDAT2 = NHDATE NHTIM2 = NHTIME NSDAT2 = NSDATE NSTIM2 = NSTIME C NWDAT = NPNT * NWPPT2 NWTOT = NWH2 + NWDAT CALL MN_HDU(RDAT(NPTRH2),NWTOT,NWH2,NWDAT,IDA,IDB 1 ,NDIM,NWPPT2,NPNT,NHDAT2,NHTIM2,NSDAT2,NSTIM2,NTMOD2 + ,EDENT2,EDLO2,EDHI2,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH2,NWTOT,IDA,IDB,NPTRH2,NPTRD2,TDTIT(NH) 1 ,TDFIL(NH),' ',TDNAM(1,NH)) CALL MN_MSU(IDA,IDB,NDIM,NWH2,NH2) C 9000 CONTINUE END +DECK,mn_exi. C SUBROUTINE MN_EXI C C SUBROUTINE CALLED AT END OF JOB OR IF EXIT FOR SOME REASON C +CDE,MNPAR. +CDE,MNFLG. +CDE,MNTYQ. C LOGICAL QOPEN C IF(LUNHIN.GT.0) THEN INQUIRE(UNIT=LUNHIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNHIN) ENDIF IF(LUNAIN.GT.0) THEN INQUIRE(UNIT=LUNAIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNAIN) ENDIF IF(LUNDIN.GT.0) THEN INQUIRE(UNIT=LUNDIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNDIN) ENDIF IF(LUNMIN.GT.0) THEN INQUIRE(UNIT=LUNMIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNMIN) ENDIF IF(LUNSIN.GT.0) THEN INQUIRE(UNIT=LUNSIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNSIN) ENDIF IF(LUNFIN.GT.0) THEN INQUIRE(UNIT=LUNFIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNFIN) ENDIF IF(LUNPIN.GT.0) THEN INQUIRE(UNIT=LUNPIN,OPENED=QOPEN) IF(QOPEN) CLOSE(UNIT=LUNPIN) ENDIF C IF(LUNJNK.GT.0) THEN CLOSE(UNIT=LUNJNK,STATUS='DELETE') CALL CLEO_FRELUN(LUNJNK,'MN_FTI') LUNJNK = 0 ENDIF C C Close the database C CALL M_DBCLS C RETURN END +DECK,mn_exm. C SUBROUTINE MN_EXM(IDELIM) C C SUBROUTINE THAT ALLOWS YOU TO EXAMINE PARAMETERS, REGISTERS C BIN CONTENTS ETC. C +CDE,MNLUN. C CHARACTER*20 TCOMM,TJUNK(1) DATA TJUNK/' '/ C 1000 CONTINUE CALL WAITYQ('Examine what or ?: ') JCMD = ICMTYQ(.TRUE.,IDELIM,TJUNK) IF(JCMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN CALL QUOTYQ('EXAMINE') IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 1000 ENDIF IF(JCMD.LT.0) RETURN CALL RESTYQ ISTR = ISTRNQ(.TRUE.,TCOMM,NCHAR) C TCOMM = ' ' C CALL ICMSTR(TCOMM) IF(NCHAR.LE.0) RETURN C IF(TCOMM.EQ.' ') RETURN C CALL RESTYQ X = VALTYQ(.TRUE.,IDELIM) C LENG = MNLLEN(TCOMM) + 1 WRITE(LUNTTO,5000) TCOMM(1:LENG),X 5000 FORMAT(1X,A,1X,'=',1X,1PG18.9) C RETURN END +DECK,mn_fgt. SUBROUTINE MN_FGT(IDA,IDB,NHD) C + ,NPTRH,NPTRD,NDIM,NWPPT,NPNT C 1 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT) C C IDA,IDB IS THE HISTOGRAM ID WHICH I WANT POINTERS ON C NHD IS THE STORAGE POSITION C NDIM IS THE NUMBER OF DIMENSIONS C NPTRH IS THE POINTER TO THE HEADER C NPTRD IS THE POINTER TO THE DATA C EDENT ARE THE NUMBER OF ENTRIES C EDLO,EDHI ARE THE LOWER AND UPPER LIMITS ON THE NUMBER OF ENTRIES C NBPPT IS THE NUMBER OF BITS PER WORD C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNINF. +CDE,MNLUN. C INTEGER IDBINT(MDIMMX) REAL ADLOT(MDIMMX),ADHIT(MDIMMX),AMEANT(MDIMMX),ASIGT(MDIMMX) C C SEE IF THIS HISTOGRAM EXISTS C NHD = 0 DO 1000 NNH=1,NDFIT IF(IDA.EQ.IDFITA(NNH) .AND. IDB.EQ.IDFITB(NNH) .AND. 1 IFPTRH(NNH).GT.0 .AND. IFPTRD(NNH).GT.0) THEN NHD = NNH GOTO 1010 ENDIF 1000 CONTINUE NHD = -1 GOTO 9000 1010 CONTINUE C C CHECK OUT THE POINTERS C NPTRH = IFPTRH(NHD) NPTRD = IFPTRD(NHD) IF(NINT(RFIT(NPTRH+3)).NE.IDA .OR. NINT(RFIT(NPTRH+4)).NE.IDB) 1 THEN IDDA = NINT(RFIT(NPTRH+3)) IDDB = NINT(RFIT(NPTRH+4)) WRITE(TXTERR,'(''Something is screwed up'' 1 ,'' with the pointers for plot'',I7,I4)') IDA,IDB CALL M_EMSG('MN_FGT',TXTERR) WRITE(TXTERR,'(''NHD ='',I4,'' ID in plot itself'',I7,I4)') + NHD,IDDA,IDDB CALL M_EMSG('MN_FGT',TXTERR) DO 2000 JJ=1,4 II1 = (JJ-1)*5 II2 = JJ*5 - 1 WRITE(TXTERR + ,'(''Words '',I2,'' ->'',I2,2X,5(1PG12.5))') + II1,II2,(RFIT(NPTRH+II),II=II1,II2) CALL M_EMSG('MN_FGT',TXTERR) 2000 CONTINUE CALL MN_ERR('MN_FGT',' ') NHD = 0 GOTO 9000 ENDIF C CALL MN_HDR(RFIT(NPTRH),NDIMT,NWPPTT,NPNTT + ,NHDATT,NHTIMT,NSDATT,NSTIMT,NTMODT 1 ,EDENTT,EDLOT,EDHIT,IDBINT,ADLOT,ADHIT,NBPPTT,AMEANT,ASIGT) NDIM = NDIMT NWPPT = NWPPTT NPNT = NPNTT NBPPT = NBPPTT NWDAT = NINT(RFIT(NPTRH+2)) NHDATE = NHDATT NHTIME = NHTIMT NSDATE = NSDATT NSTIME = NSTIMT NTMODE = NTMODT EDENT = EDENTT EDLO = EDLOT EDHI = EDHIT CALL UCOPY_i(IDBINT,IDBIN,IABS(NDIM)) CALL UCOPY_r(ADLOT,ADLO,IABS(NDIM)) CALL UCOPY_r(ADHIT,ADHI,IABS(NDIM)) CALL UCOPY_r(AMEANT,AMEAN,IABS(NDIM)) CALL UCOPY_r(ASIGT,ASIG,IABS(NDIM)) C 9000 CONTINUE NHC = NHD RETURN END +DECK,mn_fit. SUBROUTINE MN_FIT C C------------------------------------------------------------------------------ C AUTHOR IAN C. BROCK 30.04.86 C C Main Mn_Fit routine - will probably be converted to C sometime C to use KUIP condition handling C------------------------------------------------------------------------------ C +SELF,IF=UNIX,IF=SGI,IF=SCROLL. CALL NOBUFF +SELF. C CALL M_START C CALL M_RUN C CALL M_STOP C END +DECK,mn_fnw. SUBROUTINE MN_FNW(IDA,IDB,NDIM,NWRD,NHD,NPTRH,NPTRD,NWHEAD 1 ,NBPPT,NTMODE) C C IDA,IDB IS THE HISTOGRAM ID WHICH I WANT TO STORE FOR FITTING C NDIM IS THE NUMBER OF DIMENSIONS C NHD IS THE STORAGE POSITION C NPTRH IS THE POINTER TO THE HEADER C NPTRD IS THE POINTER TO THE DATA C NWHEAD IS THE NUMBER OF HEADER WORDS C NBPPT IS THE NUMBER OF BITS PER WORD C THE DEFAULT IS 32 FOR ALL PLOTS EXCEPT IF C NDIM > 2 WHEN IT IS 16 C NTMODE is the time mode (0 means not time) C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNLUN. C IF(NBPPT.LE.0) THEN IF(NDIM.GT.2) THEN NBPPT = 16 ELSE NBPPT = 32 ENDIF ENDIF C C SEE IF THIS HISTOGRAM ALREADY EXISTS AND IF IT DOES SET ITS C POINTERS NEGATIVE C C DO 1000 NH=1,NDFIT C IF(IDA.EQ.IDFITA(NH) .AND. IDB.EQ.IDFITB(NH)) THEN C IFPTRH(NH) = -IABS(IFPTRH(NH)) C IFPTRD(NH) = -IABS(IFPTRD(NH)) C ENDIF C 1000CONTINUE C C HEADER SPACE IS 11 WORDS + BINS AND LIMITS + BITS PER POINT C + UNDERFLOW AND OVERFLOWS IF IT IS A BINNED HISTOGRAM C + MEAN AND SIGMA IF IT IS A BINNED HISTOGRAM, A SERIES OF C POINTS OR A SCATTER PLOT C + DATE AND TIME C NHD = 0 C IF(IABS(NDIM).EQ.0 .OR. IABS(NDIM).GT.MDIMMX) THEN WRITE(TXTERR,11000) IDA,IDB,NDIM 11000 FORMAT(' Histogram',I7,I4,' has wrong dimension',I6) CALL MN_ERR('MN_FNW',TXTERR) GOTO 9000 ENDIF C NWHEAD = 11 + IABS(NDIM)*3 + 1 C C ONLY KEEP TRACK OF UNDERFLOWS AND OVERFLOWS FOR UP TO C 3-DIMENSIONAL PLOTS C IF(ndim.gt.-3 .and. ndim.le.3) + NWHEAD = NWHEAD + 3**IABS(NDIM) C C Leave space for the mean and sigma for binned histograms C series of points and scatter plots C IF(NDIM.GT.-3) NWHEAD = NWHEAD + 2*IABS(NDIM) C C Add date and time to the header C NWHEAD = NWHEAD + 2 C C Add the starting date and time for the plot and the time mode C IF(NTMODE.NE.0) NWHEAD = NWHEAD + 3 C C SEE IF I HAVE ENOUGH SPACE LEFT C NW = NFPTE IF(NWRD.GT.0) THEN NWNEED = (NWRD*NBPPT-1)/32 + 1 IF(NW+NWNEED+NWHEAD.GT.MFITWD .OR. NDFIT.GE.MFITMX) THEN CALL M_EMSG('MN_FNW' + ,'I have run out of space for creating new histograms') CALL MN_ERR('MN_FNW' + ,'Either make your histogram smaller or' // + ' talk to Ian Brock about increasing the space') GOTO 9000 ENDIF ENDIF C NHD = NDFIT + 1 C NPTRH = NW + 1 NPTRD = NPTRH + NWHEAD C 9000 CONTINUE RETURN END +DECK,mn_frp. C SUBROUTINE MN_FRP C C SUBROUTINE TO RESTORE THE CURRENT SET OF PARAMETERS FOR C NORMAL PLOTTING AFTER A FIT C +CDE,MNPAR. +CDE,MNFUN. +CDE,MNHPJ. C QDFIT = .FALSE. NDFUN = 0 C SIZES(1) = PSIZE(1) SIZES(2) = PSIZE(2) AMRGS(1) = PAMRG(1) AMRGS(2) = PAMRG(2) HSZES(1) = PHSZE(1) HSZES(2) = PHSZE(2) C NSID = NPSID QTITLS(1) = QPSTIT QWIND = QPWIND IWIND(1) = IPWIND(1) IWIND(2) = IPWIND(2) WSPACE(1) = WPSPAC(1) WSPACE(2) = WPSPAC(2) IPWNDS(1) = 0 IPWNDS(2) = 0 WSZES(1) = 0.0 WSZES(2) = 0.0 C RETURN END +DECK,mn_fsp. C SUBROUTINE MN_FSP C C SAVE THE CURRENT PARAMETERS AND SET THINGS UP FOR A DISPLAY C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNFUN. +CDE,MNHPJ. +SELF,IF=MIN_CGR. +CDE,MINCOM. +SELF,IF=-MIN_CGR. DOUBLE PRECISION FMIN,FEDM,ERRDEF +SELF. INTEGER NDMLST DATA NDMLST/0/ C C Skip to almost the end if the last picture was a display and C nothing has changed for it. C Skip to the display setup if the number of functions or C something has changed. C IF(QDFIT .AND. .NOT.QMNCHGE) GOTO 5000 IF(QDFIT .AND. QMNCHGE) GOTO 4000 C C SAVE THE CURRENT SIZES AND FLAGS C PSIZE(1) = SIZES(1) PSIZE(2) = SIZES(2) PAMRG(1) = AMRGS(1) PAMRG(2) = AMRGS(2) PHSZE(1) = HSZES(1) PHSZE(2) = HSZES(2) C NPSID = NSID QPSTIT = QTITLS(1) QPWIND = QWIND IPWIND(1) = IWIND(1) IPWIND(2) = IWIND(2) WPSPAC(1) = WSPACE(1) WPSPAC(2) = WSPACE(2) C C NOW SET UP STUFF FOR THE DISPLAY C QLEGO = .FALSE. QDFUN = .FALSE. NSID = 0 QTITLS(1) = .FALSE. C C OVERALL PICTURE SIZE C SIZES(1) = FSIZE(1) SIZES(2) = FSIZE(2) C C MARGIN SIZE C AMRGS(1) = FAMRG(1) AMRGS(2) = FAMRG(2) C C PLOT SIZE - ADJUST THIS IF SOMETHING HAS CHANGED IN THE NUMBER C FUNCTIONS ETC. C 4000 CONTINUE QMNCHGE = .FALSE. HSZES(1) = FHSZE(1) HSZES(2) = FHSZE(2) IF(HSZES(2).EQ.0.0) THEN TSIZE = TSZES(1) USIZE = TSZES(2) ADY1 = 2.7 IF(NFITTP.EQ.1 .OR. NFITTP.EQ.2) ADY1 = ADY1 + 1.0 IF(NHFIT.GT.1) ADY1 = ADY1 + 1.0 ADY2 = 6.2 ADY2 = ADY2 + FLOAT(NPAR_MN) + FLOAT(NFUSEM) IF(QSNORM) ADY2 = ADY2 + 2.0 +SELF,IF=-MIN_CGR. CALL MNSTAT(FMIN,FEDM,ERRDEF,NPARI,NPARX,ISTAT) UP = SNGL(ERRDEF) +SELF. IF(ABS(UP-1.0).GT.1.0E-3) ADY2 = ADY2 + 1.0 IF(QFCONV) ADY2 = ADY2 + 1.0 IF(QFINTG) ADY2 = ADY2 + 1.0 C YMGU = 1.5 * (ADY1*TSIZE + ADY2*USIZE) HSZES(2) = SIZES(2) - AMRGS(2) - YMGU ENDIF C C DECIDE WHETHER WE ARE WINDOWING AND SET STUFF UP ACCORDINGLY C FIRST TURN OFF THE WINDOWS AND MAKE SURE THAT THE TITLE C AND SCALE SIZES ARE SET BACK TO NORMAL C 5000 CONTINUE IF(.NOT.QDFIT .OR. NDMODE.NE.NDMLST) THEN IF(.NOT.QDFIT .AND. QWIND) + CALL MN_WND(-1,IDELIM,.FALSE.,IDUM,IDUM) IF(IABS(NDMODE).EQ.3) THEN QWIND = .TRUE. IWIND(1) = 1 IWIND(2) = 2 WSPACE(1) = 0.0 WSPACE(2) = 0.0 IPWNDS(1) = 0 IPWNDS(2) = 0 ELSE QWIND = .FALSE. ENDIF WSZES(1) = 0.0 WSZES(2) = 0.0 WMRGS(1) = 0.0 WMRGS(2) = 0.0 NDMLST = NDMODE ENDIF C C LAST THING IS TO SET THE DISPLAY FLAG C QDFIT = .TRUE. C 9000 CONTINUE RETURN END +DECK,mn_hbf. SUBROUTINE MN_HBF(IDELIM,MMODE) C C FETCHES HBOOK VERSION 3 HISTOGRAMS AND VERSION 4 HISTOGRAMS C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNCMD. +CDE,MNLUN. C integer idelim,mmode * CHARACTER*1 CHTYPE CHARACTER*80 CHTITL LOGICAL HEXIST LOGICAL QZERO,QRNGE INTEGER IDLSTA1(100),IDLSTA2(100),IDLSTB(100),IDLSTC(100) INTEGER IDALL(2*MHSTMX) integer ntype,nmlast,nmode,ierr,icycle,njunk,ndhis0 + ,nidl,ida1,ida2,idb1,idb2,nnid,id,ida,idb,idh,nhtot + ,nl * integer inttyq external inttyq C DATA NMLAST/0/ C NMODE = IABS(MMODE) C IF(MMODE.GT.0 .AND. IDELIM.EQ.0) THEN NJUNK = INTTYQ(.TRUE.,IDELIM) CALL RESTYQ ENDIF C NDHIS0 = NDHIS C IF(FIL_HB.EQ.' ' .OR. MMODE.LT.0 .OR. 1 (NMODE.NE.NMLAST) .OR. 1 (IDELIM.GT.0 .AND. + IDELIM.NE.ICHAR(':') .AND. IDELIM.NE.ICHAR('&'))) THEN IF(NMLAST.EQ.4 .AND. FIL_HB.NE.' ') then call m_hclean(1) endif NTYPE = 4 IF(NMODE.EQ.3) NTYPE = 1 CALL MN_FIL(NTYPE,LUNHIN,FIL_HB,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 CICB IF(NMODE.EQ.4) CALL HRFILE(LUNHIN,'MN_HBIN',' ') ENDIF NMLAST = NMODE IF(MMODE.LT.0) RETURN C C Change the directory if needed C IF(NMODE.EQ.3) THEN CALL HCDIR('//PAWC',' ') ELSE CALL M_SDIR(0,IERR) IF(IERR.NE.0) GOTO 9000 ENDIF C NIDL = 0 QZERO = .FALSE. qrnge = .false. 2000 CONTINUE C C Set the cycle number and the secondary id C ICYCLE = 99999 IDB = NDIDB C CALL WAITYQ('Give histogram number(s): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 8000 IF(NNID.GT.1) THEN CALL M_EMSG('MN_HBF','WARNING: Mn_Fit interprets' // + ' a secondary id as the cycle number') CALL M_EMSG('MN_HBF','This will be added to the curent' // + ' secondary id') IF(IDB1.NE.IDB2) THEN CALL M_EMSG('MN_HBF','It therefore does not make sense' // + ' to give a range of secondary ids') IDB2 = IDB1 ENDIF *ICB CALL M_EMSG('MN_HBF','HBOOK does not know about' // *ICB 1 ' secondary identifiers') *ICB CALL M_EMSG('MN_HBF','It will be ignored') ICYCLE = IDB1 IF(NDIDB + ICYCLE .GT. 980) THEN TXTERR = 'Cycle requested + secondary identifier' // + ' too large' CALL M_EMSG('MN_HBF',TXTERR) TXTERR = 'Secondary identifier set to 980' CALL M_EMSG('MN_HBF',TXTERR) ENDIF IDB = MIN(NDIDB + IDB1,980) ENDIF C IF(NIDL.GE.100) THEN CALL M_EMSG('MN_HBF','Ran out of space to store plot' // 1 ' numbers to get') CALL M_EMSG('MN_HBF','Issue FETCH command again to get' // + ' more plots.') GOTO 2200 ENDIF C if(.not.qzero) QZERO = IDA1.EQ.0 if(.not.qrnge) QRNGE = IDA2.GT.IDA1 NIDL = NIDL + 1 IDLSTA1(NIDL) = IDA1 IDLSTA2(NIDL) = IDA2 IDLSTB(NIDL) = IDB IDLSTC(NIDL) = ICYCLE IF(IDELIM.GE.0) GOTO 2000 2200 CONTINUE IF(NIDL.LE.0) GOTO 8000 C IF(NMODE.EQ.3) THEN IF(.NOT.QZERO .AND. QRNGE) THEN CALL MN_ERR('MN_HBF' + ,'You cannot fetch a range of histograms' // + ' with the HB3_FETCH command') GOTO 8000 ENDIF ENDIF C C Loop over all the histograms and make HBOOK into Mn_Fit ones C IF(QZERO) THEN CALL HDELET(0) IF(NMODE.EQ.3) THEN CALL HFETCH(0,LUNHIN) ELSE CALL HRIN(0,ICYCLE,0) ENDIF CALL HIDALL(IDALL,NHTOT) NHTOT = MIN0(NHTOT,MHSTMX) DO 5000 NL=1,NHTOT ID = IDALL(NL) IDH = ID IDA = ID C C Now make the HBOOK histogram into a Mn_Fit histogram C CALL M_HBMN(IDA,IDA,IDB,NMODE) 5000 CONTINUE C C Loop over the histograms in the current directory and fetch the ones C that are wanted C ELSEIF(QRNGE) THEN ID = 0 6000 CONTINUE CALL HLNEXT(ID,CHTYPE,CHTITL,'12N') IF(ID.EQ.0) GOTO 6200 DO 6100 NL=1,NIDL IDA1 = IDLSTA1(NL) IDA2 = IDLSTA2(NL) IDB = IDLSTB(NL) ICYCLE = IDLSTC(NL) IF(IDA1.EQ.0 .OR. 1 (ID.GE.IDA1 .AND. ID.LE.IDA2)) THEN IDH = ID IF(HEXIST(IDH)) CALL HDELET(IDH) CALL HRIN(IDH,ICYCLE,0) IDA = IDH C C Now make the HBOOK histogram into a Mn_Fit histogram C CALL M_HBMN(IDA,IDA,IDB,NMODE) GOTO 6000 ENDIF 6100 CONTINUE GOTO 6000 6200 CONTINUE ELSE DO 7000 NL=1,NIDL ID = IDLSTA1(NL) IDB = IDLSTB(NL) ICYCLE = IDLSTC(NL) IF(HEXIST(ID)) CALL HDELET(ID) IF(NMODE.EQ.3) THEN IDH = ID CALL HFETCH(IDH,LUNHIN) IDA = ID ELSE IDH = ID IF(HEXIST(IDH)) CALL HDELET(IDH) CALL HRIN(IDH,ICYCLE,0) IDA = ID ENDIF IF(.NOT.HEXIST(IDH)) THEN WRITE(TXTERR,'(''Histogram'',I8 1 ,'' does not exist'')') IDA CALL M_EMSG('MN_HBF',TXTERR) GOTO 7000 ENDIF C C Now make the HBOOK histogram into a Mn_Fit histogram C CALL M_HBMN(IDA,IDA,IDB,NMODE) 7000 CONTINUE ENDIF C 8000 CONTINUE C C CHECK THAT I GOT THE HISTOGRAMS I WANTED C NNID = 2 CALL MN_HNG('MN_HBF',NNID,NDHIS0,NIDL + ,IDLSTA1,IDLSTA2,IDLSTB,IDLSTB) C 9000 CONTINUE C RETURN END +DECK,mn_hbn. SUBROUTINE MN_HBN(IDA,IDB,IERR) C C MAKES AN HBOOK HISTOGRAM FROM AN MN_FIT HISTOGRAM C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNLUN. C INTEGER MPNTMX PARAMETER (MPNTMX=50 000) C COMMON/MNSCR/BUFDAT(MPNTMX),BUFERR(MPNTMX) +CDE,MNSCR. REAL BUFDAT(MPNTMX),BUFERR(MPNTMX) EQUIVALENCE(SCRATCH(1),BUFDAT(1)) EQUIVALENCE(SCRATCH(MPNTMX+1),BUFERR(1)) C INTEGER IDA,IDB,IERR C CHARACTER*80 TEXT CHARACTER*32 TAGS_NOERR(2),TAGS_ERR(4),TAGS_ASYM(6) C INTEGER IDH,II,JJ,NH,NPTR,NPPT,NOFF,NOFFL,NOFFH REAL X,Y,DX,DY,EE LOGICAL QERRL,QERRH LOGICAL HEXIST C DATA TAGS_NOERR/'X','Y'/ DATA TAGS_ERR/ 'X','Y','DX','DY'/ DATA TAGS_ASYM/ 'X','Y','DNX','DNY','DPX','DPY'/ C IERR = 0 CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_HBN',TXTERR) IERR = 1 GOTO 9000 ENDIF C IF(NDIM.LT.0) THEN IF(NWDAT.LE.0) THEN WRITE(TXTERR,'('' Plot'',I7,I4,'', I can only store'' + ,'' scatter plots or Ntuples that are in memory'')') + IDA,IDB CALL M_EMSG('MN_HBN',TXTERR) IERR = 2 GOTO 9000 ENDIF ELSEIF(NDIM.GT.2) THEN WRITE(TXTERR,'('' Plot'',I7,I4,'', I can only make HBOOK'' + ,'' histograms of 1 or 2 dimensional plots'')') IDA,IDB CALL M_EMSG('MN_HBN',TXTERR) IERR = 2 GOTO 9000 ENDIF C CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) C TEXT = TDTIT(NH) IDH = IDA IF(HEXIST(IDH) .AND. NWDAT.GT.0) THEN WRITE(TXTMES,'('' HBOOK histogram'',I8 1 ,'' will be overwritten'')') IDH CALL MN_MES(LUNTTO,'ME',TXTMES) CALL HDELET(IDH) ENDIF IF(NDIM.LT.-2) THEN WRITE(TXTMES,'('' Plot'',I7,I4,'' will be stored with'' + ,'' HBOOK id'',I8,'' in top level directory'')') + IDA,IDB,IDH ELSEIF(NDIM.EQ.-1) THEN WRITE(TXTMES,'('' Plot'',I7,I4 + ,'' will be stored as an Ntuple with'' + ,'' HBOOK id'',I8)') IDA,IDB,IDH ELSE WRITE(TXTMES,'('' Plot'',I7,I4,'' will be stored with'' + ,'' HBOOK id'',I8)') IDA,IDB,IDH ENDIF CALL MN_MES(LUNTTO,'ME',TXTMES) IF(NDIM.EQ.1) THEN CALL HBOOK1(IDH,TEXT,IDBIN(1),ADLO(1),ADHI(1),0.0) IF(QERRL) CALL HBARX(IDH) ELSEIF(NDIM.EQ.2) THEN CALL HBOOK2(IDH,TEXT,IDBIN(1),ADLO(1),ADHI(1) 1 ,IDBIN(2),ADLO(2),ADHI(2),0.0) ELSEIF(NDIM.EQ.-1 .AND. NWPPT.EQ.2) THEN CALL HBOOKN(IDH,TEXT,2,' ',10000,TAGS_NOERR) ELSEIF(NDIM.EQ.-1 .AND. NWPPT.EQ.4) THEN CALL HBOOKN(IDH,TEXT,4,' ',10000,TAGS_ERR) ELSEIF(NDIM.EQ.-1 .AND. NWPPT.EQ.6) THEN CALL HBOOKN(IDH,TEXT,6,' ',10000,TAGS_ASYM) ELSEIF(NDIM.EQ.-2) THEN CALL HBOOKN(IDH,TEXT,2,' ',10000,TAGS_NOERR) ELSEIF(NDIM.LT.-2) THEN CALL M_NTPSTO(IDA, IDB, NH, IERR) ENDIF C IF(NDIM.EQ.1) THEN NPPT = MAX0(NPNT,MPNTMX) DO 2000 II=1,NPPT NPTR = NPTRD + NWPPT*(II-1) - 1 BUFDAT(II) = RDAT(NPTR + NOFF) IF(QERRL) BUFERR(II) = RDAT(NPTR + NOFFL) 2000 CONTINUE CALL HPAK(IDH,BUFDAT) IF(QERRL) CALL HPAKE(IDH,BUFERR) ELSEIF(NDIM.EQ.2) THEN NPTR = NPTRD - NWPPT - 1 IF(IDBIN(1).GT.0) DX = (ADHI(1) - ADLO(1)) / FLOAT(IDBIN(1)) IF(IDBIN(2).GT.0) DY = (ADHI(2) - ADLO(2)) / FLOAT(IDBIN(2)) DO 3000 JJ=1,IDBIN(2) DO 2900 II=1,IDBIN(1) NPTR = NPTR + NWPPT X = ADLO(1) + FLOAT(II-1)*DX + 0.5*DX Y = ADLO(2) + FLOAT(JJ-1)*DY + 0.5*DY EE = RDAT(NPTR + 1) CALL HF2(IDH,X,Y,EE) 2900 CONTINUE 3000 CONTINUE ELSEIF(NDIM.EQ.-1) THEN NPTR = NPTRD - NWPPT DO 4000 II=1,NPNT NPTR = NPTR + NWPPT CALL UCOPY_r(RDAT(NPTR),BUFDAT(1),NWPPT) CALL HFN(IDH,BUFDAT) 4000 CONTINUE ELSEIF(NDIM.EQ.-2) THEN NPTR = NPTRD - NWPPT DO 5000 II=1,NPNT NPTR = NPTR + NWPPT CALL UCOPY_r(RDAT(NPTR),BUFDAT(1),NWPPT) CALL HFN(IDH,BUFDAT) 5000 CONTINUE ENDIF C 9000 CONTINUE END +DECK,mn_hbp. SUBROUTINE MN_HBP(IDA,IDB,TPART,IDELIM,IERR) C C GETS A PART OF A HISTOGRAM WHICH I ASK FOR C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNCMD. +CDE,MNLUN. C COMMON/QUEST/IQUEST(100) C PARAMETER (MVDIM = 1) C CHARACTER*4 TPART CHARACTER TDIR*80 C INTEGER IDBIN(2) REAL ADLO(2),ADHI(2) REAL ACONT(3**2) CHARACTER*32 TNDEF(2) C REAL VECT(1) C LOGICAL HEXIST CHARACTER*80 TITLE CHARACTER*80 TEXT C DATA TNDEF/'X', 'Y'/ C IERR = 0 ICYCLE = 99999 C IF(.NOT.HEXIST(IDA)) THEN WRITE(LUNTTO,'('' Histogram'',I7,'' does not exist'')') IDA IERR = 1 GOTO 9000 ENDIF C C FIND OUT WHICH BAND C NPART = 1 IF(TPART.EQ.'SLIX' .OR. TPART.EQ.'SLIY' .OR. 1 TPART.EQ.'BANX' .OR. TPART.EQ.'BANY') THEN 2100 CONTINUE CALL WAITYQ('Give slice or band number (=1): ') NVAL = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,NERR) IF(NERR.EQ.2) GOTO 2200 IF(NERR.NE.0) THEN IF(QRFILE) THEN GOTO 2200 ELSE GOTO 2100 ENDIF ENDIF IF(NVAL.EQ.0) THEN WRITE(LUNTTO,'('' Part 0 is not valid'')') IF(QRFILE) THEN GOTO 2200 ELSE GOTO 2100 ENDIF ENDIF NPART = NVAL ENDIF 2200 CONTINUE C C SET THE SECONDARY ID C IF(TPART.EQ.'HIST' .OR. TPART.EQ.' ') THEN IDB = 0 ELSEIF(TPART.EQ.'FUN ') THEN IDB = 1 ELSEIF(TPART.EQ.'PROX') THEN IDB = 1 ELSEIF(TPART.EQ.'PROY') THEN IDB = 2 ELSEIF(TPART.EQ.'SLIX') THEN IDB = 10 + NPART ELSEIF(TPART.EQ.'SLIY') THEN IDB = 20 + NPART ELSEIF(TPART.EQ.'BANX') THEN IDB = 30 + NPART ELSEIF(TPART.EQ.'BANY') THEN IDB = 40 + NPART ENDIF C TEXT = 'Give secondary ID for part (= ): ' WRITE(TEXT(34:36),'(I3)') IDB CALL WAITYQ(TEXT(1:39)) CALL MN_SEC(IDB,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C C BOOK THE NEW HISTOGRAM C CALL HGIVE(IDA,TEXT,NBINX,XLO,XHI,NBINY,YLO,YHI,NWT,IAD) C NWPPT = 2 IF(TPART.EQ.'FUN ' .OR. TPART(4:4).EQ.'X') THEN NPNT = NBINX NDIM = 1 ELSEIF((TPART.EQ.'HIST' .OR. TPART.EQ.' ') .AND. 1 NBINY.LE.0) THEN NPNT = NBINX NDIM = 1 ELSEIF((TPART.EQ.'HIST' .OR. TPART.EQ.' ') .AND. 1 NBINY.GT.0) THEN NPNT = NBINX * NBINY NDIM = 2 ELSE NPNT = NBINY NDIM = 1 ENDIF NWRD = NWPPT * NPNT NBPPT = 0 NTMODE = 0 C CALL MN_HNW(IDA,IDB,NDIM,NWRD,NH,NPTRH,NPTRD,NWH,NBPPT,NTMODE) IF(NH.LE.0) THEN IERR = 2 GOTO 9000 ENDIF C CALL HCDIR(TDIR,'R') IF(TDIR(1:6).EQ.'//PAWC') THEN CALL M_RTIM(NHDATE,NHTIME) ELSE CALL RZVIN(VECT,MVDIM,NFILE,IDA,ICYCLE,'D') CALL RZDATE(IQUEST(14),NHDATE,NHTIME,1) ENDIF C CALL MN_HEX(IDA,TPART,NPART,RDAT(NPTRD),NDIM,NWPPT,NPNT 1 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,TITLE,ACONT,IERR) C IF(IERR.NE.0) GOTO 9000 C C UPDATE THE HEADER AND POINTERS C NWTOT = NWH + NWRD NSDATE = 0 NSTIME = 0 CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWRD,IDA,IDB 1 ,NDIM,NWPPT,NPNT,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE 1 ,fil_hb,dir_hc,TNDEF) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C 9000 CONTINUE RETURN END +DECK,mn_hbs. SUBROUTINE MN_HBS(IDELIM) C C------------------------------------------------------------------------------ C Stores histograms in HBOOK4 RZ files C------------------------------------------------------------------------------ C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNCMD. +CDE,MNLUN. C LOGICAL HEXIST LOGICAL QZERO,QRNGE CHARACTER*80 TXT1,DIRSAV C INTEGER MSTQUL PARAMETER (MSTQUL=3) CHARACTER*10 STOQUL(MSTQUL) INTEGER IQUAL(10),NQUAL LOGICAL QNEW C DATA STOQUL/'NEW','UPDATE',' '/ C C Set up default values for qualifiers C QNEW = .TRUE. C C Check for qualifiers C CALL M_QUAL(IDELIM,STOQUL,MSTQUL,IQUAL,NQUAL) DO 1000 I=1,NQUAL IF(IQUAL(I).EQ.1) THEN QNEW = .TRUE. ELSEIF(IQUAL(I).EQ.2) THEN QNEW = .FALSE. ENDIF 1000 CONTINUE C LUNHOU = 0 CALL HCDIR(TXT1,'R') IF(QNEW) THEN CALL MN_FIL(-4,LUNHOU,FIL_HO,IDELIM,IERR) IF(IERR.NE.0) GOTO 9900 CICB CALL HRFILE(LUNHOU,'MN_HBOUT','N') ELSE CALL MN_FIL(-5,LUNHOU,FIL_HO,IDELIM,IERR) IF(IERR.NE.0) GOTO 9900 CICB CALL HRFILE(LUNHOU,'MN_HBOUT','U') ENDIF CALL HCDIR(TXT1,' ') C IF(.NOT.QRFILE .AND. IDELIM.LT.0) WRITE(LUNTTO 1 ,'('' Histograms will be stored in HBOOK format'')') C C Set the HBOOK directory and save it as storing Ntuples can change C the directory C CALL M_SDIR(1,IERR) IF(IERR.NE.0) GOTO 9000 CALL HCDIR(DIRSAV,'R') C 2000 CONTINUE QZERO = .FALSE. CALL WAITYQ('Give histograms to store (0 for all,' // 1 ' when finished): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) C IF(NNID.LE.0) GOTO 9000 IF(NNID.EQ.1 .AND. IDA1.EQ.0) QZERO = .TRUE. QRNGE = IDA1.NE.IDA2 .OR. IDB1.NE.IDB2 C DO 2500 NH=1,NDHIS IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) GOTO 2500 IDA = IDIDA(NH) IDB = IDIDB(NH) IF((NNID.EQ.1 .AND. IDA1.EQ.0) .OR. + (NNID.EQ.2 .AND. IDA1.EQ.0 .AND. + IDB.GE.IDB1 .AND. IDB.LE.IDB2) .OR. 1 (IDA.GE.IDA1 .AND. IDA.LE.IDA2 .AND. 1 IDB.GE.IDB1 .AND. IDB.LE.IDB2)) THEN IDH = IDA IF(HEXIST(IDH)) THEN CALL HDELET(IDH) ENDIF CALL MN_HBN(IDA,IDB,IERR) IF(.NOT.QZERO .AND. .NOT.QRNGE .AND. IERR.NE.0) THEN CALL MN_ERR('MN_HBS' + ,'Error converting Mn_Fit plot to HBOOK plot') GOTO 9000 ENDIF C IF(HEXIST(IDH)) CALL HROUT(IDH,ICYCLE,' ') CALL HCDIR(DIRSAV,' ') CALL M_SDIR(1,IERR) ENDIF 2500 CONTINUE IF(.NOT.QZERO) THEN GOTO 2000 ENDIF C 9000 CONTINUE CALL HRENDC('MN_HBOUT') *ICB CLOSE(UNIT=LUNHOU) *ICB CALL CLEO_FRELUN(LUNHOU,'MN_FIL') 9900 CONTINUE END +DECK,mn_hdr. SUBROUTINE MN_HDR(RBUF,NDIM,NWPPT,NPNT + ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE 1 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,AMEAN,ASIG) C C UNPACKS THE HISTOGRAM HEADER C WORD 1 TOTAL NUMBER OF WORDS C 2 NUMBER OF WORDS IN THE HEADER C 3 NUMBER OF DATA WORDS C 4 PRIMARY IDENTIFIER C 5 SECONDARY IDENTIFIER C 6 NUMBER OF DIMENSIONS C 7 NUMBER OF WORDS PER POINT C 8 NUMBER OF POINTS C 9 NUMBER OF CALLS C 10 MINIMUM NUMBER OF ENTRIES (INCLUDING WEIGHT) C 11 MAXIMUM NUMBER OF ENTRIES (INCLUDING WEIGHT) C 12 NUMBER OF BINS FOR FIRST VARIABLE C 13 LOWER LIMIT FOR FIRST VARIABLE C 14 UPPER LIMIT FOR FIRST VARIABLE C 15 NUMBER OF BINS FOR SECOND VARIABLE C 16 LOWER LIMIT FOR SECOND VARIABLE C 17 UPPER LIMIT FOR SECOND VARIABLE C 12 + 3*NDIM NUMBER OF BITS PER POINT C 13 + 3*NDIM NUMBER OF UNDERFLOWS C 14 + 3*NDIM NUMBER INSIDE LIMITS C 15 + 3*NDIM NUMBER OF OVERFLOWS C 16 + 3*NDIM ... C 12 + 3*NDIM + 3**NDIM + 1 MEAN FOR FIRST VARIABLE C 12 + 3*NDIM + 3**NDIM + 2 SIGMA FOR FIRST VARIABLE C 12 + 3*NDIM + 3**NDIM + 1 MEAN FOR SECOND VARIABLE C 12 + 3*NDIM + 3**NDIM + 2 SIGMA FOR SECOND VARIABLE C 12 + 3*NDIM + 3**NDIM + 2*NDIM + 1 DATE C 12 + 3*NDIM + 3**NDIM + 2*NDIM + 2 TIME C 12 + 3*NDIM + 3**NDIM + 2*NDIM + 3 Starting date for time plots C 12 + 3*NDIM + 3**NDIM + 2*NDIM + 4 Starting time for time plots C 12 + 3*NDIM + 3**NDIM + 2*NDIM + 5 Time mode C REAL RBUF(*) INTEGER IDBIN(*) REAL ADLO(*),ADHI(*),AMEAN(*),ASIG(*) C NWH = NINT(RBUF(2)) NDIM = NINT(RBUF(6)) NWPPT = NINT(RBUF(7)) NPNT = NINT(RBUF(8)) EDENT = RBUF(9) EDLO = RBUF(10) EDHI = RBUF(11) DO 1000 II=1,IABS(NDIM) IDBIN(II) = NINT(RBUF(3*(II-1)+12)) ADLO(II) = RBUF(3*(II-1)+13) ADHI(II) = RBUF(3*(II-1)+14) 1000 CONTINUE C C Get the number of bits per point C NN = 11 + 3*IABS(NDIM) + 1 IF(NN.LE.NWH) THEN NBPPT = NINT(RBUF(NN)) ELSE IF(NDIM.GT.2) THEN NBPPT = 16 ELSE NBPPT = 32 ENDIF ENDIF C C Skip the number of underflows and overflows and get C the means and sigmas C NN = 13 + 3*IABS(NDIM) IF(ndim.gt.-3 .and. ndim.le.3) + NN = NN + 3**IABS(NDIM) * * For dimension -1 histograms see if the underflows and overflows * are really stored. * IF(NDIM.EQ.-1) THEN IF(NWH.EQ.15 .OR. + NWH.EQ.15+2 .OR. + NWH.EQ.15+2+2 ) THEN *ICB + NWH.EQ.15+2+2+3) THEN NN = NN - 3**IABS(NDIM) ENDIF ENDIF * IF(NN.LT.NWH .AND. NDIM.GT.-3) THEN DO 2000 II=1,IABS(NDIM) AMEAN(II) = RBUF(NN+2*(II-1)) ASIG(II) = RBUF(NN+2*(II-1)+1) 2000 CONTINUE NN = NN + 2*IABS(NDIM) ELSE CALL VFILL(AMEAN,IABS(NDIM),-1.0) CALL VFILL(ASIG,IABS(NDIM),-1.0) ENDIF C C Get the date and time C IF(NN.LT.NWH) THEN NHDATE = NINT(RBUF(NN)) NHTIME = NINT(RBUF(NN+1)) ELSE NHDATE = 0 NHTIME = 0 ENDIF C C Get the starting date/time and mode for time plots C NN = NN + 2 IF(NN.LT.NWH) THEN NSDATE = NINT(RBUF(NN)) NSTIME = NINT(RBUF(NN+1)) NTMODE = NINT(RBUF(NN+2)) ELSE NSDATE = 0 NSTIME = 0 NTMODE = 0 ENDIF C RETURN END +DECK,mn_hdu. SUBROUTINE MN_HDU(RBUF,NWORD,NWH,NWDAT,IDA,IDB + ,NDIM,NWPPT,NPNT,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) C REAL RBUF(*) INTEGER IDBIN(*) REAL ADLO(*),ADHI(*) REAL ACONT(*) C RBUF(1) = FLOAT(NWORD) RBUF(2) = FLOAT(NWH) RBUF(3) = FLOAT(NWDAT) RBUF(4) = FLOAT(IDA) RBUF(5) = FLOAT(IDB) RBUF(6) = FLOAT(NDIM) RBUF(7) = FLOAT(NWPPT) RBUF(8) = FLOAT(NPNT) RBUF(9) = EDENT RBUF(10) = EDLO RBUF(11) = EDHI DO 1000 II=1,IABS(NDIM) RBUF(3*(II-1)+12) = FLOAT(IDBIN(II)) RBUF(3*(II-1)+13) = ADLO(II) RBUF(3*(II-1)+14) = ADHI(II) 1000 CONTINUE C C Underflows and overflows C NN = 11 + 3*IABS(NDIM) + 1 IF(NN.LE.NWH) RBUF(NN) = FLOAT(NBPPT) IF(ndim.gt.-3 .and. ndim.le.3) THEN NUOF = 3**IABS(NDIM) IF(NN+NUOF.LE.NWH) THEN CALL UCOPY_r(ACONT,RBUF(NN+1),NUOF) NN = NN + NUOF ENDIF ENDIF C C Skip the space for the means and sigmas C IF(NDIM.GT.-3) NN = NN + 2*IABS(NDIM) C C Date and Time C IF(NN+2.LE.NWH) THEN RBUF(NN+1) = FLOAT(NHDATE) RBUF(NN+2) = FLOAT(NHTIME) NN = NN + 2 ENDIF C C Starting Date and Time + mode for time plots C IF(NN+3.LE.NWH) THEN RBUF(NN+1) = FLOAT(NSDATE) RBUF(NN+2) = FLOAT(NSTIME) RBUF(NN+3) = FLOAT(NTMODE) NN = NN + 3 ENDIF C RETURN END +DECK,mn_hex. SUBROUTINE MN_HEX(IDA,TPART,NPART,RBUF,NDIM,NWPPT,NPNT + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,TITLE,ACONT,IERR) C C ROUTINE TO EXTRACT PART OR ALL OF AN HBOOK HISTOGRAM C CICB INTEGER MPNTMX CICB PARAMETER (MPNTMX=20000) CICB+CDE,MNSCR. CICB REAL BUFDAT(MPNTMX),BUFERR(MPNTMX) CICB EQUIVALENCE(SCRATCH(1),BUFDAT(1)) CICB EQUIVALENCE(SCRATCH(MPNTMX+1),BUFERR(1)) C REAL RBUF(*) CHARACTER*4 TPART INTEGER IDA,NPART,NDIM,NWPPT,NPNT,NBPPT,IERR,IDBIN(*) REAL EDENT,EDLO,EDHI,ADLO(*),ADHI(*) REAL ACONT(*) C CHARACTER*80 TITLE LOGICAL QERRL,QERRH C IDBIN(1) = 0 IDBIN(2) = 0 C C GET THE HISTOGRAM DIMENSIONS C TITLE = ' ' CALL HGIVE(IDA,TITLE,NBINX,XLO,XHI,NBINY,YLO,YHI,NWT,IAD) C C CHECK THAT WHAT I WANT IS REASONABLE C AND SET THE DIMENSIONS C IF(TPART.EQ.' ' .OR. TPART.EQ.'HIST') THEN CICB IF(NBINX*MAX0(1,NBINY).GT.MPNTMX) THEN CICB WRITE(TXTERR,'(''Histogram'',I8 CICB + ,'' is too big for my internal storage'')') IDA CICB CALL MN_ERR('MN_HEX',TXTERR) CICB IERR = 3 CICB GOTO 9000 CICB ENDIF ELSEIF(TPART.EQ.'FUN') THEN IF(NBINY.GT.0) THEN CALL MN_ERR('MN_HEX','Functions are not associated' // 1 ' with scatter plots') IERR = 2 GOTO 9000 ENDIF ELSEIF(NDIM.LT.-1) THEN CALL MN_ERR('MN_HEX','Called for an Ntuple.' // + ' This should not happen!') IERR = 3 GOTO 9000 ELSE IF(NBINY.LE.0) THEN CALL MN_ERR('MN_HEX','It is only possible to make' // 1 ' projections of scatter plots') IERR = 3 GOTO 9000 ENDIF ENDIF C DX = (XHI-XLO) / FLOAT(NBINX) IF(NBINY.GT.0) DY = (YHI-YLO) / FLOAT(NBINY) C CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) EDENT = 0.0 EDLO = 1.0E+30 EDHI = -1.0E+30 NHPT = 0 DEE = 0.0 CALL VZERO_r(ACONT,3**IABS(NDIM)) C C Put the data after the errors, so that when copying to the C Mn_Fit order of data, error, data, error no overwriting occurs. C However I don't think this really matters! C For variable bin width the order is x,y,dx,dy! C NPTRD1 = (NWPPT+0)*NBINX*MAX0(1,NBINY) + 1 NPTRE1 = (NWPPT-1)*NBINX*MAX0(1,NBINY) + 1 C IF((TPART.EQ.' ' .OR. TPART.EQ.'HIST') .AND. 1 IABS(NDIM).EQ.1) THEN IF(NDIM.GT.0 .OR. (NDIM.EQ.-1 .AND.NWPPT.GT.1)) THEN NB1 = 0 NB2 = NBINX + 1 ELSE NB1 = 1 NB2 = NBINX ENDIF CALL HUNPAK(IDA,RBUF(NPTRD1),TPART,NPART) IF(QERRL) CALL HUNPKE(IDA,RBUF(NPTRE1),TPART,NPART) DO 3600 I=NB1,NB2 IF(I.GE.1 .AND. I.LE.NBINX) THEN EE = RBUF(NPTRD1+I-1) IF(QERRL) DEE = RBUF(NPTRE1+I-1) ELSE EE = HI(IDA,I) DEE = 0.0 ENDIF CICB IF(QERRL) THEN CICB IF(I.GE.1 .AND. I.LE.NBINX) THEN CICB DEE = HIE(IDA,I) CICB ELSE CICB DEE = 0.0 CICB ENDIF CICB ENDIF IF(I.GE.1 .AND. I.LE.NBINX) THEN NHPT = NHPT + 1 NPTR = NWPPT*(NHPT-1) C C Variable bin width histograms C IF(NDIM.EQ.-1) THEN if(i.eq.1) call hix(ida,i,x1) if(i.lt.nbinx) then CALL HIX(IDA,I+1,X2) else x2 = xhi endif XX = 0.5*(x1+x2) DXX = 0.5*(x2-x1) X1 = X2 C RBUF(NPTR+1) = XX RBUF(NPTR+2) = EE IF(QERRL) THEN RBUF(NPTR+3) = DXX RBUF(NPTR+4) = DEE ENDIF ELSE RBUF(NPTR+1) = EE IF(QERRL) THEN RBUF(NPTR+2) = DEE ENDIF ENDIF EDENT = EDENT + EE EDLO = AMIN1(EDLO,EE-DEE) EDHI = AMAX1(EDHI,EE+DEE) ENDIF C IF(I.EQ.0) THEN NUOF = 1 ELSEIF(I.LE.NBINX) THEN NUOF = 2 ELSE NUOF = 3 ENDIF ACONT(NUOF) = ACONT(NUOF) + EE 3600 CONTINUE ELSEIF((TPART.EQ.' ' .OR. TPART.EQ.'HIST') .AND. 1 NDIM.EQ.2) THEN NBX1 = 0 NBX2 = NBINX + 1 NBY1 = 0 NBY2 = NBINY + 1 CALL HUNPAK(IDA,RBUF(NPTRD1),TPART,NPART) IF(QERRL) CALL HUNPKE(IDA,RBUF(NPTRE1),TPART,NPART) DO 3700 J=NBY1,NBY2 Y = YLO + FLOAT(J-1)*DY + 0.5*DY C IF(J.EQ.0) THEN NUOFY = 1 ELSEIF(J.LE.NBINY) THEN NUOFY = 2 ELSE NUOFY = 3 ENDIF C DO 3650 I=NBX1,NBX2 X = XLO + FLOAT(I-1)*DX + 0.5*DX IF(I.GE.1 .AND. I.LE.NBINX .AND. + J.GE.1 .AND. J.LE.NBINY) THEN NHPT = NHPT + 1 EE = RBUF(NPTRD1+NHPT-1) IF(QERRL) DEE = RBUF(NPTRE1+NHPT-1) ELSE EE = HIJ(IDA,I,J) DEE = 0.0 ENDIF IF(I.GE.1 .AND. I.LE.NBINX .AND. + J.GE.1 .AND. J.LE.NBINY) THEN NPTR = NWPPT*(NHPT-1) RBUF(NPTR+1) = EE IF(QERRL) THEN RBUF(NPTR+2) = DEE ENDIF EDENT = EDENT + EE EDLO = AMIN1(EDLO,EE-DEE) EDHI = AMAX1(EDHI,EE+DEE) ENDIF C IF(I.EQ.0) THEN NUOFX = 1 ELSEIF(I.LE.NBINX) THEN NUOFX = 2 ELSE NUOFX = 3 ENDIF NUOF = 3*(NUOFY-1) + NUOFX ACONT(NUOF) = ACONT(NUOF) + EE 3650 CONTINUE 3700 CONTINUE C C Associated functions C ELSEIF(TPART.EQ.'FUN ') THEN DO 3800 I=1,NBINX NHPT = NHPT + 1 NPTR = NWPPT*(NHPT-1) CALL HIX(IDA,I,X) EE = HIF(IDA,I) IF(NDIM.EQ.-1) THEN RBUF(NPTR+1) = X + 0.5*DX RBUF(NPTR+2) = EE IF(QERRL) THEN RBUF(NPTR+3) = 0.5*DX RBUF(NPTR+4) = DEE ENDIF ELSE RBUF(NPTR+1) = EE IF(QERRL) THEN RBUF(NPTR+2) = DEE ENDIF ENDIF EDENT = EDENT + EE EDLO = AMIN1(EDLO,EE-DEE) EDHI = AMAX1(EDHI,EE+DEE) 3800 CONTINUE IF(EDENT.LE.0) THEN CALL M_EMSG('MN_HEX',' The associated function has' // 1 ' no entries.') ENDIF C C Projections, slices, bands etc. C ELSE CALL HUNPAK(IDA,RBUF(NPTRD1),TPART,NPART) IF(QERRL) CALL HUNPKE(IDA,RBUF(NPTRE1),TPART,NPART) IF(TPART(4:4).EQ.'Y') THEN NBINX = NBINY XLO = YLO XHI = YHI DX = DY ENDIF C DO 3900 II=1,NBINX NHPT = NHPT + 1 NPTR = NWPPT*(NHPT-1) X = XLO + FLOAT(II-1)*DX + 0.5*DX EE = RBUF(NPTRD1+II-1) C IF(QERRL) DEE = SQRT(ABS(EE)) IF(QERRL) DEE = RBUF(NPTRE1+II-1) IF(NDIM.EQ.-1) THEN RBUF(NPTR+1) = X RBUF(NPTR+2) = EE IF(QERRL) THEN RBUF(NPTR+3) = 0.5*DX RBUF(NPTR+4) = DEE ENDIF ELSE RBUF(NPTR+1) = EE IF(QERRL) THEN RBUF(NPTR+2) = DEE ENDIF ENDIF EDENT = EDENT + EE EDLO = AMIN1(EDLO,EE-DEE) EDHI = AMAX1(EDHI,EE+DEE) 3900 CONTINUE IF(EDENT.LE.0) THEN CALL M_EMSG('MN_HEX','The projection has no entries.') ENDIF ENDIF C IDBIN(1) = NBINX ADLO(1) = XLO ADHI(1) = XHI IF(IABS(NDIM).GT.1) THEN IDBIN(2) = NBINY ADLO(2) = YLO ADHI(2) = YHI ENDIF C 9000 CONTINUE RETURN END +DECK,mn_hgt. SUBROUTINE MN_HGT(IDA,IDB,NHD) C C IDA,IDB IS THE HISTOGRAM ID WHICH I WANT POINTERS ON C NHD IS THE STORAGE POSITION C NDIM IS THE NUMBER OF DIMENSIONS C NPTRH IS THE POINTER TO THE HEADER C NPTRD IS THE POINTER TO THE DATA C EDENT ARE THE NUMBER OF ENTRIES C EDLO,EDHI ARE THE LOWER AND UPPER LIMITS ON THE NUMBER OF ENTRIES C NBPPT IS THE NUMBER OF BITS PER WORD C implicit none C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNFLG. +CDE,MNLUN. C integer ida,idb,nhd C INTEGER IDBINT(MDIMMX) REAL ADLOT(MDIMMX),ADHIT(MDIMMX),AMEANT(MDIMMX),ASIGT(MDIMMX) integer nnh,ierr,idda,iddb,jj,ii,ii1,ii2,idh,icycle integer ndimt,nwpptt,npntt,nhdatt,nhtimt,nsdatt,nstimt,ntmodt + ,nbpptt real edentt,edlot,edhit logical hexist external hexist C C SEE IF THIS HISTOGRAM EXISTS C NHD = 0 DO 1000 NNH=1,NDHIS IF(IDA.EQ.IDIDA(NNH) .AND. IDB.EQ.IDIDB(NNH) .AND. 1 IDPTRH(NNH).GT.0 .AND. IDPTRD(NNH).GT.0) THEN NHD = NNH GOTO 2000 ENDIF 1000 CONTINUE * * Histogram does not exist - see if it is in the current HBOOK directory * if(qafetch .and. fil_hb.ne.' ') then call m_sdir(0,ierr) if(ierr.ne.0) then nhd = -1 goto 9000 endif idh = ida icycle = 999999 if(hexist(idh)) call hdelet(idh) call hrin(idh,icycle,0) * * See if the histogram was found * if(hexist(idh)) then write(6,'('' Histogram'',I7 + ,'' fetched from HBOOK file'')') idh * * Now make the HBOOK histogram into a Mn_Fit histogram * call m_hbmn(ida,ida,idb,4) * * See if this histogram exists now * nhd = 0 do 1200 nnh=1,ndhis if(ida.eq.idida(nnh) .and. idb.eq.ididb(nnh) .and. 1 idptrh(nnh).gt.0 .and. idptrd(nnh).gt.0) then nhd = nnh goto 2000 endif 1200 continue else nhd = -1 goto 9000 endif else nhd = -1 goto 9000 endif C C CHECK OUT THE POINTERS C 2000 CONTINUE NPTRH = IDPTRH(NHD) NPTRD = IDPTRD(NHD) IF(NINT(RDAT(NPTRH+3)).NE.IDA .OR. NINT(RDAT(NPTRH+4)).NE.IDB) 1 THEN IDDA = NINT(RDAT(NPTRH+3)) IDDB = NINT(RDAT(NPTRH+4)) WRITE(TXTERR,'(''Something is screwed up'' 1 ,'' with the pointers for plot'',I7,I4)') IDA,IDB CALL M_EMSG('MN_HGT',TXTERR) WRITE(TXTERR,'(''NHD ='',I4,'' ID in plot itself'',I7,I4)') + NHD,IDDA,IDDB CALL M_EMSG('MN_HGT',TXTERR) DO 3000 JJ=1,4 II1 = (JJ-1)*5 II2 = JJ*5 - 1 WRITE(TXTERR + ,'(''Words '',I2,'' ->'',I2,2X,5(1PG12.5))') + II1,II2,(RDAT(NPTRH+II),II=II1,II2) CALL M_EMSG('MN_HGT',TXTERR) 3000 CONTINUE CALL MN_ERR('MN_HGT',' ') NHD = 0 GOTO 9000 ENDIF C CALL MN_HDR(RDAT(NPTRH),NDIMT,NWPPTT,NPNTT + ,NHDATT,NHTIMT,NSDATT,NSTIMT,NTMODT 1 ,EDENTT,EDLOT,EDHIT,IDBINT,ADLOT,ADHIT,NBPPTT,AMEANT,ASIGT) IDAC = IDA IDBC = IDB NDIM = NDIMT NWPPT = NWPPTT NPNT = NPNTT NBPPT = NBPPTT NWDAT = NINT(RDAT(NPTRH+2)) NHDATE = NHDATT NHTIME = NHTIMT EDENT = EDENTT NSDATE = NSDATT NSTIME = NSTIMT NTMODE = NTMODT EDLO = EDLOT EDHI = EDHIT CALL UCOPY_i(IDBINT,IDBIN,IABS(NDIM)) CALL UCOPY_r(ADLOT,ADLO,IABS(NDIM)) CALL UCOPY_r(ADHIT,ADHI,IABS(NDIM)) CALL UCOPY_r(AMEANT,AMEAN,IABS(NDIM)) CALL UCOPY_r(ASIGT,ASIG,IABS(NDIM)) C 9000 CONTINUE NHC = NHD RETURN END +DECK,mn_hid. SUBROUTINE MN_HID(NMODE,XPT,YPT,NPT,NSYM,XUNIT,NCOL,THICK) C C C ****************************************************************** C * * C * * C * ALGORITHM TO NOT DRAW HIDDEN LINES * C * WHEN DRAWING A LINE WITH ANY ANGLE * C * AUXILIARY FOR HPLEGO CALLED FROM HPLEG1 * C * NMODE = 0 means update the WORK array C * NMODE = 1 means don't update it C * * C * * C ****************************************************************** C REAL XPT(NPT),YPT(NPT) C PARAMETER (MPNTMX=5000) C +CDE,MNSCR. REAL XXLOW,XXHIG,YYLOW,YYHIG,RES,DRES,WRK1(MPNTMX),WRK2(MPNTMX) EQUIVALENCE(SCRATCH(1),XXLOW) EQUIVALENCE(SCRATCH(2),XXHIG) EQUIVALENCE(SCRATCH(3),YYLOW) EQUIVALENCE(SCRATCH(4),YYHIG) EQUIVALENCE(SCRATCH(5),RES) EQUIVALENCE(SCRATCH(6),DRES) EQUIVALENCE(SCRATCH(7),WRK1(1)) EQUIVALENCE(SCRATCH(MPNTMX+7),WRK2(1)) C REAL X(2),Y(2) C C ------------------------------------------------------------------ C C IF(NPT.LT.2) RETURN DO 1000 I=1,NPT-1 U1 = XPT(I) V1 = YPT(I) U2 = XPT(I+1) V2 = YPT(I+1) C IC1=MAX0(1,IFIX((U1-XXLOW)*DRES+0.5)) IC2=MAX0(1,IFIX((U2-XXLOW)*DRES+0.5)) C C Vertical line - make sure V2 is the highest point C IF(IC1.EQ.IC2) THEN VMAX=WRK1(IC1) X(1)=U1 X(2)=U1 IF(V1.GT.V2) THEN VT = V1 V1 = V2 V2 = VT ENDIF IF(V1.GE.VMAX) THEN Y(1)=V1 Y(2)=V2 ELSEIF(V2.LT.VMAX) THEN GO TO 1000 ELSE Y(1)=VMAX Y(2)=V2 ENDIF IF(NMODE.EQ.0) WRK1(IC1)=V2 IF(NINT(DRES*(Y(1)-Y(2))).NE.0) + CALL MN_LIN(X,Y,2,NSYM,XUNIT,NCOL,THICK) C C INCLINED LINE C ELSE ALFA=(V1-V2)/(U1-U2) BETA=V1-ALFA*U1 IDRAW=0 X(1)=U1 Y(1)=V1 C IF(IC2.GT.IC1) THEN NSTEP = 1 ELSE NSTEP = -1 ENDIF DO 30 IC=IC1,IC2,NSTEP VMAX=WRK1(IC) U=FLOAT(IC)*RES+XXLOW IF(IC.EQ.IC1 .AND. + (NSTEP.GT.0 .AND. U.LT.U1) .OR. + (NSTEP.LT.0 .AND. U.GT.U1)) U = U1 IF(IC.EQ.IC2 .AND. + (NSTEP.GT.0 .AND. U.GT.U2) .OR. + (NSTEP.LT.0 .AND. U.LT.U2)) U = U2 V=ALFA*U+BETA IF(V.GT.VMAX) THEN X(2)=U Y(2)=V IDRAW=1 IF(NMODE.EQ.0) WRK1(IC)=V ELSEIF(IDRAW.NE.0) THEN CALL MN_LIN(X,Y,2,NSYM,XUNIT,NCOL,THICK) IDRAW=0 ELSE X(1)=U Y(1)=V ENDIF 30 CONTINUE IF(IDRAW.NE.0) CALL MN_LIN(X,Y,2,NSYM,XUNIT,NCOL,THICK) ENDIF 1000 CONTINUE C 9000 CONTINUE RETURN END +DECK,mn_his. SUBROUTINE MN_HIS C C DO SOMETHING WITH A HISTOGRAM C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNFLG. +CDE,MNHPJ. +CDE,MNTIM. +CDE,MNTMP. +CDE,MNCMD. +CDE,MNLUN. C integer mhist PARAMETER (MHIST=13) CHARACTER*10 HSTNAM(MHIST) integer mplqul,movqul,mbkqul,mlegqul,msurqul,mcolqul PARAMETER (MPLQUL=7, MOVQUL=6, MBKQUL=6 + , mlegqul=11, msurqul=12, mcolqul=3) CHARACTER*10 PLTQUL(MPLQUL),OVEQUL(MOVQUL),BOKQUL(MBKQUL) + ,legqul(mlegqul),surqul(msurqul),colqul(mcolqul) C REAL ADAT(MDIMMX),AERN(MDIMMX),AERP(MDIMMX) INTEGER NQUAL,IQUAL(10) LOGICAL QERRL,QERRH C REAL RNUM(10),rval integer ida,idb,ida1,idb1,ida2,idb2 integer nsym,nhat,npat,nscol,nhcol,npcol integer nsyml,nhatl,npatl integer nflag,nderr,nmode,nd,npmax,nwrd,nwh,nwtot,nl,ndimo + ,nww,nloop,nval,nnum,ioerr,noff,noffl,noffh integer lenb,lene,lent,nchtit,nleg,nphi,ntheta integer i,ierr,nnid,nh,nnh,nnhp + ,modeh,modecl real err,weight C LOGICAL QQUAL,QCLEAR,QSAME,QBIN,QERRS,QERRA,QPNTPL,QNEXT,QSMOOTH + ,QEMPTY CHARACTER TEXT*255,CONCAT*255,conct0*255,TITLE*80 CHARACTER*30 TBIN,TERR character*10 tigopt(2),tigqul integer ligopt * LOGICAL QSTART,QRNGE,QRNGSV INTEGER NNHLST * integer idelim,jcmd,kcmd integer inttyq,iqstyq,ivltyq,icmtyq + ,lnblnk real valtyq external inttyq,iqstyq,ivltyq,icmtyq,valtyq,lnblnk C DATA HSTNAM/'PLOT', 'OVERLAY', 1 'DUMP', 'EXTRACT', 'LEGO', 'SURFACE','ERRORS', 2 'BOOK', 'FILL', 'DISPLAY', 'IGTABLE','2DIM', + ' '/ DATA PLTQUL/'CLEAR', 'NOCLEAR', 'NTUPLE', 'NEXT', 'SMOOTH', + 'EMPTY',' '/ DATA OVEQUL/'SAME', 'DIFFERENT', 'NTUPLE', 'NEXT', 'SMOOTH', ' '/ DATA BOKQUL/'BINNED','UNBINNED', 1 'ERROR', 'NOERROR', 'ASYMMETRIC', ' '/ data legqul/'IGTABLE','C1','C2','BAR', + 'POL','CYL','SPH','PSD','NFB','NBB',' '/ data surqul/'IGTABLE','C1','C2','CONT','SHADE', + 'POL','CYL','SPH','PSD','NFB','NBB',' '/ data colqul/'Z','NZ',' '/ DATA QSTART/.TRUE./ DATA NNHLST/0/ C *ICB IF(QSTART) THEN *ICB QSTART = .FALSE. *ICB DO 100 II=1,MDIMMX *ICB IF(II.EQ.1) THEN *ICB TNDEF(II) = 'X' *ICB ELSE IF(II.EQ.2) THEN *ICB TNDEF(II) = 'Y' *ICB ELSE IF(II.EQ.3) THEN *ICB TNDEF(II) = 'Z' *ICB ELSE *ICB TNDEF(II) = ' ' *ICB ENDIF *ICB100 CONTINUE *ICB ENDIF C IF(COMND1.EQ.'PLOT' .OR. COMND1.EQ.'OVERLAY' .OR. 1 COMND1.EQ.'EXTRACT' .OR. COMND1.EQ.'DUMP' .OR. 1 COMND1.EQ.'LEGO' .OR. COMND1.EQ.'SURFACE' .OR. 2 COMND1.EQ.'BOOK' .OR. COMND1.EQ.'FILL' .OR. 3 COMND1.EQ.'DISPLAY' .OR. + COMND1.EQ.'IGTABLE' .OR. COMND1.EQ.'2DIM') THEN COMND1 = 'HISTOGRAM' CALL RESTYQ ENDIF C 2000 CONTINUE CALL WAITYQ('Give histogram operation or ?: ') JCMD = ICMTYQ(.TRUE.,IDELIM,HSTNAM) COMND2 = ' ' IF(JCMD.GT.0) COMND2 = HSTNAM(JCMD) IF(JCMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN CALL QUOTYQ('HISTOGRAM ' // COMND2) IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 2000 ENDIF IF(JCMD.LT.0) GOTO 9000 CALL MN_DCK(IDELIM,JCMD,MHIST,HSTNAM,IERR) IF(IERR.EQ.2) CALL MN_UNK('MN_HIS') IF(IERR.GT.0) GOTO 9000 * * Get the IGTABL mode for the 2DIM command * IF(COMND2.EQ.'2DIM') THEN call m_sigopt(tigopt,ligopt,idelim,ierr) if(ierr.ne.0) goto 9000 tigopts = tigopt(2) ligopts = ligopt endif C C SET DEFAULT VALUES FOR QUALIFIERS C QCLEAR = .TRUE. QSAME = .TRUE. QBIN = .FALSE. QERRS = .TRUE. QERRA = .FALSE. QPNTPL = .FALSE. QNEXT = .FALSE. QSMOOTH = .FALSE. QEMPTY = .FALSE. C C Check for any qualifiers C 2100 CONTINUE IF(COMND2.EQ.'PLOT' .OR. COMND2.EQ.'DISPLAY') THEN CALL M_QUAL(IDELIM,PLTQUL,MPLQUL,IQUAL,NQUAL) IF(NQUAL.LT.0) GOTO 9000 DO 2200 I=1,NQUAL IF(IQUAL(I).EQ.1) THEN QCLEAR = .TRUE. ELSEIF(IQUAL(I).EQ.2) THEN QCLEAR = .FALSE. ELSEIF(IQUAL(I).EQ.3) THEN QPNTPL = .TRUE. ELSEIF(IQUAL(I).EQ.4) THEN QNEXT = .TRUE. ELSEIF(IQUAL(I).EQ.5) THEN QSMOOTH = .TRUE. ELSEIF(IQUAL(I).EQ.6) THEN QEMPTY = .TRUE. ENDIF 2200 CONTINUE ELSEIF(COMND2.EQ.'OVERLAY') THEN CALL M_QUAL(IDELIM,OVEQUL,MOVQUL,IQUAL,NQUAL) IF(NQUAL.LT.0) GOTO 9000 DO 2300 I=1,NQUAL IF(IQUAL(I).EQ.1) THEN QSAME = .TRUE. ELSEIF(IQUAL(I).EQ.2) THEN QSAME = .FALSE. ELSEIF(IQUAL(I).EQ.3) THEN QPNTPL = .TRUE. ELSEIF(IQUAL(I).EQ.4) THEN QNEXT = .TRUE. ELSEIF(IQUAL(I).EQ.5) THEN QSMOOTH = .TRUE. ENDIF 2300 CONTINUE ELSEIF(COMND2.EQ.'BOOK') THEN CALL M_QUAL(IDELIM,BOKQUL,MBKQUL,IQUAL,NQUAL) IF(NQUAL.LT.0) GOTO 9000 DO 2400 I=1,NQUAL IF(IQUAL(I).EQ.1) THEN QBIN = .TRUE. ELSEIF(IQUAL(I).EQ.2) THEN QBIN = .FALSE. ELSEIF(IQUAL(I).EQ.3) THEN QERRS = .TRUE. QERRA = .FALSE. ELSEIF(IQUAL(I).EQ.4) THEN QERRS = .FALSE. QERRA = .FALSE. ELSEIF(IQUAL(I).EQ.5) THEN QERRS = .FALSE. QERRA = .TRUE. ENDIF 2400 CONTINUE * * Qualifiers for LEGO and SURFACE. * Any qualifier means that IGTABLE will be used. * Convert the command to 2DIM and proceed. * Qualifer 1 also means use IGTABLE. * elseif(comnd2.eq.'LEGO' .or. + comnd2.eq.'2DIM' .and. tigopts(1:1).eq.'L') then call m_qual(idelim,legqul,mlegqul,iqual,nqual) if(nqual.lt.0) goto 9000 tigqul = ' ' do i=1,nqual if(iqual(i).eq.2) then tigqul = conct0(tigqul,'1') elseif(iqual(i).eq.3) then tigqul = conct0(tigqul,'2') elseif(iqual(i).eq.4) then tigqul = conct0(tigqul,'B') elseif(iqual(i).eq.5) then tigqul = conct0(tigqul,',POL') elseif(iqual(i).eq.6) then tigqul = conct0(tigqul,',CYL') elseif(iqual(i).eq.7) then tigqul = conct0(tigqul,',SPH') elseif(iqual(i).eq.8) then tigqul = conct0(tigqul,',PSD') elseif(iqual(i).eq.9) then tigqul = conct0(tigqul,',FB') elseif(iqual(i).eq.10) then tigqul = conct0(tigqul,',BB') endif enddo if(nqual.gt.0) then tigopt(1) = 'LEGO' tigopt(2) = 'L' comnd2 = '2DIM' tigopts = conct0(tigopt(2),tigqul) ligopts = lnblnk(tigopts) endif * elseif(comnd2.eq.'SURFACE' .or. + comnd2.eq.'2DIM' .and. tigopts(1:1).eq.'S') then call m_qual(idelim,surqul,msurqul,iqual,nqual) if(nqual.lt.0) goto 9000 tigqul = ' ' do i=1,nqual if(iqual(i).eq.2) then tigqul = conct0(tigqul,'1') elseif(iqual(i).eq.3) then tigqul = conct0(tigqul,'2') elseif(iqual(i).eq.4) then tigqul = conct0(tigqul,'3') elseif(iqual(i).eq.5) then tigqul = conct0(tigqul,'4') elseif(iqual(i).eq.6) then tigqul = conct0(tigqul,',POL') elseif(iqual(i).eq.7) then tigqul = conct0(tigqul,',CYL') elseif(iqual(i).eq.8) then tigqul = conct0(tigqul,',SPH') elseif(iqual(i).eq.9) then tigqul = conct0(tigqul,',PSD') elseif(iqual(i).eq.10) then tigqul = conct0(tigqul,',FB') elseif(iqual(i).eq.11) then tigqul = conct0(tigqul,',BB') endif enddo if(nqual.gt.0) then tigopt(1) = 'SURF' tigopt(2) = 'S' comnd2 = '2DIM' tigopts = conct0(tigopt(2),tigqul) ligopts = lnblnk(tigopts) endif * * Turn on or off the colour scale * elseif(comnd2.eq.'2DIM' .and. tigopts(1:3).eq.'COL') then call m_qual(idelim,colqul,mcolqul,iqual,nqual) if(nqual.lt.0) goto 9000 tigqul = 'Z' do i=1,nqual if(iqual(i).eq.1) then tigqul = 'Z' elseif(iqual(i).eq.2) then tigqul = ' ' endif enddo if(nqual.gt.0) then tigopts = conct0(tigopts,tigqul) ligopts = lnblnk(tigopts) endif endif C C PLOT, OVERLAY, 2D, LEGO or SURFACE PLOT C IF(COMND2.EQ.'PLOT' .OR. COMND2.EQ.'OVERLAY' .OR. 1 COMND2.EQ.'LEGO' .OR. COMND2.EQ.'SURFACE' .OR. 3 COMND2.EQ.'DISPLAY' .OR. + COMND2.EQ.'IGTABLE' .OR. COMND2.EQ.'2DIM') THEN C C Set up any parameters needed for special displays C implemented for L3 C IF(COMND2.EQ.'DISPLAY') THEN CALL MN_DSC(IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 ENDIF C IF(.NOT.QNEXT) THEN IDB1 = NDIDB IDB2 = NDIDB QHBPRT = .TRUE. CALL WAITYQ('Give histogram number: ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) QHBPRT = .FALSE. C IF(NNID.LE.0) GOTO 9000 IF(IDA1.LT.0) GOTO 9000 QRNGE = IDA1.EQ.0 .OR. IDA1.NE.IDA2 .OR. IDB1.NE.IDB2 ELSE QRNGE = .FALSE. ENDIF QRNGSV = QRNGE C IF(QRNGE) THEN IF(COMND2.EQ.'OVERLAY') THEN CALL MN_ERR('MN_HIS' + ,' You cannot overlay a range of plots') GOTO 9000 ENDIF NNH = 0 NNHP = 0 ENDIF C 3000 CONTINUE IF(QRNGE) THEN NNH = NNH + 1 IF(NNH.GT.NDHIS) GOTO 9000 IF(IDPTRH(NNH).LE.0 .OR. IDPTRD(NNH).LE.0) GOTO 3000 IDA = IDIDA(NNH) IDB = IDIDB(NNH) IF((IDA1.NE.0 .AND. (IDA.LT.IDA1 .OR. IDA.GT.IDA2)) .OR. 1 (NNID.GT.1 .AND. 2 (IDB.LT.IDB1 .OR. IDB.GT.IDB2))) GOTO 3000 NNHP = NNHP + 1 ELSEIF(QNEXT) THEN NNH = NNHLST 2900 CONTINUE NNH = NNH + 1 IF(NNH.GT.NDHIS) THEN CALL MN_MES(LUNTTO,'ME','No more plots to draw') GOTO 9000 ENDIF IF(IDPTRH(NNH).LE.0 .OR. IDPTRD(NNH).LE.0) GOTO 2900 IDA = IDIDA(NNH) IDB = IDIDB(NNH) QRNGE = .FALSE. ELSE IDA = IDA1 IDB = IDB1 ENDIF C IF(IDB.LT.0) THEN KCMD = -IDB CALL MN_HBP(IDA,IDB,HBPNAM(KCMD),IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 GOTO 3500 ENDIF C 3500 CONTINUE C C SEE IF THE PLOT EXISTS C CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_HIS',TXTERR) GOTO 9000 ENDIF NNHLST = NH * * Check the plot dimensions, but not for displays. * IF(COMND2.NE.'DISPLAY' .and. + ((.NOT.QPNTPL .AND. IABS(NDIM).GT.2) .OR. + (QPNTPL .AND. NDIM.GT.0))) THEN IF(QRNGE .OR. QNEXT) THEN IF(QRNGE) NNHP = NNHP - 1 GOTO 3000 ENDIF WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' has a dimension of'',I4)') IDA,IDB,NDIM CALL M_EMSG('MN_HIS',TXTERR) WRITE(TXTERR,'(''I can only plot 2 dimensions.'')') CALL M_EMSG('MN_HIS',TXTERR) WRITE(TXTERR,'(''Use the command PROJECT to make the'' 2 ,'' projection you want'')') CALL MN_ERR('MN_HIS',TXTERR) GOTO 9000 ELSEIF(QPNTPL .AND. (INTPMN(1).LE.0 .OR. INTPMN(2).LE.0)) THEN IF(QRNGE) THEN NNHP = NNHP - 1 GOTO 3000 ENDIF CALL MN_ERR('MN_HIS' + ,'You must use the SET NTUPLE command' // + ' to set the variables to plot') GOTO 9000 ELSEIF(QPNTPL .AND. NWDAT.EQ.0) THEN IF(QRNGE) THEN NNHP = NNHP - 1 GOTO 3000 ENDIF CALL MN_ERR('MN_HIS' + ,'You can only directly plot Ntuples' // + ' if they are in memory (<50000 words)') GOTO 9000 ELSEIF((COMND2.EQ.'IGTABLE' .OR. COMND2.EQ.'2DIM') .AND. + NDIM.NE.2) THEN IF(QRNGE) THEN NNHP = NNHP - 1 GOTO 3000 ENDIF WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' has a dimension of'',I4)') IDA,IDB,NDIM CALL M_EMSG('MN_HIS',TXTERR) TXTERR = 'I can only IGTABL or 2DIM plot 2 dimensions.' CALL MN_ERR('MN_HIS',TXTERR) GOTO 9000 ENDIF C C SET UP THE PLOT NUMBER IN THE BUFFER C IF(COMND2.EQ.'PLOT' .OR. COMND2.EQ.'LEGO' .OR. + COMND2.EQ.'SURFACE' .OR. COMND2.EQ.'DISPLAY' .OR. + COMND2.EQ.'IGTABLE' .OR. COMND2.EQ.'2DIM') THEN C C IF LAST PLOT WAS A FIT GET BACK THE PARAMETERS FOR C A NORMAL PLOT C IF(QDFIT) CALL MN_FRP C C Get the plot number C IF(QRNGE .AND. NNHP.EQ.1) QRNGE = .FALSE. CALL M_NPLT(QRNGE,QCLEAR,IERR) QRNGE = QRNGSV IF(IERR.NE.0) GOTO 9000 C MODEH = 1 MODECL= 1 IF(NHPLT.EQ.1) NDRWLN = 0 C CALL MN_ZER(NHPLT,IDELIM) C ELSEIF(COMND2.EQ.'OVERLAY') THEN IF(NHPLT.LT.MHPLT) THEN NHPLT = NHPLT + 1 ELSE CALL MN_ERR('MN_HIS' + ,'Buffer for overlaying histograms is full') GOTO 9000 ENDIF C IF(QSAME) THEN MODEH = 2 ELSE MODEH = 3 ENDIF MODECL = 0 C NPLTCM(NHPLT) = 0 NPLTKY(NHPLT) = 0 ENDIF C C Setup the symbol numbers C IF(COMND2.EQ.'PLOT') THEN IF(.NOT.QCLEAR) MODECL = 0 NSYM = NSYMS NHAT = NHATS NPAT = NPATS nscol = icols(7) nhcol = icols(8) npcol = icols(9) QLEGO = .FALSE. NLEG = 0 IF(QEMPTY) THEN NLEG = 10 ELSEIF(QSMOOTH) THEN NLEG = -1 NSYM = -IABS(MOD(NSYM,10)) ENDIF C ELSEIF(COMND2.EQ.'OVERLAY') THEN IF(QLEGO) THEN CALL MN_ERR('MN_HIS' + ,'You cannot do an overlay on a lego plot') GOTO 9000 ENDIF NSYM = ISIGN(IABS(NSYMU)+1,NSYMU) NHAT = 0 NPAT = 0 NLEG = 0 nscol = icols(7) nhcol = icols(8) npcol = icols(9) IF(QSMOOTH) THEN NLEG = -1 NSYM = -IABS(MOD(NSYM,10)) ENDIF C ELSEIF(COMND2.EQ.'LEGO' .OR. COMND2.EQ.'SURFACE' .OR. + COMND2.EQ.'IGTABLE' .OR. COMND2.EQ.'2DIM') THEN QLEGO = .TRUE. IF(COMND2.EQ.'LEGO') THEN NLEG = 1 ELSEIF(COMND2.EQ.'SURFACE') THEN NLEG = 2 ELSEIF((TIGOPTS(1:1).EQ.'L' .OR. + TIGOPTS(1:1).EQ.'S') .AND. + (INDEX(TIGOPTS,'POL').GT.0 .OR. + INDEX(TIGOPTS,'CYL').GT.0 .OR. + INDEX(TIGOPTS,'SPH').GT.0 .OR. + INDEX(TIGOPTS,'PSD').GT.0)) THEN NLEG = 9 ELSEIF(TIGOPTS(1:1).EQ.'L' .OR. + TIGOPTS(1:1).EQ.'S') THEN NLEG = 8 ELSE NLEG = 7 ENDIF NSYM = 1 NHAT = 0 NPAT = 0 nscol = icols(7) nhcol = icols(8) npcol = icols(9) C C GET THE ANGLES FOR THE LEGO PLOT C IF(COMND2.EQ.'LEGO' .OR. COMND2.EQ.'SURFACE' .OR. + COMND2.EQ.'2DIM' .AND. + (TIGOPTS(1:1).EQ.'L' .OR. TIGOPTS(1:1).EQ.'S')) THEN NNUM = 0 4000 CONTINUE TEXT = 'Give viewing angle theta,phi (= , ): ' if(comnd2.eq.'2DIM') then NTHETA = NINT(AIGPARS(1)) else NTHETA = NINT(ALEGS(1)) endif WRITE(TEXT(36:38),'(I3)',IOSTAT=IOERR) NTHETA if(comnd2.eq.'2DIM') then NPHI = NINT(AIGPARS(2)) else NPHI = NINT(ALEGS(2)) endif WRITE(TEXT(40:42),'(I3)',IOSTAT=IOERR) NPHI CALL WAITYQ(TEXT(1:LNBLNK(TEXT)+1)) C RVAL = VALTYQ(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 4100 IF(IERR.NE.0) THEN IF(IERR.NE.2) CALL RESTYQ GOTO 4100 ENDIF NNUM = NNUM + 1 if(comnd2.eq.'2DIM') then AIGPARS(NNUM) = RVAL NIGPARS = NNUM IF(IDELIM.EQ.0 .AND. NNUM.LT.MIGPAR) GOTO 4000 else if(rval.lt.0.0 .or. rval.ge.90.0) then txterr = 'Angles must be between 0 and 90 degrees' call mn_err('MN_HIS',txterr) goto 9000 endif ALEGS(NNUM) = RVAL IF(IDELIM.EQ.0 .AND. NNUM.LT.2) GOTO 4000 endif 4100 CONTINUE C C Get any parameters for 2DIM command C ELSEIF(COMND2.EQ.'2DIM') THEN call m_sigpar(tigopt(1),aigpars,nigpars,idelim,ierr) if(ierr.ne.0) goto 9000 ENDIF C C L3 DETECTOR DISPLAY C ELSEIF(COMND2.EQ.'DISPLAY') THEN QLEGO = .TRUE. NLEG = 11 IF(.NOT.QCLEAR) MODECL = 0 NSYM = NSYMS NHAT = NHATS NPAT = NPATS nscol = icols(7) nhcol = icols(8) npcol = icols(9) CALL MN_DSX(IDELIM,IERR,NSYM,NHAT,NPAT) IF(IERR.NE.0) GOTO 9000 ENDIF C IF(COMND2.EQ.'PLOT' .OR. COMND2.EQ.'OVERLAY') THEN IF(.NOT.QRNGE .OR. (QRNGE.AND.NNHP.EQ.1)) THEN IF(IDELIM.GE.0 .OR. + (COMND2.EQ.'OVERLAY' .AND. .NOT.QRFILE)) THEN if(comnd2.eq.'OVERLAY' .and. idelim.lt.0) then write(text,'( + '' Default symbol, hatch and pattern are:'' + ,I3,''/'',A + ,'','',I4,''/'',A,'','',I4,''/'',A)',iostat=ioerr) + NSYM,colnam(nscol) + ,NHAT,colnam(nhcol) + ,NPAT,colnam(npcol) LENT = LNBLNK(text) call csqmbl(text,1,lent) LENT = LNBLNK(text) call mn_mes(luntto,'ME',text(:lent)) endif call waityq( + 'Give symbol, hatch and pattern for plot' // + ' ( = default):') NNUM = 0 4500 CONTINUE NVAL = IVLTYQ(.TRUE.,IDELIM) * * See if the colour is specified * call m_qual(idelim,colnam(1),mcol,iqual,nqual) if(nqual.lt.0) goto 9000 CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 4600 IF(IERR.GT.0) THEN GOTO 9000 ELSE NNUM = NNUM + 1 IF(NNUM.EQ.1) THEN NSYM = NVAL if(nqual.gt.0) nscol = iqual(1) ELSE IF(NNUM.EQ.2) THEN NHAT = NVAL if(nqual.gt.0) nhcol = iqual(1) ELSE IF(NNUM.EQ.3) THEN NPAT = NVAL if(nqual.gt.0) npcol = iqual(1) ENDIF ENDIF IF(NNUM.LT.3 .AND. IDELIM.EQ.0) GOTO 4500 4600 CONTINUE IF(NSYM.EQ.0) NSYM = NSYMS ENDIF ELSE NSYM = NSYML NHAT = NHATL NPAT = NPATL ENDIF ENDIF C IF(QPNTPL) NLEG = NLEG + 100 C QDFUN = .FALSE. IPLTIA(NHPLT) = IDA IPLTIB(NHPLT) = IDB IPLTSY(NHPLT) = NSYM IPLTHA(NHPLT) = NHAT IPLTPA(NHPLT) = NPAT IPLTCO(1,NHPLT) = nscol IPLTCO(2,NHPLT) = nhcol IPLTCO(3,NHPLT) = npcol IPLTFL(NHPLT) = MODEH IPLTCL(NHPLT) = MODECL IPLTLG(NHPLT) = NLEG C NFLAG = 0 CALL MN_DRW(NFLAG,NDERR) C IF(QRNGE .AND. NDERR.GE.0) THEN NSYML = NSYM NHATL = NHAT NPATL = NPAT GOTO 3000 ENDIF C C DUMP THE HISTOGRAM CONTENTS C ELSEIF(COMND2.EQ.'DUMP') THEN CALL WAITYQ('Give histogram number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(IDA.LE.0) GOTO 9000 CALL MN_DMP(IDA,IDB,LUNDMP) C C CHANGE THE ERRORS ON A HISTOGRAM C ELSEIF(COMND2.EQ.'ERRORS') THEN CALL WAITYQ('Give histogram number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA.LE.0) GOTO 9000 C IF(.NOT.QRFILE .AND. IDELIM.LT.0) WRITE(LUNTTO + ,'('' Mode =-1 means errors deleted'' + ,/,'' Mode = 0 means errors are set to 0'' 1 ,/,'' Mode = 1 means errors are square root'' 2 ,'' of the number of entries'' 3 ,/,'' Mode = 2 is the same as 1, except the'' 4 ,'' error on zero is set to one'' + ,/,'' Mode = 3 means the error you give'' + ,'' will be put on all points'')') CALL WAITYQ('Give mode: ') NVAL = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 9000 IF(IERR.NE.0) GOTO 9000 NMODE = NVAL err = 0.0 IF(NMODE.LT.-1 .OR. NMODE.GT.3) THEN WRITE(LUNTTO,'('' *** MN_HIS: Illegal mode'',I4)') NMODE GOTO 9000 elseif(nmode.eq.3) then call waityq('Give the error: ') err = valtyq(.true.,idelim) call mn_rck(err,idelim,ierr) if(ierr.eq.2) goto 9000 if(ierr.ne.0) goto 9000 ENDIF C CALL MN_ERC(IDA,IDB,NMODE,err) C C EXTRACT PART OF AN HBOOK HISTOGRAM C ELSEIF(COMND2.EQ.'EXTRACT') THEN 7000 CONTINUE QHBPRT = .TRUE. CALL WAITYQ('Give HBOOK histogram number and part: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) QHBPRT = .FALSE. IF(NNID.LE.0) GOTO 9000 IF(IDA.LE.0) THEN IF(QRFILE) THEN GOTO 9000 ELSE GOTO 7000 ENDIF ENDIF C IF(IDB.GE.0 .OR. NNID.EQ.1) THEN 7100 CONTINUE CALL WAITYQ('Give histogram part: ') KCMD = ICMTYQ(.TRUE.,IDELIM,HBPNAM) IF(KCMD.LT.0) GOTO 9000 CALL MN_DCK(IDELIM,KCMD,MHBP,HBPNAM,IERR) IF(IERR.EQ.2) CALL MN_UNK('MN_HIS') IF(IDELIM.GT.0 .OR. KCMD.LE.0) THEN IF(QRFILE) THEN GOTO 9000 ELSE GOTO 7100 ENDIF ENDIF ELSE KCMD = -IDB ENDIF C IDB = NDIDB CALL MN_HBP(IDA,IDB,HBPNAM(KCMD),IDELIM,IERR) C C BOOK A NEW PLOT C ELSE IF(COMND2.EQ.'BOOK') THEN IDB = NDIDB CALL WAITYQ('Give plot number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) C C CHECK FOR QUALIFIER C QQUAL = NNID.EQ.0 .AND. IDELIM.EQ.ICHAR('/') IF(QQUAL) GOTO 2100 IF(IDA.LE.0 .OR. NNID.LE.0) GOTO 9000 C TBIN = 'binned' IF(.NOT.QBIN) TBIN = 'unbinned' LENB = LNBLNK(TBIN) TERR = 'with errors' IF(.NOT.QERRS) TERR = 'without errors' IF(QERRA) TERR = 'with asymmetric errors' LENE = LNBLNK(TERR) WRITE(LUNTTO,'('' I will book a new '',A,'' plot'',I7,I4 1 ,1X,A)') TBIN(1:LENB),IDA,IDB,TERR(1:LENE) C TITLE = ' ' CALL WAITYQ('Give plot title: ') NCHTIT = IQSTYQ(.TRUE.,IDELIM,TITLE) C CALL WAITYQ('Give number of dimensions: ') NDIM = IVLTYQ(.TRUE.,IDELIM) CALL MN_NCK(NDIM,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 * NTMODE = 0 nsdate = 0 nstime = 0 * * See if the x-axis mode is date or time * if(ismods(1).eq.3 .or. ismods(1).eq.4) then ntmode = nmtime nsdate = ndtref nstime = ntmref endif C IF(QBIN) THEN NPNT = 1 NWPPT = 1 IF(QERRS .AND. .NOT.QERRA) NWPPT = 2*NWPPT IF(QERRA) NWPPT = 3*NWPPT NDIM = IABS(NDIM) DO 7300 ND=1,NDIM TEXT = CONCAT(TNDEF(ND),'axis:') LENT = LNBLNK(TEXT) IF(IDELIM.LT.0) WRITE(LUNTTO,'(1X,A)') TEXT(1:LENT) CALL MN_BLM(1,ntmode,IDELIM,COMND1 // ' ' // COMND2 + ,IDBIN(ND),ADLO(ND),ADHI(ND),NNUM,IERR) IDBIN(ND) = IABS(IDBIN(ND)) IF(IDBIN(ND).LE.0 .OR. IERR.NE.0) GOTO 9000 NPNT = NPNT * IDBIN(ND) 7300 CONTINUE NPMAX = NPNT C ELSE NDIM = -IABS(NDIM) NPNT = 0 NWPPT = IABS(NDIM) IF(NDIM.EQ.-1) NWPPT = NWPPT + 1 IF(QERRS .AND. .NOT.QERRA) NWPPT = 2*NWPPT IF(QERRA) NWPPT = 3*NWPPT CALL VZERO_i(IDBIN(1),IABS(NDIM)) CALL UFILL(ADLO,1,IABS(NDIM), 1.0E+30) CALL UFILL(ADHI,1,IABS(NDIM),-1.0E+30) C CALL WAITYQ('Give maximum number of points in plot: ') NPMAX = IVLTYQ(.TRUE.,IDELIM) CALL MN_NCK(NPMAX,IDELIM,IERR) IF(IERR.NE.0) NPMAX = 100 ENDIF C NBPPT = 0 NWRD = NPMAX * NWPPT EDENT = 0.0 IF(NDIM.EQ.-1) THEN EDLO = 1.0E+30 EDHI = -1.0E+30 ELSE EDLO = 0.0 EDHI = 1.0 ENDIF CALL VZERO_r(ACONT(1),3**MIN0(IABS(NDIM),3)) C NBPPT = 0 CALL MN_HNW(IDA,IDB,NDIM,NWRD,NH,NPTRH,NPTRD,NWH,NBPPT,NTMODE) IF(NH.LE.0) GOTO 9000 C C CLEAR THE DATA ARRAY C CALL VZERO_r(RDAT(NPTRD),NWRD) C NWTOT = NWH + NWRD CALL M_RTIM(NHDATE,NHTIME) CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWRD,IDA,IDB,NDIM,NWPPT,NPNT 1 ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) if(ndim.ge.-1) then CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE(1:NCHTIT) 1 ,'Generated internally',' ',TNDEF) else CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE(1:NCHTIT) 1 ,'Generated internally',' ',TNNTP) endif CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C C FILL A NEW PLOT C ELSE IF(COMND2.EQ.'FILL') THEN CALL WAITYQ('Give plot number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(IDA.LE.0) GOTO 9000 C CALL MN_HGT(IDA,IDB,NH) C + ,NPTRH,NPTRD,NDIM,NWPPT,NPNT C 1 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_HIS',TXTERR) GOTO 9000 ENDIF C CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) NLOOP = 1 IF(NDIM.LT.0 .AND. QERRL) NLOOP = NLOOP + 1 IF(NDIM.LT.0 .AND. QERRH) NLOOP = NLOOP + 1 IF(NDIM.GT.0) THEN NWW = IABS(NDIM) + 1 ELSE NWW = NWPPT / NLOOP ENDIF C CALL VZERO_r(ADAT(1),MDIMMX) CALL VZERO_r(AERN(1),MDIMMX) CALL VZERO_r(AERP(1),MDIMMX) NDIMO = NDIM C DO 7600 NL=1,NLOOP NNUM = 0 7500 CONTINUE IF(NL.EQ.1) THEN CALL WAITYQ('Give data: ') ELSE IF(NL.EQ.2 .AND. .NOT.QERRH) THEN CALL WAITYQ('Give errors: ') ELSE IF(NL.EQ.2 .AND. QERRH) THEN CALL WAITYQ('Give negative errors: ') ELSE IF(NL.EQ.3) THEN CALL WAITYQ('Give positive errors: ') ENDIF RVAL = VALTYQ(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 7550 IF(IERR.NE.0) THEN CALL MN_ERR('MN_HIS','Error in data') GOTO 9000 ENDIF NNUM = NNUM + 1 IF(NL.EQ.1) THEN RNUM(NNUM) = RVAL ELSE RNUM(NNUM) = ABS(RVAL) ENDIF IF(NNUM.LT.NWW .AND. IDELIM.EQ.0) GOTO 7500 C 7550 CONTINUE IF(NL.EQ.1 .AND. NNUM.LT.IABS(NDIMO)) THEN WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' has'',I4,'' dimensions,'')') IDA,IDB,IABS(NDIMO) CALL M_EMSG('MN_HIS',TXTERR) WRITE(TXTERR,'(''but you only gave me'',I4 2 ,'' co-ordinates'')') NNUM CALL MN_ERR('MN_HIS',TXTERR) GOTO 9000 ENDIF C IF(NL.EQ.1) THEN CALL UCOPY_r(RNUM,ADAT,NNUM) C C IF WEIGHT IS GIVEN THEN INTERPRET IT OTHERWISE SET IT C TO 1 C IF(NDIMO.GT.0) THEN IF(NNUM.LT.NWW) THEN WEIGHT = 1.0 ELSE WEIGHT = RNUM(NWW) ENDIF ELSE WEIGHT = 1.0 ENDIF ELSE IF(NL.EQ.2) THEN CALL UCOPY_r(RNUM,AERN,NNUM) ELSE IF(NL.EQ.3) THEN CALL UCOPY_r(RNUM,AERP,NNUM) ENDIF 7600 CONTINUE C IF(NDIMO.LT.0 .AND. QERRL) THEN CALL M_FILF(IDA,IDB,ADAT,AERN,AERP) ELSE CALL M_FILB(IDA,IDB,ADAT,WEIGHT) ENDIF ENDIF C 9000 CONTINUE END +DECK,mn_hng. SUBROUTINE MN_HNG(TNAME,NNID,NDHIS0,NIDL,IDLSA1,IDLSA2 1 ,IDLSB1,IDLSB2) C C SUBROUTINE TO CHECK HOW MANY PLOTS WERE FETCHED AND IF I GOT WHAT C I ASKED FOR C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNLUN. C CHARACTER*(*) TNAME INTEGER IDLSA1(*),IDLSA2(*),IDLSB1(*),IDLSB2(*) CHARACTER*80 TEXT C IF(NDHIS.EQ.NDHIS0) THEN TEXT = ' ' // TNAME // ': No plots fetched' CALL MN_MES(LUNTTO,'ME',TEXT) ELSE NHF = 0 DO 9050 IL=1,NIDL NHFI = 0 DO 9040 NH=NDHIS0+1,NDHIS IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) GOTO 9040 IF((NNID.EQ.1 .AND. 1 (IDLSA1(IL).EQ.0 .OR. 1 (IDIDA(NH).GE.IDLSA1(IL) .AND. 1 IDIDA(NH).LE.IDLSA2(IL)))) .OR. 2 (NNID.EQ.2 .AND. 2 (IDLSA1(IL).EQ.0 .AND. 2 IDIDB(NH).GE.IDLSB1(IL) .AND. 2 IDIDB(NH).LE.IDLSB2(IL)) .OR. 2 (IDIDA(NH).GE.IDLSA1(IL) .AND. 2 IDIDA(NH).LE.IDLSA2(IL) .AND. 2 IDIDB(NH).GE.IDLSB2(IL) .AND. 2 IDIDB(NH).LE.IDLSB2(IL)))) THEN NHF = NHF + 1 NHFI = NHFI + 1 ENDIF 9040 CONTINUE IF(NHFI.EQ.0) THEN IF(IDLSA1(IL).EQ.IDLSA2(IL)) THEN IF(NNID.EQ.1) THEN WRITE(TEXT,'( 1 '' Plot'',I7,'' not found'')') 1 IDLSA1(IL) ELSE WRITE(TEXT,'( 1 '' Plot'',I7,I4,'' not found'')') 1 IDLSA1(IL),IDLSB1(IL) ENDIF CALL M_EMSG(TNAME,TEXT) ELSE IF(NNID.EQ.1) THEN WRITE(TEXT,'( 1 '' No plot found in the range'' 1 ,I7,'' :'',I7)') IDLSA1(IL),IDLSA2(IL) CALL M_EMSG(TNAME,TEXT) ELSE WRITE(TEXT,'( 1 '' No plot found in the range'' 1 ,I7,'' :'',I7,'' &'',I4,'' &'',I4)') 1 IDLSA1(IL),IDLSA2(IL),IDLSB1(IL),IDLSB2(IL) CALL M_EMSG(TNAME,TEXT) ENDIF ENDIF 9050 CONTINUE C WRITE(TEXT,'(1X,A,'': A total of'',I6 1 ,'' plots have been read in'')') TNAME,NHF CALL MN_MES(LUNTTO,'ME',TEXT) ENDIF C RETURN END +DECK,mn_hnw. SUBROUTINE MN_HNW(IDA,IDB,NDIM,NWRD,NHD,NPTRH,NPTRD,NWHEAD 1 ,NBPPT,NTMODE) C C IDA,IDB IS THE HISTOGRAM ID WHICH I WANT TO STORE C NDIM IS THE NUMBER OF DIMENSIONS C NHD IS THE STORAGE POSITION C NPTRH IS THE POINTER TO THE HEADER C NPTRD IS THE POINTER TO THE DATA C NWHEAD IS THE NUMBER OF HEADER WORDS C NBPPT IS THE NUMBER OF BITS PER WORD C THE DEFAULT IS 32 FOR ALL PLOTS EXCEPT IF C NDIM > 2 WHEN IT IS 16 C TRUE SCATTER PLOTS ARE ALWAYS 32 WHATEVER YOU TRY TO SET C NTMODE is the time mode (0 means not time) C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNLUN. C IF(NBPPT.LE.0) THEN IF(NDIM.GT.2) THEN NBPPT = 16 ELSE NBPPT = 32 ENDIF ENDIF IF(NDIM.LT.0) NBPPT = 32 C C HEADER SPACE IS 11 WORDS + BINS AND LIMITS + BITS PER POINT C + UNDERFLOW AND OVERFLOWS IF IT IS A BINNED HISTOGRAM C + MEAN AND SIGMA IF IT IS A BINNED HISTOGRAM, A SERIES OF C POINTS OR A SCATTER PLOT C + DATE AND TIME C + DATE,TIME and TIME MODE if requested C NHD = 0 C IF(IABS(NDIM).EQ.0 .OR. IABS(NDIM).GT.MDIMMX) THEN WRITE(TXTERR,11000) IDA,IDB,NDIM 11000 FORMAT(' Histogram',I7,I4,' has wrong dimension',I6) CALL MN_ERR('MN_HNW',TXTERR) GOTO 9000 ENDIF C NWHEAD = 11 + IABS(NDIM)*3 + 1 C C ONLY KEEP TRACK OF UNDERFLOWS AND OVERFLOWS FOR UP TO C 3-DIMENSIONAL PLOTS C IF(ndim.gt.-3 .and. ndim.le.3) + NWHEAD = NWHEAD + 3**IABS(NDIM) C C Leave space for the mean and sigma for binned histograms C series of points and scatter plots C IF(NDIM.GT.-3) NWHEAD = NWHEAD + 2*IABS(NDIM) C C Add date and time to the header C NWHEAD = NWHEAD + 2 C C Add the starting date and time for the plot and the time mode C IF(NTMODE.NE.0) NWHEAD = NWHEAD + 3 C C SEE IF I HAVE ENOUGH SPACE LEFT C NW = NDPTE IF(NWRD.GT.0) THEN NWNEED = (NWRD*NBPPT-1)/32 + 1 IF(NW+NWNEED+NWHEAD.GT.NHSTWD .OR. NDHIS.GE.MHSTMX) THEN CALL M_EMSG('MN_HNW' + ,'I have run out of space for creating new histograms') CALL MN_ERR('MN_HNW' + ,'Issue the command SQUEEZE to get unused space back') GOTO 9000 ENDIF ENDIF C NHD = NDHIS + 1 C NPTRH = NW + 1 NPTRD = NPTRH + NWHEAD C C Initialize all the header info for the new plot C IDIDA(NHD) = 0 IDIDB(NHD) = 0 IDPTRH(NHD) = 0 IDPTRD(NHD) = 0 TDTIT(NHD) = ' ' TDFIL(NHD) = ' ' TDDIR(NHD) = ' ' TDNAM(1,NHD) = ' ' C 9000 CONTINUE RETURN END +DECK,mn_hyf. C SUBROUTINE MN_HYF(IDELIM) C C ROUTINE TO FETCH HYBRID HISTOGRAMS C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNCMD. +CDE,MNFLG. +CDE,MNLUN. C INTEGER IDBIN(2) REAL ADLO(2),ADHI(2) REAL ACONT(3**2) CHARACTER*32 TNDEF(2) C CHARACTER*80 TITLE LOGICAL QZERO INTEGER IDLST1(100),IDLST2(100) LOGICAL Q1DF,Q2DF C DATA TNDEF/'X', 'Y'/ C IF(IDELIM.EQ.0) THEN NJUNK = INTTYQ(.TRUE.,IDELIM) CALL RESTYQ ENDIF C IF(FIL_HY.EQ.' ' .OR. 1 (IDELIM.GT.0 .AND. IDELIM.NE.ICHAR(':'))) THEN CALL MN_FIL(1,LUNYIN,FIL_HY,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 ELSE REWIND(LUNYIN) ENDIF C NIDL = 0 QZERO = .FALSE. Q1DF = .FALSE. Q2DF = .FALSE. NDHIS0 = NDHIS 2000 CONTINUE CALL WAITYQ('Give histogram number(s): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 8000 C C DECIDE WHETHER TO FETCH 1-D OR 2-D PLOTS C BY DEFAULT FETCH THE 1-D PLOTS C Q1DF = Q1DF .OR. IDB1.EQ.1 .OR. IDB2.EQ.1 Q2DF = Q2DF .OR. IDB1.EQ.2 .OR. IDB2.EQ.2 C IF(NIDL.GE.100) THEN WRITE(LUNTTO,'('' *** MN_HYF: Ran out of space to store'' 1 ,'' plot numbers to get'' 2 ,/,13X,''Issue HY_FETCH command again'' 3 ,'' to get more plots.'')') GOTO 2200 ENDIF C IF(IDA1.EQ.0) QZERO = .TRUE. NIDL = NIDL + 1 IDLST1(NIDL) = IDA1 IDLST2(NIDL) = IDA2 IF(IDELIM.GE.0) GOTO 2000 2200 CONTINUE IF(NIDL.LE.0) GOTO 8000 IF(.NOT.Q2DF) Q1DF = .TRUE. IF(QZERO) THEN NIDL = 1 IDLST1(1) = 0 IDLST2(1) = 0 ENDIF C C NOW FETCH THE HISTOGRAMS C IF(Q1DF .AND. Q2DF) THEN NT1 = 1 NT2 = 2 ELSE IF(Q1DF .AND. .NOT.Q2DF) THEN NT1 = 1 NT2 = 1 ELSE IF(.NOT.Q1DF .AND. Q2DF) THEN NT1 = 2 NT2 = 2 ENDIF CALL HYREAD(LUNYIN,IERR) IF(IERR.NE.0) THEN WRITE(LUNTTO,'('' *** Error reading in HYBRID plots ***'')') GOTO 9000 ENDIF C DO 6000 NT=NT1,NT2 IDB = NDIDB + NT - 1 DO 5000 NL=1,NIDL ID0 = 0 IDA1 = IDLST1(NL) IDA2 = IDLST2(NL) DO 4500 ID=IDA1,IDA2 4100 CONTINUE IF(QZERO) THEN CALL HYFNXT(ID0,NT) IF(ID0.LE.0) GOTO 5000 IDA = ID0 ELSE IDA = ID ENDIF C CALL HYFET(IDA,NT,NCALL 1 ,IDBIN,ADLO,ADHI,AUND,AINS,AOVE,TITLE,IERR) IF(IERR.NE.0) THEN IF(IDA1.EQ.IDA2) THEN WRITE(LUNTTO,'('' *** MN_HYF: Plot'',I7 1 ,'' not found'')') IDA ENDIF GOTO 4500 ENDIF EDENT = FLOAT(NCALL) IF(NT.EQ.1) THEN NDIM = 1 NWPPT = 1 NPNT = IDBIN(1) ACONT(1) = AUND ACONT(2) = AINS ACONT(3) = AOVE ELSE NDIM = 2 NWPPT = 1 NPNT = IDBIN(1)*IDBIN(2) ACONT(5) = AINS ENDIF NWRD = NPNT*NWPPT NBPPT = 0 NTMODE = 0 C C GET THE HISTOGRAM NUMBER AND THE POINTER C RESERVE SPACE FOR THE HISTOGRAM C CALL MN_HNW(IDA,IDB,NDIM,NWRD 1 ,NH,NPTRH,NPTRD,NWH,NBPPT,NTMODE) IF(NH.LE.0) GOTO 8000 C C GET THE HISTOGRAM CONTENTS C CALL HYUPAK(RDAT(NPTRD),EDLO,EDHI) C C FILL IN THE HEADER INFORMATION AND THE POINTERS C NWDAT = NWPPT * NPNT NWTOT = NWH + NWDAT NHDATE = 0 NHTIME = 0 NSDATE = 0 NSTIME = 0 CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB + ,NDIM,NWPPT,NPNT,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE 1 ,FIL_HY,' ',TNDEF) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C IF(QZERO) GOTO 4100 4500 CONTINUE 5000 CONTINUE 6000 CONTINUE C 8000 CONTINUE C C CHECK THAT I GOT THE HISTOGRAMS I WANTED C NNID = 1 IDB1 = NDIDB IF(.NOT.Q1DF .AND. Q2DF) IDB1 = NDIDB + 1 IDB2 = IDB1 IF(Q1DF .AND. Q2DF) THEN NNID = 2 IDB2 = NDIDB + 1 ENDIF CALL MN_HNG('MN_HYF',NNID,NDHIS0,NIDL,IDLST1,IDLST2,IDB1,IDB2) C 9000 CONTINUE C RETURN END +DECK,mn_idx. SUBROUTINE MN_IDX(IDA1,IDA2,IDB1,IDB2,NNID,NMODE) C C PRINTS AND INDEX OF ALL BOOKED MNBOOK HISTOGRAMS C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCMD. +CDE,MNLUN. C CHARACTER*80 FILNAM CHARACTER*80 TEXT C FILNAM = ' ' IF(LUNDMP.NE.LUNTTO) CALL MN_MES(LUNDMP,'I','1') CALL MN_MES(LUNDMP,'I',' ') CALL MN_MES(LUNDMP,'I',' The following MNBOOK histograms exist:') IF(NMODE.EQ.0) THEN WRITE(TEXT,'(6X,''ID'',2X,''IDB'',1X,''Points'' 1 ,4X,''Area'',4X,''Dim'')') ELSE WRITE(TEXT,'(6X,''ID'',2X,''IDB'',1X,''Points'' 1 ,4X,''Area'',4X,''Dim'',2X,''Start'',2X,''Length'')') ENDIF CALL MN_MES(LUNDMP,'I',TEXT) DO 2400 NH=1,NDHIS IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) GOTO 2400 IDA = IDIDA(NH) IDB = IDIDB(NH) CALL MN_HGT(IDA,IDB,NHD) IF(NHD.LE.0) GOTO 2400 IF((IDA1.NE.0 .AND. 1 (IDA.LT.IDA1 .OR. IDA.GT.IDA2)) .OR. 2 (NNID.GT.1 .AND. 2 (IDB.LT.IDB1 .OR. IDB.GT.IDB2))) GOTO 2400 NWTOT = NINT(RDAT(NPTRH)) LENPR = max0(1,MNLLEN(TDFIL(NH))) IF(FILNAM.NE.TDFIL(NH)) THEN TEXT = ' Histograms from file: ' LENT = MNLLEN(TEXT) TXTMES = TEXT(1:LENT) // ' ' // TDFIL(NH)(1:LENPR) CALL MN_MES(LUNDMP,'I',TXTMES) FILNAM = TDFIL(NH) ENDIF C LENPR = MNLLEN(TDTIT(NH)) IF(LENPR.EQ.0) THEN LENPR = 1 TDTIT(NH) = ' ' ENDIF IF(NMODE.EQ.0) THEN WRITE(TEXT,'(1X,I7,1X,I4,1X,I6,1X,F9.1,1X,I4)' 1 ,IOSTAT=IOERR) IDA,IDB,NPNT,EDENT,NDIM ELSE WRITE(TEXT,'(1X,I7,1X,I4,1X,I6,1X,F9.1,1X,I4,2I7)' 1 ,IOSTAT=IOERR) IDA,IDB,NPNT,EDENT,NDIM,NPTRH,NWTOT ENDIF LENT = MNLLEN(TEXT) LEN2 = MIN0(80-LENT-2,LENPR) TXTMES = TEXT(1:LENT) // ' ' // TDTIT(NH)(1:LEN2) CALL MN_MES(LUNDMP,'I',TXTMES) 2400 CONTINUE CALL MN_MES(LUNDMP,'E',' ') C RETURN END +DECK,mn_inc. SUBROUTINE MN_INC C C Initialize all the command names needed in more than one routine C implicit none * +CDE,MNCMD. +CDE,MNCMT. +CDE,MNTIM. +CDE,MNPRS. C DRWNAM( 1) = 'LINE' DRWNAM( 2) = 'ARROW' DRWNAM( 3) = 'BOX' DRWNAM( 4) = 'TRIANGLE' DRWNAM( 5) = 'POLYGON' DRWNAM( 6) = 'POLYLINE' DRWNAM( 7) = 'CIRCLE' DRWNAM( 8) = 'ARC' DRWNAM( 9) = 'SINE' DRWNAM(10) = 'GLUON' DRWNAM(11) = 'SYMBOL' DRWNAM(12) = 'ELLIPSE' DRWNAM(13) = 'SEGMENT' DRWNAM(14) = 'END' DRWNAM(15) = 'CHANGE' DRWNAM(16) = 'DELETE' DRWNAM(17) = 'LIST' DRWNAM(18) = 'STORE' DRWNAM(19) = 'FETCH' DRWNAM(20) = ' ' C C IPNTD(1) = 2 C IPNTD(2) = 2 C IPNTD(3) = 4 C IPNTD(4) = 3 C IPNTD(5) = 0 C LOGNAM( 1) = 'YES' LOGNAM( 2) = 'NO' LOGNAM( 3) = '.TRUE.' LOGNAM( 4) = '.FALSE.' LOGNAM( 5) = 'TRUE' LOGNAM( 6) = 'FALSE' LOGNAM( 7) = 'ON' LOGNAM( 8) = 'OFF' LOGNAM( 9) = ' ' C SCLMOD( 1) = 'REAL' SCLMOD( 2) = 'INTEGER' SCLMOD( 3) = 'LOG' SCLMOD( 4) = 'DATE' SCLMOD( 5) = 'TIME' SCLMOD( 6) = ' ' C OPTNAM( 1) = 'LEFT' OPTNAM( 2) = 'CENTRE' OPTNAM( 3) = 'RIGHT' OPTNAM( 4) = 'CENTER' OPTNAM( 5) = ' ' UNTNAM( 1) = 'CM' UNTNAM( 2) = 'PLOT' UNTNAM( 3) = ' ' C HBPNAM( 1) = 'HIST' HBPNAM( 2) = 'FUN' HBPNAM( 3) = 'PROX' HBPNAM( 4) = 'PROY' HBPNAM( 5) = 'SLIX' HBPNAM( 6) = 'SLIY' HBPNAM( 7) = 'BANX' HBPNAM( 8) = 'BANY' HBPNAM( 9) = ' ' C CUTNAM( 1) = '.EQ.' CUTNAM( 2) = '.NE.' CUTNAM( 3) = '.LT.' CUTNAM( 4) = '.LE.' CUTNAM( 5) = '.GT.' CUTNAM( 6) = '.GE.' CUTNAM( 7) = ' ' CUTNM2( 1) = '=' CUTNM2( 2) = '<>' CUTNM2( 3) = '<' CUTNM2( 4) = '<=' CUTNM2( 5) = '>' CUTNM2( 6) = '>=' CUTNM2( 7) = ' ' ANDNAM( 1) = 'AND' ANDNAM( 2) = 'OR' ANDNAM( 3) = ' ' C ORDNAM( 1) = 'X' ORDNAM( 2) = 'Y' ORDNAM( 3) = 'DX' ORDNAM( 4) = 'DY' ORDNAM( 5) = 'DNX' ORDNAM( 6) = 'DNY' ORDNAM( 7) = 'DPX' ORDNAM( 8) = 'DPY' ORDNAM( 9) = 'DXN' ORDNAM(10) = 'DYN' ORDNAM(11) = 'DXP' ORDNAM(12) = 'DYP' ORDNAM(13) = 'DUMMY' ORDNAM(14) = 'DATE_TIM' ORDNAM(15) = 'DATE' ORDNAM(16) = 'TIME' ORDNAM(17) = 'DATE_MIN' ORDNAM(18) = 'TIME_MIN' ORDNAM(19) = 'VAXTIME' ORDNAM(20) = ' ' MDUMMY = 13 C TIMNAM(1) = 'DAY' TIMNAM(2) = 'HOUR' TIMNAM(3) = 'MINUTE' TIMNAM(4) = 'SECOND' TIMNAM(5) = ' ' C NTONAM( 1) = 'X' NTONAM( 2) = 'Y' NTONAM( 3) = 'Z' NTONAM( 4) = 'DX' NTONAM( 5) = 'DY' NTONAM( 6) = 'DZ' NTONAM( 7) = 'DNX' NTONAM( 8) = 'DNY' NTONAM( 9) = 'DNZ' NTONAM(10) = 'DPX' NTONAM(11) = 'DPY' NTONAM(12) = 'DPZ' NTONAM(13) = ' ' C C Colours C call m_scnam C C IGTABL/HPLTAB possibilities C MTBL2D = 7 MTBL3D = 16 MTBLEGO = 8 MTBSURF = 12 TBLNAM( 1,1) = 'SCATTER' TBLNAM( 1,2) = 'P' TBLNAM( 2,1) = 'BOX' TBLNAM( 2,2) = 'B' TBLNAM( 3,1) = 'ARROW' TBLNAM( 3,2) = 'R' TBLNAM( 4,1) = 'CONTOUR' TBLNAM( 4,2) = 'C' TBLNAM( 5,1) = 'COLOUR' TBLNAM( 5,2) = 'COL' TBLNAM( 6,1) = 'TEXT' TBLNAM( 6,2) = 'T' TBLNAM( 7,1) = 'CHAR' TBLNAM( 7,2) = 'K' TBLNAM( 8,1) = 'LEGO' TBLNAM( 8,2) = 'L' TBLNAM( 9,1) = 'LEGOBAR' TBLNAM( 9,2) = 'LB' TBLNAM(10,1) = 'LEGOC1' TBLNAM(10,2) = 'L1' TBLNAM(11,1) = 'LEGOC2' TBLNAM(11,2) = 'L2' TBLNAM(12,1) = 'SURF' TBLNAM(12,2) = 'S' TBLNAM(13,1) = 'SURFC1' TBLNAM(13,2) = 'S1' TBLNAM(14,1) = 'SURFC2' TBLNAM(14,2) = 'S2' TBLNAM(15,1) = 'SURFCONT' TBLNAM(15,2) = 'S3' TBLNAM(16,1) = 'SURFSHADE' TBLNAM(16,2) = 'S4' TBLNAM(17,1) = ' ' TBLNAM(17,2) = ' ' C TSPSYM = '_$' TCMSYM = '_$/-*' TCTSYM = '_-*$()[]{}&' THPSYM = '_$/' TSCOMM = '!' TSCONT = '-' C C Parameter names you can access in DEPOSIT or expressions C MP_REG = 1 MP_NTP = 9 DPINAM( 1) = 'R' DPINAM( 2) = 'IR' DPINAM( 3) = 'P' DPINAM( 4) = 'ERR' DPINAM( 5) = 'ERN' DPINAM( 6) = 'ERP' DPINAM( 7) = 'LOLIM' DPINAM( 8) = 'HILIM' DPINAM( 9) = 'X' DPINAM(10) = 'DX' DPINAM(11) = 'DNX' DPINAM(12) = 'DPX' DPINAM(13) = 'Y' DPINAM(14) = 'DY' DPINAM(15) = 'DNY' DPINAM(16) = 'DPY' C C FORTRAN functions which are available in expressions C PRSNAM( 1) = 'SQRT' PRSNAM( 2) = 'SIN' PRSNAM( 3) = 'COS' PRSNAM( 4) = 'TAN' PRSNAM( 5) = 'ALOG' PRSNAM( 6) = 'ALOG10' PRSNAM( 7) = 'EXP' PRSNAM( 8) = 'ASIN' PRSNAM( 9) = 'ACOS' PRSNAM(10) = 'ATAN' PRSNAM(11) = 'ABS' PRSNAM(12) = 'INT' PRSNAM(13) = 'NINT' PRSNAM(14) = 'MIN' PRSNAM(15) = 'MAX' PRSNAM(16) = 'MOD' PRSNAM(17) = 'SIGN' PRSNAM(18) = 'DATE' PRSNAM(19) = 'TIME' PRSNAM(20) = 'TIME_MIN' PRSNAM(21) = 'DATE_TIM' PRSNAM(22) = 'DATE_MIN' PRSNAM(23) = 'FPOS' PRSNAM(24) = 'FNEG' PRSNAM(25) = 'DFPOS' PRSNAM(26) = 'DDFPOS' PRSNAM(27) = 'DFNEG' PRSNAM(28) = 'DDFNEG' PRSNAM(29) = 'FINT' C CALL TZERO(VARNAM,MVARBL) TDUMMY = ' ' NVARBL = 0 C END +DECK,mn_ind. SUBROUTINE MN_IND C C------------------------------------------------------------------------------- C AUTHOR IAN C. BROCK 25TH FEB. 1986 C LAST CHANGED 25TH FEB. 1986 C SUBROUTINE TO PRINT OUT A COMPACT FORMAT OF THE HBOOK INDEX C------------------------------------------------------------------------------- C +CDE,MNLUN. C PARAMETER (MXHIST=500) INTEGER IDVECT(MXHIST) CHARACTER*80 TITLE C CALL HIDALL(IDVECT,NHIST) IF(NHIST.GT.MXHIST) THEN WRITE(LUNTTO,11000) NHIST,MXHIST WRITE(LUNLPT,11000) NHIST,MXHIST 11000 FORMAT(/,' MN_IND: Too many histograms',I6 1 ,' Will only give index for',I6) NHIST = MXHIST ENDIF C WRITE(LUNTTO,11805) 11805 FORMAT(/,7X,'ID',3X,'Area',7X,'Mean' 1 ,7X,'Sigma',20X,'Title') C DO 1000 I=1,NHIST ID = IDVECT(I) TITLE = ' ' CALL HGIVE(ID,TITLE,NXBIN,XMIN,XMAX,NYBIN,YMIN,YMAX 1 ,NWT,IAD) CALL HNOENT(ID,NENTRY) IF(NENTRY.LE.0 .OR. 1 (XMIN.LT.-1.0E+10 .AND. XMAX.GT.1.0E+10)) THEN AVE = 0.0 SIG = 0.0 ELSE AVE = HSTATI(ID,1,'HIST',1) SIG = HSTATI(ID,2,'HIST',1) ENDIF C WRITE(LUNTTO,11820,IOSTAT=IOERR) ID,NENTRY,AVE,SIG,TITLE 11820 FORMAT(1X,I8,I9,G13.5,G12.5,1X,A) 1000 CONTINUE C RETURN END +DECK,mn_inl. SUBROUTINE MN_INL C C Subroutine to initialize the values of resonance masses C for LUND Monte Carlo for dipion decays of Upsilon resonances C and of Psi resonances C implicit none C +CDE,MNLUJ. C resnam(1) = 'U(1S)' RESMAS(1) = 9.46037 resnam(2) = 'U(2S)' RESMAS(2) = 10.02330 resnam(3) = 'U(3S)' RESMAS(3) = 10.3553 resnam(4) = 'U(4S)' RESMAS(4) = 10.580 resnam(5) = 'hb(1P1)' RESMAS(5) = 9.900 resnam(6) = 'Etac' RESMAS(6) = 2.9798 resnam(7) = 'J/Psi' RESMAS(7) = 3.09688 resnam(8) = 'Chic0' RESMAS(8) = 3.4151 resnam(9) = 'Chic1' RESMAS(9) = 3.51053 resnam(10)= 'Chic2' RESMAS(10)= 3.55617 resnam(11)= 'Psi(2S)' RESMAS(11)= 3.68600 resnam(12)= 'Psi(3770)' RESMAS(12)= 3.7699 resnam(13)= 'hc(1P1)' RESMAS(13)= 3.510 C END +DECK,mn_key. SUBROUTINE MN_KEY(NCSYMB,X,Y,CTEXT,CSIZE,ANGLE,IOPT + ,NFONT,NCOL,THICK,XUNIT,ncolt) C IMPLICIT NONE C +CDE,MNPIJ. C CHARACTER*(*) CTEXT INTEGER NCSYMB,IOPT,NFONT,NCOL,ncolt REAL X,Y,CSIZE,ANGLE,THICK,XUNIT C REAL SSIZE,SSYM,XX,YY,DX,DY C SSIZE = CSIZE SSYM = CSIZE C CALL MN_SYM(NCSYMB,X,Y,DX,DY,DX,DY,SSYM,SSYM + ,NCOL,ncolt,THICK,XUNIT,-1) C XX = X + 2.0*SSIZE*COS(ANGLE*DRAD) YY = Y - 0.5*CSIZE + 2.0*SSIZE*SIN(ANGLE*DRAD) C CALL MN_TXT(XX,YY,CTEXT,CSIZE,ANGLE,IOPT,NFONT,NCOLt,THICK) C RETURN END +DECK,mn_ldd. SUBROUTINE MN_LDD(NMODE) C C SUBROUTINE TO LIST THE SHAPES BEING DRAWN C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNLUN. C INTEGER NMODE C INTEGER NDRWTP,NDRWPT INTEGER NN,NT,II,JJ,J1,J2,NLINE,IOERR C CALL MN_MES(LUNTTO,'I',' The following items exist to be drawn:') DO 1100 NN=1,NDRWLN NDRWTP = IDRWTP(NN) NDRWPT = NINT(RDRWPM(20,NN)) IF(NDRWTP.EQ.MDRW_LINE) THEN NT = 1 ELSEIF(NDRWTP.EQ.MDRW_ARROW) THEN NT = 3 ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN NT = 4 ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN NT = 5 ELSE NT = 2 ENDIF C WRITE(TXTMES,'(1X,''Item'',I3,'':'',1X,A 1 ,(1X,A,1X,I4,'';''),(1X,A,1X,A,'';'') + ,(1X,A,1X,F6.3,'';''))',IOSTAT=IOERR) 2 NN,DRWNAM(NDRWTP)(1:9) 3 ,TDRWN(1,NT)(1:10),NINT(RDRWPM(1,NN)) 3 ,TDRWN(2,NT)(1: 6),COLNAM(NINT(RDRWPM(2,NN)))(1:10) 3 ,TDRWN(3,NT)(1:10),RDRWPM(3,NN) CALL MN_MES(LUNTTO,'I',TXTMES) C IF(NDRWTP.EQ.MDRW_LINE) THEN WRITE(TXTMES,'(2X,(1X,A,1X,A,'';'') + ,(T60,A,1X,I2))',IOSTAT=IOERR) + TDRWN(4,NT)(1:10),UNTNAM(NINT(RDRWPM(4,NN))+1)(1:4) + ,TDRWN(7,NT)(1:16),NINT(RDRWPM(7,NN)) CALL MN_MES(LUNTTO,'I',TXTMES) ELSEIF(NDRWTP.EQ.MDRW_ARROW) THEN WRITE(TXTMES,'(2X,(1X,A,1X,A,'';'') + ,1(1X,A,1X,I4,'';''),(T60,A,1X,I2))',IOSTAT=IOERR) + TDRWN(4,NT)(1:10),UNTNAM(NINT(RDRWPM(4,NN))+1)(1:4) + ,(TDRWN(II,NT)(1:10),NINT(RDRWPM(II,NN)),II=5,5) + ,TDRWN(7,NT)(1:16),NINT(RDRWPM(7,NN)) CALL MN_MES(LUNTTO,'I',TXTMES) ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN WRITE(TXTMES,'(2X,(1X,A,1X,A,'';'') + ,2(1X,A,1X,F6.2,'';''),(T60,A,1X,I2))',IOSTAT=IOERR) + TDRWN(4,NT)(1:10),UNTNAM(NINT(RDRWPM(4,NN))+1)(1:4) + ,(TDRWN(II,NT)(1:10),RDRWPM(II,NN),II=5,6) + ,TDRWN(7,NT)(1:16),NINT(RDRWPM(7,NN)) CALL MN_MES(LUNTTO,'I',TXTMES) ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN WRITE(TXTMES,'(2X,(1X,A,1X,A,'';'') + ,2(1X,A,1X,I4,'';''),(T60,A,1X,I2))',IOSTAT=IOERR) + TDRWN(4,NT)(1:10),UNTNAM(NINT(RDRWPM(4,NN))+1)(1:4) + ,(TDRWN(II,NT)(1:10),NINT(RDRWPM(II,NN)),II=5,6) + ,TDRWN(7,NT)(1:16),NINT(RDRWPM(7,NN)) CALL MN_MES(LUNTTO,'I',TXTMES) ELSE WRITE(TXTMES,'(2X,(1X,A,1X,A,'';'') + ,2(1X,A,1X,I4,'';'') + ,(T60,A,1X,I2))',IOSTAT=IOERR) + TDRWN(4,2)(1:10),UNTNAM(NINT(RDRWPM(4,NN))+1)(1:4) + ,(TDRWN(II,2)(1:10),NINT(RDRWPM(II,NN)),II=5,6) + ,TDRWN(7,NT)(1:16),NINT(RDRWPM(7,NN)) CALL MN_MES(LUNTTO,'I',TXTMES) WRITE(TXTMES,'(2X,2(1X,A,1X,A,'';''))',IOSTAT=IOERR) 3 TDRWN(8,NT)(1:15),COLNAM(NINT(RDRWPM(8,NN)))(1:10) 3 ,TDRWN(9,NT)(1:15),COLNAM(NINT(RDRWPM(9,NN)))(1:10) CALL MN_MES(LUNTTO,'I',TXTMES) ENDIF if(nint(rdrwpm(4,nn)).eq.1) then write(txtmes,'(3X,''Plot ID'',I8,'','',I4)',iostat=ioerr) + nint(rdrwpm(18,nn)),nint(rdrwpm(19,nn)) CALL MN_MES(LUNTTO,'I',TXTMES) endif C NLINE = (NDRWPT-1)/2 + 1 DO 1000 II=1,NLINE J1 = 2*II - 1 J2 = MIN0(NDRWPT,2*II) IF(NDRWTP.EQ.MDRW_SEG) THEN IF(II.EQ.1) THEN WRITE(TXTMES + ,'(3X,''Point1:'',2(1PG11.4) + ,2X,''Point2:'',2(1PG11.4))') + (XDRWPT(JJ,NN),YDRWPT(JJ,NN),JJ=J1,J2) ELSE WRITE(TXTMES + ,'(3X,''Sagitta:'',1(1PG11.4))') + (XDRWPT(JJ,NN),JJ=J1,J2) ENDIF ELSEIF(NDRWTP.EQ.MDRW_CIRCLE .OR. NDRWTP.EQ.MDRW_ARC .OR. + NDRWTP.EQ.MDRW_ELLIPSE) THEN IF(II.EQ.1) THEN WRITE(TXTMES + ,'(3X,''Centre:'',2(1PG11.4) + ,2X,''Radii: '',2(1PG11.4))') + (XDRWPT(JJ,NN),YDRWPT(JJ,NN),JJ=J1,J2) ELSE if(NDRWTP.EQ.MDRW_ELLIPSE) THEN WRITE(TXTMES + ,'(3X,''Angle: '',1(1PG11.4))') + (XDRWPT(JJ,NN),JJ=J1,J2) else WRITE(TXTMES + ,'(3X,''Angles: '',2(1PG11.4))') + (XDRWPT(JJ,NN),YDRWPT(JJ,NN),JJ=J1,J2) endif ENDIF ELSE WRITE(TXTMES + ,'(3X,''Pnt'',I3,'':'',2(1PG11.4) + ,4X,I3,'':'',2(1PG11.4))') + (JJ,XDRWPT(JJ,NN),YDRWPT(JJ,NN),JJ=J1,J2) ENDIF CALL MN_MES(LUNTTO,'I',TXTMES) 1000 CONTINUE 1100 CONTINUE CALL MN_MES(LUNTTO,'E',' ') C END +DECK,mn_ldp. SUBROUTINE MN_LDP(NLI,QNEW,NMODE,IDAI,IDBI) C C Does the real drawing of items C Mode -1 means draw now C 0 means draw everything regardless of the flag C 1 means draw with flag 0 in plot coordinates C 2 means draw with flag 1 in plot coordinates C 11 means draw with flag 0 in cm coordinates C 12 means draw with flag 1 in cm coordinates C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNPRS. +CDE,MNPIJ. C INTEGER NLI,NMODE,idai,idbi LOGICAL QNEW C REAL XPT(MCPNT+4),YPT(MCPNT+4) REAL XA(2),YA(2) INTEGER NA,I,IERR,NL,NL1,NL2,NSEGM REAL THETA,THE3,THE4,RAD1,RAD2,PHI1,PHI2 INTEGER NSYM,NsCOL,nhcol,npcol + ,JMODE,NHAT,NPAT,NATYP,LMODE,IDA,IDB,NDRWTP,NPT REAL THICK,SINEH,SINEL,SIZE,AUNIT,XUNIT C IF(NLI.LT.0) THEN RETURN ELSEIF(NLI.EQ.0) THEN NL1 = 1 NL2 = NDRWLN ELSE NL1 = NLI NL2 = NLI ENDIF C C IF THERE ARE NO HISTOGRAMS THEN SET UP SCREEN C IF(NHPLT.LE.0 .AND. NL1.EQ.1 .AND. QNEW) THEN call m_spage ENDIF C *ICB write(6,'('' MN_LDP called with mode'',I3,'' ID'',I8,I4)') *ICB + nmode,idai,idbi DO 1000 NL=NL1,NL2 NDRWTP = IDRWTP(NL) NPT = NINT(RDRWPM(20,NL)) C NSYM = NINT(RDRWPM(1,NL)) NsCOL = NINT(RDRWPM(2,NL)) THICK = RDRWPM(3,NL) JMODE = NINT(RDRWPM(4,NL)) NHAT = NINT(RDRWPM(5,NL)) NPAT = NINT(RDRWPM(6,NL)) SINEH = RDRWPM(5,NL) SINEL = RDRWPM(6,NL) NATYP = NINT(RDRWPM(5,NL)) IF(NATYP.EQ.0) NATYP = 1 LMODE = NINT(RDRWPM(7,NL)) NhCOL = NINT(RDRWPM(8,NL)) NpCOL = NINT(RDRWPM(9,NL)) SIZE = TSZES(4) AUNIT = TSZES(5) IDA = NINT(RDRWPM(18,NL)) IDB = NINT(RDRWPM(19,NL)) C C See if this should be drawn now C if(nmode.eq.01 .and. (jmode.ne.1 .or. lmode.ne.0)) goto 1000 if(nmode.eq.02 .and. (jmode.ne.1 .or. lmode.ne.1)) goto 1000 if(nmode.eq.11 .and. (jmode.ne.0 .or. lmode.ne.0)) goto 1000 if(nmode.eq.12 .and. (jmode.ne.0 .or. lmode.ne.1)) goto 1000 if(nmode.eq.1 .or. nmode.eq.2) then if(ida.ne.idai .or. idb.ne.idbi) goto 1000 endif *ICB write(6,'('' Drawing item'',I3,'' with mode'',I3 *ICB + '' ID'',I8,I4)') nl,lmode,ida,idb *ICB IF((NMODE.EQ.1 .AND. LMODE.NE.1) .OR. *ICB + (NMODE.EQ.0 .AND. LMODE.NE.0)) GOTO 1000 C C Create a segment if we are drawing all items C IF(NLI.EQ.0) THEN NSEGM = 15000 + NL CALL M_CRSG(NSEGM) ENDIF C C If this is plot mode then get the correct plot co-ordinates C This should no longer be necessary as the call will be made C from inside MN_PLT at the right point. C *ICB IF(nhplt.gt.0 .and. JMODE.EQ.1) THEN *ICB CALL MN_PPP(IDA,IDB,IERR) *ICB ENDIF C C LINE C IF(NDRWTP.EQ.MDRW_LINE .OR. NDRWTP.EQ.MDRW_POLYLINE) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,NPT,JMODE) CALL MN_LIN(XPT,YPT,NPT,NSYM,AUNIT,NsCOL,THICK) C C ARROW C ELSE IF(NDRWTP.EQ.MDRW_ARROW) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,NPT,JMODE) CALL MN_LIN(XPT,YPT,NPT,NSYM,AUNIT,NsCOL,THICK) IF(XPT(1).EQ.XPT(2) .AND. YPT(1).EQ.YPT(2)) THEN GOTO 9000 ENDIF C C Sort out where to put the arrowhead C IF(IABS(NATYP).EQ.1) THEN NA = 1 XA(1) = XPT(2) YA(1) = YPT(2) ELSEIF(IABS(NATYP).EQ.2) THEN NA = 1 XA(1) = XPT(1) YA(1) = YPT(1) ELSEIF(IABS(NATYP).EQ.3) THEN NA = 2 XA(1) = XPT(1) YA(1) = YPT(1) XA(2) = XPT(2) YA(2) = YPT(2) ELSEIF(IABS(NATYP).EQ.4) THEN NA = 1 XA(1) = 0.5 * (XPT(1) + XPT(2)) YA(1) = 0.5 * (YPT(1) + YPT(2)) ELSE GOTO 9000 ENDIF C DO I=1,NA IF(IABS(NATYP).EQ.1 .OR. IABS(NATYP).EQ.4 .OR. + (IABS(NATYP).EQ.3 .AND. I.EQ.2)) THEN IF(ABS(XPT(1)-XPT(2)).LT.1.0E-10) THEN THETA = PI / 2.0 IF(YPT(1).LT.YPT(2)) THETA = -PI / 2.0 ELSE IF(YPT(1).EQ.YPT(2)) THEN THETA = 0.0 IF(XPT(1).LT.XPT(2)) THETA = PI ELSE THETA = ATAN2(YPT(1)-YPT(2),XPT(1)-XPT(2)) ENDIF ELSE IF(ABS(XPT(1)-XPT(2)).LT.1.0E-10) THEN THETA = PI / 2.0 IF(YPT(2).LT.YPT(1)) THETA = -PI / 2.0 ELSE IF(YPT(1).EQ.YPT(2)) THEN THETA = 0.0 IF(XPT(2).LT.XPT(1)) THETA = PI ELSE THETA = ATAN2(YPT(2)-YPT(1),XPT(2)-XPT(1)) ENDIF ENDIF THE3 = THETA + PI / 9.0 THE4 = THETA - PI / 9.0 XPT(MCPNT+1) = XA(I) + SIZE * COS(THE3) YPT(MCPNT+1) = YA(I) + SIZE * SIN(THE3) XPT(MCPNT+2) = XA(I) YPT(MCPNT+2) = YA(I) XPT(MCPNT+3) = XA(I) + SIZE * COS(THE4) YPT(MCPNT+3) = YA(I) + SIZE * SIN(THE4) IF(NATYP.GT.0) THEN CALL MN_LIN(XPT(MCPNT+1),YPT(MCPNT+1),3,NSYM,AUNIT 1 ,NsCOL,THICK) ELSE CALL TVSHAD(2,XPT(MCPNT+1),YPT(MCPNT+1),3,100 + ,NhCOL) ENDIF ENDDO C C Box C ELSEIF(NDRWTP.EQ.MDRW_BOX) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL) + ,XPT(MCPNT+1),YPT(MCPNT+1),2,JMODE) XPT(1) = XPT(MCPNT+1) YPT(1) = YPT(MCPNT+1) XPT(2) = XPT(MCPNT+2) YPT(2) = YPT(MCPNT+1) XPT(3) = XPT(MCPNT+2) YPT(3) = YPT(MCPNT+2) XPT(4) = XPT(MCPNT+1) YPT(4) = YPT(MCPNT+2) XPT(5) = XPT(1) YPT(5) = YPT(1) CALL MN_LIN(XPT,YPT,5,NSYM,AUNIT,NsCOL,THICK) C C FILL WITH A PATTERN OR HATCHING C IF(NHAT.NE.0) CALL TVSHAD(1,XPT,YPT,5,NHAT,NhCOL) IF(NPAT.NE.0) CALL TVSHAD(2,XPT,YPT,5,NPAT,NpCOL) C C Triangle and Polygon C ELSEIF(NDRWTP.EQ.MDRW_TRIANGLE .OR. + NDRWTP.EQ.MDRW_POLYGON) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,NPT,JMODE) XPT(NPT+1) = XPT(1) YPT(NPT+1) = YPT(1) CALL MN_LIN(XPT,YPT,NPT+1,NSYM,AUNIT,NsCOL,THICK) C C FILL WITH A PATTERN OR HATCHING C IF(NHAT.NE.0) CALL TVSHAD(1,XPT,YPT,NPT+1,NHAT,NhCOL) IF(NPAT.NE.0) CALL TVSHAD(2,XPT,YPT,NPT+1,NPAT,NpCOL) C C Circle C ELSEIF(NDRWTP.EQ.MDRW_CIRCLE) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,1,JMODE) XPT(MCPNT+1) = XDRWPT(1,NL) XPT(MCPNT+2) = XDRWPT(1,NL) + XDRWPT(2,NL) YPT(MCPNT+1) = YDRWPT(1,NL) YPT(MCPNT+2) = YDRWPT(1,NL) + YDRWPT(2,NL) CALL MN_CTR(XPT(MCPNT+1),YPT(MCPNT+1),XPT(2),YPT(2),2 + ,JMODE) RAD1 = XPT(3) - XPT(2) C CALL TVARC(XPT(1),YPT(1),0.0,RAD1,0.0,0.0 + ,NSYM,NsCOL,THICK,NHAT,NPAT,nhcol,npcol) C C Arc C ELSEIF(NDRWTP.EQ.MDRW_ARC) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,1,JMODE) XPT(MCPNT+1) = XDRWPT(1,NL) XPT(MCPNT+2) = XDRWPT(1,NL) + XDRWPT(2,NL) YPT(MCPNT+1) = YDRWPT(1,NL) YPT(MCPNT+2) = YDRWPT(1,NL) + YDRWPT(2,NL) CALL MN_CTR(XPT(MCPNT+1),YPT(MCPNT+1),XPT(2),YPT(2),2 + ,JMODE) RAD1 = XPT(3) - XPT(2) RAD2 = YPT(3) - YPT(2) PHI1 = XDRWPT(3,NL) PHI2 = YDRWPT(3,NL) C CALL TVARC(XPT(1),YPT(1),RAD1,RAD2,PHI1,PHI2 + ,NSYM,NsCOL,THICK,NHAT,NPAT,nhcol,npcol) C C Sine Wave - photons C ELSEIF(NDRWTP.EQ.MDRW_SINE) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,NPT,JMODE) CALL MN_SIN(XPT,YPT,NPT,NSYM,SINEH,SINEL,NsCOL,THICK) C C Gluon C ELSEIF(NDRWTP.EQ.MDRW_GLUON) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,NPT,JMODE) CALL MN_GLU(XPT,YPT,NPT,NSYM,SINEH,SINEL,NsCOL,THICK) C C Symbol C ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN SIZE = THICK THICK = ATHKS(7) XUNIT = TSZES(5) CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,1,JMODE) CALL MN_SYM(NSYM,XPT,YPT,0.0,0.0,0.0,0.0 + ,SIZE,SIZE,NsCOL,nscol,THICK,XUNIT,-1) C C Ellipse C ELSEIF(NDRWTP.EQ.MDRW_ELLIPSE) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,1,JMODE) XPT(MCPNT+1) = XDRWPT(1,NL) XPT(MCPNT+2) = XDRWPT(1,NL) + XDRWPT(2,NL) YPT(MCPNT+1) = YDRWPT(1,NL) YPT(MCPNT+2) = YDRWPT(1,NL) + YDRWPT(2,NL) CALL MN_CTR(XPT(MCPNT+1),YPT(MCPNT+1),XPT(2),YPT(2),2 + ,JMODE) RAD1 = XPT(3) - XPT(2) RAD2 = YPT(3) - YPT(2) PHI1 = XDRWPT(3,NL) C CALL TVELL(XPT(1),YPT(1),RAD1,RAD2,PHI1,0.0 + ,NSYM,NsCOL,THICK,NHAT,NPAT,nhcol,npcol) C C Segment C ELSEIF(NDRWTP.EQ.MDRW_SEG) THEN CALL MN_CTR(XDRWPT(1,NL),YDRWPT(1,NL),XPT,YPT,2,JMODE) XPT(MCPNT+1) = XDRWPT(1,NL) XPT(MCPNT+2) = XDRWPT(1,NL) + XDRWPT(3,NL) YPT(MCPNT+1) = YDRWPT(1,NL) YPT(MCPNT+2) = YDRWPT(1,NL) CALL MN_CTR(XPT(MCPNT+1),YPT(MCPNT+1),XPT(3),YPT(3),2 + ,JMODE) RAD1 = XPT(4) - XPT(3) C CALL TVSEG(XPT(1),YPT(1),rad1 + ,nsym,nscol,thick,nhat,npat,nhcol,npcol) ENDIF C C Close the segment if we are drawing all items C IF(NLI.EQ.0) THEN CALL M_CLSG(NSEGM) ENDIF C 1000 CONTINUE C 9000 CONTINUE IF(NMODE.EQ.-1) CALL TVSHOW END +DECK,mn_ldw. SUBROUTINE MN_LDW(IDELIM) C C DRAWS SOMETHING ON A PICTURE C THE VALID POSSIBILITIES ARE: C LINE, ARROW, BOX, TRIANGLE, POLYGON, POLYLINE, CIRCLE, ARC, SINE, GLUON C implicit none * +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNCMT. +CDE,MNFLG. +CDE,MNPIJ. +CDE,MNLUN. * integer idelim C REAL XPT(MCPNT),YPT(MCPNT) CHARACTER*80 TEXT,THEAD,THELP LOGICAL QNEW,QCHGE,QDEL,QLIST,QFETCH,QSTORE,QCHGED,QEXIT,QUMOUS REAL RNUM(10) INTEGER NSYM,NsCOL,nhcol,npcol,JMODE,NHAT,NPAT,NATYP,LMODE REAL THICK,SIZE,SINEH,SINEL * integer nsegm,istat,nnum,nnp,lenf,lent,i,ii,nrec,n1,n2 + ,nhead,nnpnt,nnlin,nn,nval,ierr,ioerr,np,npt,ida,idb,nplt + ,ndrwtp,ndrwpt real rval,phi,phid,rad,xpos,ypos * integer jcmd,kcmd integer inttyp,inttyq,icmtyp,icmtyq,ivltyq + ,lnblnk real reltyp,valtyq external inttyp,inttyq,icmtyp,icmtyq,ivltyq,reltyp,valtyq C QEXIT = IDELIM.EQ.0 QUMOUS = QMOUSE C NSYM = 1 NsCOL = ICOLS(7) NhCOL = ICOLS(8) NpCOL = ICOLS(9) THICK = ATHKS(7) SIZE = TSZES(4) JMODE = 0 NHAT = NHATS NPAT = NPATS SINEH = TSZES(4) SINEL = TSZES(4) NATYP = 1 LMODE = 0 C 1000 CONTINUE QNEW = .TRUE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .FALSE. QSTORE = .FALSE. QFETCH = .FALSE. QCHGED = .FALSE. CALL WAITYQ('DRAW> Give item to draw, command or ?: ') JCMD = ICMTYQ(.TRUE.,IDELIM,DRWNAM) COMND2 = ' ' IF(JCMD.GT.0) COMND2 = DRWNAM(JCMD) IF(JCMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN CALL MN_MES(LUNTTO,'M',' List of valid commands:') CALL MN_MES(LUNTTO,'M',' ? to get this help') CALL MN_MES(LUNTTO,'M',' LINE to draw a line') CALL MN_MES(LUNTTO,'M',' ARROW to draw an arrow') CALL MN_MES(LUNTTO,'M',' BOX to draw a box') CALL MN_MES(LUNTTO,'M',' TRIANGLE to draw a triangle') CALL MN_MES(LUNTTO,'M',' POLYGON to draw a polygon') CALL MN_MES(LUNTTO,'M',' POLYLINE to draw a polyline') CALL MN_MES(LUNTTO,'M',' CIRCLE to draw a circle') CALL MN_MES(LUNTTO,'M',' ARC to draw an arc') CALL MN_MES(LUNTTO,'M',' SINE to draw a sine wave') CALL MN_MES(LUNTTO,'M',' GLUON to draw a gluon line') CALL MN_MES(LUNTTO,'M',' SYMBOL to draw a symbol') CALL MN_MES(LUNTTO,'M',' ELLIPSE to draw an ellipse') CALL MN_MES(LUNTTO,'M',' SEGMENT to draw a segment') CALL MN_MES(LUNTTO,'M' + ,' CHANGE to change an existing item') CALL MN_MES(LUNTTO,'M' + ,' DELETE to delete an existing item') CALL MN_MES(LUNTTO,'M' + ,' LIST to list the existing items') CALL MN_MES(LUNTTO,'M' + ,' STORE to store one or more items') CALL MN_MES(LUNTTO,'M' + ,' FETCH to fetch stored items') CALL MN_MES(LUNTTO,'E',' END or to exit') CALL ZERTYQ('.FALSE.') GOTO 1000 ELSEIF(JCMD.LT.0) THEN GOTO 9000 ELSEIF(JCMD.EQ.0 .OR. IDELIM.GT.0) THEN CALL MN_DCK(IDELIM,JCMD,MDRAW,DRWNAM,IERR) IF(IERR.EQ.2) CALL MN_UNK('MN_CMD') GOTO 8000 C ELSEIF(COMND2.EQ.'END') THEN GOTO 9000 ELSEIF(COMND2.EQ.'LINE' .OR. COMND2.EQ.'ARROW' .OR. + COMND2.EQ.'BOX' .OR. COMND2.EQ.'TRIANGLE' .OR. + COMND2.EQ.'POLYGON' .OR. COMND2.EQ.'POLYLINE' .OR. + COMND2.EQ.'CIRCLE' .OR. + COMND2.EQ.'ARC' .OR. COMND2.EQ.'SINE' .OR. + COMND2.EQ.'GLUON' .OR. COMND2.EQ.'SYMBOL' .OR. + COMND2.EQ.'ELLIPSE' .OR. COMND2.EQ.'SEGMENT') THEN QNEW = .TRUE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .FALSE. QSTORE = .FALSE. QFETCH = .FALSE. C C Get the latest plot number so we know what transformation to use C DO 1100 NP=NHPLT,1,-1 IF(IPLTIA(NP).GT.0 .AND. IPLTFL(NP).EQ.1) THEN NPLT = NP GOTO 1110 ENDIF 1100 CONTINUE NPLT = 0 IDA = 0 IDB = 0 GOTO 1120 1110 CONTINUE IDA = IPLTIA(NPLT) IDB = IPLTIB(NPLT) 1120 CONTINUE C IF(COMND2.EQ.'LINE') THEN NDRWTP = MDRW_LINE NDRWPT = 2 ELSE IF(COMND2.EQ.'ARROW') THEN NDRWTP = MDRW_ARROW NDRWPT = 2 ELSE IF(COMND2.EQ.'BOX') THEN NDRWTP = MDRW_BOX NDRWPT = 2 ELSE IF(COMND2.EQ.'TRIANGLE') THEN NDRWTP = MDRW_TRIANGLE NDRWPT = 3 ELSE IF(COMND2.EQ.'POLYGON' .OR. COMND2.EQ.'POLYLINE') THEN IF(COMND2.EQ.'POLYGON') THEN NDRWTP = MDRW_POLYGON ELSEIF(COMND2.EQ.'POLYLINE') THEN NDRWTP = MDRW_POLYLINE ENDIF C CALL WAITYQ('Give number of points: ') NDRWPT = IVLTYQ(.TRUE.,IDELIM) CALL MN_NCK(NDRWPT,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 IF(NDRWPT.GT.MCPNT) THEN WRITE(TXTERR,'( + ''I can make a polygon or polyline of up to'',I4 + ,'' points'')',IOSTAT=IOERR) MCPNT CALL MN_ERR('MN_LDW',TXTERR) GOTO 9000 ELSEIF(COMND2.EQ.'POLYGON' .AND. NDRWPT.LT.3) THEN CALL MN_ERR('MN_LDW' + ,'A polygon must have at least 3 points') GOTO 9000 ELSEIF(COMND2.EQ.'POLYLNE' .AND. NDRWPT.LT.2) THEN CALL MN_ERR('MN_LDW' + ,'A polyline must have at least 2 points') GOTO 9000 ENDIF ELSE IF(COMND2.EQ.'CIRCLE') THEN NDRWTP = MDRW_CIRCLE NDRWPT = 2 ELSE IF(COMND2.EQ.'ARC') THEN NDRWTP = MDRW_ARC NDRWPT = 3 ELSE IF(COMND2.EQ.'SINE') THEN NDRWTP = MDRW_SINE NDRWPT = 2 ELSE IF(COMND2.EQ.'GLUON') THEN NDRWTP = MDRW_GLUON NDRWPT = 2 ELSE IF(COMND2.EQ.'SYMBOL') THEN NDRWTP = MDRW_SYMBOL NDRWPT = 1 ELSE IF(COMND2.EQ.'ELLIPSE') THEN NDRWTP = MDRW_ELLIPSE NDRWPT = 3 ELSE IF(COMND2.EQ.'SEGMENT') THEN NDRWTP = MDRW_SEG NDRWPT = 3 ENDIF ELSEIF(COMND2.EQ.'CHANGE') THEN QNEW = .FALSE. QCHGE = .TRUE. QDEL = .FALSE. QLIST = .FALSE. QSTORE = .FALSE. QFETCH = .FALSE. ELSEIF(COMND2.EQ.'DELETE') THEN QNEW = .FALSE. QCHGE = .FALSE. QDEL = .TRUE. QLIST = .FALSE. QSTORE = .FALSE. QFETCH = .FALSE. ELSEIF(COMND2.EQ.'LIST') THEN QNEW = .FALSE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .TRUE. QSTORE = .FALSE. QFETCH = .FALSE. ELSEIF(COMND2.EQ.'STORE') THEN QNEW = .FALSE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .FALSE. QSTORE = .TRUE. QFETCH = .FALSE. ELSEIF(COMND2.EQ.'FETCH') THEN QNEW = .FALSE. QCHGE = .FALSE. QDEL = .FALSE. QLIST = .FALSE. QSTORE = .FALSE. QFETCH = .TRUE. ENDIF C IF(QCHGE .OR. QDEL .OR. QLIST .OR. QSTORE) THEN IF((QRFILE .OR. NDRWLN.GT.1) .OR. 1 QLIST .OR. QDEL .OR. QSTORE) THEN IF(QLIST .OR. IDELIM.LT.0) THEN CALL MN_LDD(0) ENDIF IF(QLIST) GOTO 8000 C 1200 CONTINUE IF(QCHGE) THEN CALL WAITYQ('DRAW> Give item number to change: ') ELSEIF(QDEL) THEN CALL WAITYQ('DRAW> Give item number to delete: ') ELSEIF(QSTORE) THEN CALL WAITYQ('DRAW> Give item number to store: ') ENDIF NVAL = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 9000 IF(IERR.NE.0) THEN IF(QRFILE) THEN GOTO 9000 ELSE GOTO 1200 ENDIF ENDIF IF((QCHGE .AND.(NVAL.EQ.0 .OR. NVAL.GT.NDRWLN)) .OR. + (.NOT.QCHGE .AND.(NVAL.LT.0 .OR. NVAL.GT.NDRWLN))) THEN WRITE(LUNTTO,'(1X,I4 1 ,'' is an invalid item number'')') NVAL GOTO 1200 ELSE NNLIN = NVAL ENDIF ELSE NNLIN = 1 ENDIF C C DELETE AN ITEM C IF(QDEL) THEN IF(NNLIN.EQ.0) THEN NDRWLN = 0 ELSE DO 1500 NN=NNLIN,NDRWLN-1 IDRWTP(NN) = IDRWTP(NN+1) NNPNT = NINT(RDRWPM(20,NN+1)) CALL UCOPY_r(RDRWPM(1,NN+1),RDRWPM(1,NN),20) CALL UCOPY_r(XDRWPT(1,NN+1),XDRWPT(1,NN),NNPNT) CALL UCOPY_r(YDRWPT(1,NN+1),YDRWPT(1,NN),NNPNT) 1500 CONTINUE NDRWLN = NDRWLN - 1 ENDIF GOTO 8000 C C Store an item in a file C ELSEIF(QSTORE) THEN IF(NNLIN.EQ.0) THEN N1 = 1 N2 = NDRWLN ELSE N1 = NNLIN N2 = NNLIN ENDIF C LUNPOU = 0 CALL MN_FIL(-13,LUNPOU,FIL_PO,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C DO 1600 NN=N1,N2 NNPNT = NINT(RDRWPM(20,NN)) IF(IDRWTP(NN).EQ.MDRW_LINE) THEN NHEAD = 7 WRITE(LUNPOU,11601) + DRWNAM(IDRWTP(NN)),IDRWTP(NN) + ,NNPNT,NHEAD + ,(NINT(RDRWPM(II,NN)),II=1,2) + ,(RDRWPM(II,NN),II=3,3) + ,(NINT(RDRWPM(II,NN)),II=4,4) + ,NINT(RDRWPM(7,NN)) 11601 FORMAT(1X,A10,1X,I4,1X,I4,1X,I4 + ,/,2I6,F8.3,I6,' 0 0',I3) ELSEIF(IDRWTP(NN).EQ.MDRW_ARROW) THEN NHEAD = 7 WRITE(LUNPOU,11602) + DRWNAM(IDRWTP(NN)),IDRWTP(NN) + ,NNPNT,NHEAD + ,(NINT(RDRWPM(II,NN)),II=1,2) + ,(RDRWPM(II,NN),II=3,3) + ,(NINT(RDRWPM(II,NN)),II=4,4) + ,(NINT(RDRWPM(II,NN)),II=5,5) + ,NINT(RDRWPM(7,NN)) 11602 FORMAT(1X,A10,1X,I4,1X,I4,1X,I4 + ,/,2I6,F8.3,2I6,' 0',I3) ELSEIF(IDRWTP(NN).EQ.MDRW_SINE .OR. + IDRWTP(NN).EQ.MDRW_GLUON) THEN NHEAD = 7 WRITE(LUNPOU,11603) + DRWNAM(IDRWTP(NN)),IDRWTP(NN) + ,NNPNT,NHEAD + ,(NINT(RDRWPM(II,NN)),II=1,2) + ,(RDRWPM(II,NN),II=3,3) + ,(NINT(RDRWPM(II,NN)),II=4,4) + ,(RDRWPM(II,NN),II=5,6) + ,NINT(RDRWPM(7,NN)) 11603 FORMAT(1X,A10,1X,I4,1X,I4,1X,I4 + ,/,2I6,F8.3,I6,2F8.3,I3) ELSE NHEAD = 9 WRITE(LUNPOU,11604) + DRWNAM(IDRWTP(NN)),IDRWTP(NN) + ,NNPNT,NHEAD + ,(NINT(RDRWPM(II,NN)),II=1,2) + ,(RDRWPM(II,NN),II=3,3) + ,(NINT(RDRWPM(II,NN)),II=4,4) + ,(NINT(RDRWPM(II,NN)),II=5,6) + ,NINT(RDRWPM(7,NN)) + ,(NINT(RDRWPM(II,NN)),II=8,9) 11604 FORMAT(1X,A10,1X,I4,1X,I4,1X,I4 + ,/,2I6,F8.3,3I6,I3,2I4) ENDIF WRITE(LUNPOU,11610) + (XDRWPT(II,NN),YDRWPT(II,NN),II=1,NNPNT) 11610 FORMAT((1X,2(2(1PG15.7),2X))) 1600 CONTINUE CLOSE(UNIT=LUNPOU) call cleo_frelun(lunpou,'MN_FIL') GOTO 8000 ENDIF C C Fetch all the items from a file C ELSEIF(QFETCH) THEN LUNPIN = 0 CALL MN_FIL(13,LUNPIN,FIL_PI,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C NN = NDRWLN C C Start to read in an item C 1700 CONTINUE NREC = 0 NN = NN + 1 C C Read in the next record of an item C 1710 CONTINUE NREC = NREC + 1 TXTERR = 'Read Error' READ(LUNPIN,'(A)',ERR=1780,END=1790) TEXT IF(TEXT(1:1).EQ.TSCOMM) GOTO 1700 CALL QUOTYP(TEXT) C C Header C IF(NREC.EQ.1) THEN KCMD = ICMTYP(.TRUE.,IDELIM,DRWNAM) IF(KCMD.LE.0) THEN TXTERR = 'Item Name' GOTO 1780 ENDIF IDRWTP(NN) = INTTYP(.TRUE.,IDELIM) IF(IDELIM.NE.0) THEN TXTERR = 'Item Type' GOTO 1780 ENDIF NNPNT = INTTYP(.TRUE.,IDELIM) IF(IDELIM.NE.0) THEN TXTERR = 'Number of Points' GOTO 1780 ENDIF NHEAD = INTTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) THEN TXTERR = 'Number of Header Words' GOTO 1780 ENDIF C C Symbol, thickness etc. C ELSEIF(NREC.EQ.2) THEN DO I=1,MIN0(NHEAD,10) RDRWPM(I,NN) = RELTYP(.TRUE.,IDELIM) IF(IDELIM.NE.0) GOTO 1750 ENDDO 1750 CONTINUE RDRWPM(20,NN) = NNPNT C C The points C ELSE NP = 0 DO I=1,NNPNT XDRWPT(I,NN) = RELTYP(.TRUE.,IDELIM) IF(IDELIM.NE.0) THEN WRITE(TXTERR,'(''Point'',I4)') I GOTO 1780 ENDIF YDRWPT(I,NN) = RELTYP(.TRUE.,IDELIM) NP = NP + 1 C C Read in the next record if necessary C IF(I.LT.NNPNT .AND. IDELIM.LT.0) THEN 1760 CONTINUE TXTERR = 'Read Error' READ(LUNPIN,'(A)',ERR=1780,END=1790) TEXT IF(TEXT(1:1).EQ.TSCOMM) GOTO 1760 CALL QUOTYP(TEXT) ENDIF ENDDO GOTO 1700 ENDIF GOTO 1710 C C Error reading the file C 1780 CONTINUE CALL ZERTYQ('.FALSE.') CLOSE(UNIT=LUNPIN) call cleo_frelun(lunpin,'MN_FIL') TEXT = TXTERR LENF = LNBLNK(FIL_PI) TXTERR = 'Error reading items from file: ' // FIL_PI(:LENF) CALL M_EMSG('MN_LDW',TXTERR) LENT = LNBLNK(TEXT) WRITE(TXTERR,'('' Item: '',I4,'' Error Type: '',A)') + NN,TEXT(:LENT) CALL MN_ERR('MN_LDW',TXTERR) C C End of file reached C 1790 CONTINUE IF(NREC.LT.3 .OR. NP.LT.NNPNT) THEN NN = NN - 1 ENDIF CALL ZERTYQ('.FALSE.') CLOSE(UNIT=LUNPIN) call cleo_frelun(lunpin,'MN_FIL') NNP = NN - NDRWLN IF(NNP.GT.0) THEN WRITE(TXTMES,'('' I have read in'',I4,'' new items'')') + NNP NDRWLN = NN ELSE TXTMES = 'No new items read in' ENDIF CALL MN_MES(LUNTTO,'ME',TXTMES) GOTO 8000 ENDIF C C NEW LINE C IF(QNEW) THEN NNLIN = NDRWLN + 1 IF(NNLIN.GT.MCLIN) THEN WRITE(TXTERR,'(''No more room to draw things.'' 1 ,'' Maximum number of items is'',I5)') MCLIN CALL MN_ERR('MN_LDW',TXTERR) GOTO 9000 ENDIF IDRWTP(NNLIN) = NDRWTP RDRWPM(20,NNLIN) = FLOAT(NDRWPT) RDRWPM(1,NNLIN) = FLOAT(NSYM) RDRWPM(2,NNLIN) = FLOAT(NsCOL) RDRWPM(3,NNLIN) = THICK RDRWPM(4,NNLIN) = FLOAT(JMODE) IF(NDRWTP.EQ.MDRW_ARROW) THEN RDRWPM(5,NNLIN) = FLOAT(NATYP) ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN RDRWPM(5,NNLIN) = SINEH RDRWPM(6,NNLIN) = SINEL ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN RDRWPM(3,NNLIN) = SIZE RDRWPM(5,NNLIN) = FLOAT(NHAT) RDRWPM(6,NNLIN) = FLOAT(NPAT) ELSE RDRWPM(5,NNLIN) = FLOAT(NHAT) RDRWPM(6,NNLIN) = FLOAT(NPAT) ENDIF RDRWPM(7,NNLIN) = FLOAT(LMODE) RDRWPM(8,NNLIN) = FLOAT(NhCOL) RDRWPM(9,NNLIN) = FLOAT(NpCOL) RDRWPM(18,NNLIN) = FLOAT(IDA) RDRWPM(19,NNLIN) = FLOAT(IDB) CALL VZERO_r(XDRWPT(1,NNLIN),MCPNT) CALL VZERO_r(YDRWPT(1,NNLIN),MCPNT) C C CHANGE A LINE C ELSE IF(QCHGE) THEN NDRWTP = IDRWTP(NNLIN) NDRWPT = NINT(RDRWPM(20,NNLIN)) NSYM = NINT(RDRWPM(1,NNLIN)) NsCOL = NINT(RDRWPM(2,NNLIN)) THICK = RDRWPM(3,NNLIN) JMODE = NINT(RDRWPM(4,NNLIN)) IF(NDRWTP.EQ.MDRW_ARROW) THEN NATYP = NINT(RDRWPM(5,NNLIN)) ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN SINEH = RDRWPM(5,NNLIN) SINEL = RDRWPM(6,NNLIN) ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN SIZE = RDRWPM(3,NNLIN) NHAT = NINT(RDRWPM(5,NNLIN)) NPAT = NINT(RDRWPM(6,NNLIN)) ELSE NHAT = NINT(RDRWPM(5,NNLIN)) NPAT = NINT(RDRWPM(6,NNLIN)) ENDIF LMODE = NINT(RDRWPM(7,NNLIN)) NhCOL = NINT(RDRWPM(8,NNLIN)) NpCOL = NINT(RDRWPM(9,NNLIN)) IDA = NINT(RDRWPM(18,NNLIN)) IDB = NINT(RDRWPM(19,NNLIN)) CALL UCOPY_r(XDRWPT(1,NNLIN),XPT,NDRWPT) CALL UCOPY_r(YDRWPT(1,NNLIN),YPT,NDRWPT) ENDIF C 2000 CONTINUE C THEAD = ' ' THELP = 'DRAW ' // DRWNAM(NDRWTP) IF(NDRWTP.EQ.MDRW_LINE .OR. NDRWTP.EQ.MDRW_POLYLINE) THEN CALL MN_ENM(IDELIM,THELP,THEAD,10,TDRWN(1,1),IDRWN(1,1) + ,RDRWPM(1,NNLIN),NNUM,RNUM,IERR) ELSEIF(NDRWTP.EQ.MDRW_ARROW) THEN CALL MN_ENM(IDELIM,THELP,THEAD,10,TDRWN(1,3),IDRWN(1,3) + ,RDRWPM(1,NNLIN),NNUM,RNUM,IERR) ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. + NDRWTP.EQ.MDRW_GLUON) THEN CALL MN_ENM(IDELIM,THELP,THEAD,10,TDRWN(1,4),IDRWN(1,4) + ,RDRWPM(1,NNLIN),NNUM,RNUM,IERR) ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN CALL MN_ENM(IDELIM,THELP,THEAD,10,TDRWN(1,5),IDRWN(1,5) + ,RDRWPM(1,NNLIN),NNUM,RNUM,IERR) ELSE CALL MN_ENM(IDELIM,THELP,THEAD,10,TDRWN(1,2),IDRWN(1,2) + ,RDRWPM(1,NNLIN),NNUM,RNUM,IERR) ENDIF IF(IERR.NE.0) GOTO 9000 C DO 3000 II=1,NNUM IF(II.EQ.1) THEN IF(NDRWTP.EQ.MDRW_SYMBOL) THEN NSYM = NINT(RNUM(1)) ELSE NSYM = IABS(NINT(RNUM(1))) ENDIF ELSEIF(II.EQ.2) THEN * * Set the symbol colour. If this a new item set the hatch * and pattern colours also * NsCOL = NINT(RNUM(2)) if(qnew) then nhcol = nscol npcol = nscol endif ELSEIF(II.EQ.3) THEN THICK = RNUM(3) IF(NDRWTP.EQ.MDRW_SYMBOL) SIZE = RNUM(3) ELSEIF(II.EQ.4) THEN JMODE = NINT(RNUM(4)) ELSEIF(II.EQ.5) THEN IF(NDRWTP.EQ.MDRW_ARROW) THEN NATYP = NINT(RNUM(5)) ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN SINEH = RNUM(5) SINEL = RNUM(5) ELSE NHAT = NINT(RNUM(5)) ENDIF ELSEIF(II.EQ.6) THEN IF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN SINEL = RNUM(6) ELSE NPAT = NINT(RNUM(6)) ENDIF ELSEIF(II.EQ.7) THEN LMODE = NINT(RNUM(7)) ELSEIF(II.EQ.8) THEN NhCOL = NINT(RNUM(8)) ELSEIF(II.EQ.9) THEN NpCOL = NINT(RNUM(9)) ENDIF 3000 CONTINUE C DO 3700 II=1,NDRWPT * * Use the mouse to position the point * IF(QUMOUS) THEN IF(QCHGE) THEN WRITE(TEXT,'('' DRAW> Pnt'',I4 + ,'' x,y: '',2(1PG11.4) + ,'' Give new position with the mouse:'')') 1 II,XPT(II),YPT(II) ELSE WRITE(TEXT + ,'('' DRAW> Pnt'',I4 + ,'' Give position using the mouse: '')') II ENDIF CALL MN_MES(LUNTTO,'ME',TEXT) CALL TVQLC(XPOS,YPOS,ISTAT) IF(ISTAT.EQ.1) THEN XPT(II) = XPOS YPT(II) = YPOS NNUM = 2 C C For circle, arc and ellipse transform points to radius/angle C IF(II.GT.1 .AND. + (NDRWTP.EQ.MDRW_CIRCLE .OR. + NDRWTP.EQ.MDRW_ARC .OR. + NDRWTP.EQ.MDRW_ELLIPSE)) THEN RAD = SQRT((XPT(II)-XPT(1))**2 + + (YPT(II)-YPT(1))**2) PHI = ATAN2(YPT(II)-YPT(1),XPT(II)-XPT(1)) PHID = PHI * RDEG IF(NDRWTP.EQ.MDRW_CIRCLE) THEN XPT(2) = RAD YPT(2) = 0.0 ELSEIF(NDRWTP.EQ.MDRW_ARC) THEN IF(II.EQ.2) THEN XPT(2) = RAD XPT(3) = PHID ELSE YPT(2) = RAD YPT(3) = PHID ENDIF ELSEIF(NDRWTP.EQ.MDRW_ELLIPSE) THEN IF(II.EQ.2) THEN XPT(2) = RAD XPT(3) = PHID ELSE YPT(2) = RAD ENDIF ENDIF ENDIF ENDIF * * Give the values * ELSE IF(QCHGE) THEN IF(NDRWTP.EQ.MDRW_SEG) THEN IF(II.EQ.1) THEN WRITE(TEXT,'('' Point1: '',2(1PG11.4))') + XPT(II),YPT(II) ELSEIF(II.EQ.2) THEN WRITE(TEXT,'('' Point2: '',2(1PG11.4))') + XPT(II),YPT(II) ELSEIF(II.EQ.3) THEN WRITE(TEXT,'('' Sagitta: '',1(1PG11.4))') + XPT(II) ENDIF ELSEIF(NDRWTP.EQ.MDRW_CIRCLE .OR. + NDRWTP.EQ.MDRW_ARC .OR. + NDRWTP.EQ.MDRW_ELLIPSE) THEN IF(II.EQ.1) THEN WRITE(TEXT,'('' Centre x,y: '',2(1PG11.4))') + XPT(II),YPT(II) ELSEIF(II.EQ.2) THEN WRITE(TEXT,'('' Radii: '',2(1PG11.4))') + XPT(II),YPT(II) ELSEIF(II.EQ.3) THEN if(NDRWTP.EQ.MDRW_ELLIPSE) THEN WRITE(TEXT,'('' Angle: '',1(1PG11.4))') + XPT(II) else WRITE(TEXT,'('' Angles: '',2(1PG11.4))') + XPT(II),YPT(II) endif ENDIF ELSE WRITE(TEXT,'('' Point'',I4,'' x,y: '' + ,2(1PG11.4))') II,XPT(II),YPT(II) ENDIF CALL MN_MES(LUNTTO,'ME',TEXT) WRITE(TEXT 1 ,'(''DRAW> Give new values or'' 1 ,'' to keep old ones: '')') ELSE IF(NDRWTP.EQ.MDRW_SEG) then IF(II.EQ.1) THEN WRITE(TEXT,'(''DRAW> Give point1:'')') ELSEIF(II.EQ.2) THEN WRITE(TEXT,'(''DRAW> Give point2:'')') ELSEIF(II.EQ.3) THEN WRITE(TEXT,'(''DRAW> Give sagitta:'')') ENDIF ELSEIF(NDRWTP.EQ.MDRW_CIRCLE .OR. + NDRWTP.EQ.MDRW_ARC .OR. + NDRWTP.EQ.MDRW_ELLIPSE) THEN IF(II.EQ.1) THEN WRITE(TEXT,'(''DRAW> Give centre:'')') ELSEIF(II.EQ.2) THEN WRITE(TEXT,'(''DRAW> Give radii:'')') ELSEIF(II.EQ.3) THEN WRITE(TEXT,'(''DRAW> Give angles:'')') ENDIF ELSE WRITE(TEXT,'(''DRAW> Point'',I4 + ,'' Give x,y: '')') II ENDIF ENDIF 3600 CONTINUE NNUM = 0 3610 CONTINUE CALL WAITYQ(TEXT(1:LNBLNK(TEXT)+1)) RVAL = VALTYQ(.TRUE.,IDELIM) IF(IDELIM.EQ.ICHAR('=')) THEN NNUM = NNUM + 1 GOTO 3620 ENDIF CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 3620 IF(IERR.NE.0) GOTO 9000 C NNUM = NNUM + 1 IF(NNUM.EQ.1) THEN XPT(II) = RVAL ELSE YPT(II) = RVAL ENDIF 3620 CONTINUE IF(NNUM.EQ.1 .AND. IDELIM.EQ.0) GOTO 3610 ENDIF 3700 CONTINUE C C NOW STORE LINE C IF(QNEW) NDRWLN = NNLIN IDRWTP(NNLIN) = NDRWTP RDRWPM(20,NNLIN) = FLOAT(NDRWPT) RDRWPM(1,NNLIN) = FLOAT(NSYM) RDRWPM(2,NNLIN) = FLOAT(NsCOL) RDRWPM(3,NNLIN) = THICK RDRWPM(4,NNLIN) = FLOAT(JMODE) IF(NDRWTP.EQ.MDRW_ARROW) THEN RDRWPM(5,NNLIN) = FLOAT(NATYP) ELSEIF(NDRWTP.EQ.MDRW_SINE .OR. NDRWTP.EQ.MDRW_GLUON) THEN RDRWPM(5,NNLIN) = SINEH RDRWPM(6,NNLIN) = SINEL ELSEIF(NDRWTP.EQ.MDRW_SYMBOL) THEN RDRWPM(3,NNLIN) = SIZE RDRWPM(5,NNLIN) = FLOAT(NHAT) RDRWPM(6,NNLIN) = FLOAT(NPAT) ELSE RDRWPM(5,NNLIN) = FLOAT(NHAT) RDRWPM(6,NNLIN) = FLOAT(NPAT) ENDIF RDRWPM(7,NNLIN) = FLOAT(LMODE) RDRWPM(8,NNLIN) = FLOAT(NhCOL) RDRWPM(9,NNLIN) = FLOAT(NpCOL) RDRWPM(18,NNLIN) = FLOAT(IDA) RDRWPM(19,NNLIN) = FLOAT(IDB) CALL UCOPY_r(XPT,XDRWPT(1,NNLIN),NDRWPT) CALL UCOPY_r(YPT,YDRWPT(1,NNLIN),NDRWPT) C C DRAW THE LINE C CALL MN_TON(IERR) IF(IERR.NE.0) GOTO 4100 C C Create a segment C IF(LMODE.EQ.0) THEN NSEGM = 15000 + NNLIN ELSE NSEGM = 15100 + NNLIN ENDIF IF(.NOT.QNEW) CALL M_DLSG(NSEGM) CALL M_CRSG(NSEGM) C CALL MN_LDP(NNLIN,QNEW,-1,0,0) C C Close the segment C CALL M_CLSG(NSEGM) C CALL MN_TOF(.TRUE.) 4100 CONTINUE C IF(.NOT.QRFILE) THEN CALL WAITYP('Change item [Y/N]? ') KCMD = ICMTYP(.TRUE.,IDELIM,LOGNAM) IF(MOD(KCMD,2).EQ.1) THEN QNEW = .FALSE. QCHGE = .TRUE. GOTO 2000 ELSE IF(QCHGE) QCHGED = .TRUE. ENDIF ENDIF IF(QCHGE) QCHGED = .TRUE. C 8000 CONTINUE IF(.NOT.QEXIT) GOTO 1000 C 9000 CONTINUE IF(QCHGED) WRITE(LUNTTO 1 ,'('' Give command REDRAW to get rid'' 1 ,'' of the old things you have changed'')') END +DECK,mn_lgi. C SUBROUTINE MN_LGI(TLOGON) C C SUBROUTINE TO FIND OUT IF A LOGON FILE EXITS C +SELF,IF=VMS. INCLUDE '($SSDEF)' INTEGER*2 LENT +SELF. +CDE,MNDIR. +CDE,MNLUN. C CHARACTER*(*) TLOGON C TLOGON = 'mn_logon.mnf' CALL MN_FIL(52,LUNTMP,TLOGON,IDELIM,IERR) IF(IERR.NE.0) THEN GOTO 2000 ELSE CLOSE(UNIT=LUNTMP) GOTO 9000 ENDIF C 2000 CONTINUE C +SELF,IF=VMS. ISTAT = LIB$SYS_TRNLOG('MN$LOGON', LENT, TLOGON,,,) IF (ISTAT.EQ.SS$_NOTRAN) GOTO 3000 +SELF,IF=UNIX. TLOGON = TMNHOM(1:LMNHOM) // '.mn_fitrc' +SELF. C +SELF,IF=VMS,UNIX. CALL MN_FIL(52,LUNTMP,TLOGON,IDELIM,IERR) IF(IERR.NE.0) GOTO 3000 CLOSE(UNIT=LUNTMP) GOTO 9000 +SELF. C 3000 CONTINUE TLOGON = ' ' +SELF,IF=VMS. WRITE(LUNTTO,'('' Logon file MN_LOGON.MNF or MN$LOGON:'' 1 ,'' not found'')') +SELF,IF=UNIX. WRITE(LUNTTO,'('' Logon file mn_logon.mnf or'' + ,'' $HOME/.mn_fitrc not found'')') +SELF. C 9000 CONTINUE END +DECK,mn_mgt. SUBROUTINE MN_MGT(IDA,IDB,LUNMIN,TFILE 1 ,NWWT,BUFTMP,LNBLOK,LNREC,IERR) C C LOCATES THE BEGINNING OF PLOT IDA,IDB IN FILE TFILE C +CDE,MNPAR. +CDE,MNLUN. C REAL BUFTMP(*) CHARACTER*(*) TFILE CHARACTER*80 TNAME,TLAST LOGICAL QOPEN C INTEGER IDBINT(MDIMMX) REAL ADLOT(MDIMMX),ADHIT(MDIMMX),AMEANT(MDIMMX),ASIGT(MDIMMX) C DATA TLAST/' '/ C IERR = 0 QOPEN = .FALSE. IF(LUNMIN.NE.0) INQUIRE(UNIT=LUNMIN,OPENED=QOPEN) IF(QOPEN .AND. TFILE.NE.TLAST) THEN CLOSE(UNIT=LUNMIN) QOPEN = .FALSE. ENDIF C IF(.NOT.QOPEN .OR. TFILE.NE.TLAST) THEN TNAME = TFILE CALL MN_FIL(41,LUNMIN,TNAME,IDELIM,JERR) IF(JERR.NE.0) GOTO 9100 ELSE REWIND LUNMIN ENDIF C 3300 CONTINUE READ(LUNMIN,ERR=9100,END=9100) NW,(BUFTMP(II),II=1,NW) IDRA = NINT(BUFTMP(4)) IDRB = NINT(BUFTMP(5)) C CALL MN_HDR(BUFTMP(1),NDIMT,NWPPTT,NPNTT + ,NHDATT,NHTIMT,NSDATT,NSTIMT,NTMODT 1 ,EDENTT,EDLOT,EDHIT,IDBINT,ADLOT,ADHIT,NBPPTT,AMEANT,ASIGT) LNBLOK = NINT(BUFTMP(NW-1)) LNREC = NINT(BUFTMP(NW)) NWWT = NINT(BUFTMP(3)) IF(NWWT.EQ.0) NWWT = NPNTT * NWPPTT C C GOT THE PLOT I WANTED SO NOW RETURN C IF(IDRA.EQ.IDA .AND. IDRB.EQ.IDB) THEN GOTO 3450 C C READ THE RECORD WITH THE TITLES AND THEN THE DATA C ELSE READ(LUNMIN,ERR=9100,END=9100) BUFTMP(1) DO 3400 JJ=1,LNREC READ(LUNMIN,ERR=9100,END=9100) BUFTMP(1) 3400 CONTINUE GOTO 3300 ENDIF 3450 CONTINUE C TLAST = TFILE C 9000 CONTINUE RETURN C 9100 CONTINUE IERR = 1 WRITE(TXTERR,'(''Error trying to read in the'' 1 ,'' Ntuple'',I7,I4)') IDA,IDB CALL MN_ERR('MN_MGT',TXTERR) RETURN END +DECK,mn_mnf. SUBROUTINE MN_MNF(IDELIM) C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNFLG. +CDE,MNCMD. +CDE,MNLUN. C INTEGER IDLSA1(100),IDLSA2(100),IDLSB1(100),IDLSB2(100) C IF(IDELIM.EQ.0) THEN NJUNK = INTTYQ(.TRUE.,IDELIM) CALL RESTYQ ENDIF C NDHIS0 = NDHIS C IF(FIL_MN.EQ.' ' .OR. 1 (IDELIM.GT.0 .AND. 2 IDELIM.NE.ICHAR(':') .AND. IDELIM.NE.ICHAR('&'))) THEN CALL MN_FIL(1,LUNMIN,FIL_MN,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 ELSE REWIND LUNMIN ENDIF C NIDL = 0 2000 CONTINUE CALL WAITYQ('Give histogram number(s): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 C IF(NIDL.GE.100) THEN WRITE(LUNTTO,'('' *** MN_MNF: Ran out of space to store plot'' 1 ,'' numbers to get'' 2 ,/,13X,'' Issue MN_FETCH command again to get more plots.'') 2 ') GOTO 3000 ENDIF C NIDL = NIDL + 1 C IF(IDA1.EQ.0 .AND. NNID.EQ.1) THEN C IDB1 = 0 C IDB2 = 999 C END IF IDLSA1(NIDL) = IDA1 IDLSA2(NIDL) = IDA2 IDLSB1(NIDL) = IDB1 IDLSB2(NIDL) = IDB2 C C READ IN THE DATA C REWIND LUNMIN CALL MN_MNR(IDA1,IDA2,IDB1,IDB2,NNID,LUNMIN,FIL_MN) IF(IDELIM.EQ.0) GOTO 2000 3000 CONTINUE C 8000 CONTINUE C C CHECK THAT I GOT THE HISTOGRAMS I WANTED C IF(NNID.EQ.1) THEN NNID = 2 DO 8100 NL=1,NIDL IF(IDLSA1(NL).EQ.0) THEN IDLSB1(NL) = 0 IDLSB2(NL) = 999 ENDIF 8100 CONTINUE ENDIF CALL MN_HNG('MN_MNF',NNID,NDHIS0,NIDL,IDLSA1,IDLSA2 1 ,IDLSB1,IDLSB2) C C MAKE SURE THAT THE 1 AND 2 DIMENSIONAL HISTOGRAMS GET ERRORS C STORED AS WELL C NMODE = 1 err = 0.0 NDH1 = NDHIS0 + 1 NDH2 = NDHIS DO 8500 NH=NDH1,NDH2 IDA = IDIDA(NH) IDB = IDIDB(NH) CALL MN_HGT(IDA,IDB,NH) IF((NDIM.EQ.1 .OR. NDIM.EQ.2) .AND. NWPPT.EQ.1) THEN CALL MN_ERC(IDA,IDB,NMODE,err) ENDIF 8500 CONTINUE C 9000 CONTINUE RETURN END +DECK,mn_mnr. SUBROUTINE MN_MNR(IDA1,IDA2,IDB1,IDB2,NNID,LUN,TFILE) C C ROUTINE FOR READING IN MNBOOK PLOTS C NOTE THAT THEY WILL NOW ALWAYS BE READ INTO MEMORY C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNTMP. +CDE,MNLUN. C +CDE,MNSCR. REAL BUFDAT(100) EQUIVALENCE(SCRATCH(1),BUFDAT(1)) C CHARACTER*(*) TFILE CHARACTER*80 TITLE CHARACTER*32 TNAME(MDIMMX) C INTEGER IDBIN(MDIMMX) REAL ADLO(MDIMMX),ADHI(MDIMMX),AMEAN(MDIMMX),ASIG(MDIMMX) LOGICAL QRNGE C QRNGE = IDA1.NE.IDA2 .OR. IDB1.NE.IDB2 C C READ IN THE HEADER C 1000 CONTINUE READ(LUN,ERR=9100,END=9200) NW,(BUFDAT(II),II=1,NW) NWHEAD = NINT(BUFDAT(2)) NWDAT = NINT(BUFDAT(3)) IDA = NINT(BUFDAT(4)) IDB = NINT(BUFDAT(5)) CALL MN_HDR(BUFDAT(1),NDIM,NWPPT,NPNT + ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,AMEAN,ASIG) LNBLOK = NINT(BUFDAT(NW-1)) LNREC = NINT(BUFDAT(NW)) C C SORT OUT THE NUMBER OF DATA WORDS TO READ IN C IF(NDIM.GT.0) THEN NWW = NWDAT ELSE NWW = NPNT * NWPPT ENDIF C C SEE IF THIS IS THE CORRECT HISTOGRAM C IF((.NOT.QRNGE .AND. 1 (IDA1.EQ.0 .AND. NNID.EQ.1) .OR. 1 (IDA1.EQ.0 .AND. IDB.EQ.IDB1) .OR. 2 (IDA1.EQ.IDA .AND. IDB1.EQ.IDB)) .OR. 4 (QRNGE .AND. 5 (IDA1.EQ.0 .AND. NNID.EQ.1) .OR. 6 (IDA1.EQ.0 .AND. IDB.GE.IDB1 .AND. IDB.LE.IDB2) .OR. 7 (IDA.GE.IDA1 .AND. IDA.LE.IDA2 .AND. 8 IDB.GE.IDB1 .AND. IDB.LE.IDB2))) THEN C C BOOK THE NEW HISTOGRAM C CALL MN_HNW(IDA,IDB,NDIM,NWDAT,NH,NPTRH,NPTRD,NWH + ,NBPPT,NTMODE) IF(NH.LE.0) GOTO 9000 C IF(NDIM.LT.0) THEN NWDAT = NWW BUFDAT(1) = FLOAT(NWHEAD + NWDAT) BUFDAT(3) = FLOAT(NWDAT) ENDIF C C COPY THE HEADER TO THE RIGHT PLACE C CALL UCOPY_r(BUFDAT(1),RDAT(NPTRH),NWHEAD) C C For dimension -1 see if the underflows and overflows are * really stored * IF(NDIM.EQ.-1) THEN IF(NWHEAD.EQ.15 .OR. + NWHEAD.EQ.15+2 .OR. + NWHEAD.EQ.15+2+2 ) THEN *ICB + NWHEAD.EQ.15+2+2+3) THEN RDAT(15+1) = -1.0 RDAT(15+2) = -1.0 RDAT(15+3) = -1.0 IF(NWHEAD.GT.15) + CALL UCOPY_r(BUFDAT(15+1),RDAT(NPTRH+15+3),NWHEAD-15) NWHEAD = NWHEAD + 3 RDAT(NPTRH) = RDAT(NPTRH) + 3 RDAT(NPTRH+1) = RDAT(NPTRH+1) + 3 ENDIF ENDIF C C Zero any header words that have come from header expansion C and fix up the total number of words C IF(NWH.GT.NWHEAD) THEN CALL VZERO_r(RDAT(NPTRH+NWHEAD),NWH-NWHEAD) RDAT(NPTRH) = NWH + NWDAT RDAT(NPTRH+1) = NWH ENDIF C READ(LUN,ERR=9100,END=9300) NBT,LENTIT,LENNAM 1 ,TITLE,(TNAME(II)(1:LENNAM),II=1,IABS(NDIM)) C C READ IN ALL THE POINTS FOR N-DIMENSIONAL HISTOGRAMS AND EITHER C 1 OR 2 DIMENSIONAL SCATTER PLOTS. C ALSO READ IN THE DATA POINTS C FOR A SCATTER PLOT WITH MORE THEN 2 DIMENSIONS C ND1 = NPTRD NWWTOT = 0 DO 2900 JJ=1,LNREC READ(LUN,ERR=9100,END=9300) NNWD 1 ,(RDAT(II),II=ND1,ND1+NNWD-1) ND1 = ND1 + NNWD NWWTOT = NWWTOT + NNWD 2900 CONTINUE C C CHECK THAT WE REALLY READ IN THE NUMBER OF WORDS EXPECTED C IF(NWWTOT.NE.NWW) THEN WRITE(LUNTTO,'('' MN_MNR: Histogram'',I7,I4 1 ,'' I read in'',I6,'' while expecting'',I6,'' words'')') 2 IDA,IDB,NWWTOT,NWW GOTO 3000 ENDIF C C UPDATE THE POINTERS C NWTOT = NWH + NWDAT CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE 1 ,TFILE,' ',TNAME) C 3000 CONTINUE IF(QRNGE .OR. IDA1.EQ.0) GOTO 1000 C C NOT THE RIGHT HISTOGRAM C ELSE READ(LUN) BUFDAT(1) DO 3900 JJ=1,LNREC READ(LUN,ERR=9100,END=9300) BUFDAT(1) 3900 CONTINUE GOTO 1000 ENDIF C 9000 CONTINUE GOTO 9900 C C ERROR FETCHING A PLOT C 9100 CONTINUE WRITE(LUNTTO,'('' *** MN_MNR: Error fetching MNBOOK histogram'' 1 ,I7,I4)') IDA,IDB GOTO 9900 C C END OF FILE READING THE HEADER C 9200 CONTINUE GOTO 9900 C C END OF FILE TRYING TO READ IN DATA C 9300 CONTINUE WRITE(LUNTTO,'('' *** MN_MNR: End of file fetching MNBOOK'' 1 ,'' histogram'',I7,I4)') IDA1,IDB1 GOTO 9900 C 9900 CONTINUE RETURN END +DECK,mn_mns. C SUBROUTINE MN_MNS C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. C LOGICAL QOPEN,QZERO C QOPEN = .FALSE. LUNMOU = 0 CALL MN_FIL(-1,LUNMOU,FIL_MO,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 QOPEN = .TRUE. C 2000 CONTINUE CALL WAITYQ('Give histogram(s) to store (0 for all,' // 1 ' when finished): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 QZERO = .FALSE. IF(NNID.EQ.1 .AND. IDA1.EQ.0) QZERO = .TRUE. C DO 2500 NH=1,NDHIS IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) GOTO 2500 IDA = IDIDA(NH) IDB = IDIDB(NH) IF(IDA1.EQ.0 .OR. 1 (IDA.GE.IDA1 .AND. IDA.LE.IDA2 .AND. 1 IDB.GE.IDB1 .AND. IDB.LE.IDB2)) THEN CALL MN_MNW(IDA,IDB,NNID,LUNMOU) ENDIF 2500 CONTINUE IF(.NOT.QZERO) GOTO 2000 C 9000 CONTINUE IF(QOPEN) THEN CLOSE(UNIT=LUNMOU) CALL CLEO_FRELUN(LUNMOU,'MN_FIL') ENDIF C END +DECK,mn_mnw. C SUBROUTINE MN_MNW(JDA,JDB,NNID,LUN) C C Routine for writing MNBOOK histograms C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNTMP. +CDE,MNLUN. C LOGICAL QERRL,QERRH LOGICAL QTMPRD C NLOOP = 1 IF(JDA.EQ.0) THEN NLOOP = NDHIS ENDIF C DO 3000 NL=1,NLOOP IF(JDA.EQ.0) THEN IDA = IDIDA(NL) IDB = IDIDB(NL) IF(IDPTRH(NL).LE.0 .OR. IDPTRD(NL).LE.0) GOTO 3000 IF(NNID.EQ.2 .AND. JDB.NE.IDB) GOTO 3000 ELSE IDA = JDA IDB = JDB ENDIF CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Plot'',I7,I4,'' does not exist'')') + IDA,IDB CALL MN_ERR('MN_MNW',TXTERR) GOTO 3000 ENDIF C NWH = NINT(RDAT(NPTRH+1)) NWDAT = NINT(RDAT(NPTRH+2)) NWTOT = NWH + NWDAT C IF(NWDAT.LE.0) THEN IF(QMNOPN) THEN REWIND LUNMNU NRECU = 0 NRECG = 0 C C FIND OUT HOW MANY RECORDS THERE ARE FOR THIS PLOT C DO 1300 NN=1,NUBIN IF(IDTA(NN).EQ.IDA .AND. IDTB(NN).EQ.IDB) THEN NTREC = IDWR(NN) GOTO 1310 ENDIF 1300 CONTINUE WRITE(LUNTTO,'('' *** MN_MNW: I expect the data'' 1 ,'' for plot'',I7,I4,'' to be stored in a'' 2 ,'' temporary file'' 3 ,/,13X,''but the file is not open'')') IDA,IDB GOTO 3000 1310 CONTINUE ENDIF C C MAKE SURE THE NUMBER OF POINTS IS FILLED PROPERLY C EDLO = 0.0 EDHI = 0.0 IF(EDENT.GT.0.0) EDHI = 1.0 ELSE CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) C CALL MN_UOF(RDAT(NPTRH),ACONT) C EDLO = 1.0E+30 EDHI = -1.0E+30 DEEL = 0.0 DEEH = 0.0 NERR = 0 DO 2100 II=1,NPNT EE = AMNE(II,NH,NERR) IF(QERRL) DEEL = AMNDEN(II,NH,NERR) DEEH = DEEL IF(QERRH) DEEH = AMNDEP(II,NH,NERR) EDLO = AMIN1(EDLO,EE-DEEL) EDHI = AMAX1(EDHI,EE+DEEH) 2100 CONTINUE ENDIF C CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB + ,NDIM,NWPPT,NPNT,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C QTMPRD = NWDAT.EQ.0 IF(NDIM.GT.0) THEN NWW = NWDAT ELSE NWW = NPNT * NWPPT ENDIF NH1 = NPTRH NH2 = NPTRH + NWH - 1 IF(QTMPRD) THEN NNREC = NTREC ELSE NNREC = (NWW-1)/MNBLOK + 1 ENDIF ANBLK = FLOAT(MNBLOK) ANREC = FLOAT(NNREC) NWT = NWH + 2 WRITE(LUN,ERR=9100) NWT,(RDAT(II),II=NH1,NH2),ANBLK,ANREC LENTIT = LEN(TDTIT(NH)) LENNAM = LEN(TDNAM(1,NH)) NBT = LENTIT + IABS(NDIM)*LENNAM WRITE(LUN,ERR=9100) NBT,LENTIT,LENNAM,TDTIT(NH) 1 ,(TDNAM(II,NH),II=1,IABS(NDIM)) DO 2900 JJ=1,NNREC IF(NDIM.GT.0 .OR. .NOT.QTMPRD) THEN NWD = MIN0(MNBLOK,NWW-(JJ-1)*MNBLOK) ND1 = NPTRD + (JJ-1)*MNBLOK ND2 = ND1 + NWD - 1 WRITE(LUN,ERR=9100) NWD,(RDAT(II),II=ND1,ND2) ELSE IF(QMNOPN .AND. QTMPRD) THEN 2800 CONTINUE NRECU = NRECU + 1 READ(LUNMNU,ERR=9200) IDDA,IDDB,NNWD 1 ,(RTMP(II,1),II=1,NNWD) IF(IDDA.NE.IDA .OR. IDDB.NE.IDB) GOTO 2800 NRECG = NRECG + 1 C IF(NNWD.NE.NWD) THEN C WRITE(LUNTTO,'('' MN_MNW: I expected to read'' C 1 ,'' in'',I6,'' words, but got'',I6 C 2 ,/,9X,'' trying to read record'',I6 C 3 ,'' from the temporary file'' C 4 ,'' for histogram'',I7,I4)') NWD,NNWD,NRECU C 5 ,IDA,IDB C GOTO 2800 C ENDIF WRITE(LUN,ERR=9100) NNWD,(RTMP(II,1),II=1,NNWD) ELSE GOTO 9300 ENDIF 2900 CONTINUE 3000 CONTINUE C 9000 CONTINUE GOTO 9900 C C ERROR WRITING OUT THE HISTOGRAMS C 9100 CONTINUE WRITE(LUNTTO,19100) IDA,IDB 19100 FORMAT(' *** MN_MNW: Error trying to store histogram',I7,I4 1 ,/,13X,'Store will be aborted') GOTO 9900 C C ERROR READING TEMPORARY FILE C 9200 CONTINUE WRITE(LUNTTO,19200) NRECU,IDA,IDB 19200 FORMAT(' *** MN_MNW: Error trying to read record',I6 1 ,' from the temporary file' 2 ,/,13X,'for histogram',I7,I4,' Store will be aborted') GOTO 9900 C C TEMPORARY FILE IS NOT OPEN C 9300 CONTINUE WRITE(LUNTTO,19300) IDA,IDB 19300 FORMAT(' *** MN_MNW: I expect the data for plot',I7,I4 1 ,' to be stored in a temporary file' 2 ,/,13X,'but the file is not open. Store will be aborted') GOTO 9900 C 9900 CONTINUE RETURN END +DECK,mn_msu. SUBROUTINE MN_MSU(IDA,IDB,NDIM1,NWH1,NHI) C C Calls the routine to calculate the means and sigmas of C a plot and puts the data in the header. C This has to be done after MN_PTU because the pointers are not correct C until that time. C If NHI is non-zero use it, otherwise call MN_HGT. C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNLUN. C integer ida,idb,ndim1,nwh1,nhi * integer nh REAL AMEAN1(MDIMMX),ASIG1(MDIMMX) * nh = nhi C C Find the means and sigmas and put them in the header C IF(NDIM1.GT.-3) THEN NN = 12 + 3*IABS(NDIM1) if(ndim1.gt.-3 .and. ndim1.le.3) + nn = nn + 3**iabs(ndim1) IF(NN+2*IABS(NDIM1).GT.NWH1) THEN WRITE(TXTERR,'(''Not enough space in the header of plot'' + ,I7,I4,'' to store the mean and sigma'')') IDA,IDB CALL MN_ERR('MN_MSU',TXTERR) ELSE CALL M_MEAN(IDA,IDB,AMEAN1,ASIG1) if(nh.le.0) then CALL MN_HGT(IDA,IDB,NH) endif DO 2000 II=1,IABS(NDIM1) RDAT(NPTRH + NN + 2*(II-1) + 0) = AMEAN1(II) RDAT(NPTRH + NN + 2*(II-1) + 1) = ASIG1(II) 2000 CONTINUE ENDIF ENDIF C END +DECK,mn_opr. SUBROUTINE MN_OPR C C Subroutine for doing histogram operations, adding, subtracting, C multiplying, dividing scaling and normalizing C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCMD. +CDE,MNFLG. +CDE,MNLUN. C INTEGER IDBIN1(MDIMMX),IDBIN2(MDIMMX) REAL ADLO1(MDIMMX),ADHI1(MDIMMX),ADLO2(MDIMMX),ADHI2(MDIMMX) real acont1(3**3),acont2(3**3),acont3(3**3) C REAL RNUM(10) C CHARACTER*10 THNAM(2) CHARACTER*80 TDFIL3 LOGICAL QERRL1,QERRH1,QERRL2,QERRH2,QERRL3,QERRH3 LOGICAL QRNGE,QENULU C DATA THNAM/'HIST',' '/ C CALL WAITYQ('Give input, output histogram numbers: ') CALL MN_HRN(IDA11,IDA12,IDB11,IDB12,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. 1 COMND1.EQ.'EFFICIENCY'.OR. COMND1.EQ.'AVERAGE') THEN CALL MN_HRN(IDA21,IDA22,IDB21,IDB22,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 ELSE IDA21 = IDA11 IDA22 = IDA12 IDB21 = IDB11 IDB22 = IDB12 ENDIF CALL WAITYQ('Give output histogram numbers: ') CALL MN_HRN(IDA31,IDA32,IDB31,IDB32,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA11.LT.0) THEN WRITE(LUNTTO,'('' Error specifying the histogram numbers'')') IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. 1 COMND1.EQ.'EFFICIENCY'.OR. COMND1.EQ.'AVERAGE') THEN WRITE(LUNTTO,'('' Input histogram numbers'' 1 ,2(I7,'':'',I7,'' &'',I4,'';''))') 1 IDA11,IDA12,IDB11,IDA21,IDA22,IDB21 ELSE WRITE(LUNTTO,'('' Input histogram number'' 1 ,I7,'':'',I7,'' &'',I4,'';'')') 1 IDA11,IDA12,IDB11 ENDIF WRITE(LUNTTO,'('' Output histogram number'' 1 ,I7,'':'',I7,'' &'',I4,'';'')') 1 IDA31,IDA32,IDB31 GOTO 9000 ENDIF IF(IDB11.NE.IDB12 .OR. IDB21.NE.IDB22 .OR. IDB31.NE.IDB32) THEN WRITE(LUNTTO,'('' *** MN_OPR: You can only specify a range'' 1 ,'' of primary identifiers'')') GOTO 9000 ENDIF C C NOW SORT OUT WHAT I HAVE SPECIFIED C QRNGE = IDA11.EQ.0 .OR. IDA11.NE.IDA12 IF(QRNGE) THEN IF(IDA11.NE.IDA21 .OR. IDA11.NE.IDA31 .OR. 1 IDA12.NE.IDA22 .OR. IDA12.NE.IDA32) THEN WRITE(LUNTTO,'('' *** MN_OPR: You must give the same'' 1 ,'' range for all primary identifiers'')') GOTO 9000 ENDIF ENDIF C C CHECK THAT THE HISTOGRAMS EXIST C NNH1 = 0 NLOOP = 0 NDHIS0 = NDHIS 2000 CONTINUE IF(QRNGE) THEN NNH1 = NNH1 + 1 IF(NNH1.GT.NDHIS0) GOTO 9000 IDA1 = IDIDA(NNH1) IDB1 = IDIDB(NNH1) IF(IDPTRH(NNH1).LE.0 .OR. IDPTRD(NNH1).LE.0) GOTO 2000 IF(IDA11.NE.0 .AND. 1 (IDA1.LT.IDA11 .OR. IDA1.GT.IDA12)) GOTO 2000 IF(IDB1.NE.IDB11) GOTO 2000 IDA2 = IDA1 IDA3 = IDA1 IDB2 = IDB21 IDB3 = IDB31 ELSE IDA1 = IDA11 IDA2 = IDA21 IDA3 = IDA31 IDB1 = IDB11 IDB2 = IDB21 IDB3 = IDB31 ENDIF C CALL MN_HGT(IDA1,IDB1,NH1) NPTRH1 = NPTRH NPTRD1 = NPTRD NDIM1 = NDIM NWPPT1 = NWPPT NPNT1 = NPNT NBPPT1 = NBPPT NSDAT1 = NSDATE NSTIM1 = NSTIME NTMOD1 = NTMODE EDENT1 = EDENT EDLO1 = EDLO EDHI1 = EDHI CALL UCOPY_i(IDBIN,IDBIN1,IABS(NDIM)) CALL UCOPY_r(ADLO,ADLO1,IABS(NDIM)) CALL UCOPY_r(ADHI,ADHI1,IABS(NDIM)) call mn_uof(rdat(nptrh1),acont1) IF(NH1.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA1,IDB1 CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF IF(NPNT1.LE.0 .OR. (EDENT1.EQ.0.0 .AND. + COMND1.NE.'ADD' .AND. COMND1.NE.'SUBTRACT' .AND. + COMND1.NE.'MULTIPLY' .AND. COMND1.NE.'DIVIDE' .AND. + COMND1.NE.'SCALE' .AND. + COMND1.NE.'XSHIFT' .AND. COMND1.NE.'XSCALE' .AND. + COMND1.NE.'YSHIFT' .AND. COMND1.NE.'YSCALE' .AND. + COMND1.NE.'ZSHIFT' .AND. COMND1.NE.'ZSCALE' )) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' has no entries'')') IDA1,IDB1 IF(QRNGE) THEN CALL M_EMSG('MN_OPR',TXTERR) GOTO 2000 ELSE CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF ENDIF IF(NDIM1.LT.-1) THEN WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' is an Ntuple'')') IDA1,IDB1 CALL MN_ERR('MN_OPR',TXTERR) IF(QRNGE) THEN CALL M_EMSG('MN_OPR',TXTERR) GOTO 2000 ELSE CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF ENDIF C IF((COMND1.EQ.'ZSHIFT' .OR. COMND1.EQ.'ZSCALE') .AND. + NDIM1.LT.2) THEN WRITE(TXTERR,'(''Plot'',I7,I4,'' is less than 2-D'')') + IDA1,IDA2 IF(QRNGE) THEN CALL M_EMSG('MN_OPR',TXTERR) GOTO 2000 ELSE CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF ENDIF C IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. 1 COMND1.EQ.'EFFICIENCY'.OR. COMND1.EQ.'AVERAGE') THEN CALL MN_HGT(IDA2,IDB2,NH2) NPTRH2 = NPTRH NPTRD2 = NPTRD NDIM2 = NDIM NWPPT2 = NWPPT NPNT2 = NPNT NBPPT2 = NBPPT NSDAT2 = NSDATE NSTIM2 = NSTIME NTMOD2 = NTMODE EDENT2 = EDENT EDLO2 = EDLO EDHI2 = EDHI CALL UCOPY_i(IDBIN,IDBIN2,IABS(NDIM)) CALL UCOPY_r(ADLO,ADLO2,IABS(NDIM)) CALL UCOPY_r(ADHI,ADHI2,IABS(NDIM)) call mn_uof(rdat(nptrh2),acont2) IF(NH2.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA2,IDB2 CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF * * Remove this check as it is not necessary * *ICB IF(NPNT2.LE.0 .OR. (EDENT2.EQ.0.0 .AND. *ICB + COMND1.NE.'ADD' .AND. COMND1.NE.'SUBTRACT' .AND. *ICB + COMND1.NE.'MULTIPLY' .AND. COMND1.NE.'EFFICIENCY')) THEN *ICB WRITE(TXTERR,'(''Histogram'',I7,I4 *ICB 1 ,'' has no entries'')') *ICB 1 IDA2,IDB2 *ICB CALL MN_ERR('MN_OPR',TXTERR) *ICB IF(QRNGE) GOTO 2000 *ICB GOTO 9000 *ICB ENDIF IF(NDIM2.LT.-1) THEN WRITE(TXTERR,'(''Plot'',I7,I4 1 ,'' is an Ntuple'')') IDA2,IDB2 CALL MN_ERR('MN_OPR',TXTERR) IF(QRNGE) GOTO 2000 GOTO 9000 ENDIF ENDIF C C CHECK THAT THE HISTOGRAMS ARE DEFINED THE SAME C IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. 1 COMND1.EQ.'EFFICIENCY'.OR. COMND1.EQ.'AVERAGE') THEN CALL M_HCMP(0,IDA1,IDB1,IDA2,IDB2,IERR) IF(IERR.NE.0) GOTO 9000 ENDIF C NLOOP = NLOOP + 1 IF(.NOT.QRNGE .OR. (QRNGE .AND. NLOOP.EQ.1)) THEN NNUM = 0 RNUM(1) = 1.0 RNUM(2) = 1.0 4000 CONTINUE IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE') THEN CALL WAITYQ('Give scale factor(s) for histograms' // 1 '(=1.0): ') ELSEIF(COMND1.EQ.'EFFICIENCY') THEN GOTO 4500 ELSEIF(COMND1.EQ.'NORMALIZE') THEN IF(.NOT.QRFILE .AND. IDELIM.LT.0) + CALL MN_MES(LUNTTO,'ME' + ,' To normalize to the area of another' // + ' histogram give the command HIST') CALL WAITYQ('Give normalization (=1.0) or' // 1 ' HIST: ') ELSEIF(COMND1.EQ.'SCALE') THEN CALL WAITYQ( 1 'Give scale factor to multiply contents by (=1.0): ') ELSEIF(COMND1.EQ.'AVERAGE') THEN GOTO 4500 ELSEIF(COMND1.EQ.'XSHIFT') THEN CALL WAITYQ('Give amount to shift the x-axis: ') ELSEIF(COMND1.EQ.'XSCALE') THEN CALL WAITYQ('Give amount to scale the x-axis: ') ELSEIF(COMND1.EQ.'YSHIFT') THEN CALL WAITYQ('Give amount to shift the y-axis: ') ELSEIF(COMND1.EQ.'YSCALE') THEN CALL WAITYQ('Give amount to scale the y-axis: ') ELSEIF(COMND1.EQ.'ZSHIFT') THEN CALL WAITYQ('Give amount to shift the z-axis: ') ELSEIF(COMND1.EQ.'ZSCALE') THEN CALL WAITYQ('Give amount to scale the z-axis: ') ENDIF C RVAL = VALTYQ(.TRUE.,IDELIM) C IF(COMND1.EQ.'NORMALIZE' .AND. IDELIM.GT.0) THEN CALL RESTYQ KCMD = ICMTYQ(.TRUE.,JDELIM,THNAM) IF(KCMD.EQ.1) THEN CALL WAITYQ('Give histogram number to normalize to: ') CALL MN_HNO(IDA2,IDB2,KDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA2.LE.0) GOTO 9000 CALL MN_HGT(IDA2,IDB2,NH2) NPTRH2 = NPTRH NPTRD2 = NPTRD NDIM2 = NDIM NWPPT2 = NWPPT NPNT2 = NPNT NBPPT2 = NBPPT NSDAT2 = NSDATE NSTIM2 = NSTIME NTMOD2 = NTMODE EDENT2 = EDENT EDLO2 = EDLO EDHI2 = EDHI CALL UCOPY_i(IDBIN,IDBIN2,IABS(NDIM)) CALL UCOPY_r(ADLO,ADLO2,IABS(NDIM)) CALL UCOPY_r(ADHI,ADHI2,IABS(NDIM)) IF(NH2.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA2,IDB2 CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF IF(IABS(NDIM1).NE.IABS(NDIM2)) THEN WRITE(TXTERR,'(''Histograms'',I7,I4,'';'',I7,I4 1 ,'' do not have the same dimensions'',2I4)') 2 IDA1,IDB1,IDA2,IDB2,NDIM1,NDIM2 CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF RVAL = EDENT2 GOTO 4100 ENDIF ENDIF C CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.GT.0) THEN IF(QRFILE) THEN GOTO 4500 ELSE NNUM = 0 IF(IERR.EQ.2) GOTO 4500 GOTO 4000 ENDIF ENDIF C 4100 CONTINUE NNUM = NNUM + 1 RNUM(NNUM) = RVAL IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE') THEN IF(IDELIM.EQ.0 .AND. NNUM.LT.2) GOTO 4000 ENDIF C 4500 CONTINUE IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE') THEN SCAL1 = 1.0 SCAL2 = 1.0 IF(NNUM.GE.1) SCAL1 = RNUM(1) IF(NNUM.GE.2) SCAL2 = RNUM(2) ELSEIF(COMND1.EQ.'NORMALIZE') THEN ANORM = 1.0 IF(NNUM.GE.1) ANORM = RNUM(1) ELSEIF(COMND1.EQ.'SCALE') THEN SCAL = 1.0 IF(NNUM.GE.1) SCAL = RNUM(1) ELSEIF(COMND1.EQ.'EFFICIENCY') THEN SCAL1 = 1.0 SCAL2 = 1.0 ELSEIF(COMND1.EQ.'AVERAGE') THEN SCAL1 = 1.0 SCAL2 = 1.0 ELSEIF(COMND1.EQ.'XSHIFT') THEN SHIFT = 0.0 IF(NNUM.GE.1) SHIFT = RNUM(1) ELSEIF(COMND1.EQ.'XSCALE') THEN SCALE = 1.0 IF(NNUM.GE.1) SCALE = RNUM(1) ELSEIF(COMND1.EQ.'YSHIFT') THEN SHIFT = 0.0 IF(NNUM.GE.1) SHIFT = RNUM(1) ELSEIF(COMND1.EQ.'YSCALE') THEN SCALE = 1.0 IF(NNUM.GE.1) SCALE = RNUM(1) ELSEIF(COMND1.EQ.'ZSHIFT') THEN SHIFT = 0.0 IF(NNUM.GE.1) SHIFT = RNUM(1) ELSEIF(COMND1.EQ.'ZSCALE') THEN SCALE = 1.0 IF(NNUM.GE.1) SCALE = RNUM(1) ENDIF ENDIF C C NOW DO THE OPERATION C 5000 CONTINUE C C BOOK THE OUTPUT HISTOGRAM C NWRD = NINT(RDAT(NPTRH1+2)) NBPPT3 = 0 NTMOD3 = NTMOD1 CALL MN_HNW(IDA3,IDB3,NDIM1,NWRD,NH3,NPTRH3,NPTRD3,NWH3 + ,NBPPT3,NTMOD3) IF(NH3.LE.0) GOTO 9000 C NDIM3 = NDIM1 NWPPT3 = NWPPT1 NPNT3 = NPNT1 NSDAT3 = NSDAT1 NSTIM3 = NSTIM1 C C SORT OUT THE OFFSETS AND WHETHER ERRORS ARE BOOKED FOR EACH C HISTOGRAM C CALL AMNOFF(NDIM1,NWPPT1,NOFF1,NOFFL1,NOFFH1,QERRL1,QERRH1) CALL AMNOFF(NDIM2,NWPPT2,NOFF2,NOFFL2,NOFFH2,QERRL2,QERRH2) CALL AMNOFF(NDIM3,NWPPT3,NOFF3,NOFFL3,NOFFH3,QERRL3,QERRH3) C C Do not allow asymmetric errors for averaging C IF(COMND1.EQ.'AVERAGE' .AND. + (QERRH1 .OR. QERRH2)) THEN WRITE(TXTERR,'( + ''You cannot average histograms with asymmetric errors'')') CALL MN_ERR('MN_OPR',TXTERR) GOTO 9000 ENDIF C C Set the number of entries starting values C EDENT3 = 0.0 EDLO3 = 1.0E+30 EDHI3 = -1.0E+30 C C If the plot is a histogram and we are scaling or shifting the x-axis C then there is no need to loop over all the points C IF(COMND1.EQ.'XSHIFT' .OR. COMND1.EQ.'XSCALE') THEN IF(COMND1.EQ.'XSHIFT') THEN ADLO1(1) = ADLO1(1) + SHIFT ADHI1(1) = ADHI1(1) + SHIFT ELSEIF(COMND1.EQ.'XSCALE') THEN ADLO1(1) = ADLO1(1) * SCALE ADHI1(1) = ADHI1(1) * SCALE ENDIF EDENT3 = EDENT1 EDLO3 = EDLO1 EDHI3 = EDHI1 call ucopy_r(acont1,acont3,3**min0(3,iabs(ndim))) IF(NDIM1.GT.0) THEN NWDAT = NPNT3 * NWPPT3 CALL UCOPY_r(RDAT(NPTRD1),RDAT(NPTRD3),NWDAT) GOTO 6000 ENDIF ENDIF C IF((COMND1.EQ.'YSHIFT' .OR. COMND1.EQ.'YSCALE') .AND. + NDIM.GT.1) THEN IF(COMND1.EQ.'YSHIFT') THEN ADLO1(2) = ADLO1(2) + SHIFT ADHI1(2) = ADHI1(2) + SHIFT ELSEIF(COMND1.EQ.'YSCALE') THEN ADLO1(2) = ADLO1(2) * SCALE ADHI1(2) = ADHI1(2) * SCALE ENDIF EDENT3 = EDENT1 EDLO3 = EDLO1 EDHI3 = EDHI1 call ucopy_r(acont1,acont3,3**min0(3,iabs(ndim))) NWDAT = NPNT3 * NWPPT3 CALL UCOPY_r(RDAT(NPTRD1),RDAT(NPTRD3),NWDAT) GOTO 6000 ENDIF C IF((COMND1.EQ.'ZSHIFT' .OR. COMND1.EQ.'ZSCALE') .AND. + NDIM.GT.2) THEN IF(COMND1.EQ.'ZSHIFT') THEN ADLO1(3) = ADLO1(3) + SHIFT ADHI1(3) = ADHI1(3) + SHIFT ELSEIF(COMND1.EQ.'ZSCALE') THEN ADLO1(3) = ADLO1(3) * SCALE ADHI1(2) = ADHI1(3) * SCALE ENDIF EDENT3 = EDENT1 EDLO3 = EDLO1 EDHI3 = EDHI1 call ucopy_r(acont1,acont3,3**min0(3,iabs(ndim))) NWDAT = NPNT3 * NWPPT3 CALL UCOPY_r(RDAT(NPTRD1),RDAT(NPTRD3),NWDAT) GOTO 6000 ENDIF C DEEL1 = 0.0 DEEH1 = 0.0 DEEL2 = 0.0 DEEH2 = 0.0 DEEL3 = 0.0 DEEH3 = 0.0 NERR = 0 C C If 0 points are supposed to have errors of one, then only add these C on operations between histogtams and not when scaling or normalizing C IF(QENULL .AND. + (COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. + COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. + COMND1.EQ.'EFFICIENCY'.OR. COMND1.EQ.'AVERAGE')) THEN QENULU = .TRUE. ELSE QENULU = .FALSE. ENDIF C DO 5500 II=1,NPNT3 NPTR1 = NPTRD1 + NWPPT1*(II-1) - 1 NPTR3 = NPTRD3 + NWPPT3*(II-1) - 1 C EE1 = AMNE(II,NH1,NERR) IF(QERRL1) THEN DEEL1 = AMNDEN(II,NH1,NERR) IF(QENULU .AND. EE1.EQ.0.0 .AND. DEEL1.EQ.0.0) DEEL1=1.0 ENDIF IF(QERRH1) THEN DEEH1 = AMNDEP(II,NH1,NERR) IF(QENULU .AND. EE1.EQ.0.0 .AND. DEEH1.EQ.0.0) DEEH1=1.0 ENDIF C IF(COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. 1 COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. 1 COMND1.EQ.'EFFICIENCY'.OR. COMND1.EQ.'AVERAGE') THEN C EE2 = AMNE(II,NH2,NERR) IF(QERRL2) THEN DEEL2 = AMNDEN(II,NH2,NERR) IF(QENULU .AND. EE2.EQ.0.0 .AND. DEEL2.EQ.0.0) 1 DEEL2 = 1.0 ENDIF IF(QERRH2) THEN DEEH2 = AMNDEP(II,NH2,NERR) IF(QENULU .AND. EE2.EQ.0.0 .AND. DEEH2.EQ.0.0) 1 DEEH2 = 1.0 ELSEIF(QERRH1) THEN DEEH2 = DEEL2 ENDIF ENDIF C IF(COMND1.EQ.'ADD') THEN EE3 = SCAL1*EE1 + SCAL2*EE2 IF(QERRL3) DEEL3 = 1 SQRT((SCAL1*DEEL1)**2 + (SCAL2*DEEL2)**2) IF(QERRH3) DEEH3 = 1 SQRT((SCAL1*DEEH1)**2 + (SCAL2*DEEH2)**2) ELSEIF(COMND1.EQ.'SUBTRACT') THEN EE3 = SCAL1*EE1 - SCAL2*EE2 IF(QERRL3) DEEL3 = 1 SQRT((SCAL1*DEEL1)**2 + (SCAL2*DEEL2)**2) IF(QERRH3) DEEH3 = 1 SQRT((SCAL1*DEEH1)**2 + (SCAL2*DEEH2)**2) ELSEIF(COMND1.EQ.'MULTIPLY') THEN EE3 = SCAL1*EE1 * SCAL2*EE2 IF(QERRL3) DEEL3 = SCAL1 * SCAL2 * 1 SQRT((DEEL1*EE2)**2 + (DEEL2*EE1)**2) IF(QERRH3) DEEH3 = SCAL1 * SCAL2 * 1 SQRT((DEEH1*EE2)**2 + (DEEH2*EE1)**2) ELSEIF(COMND1.EQ.'DIVIDE') THEN IF(EE2.NE.0.0 .AND. SCAL2.NE.0.0) THEN EE3 = (SCAL1*EE1) / (SCAL2*EE2) IF(QERRL3) DEEL3 = SCAL1 / SCAL2 * 1 SQRT((DEEL1/EE2)**2 + (DEEL2*EE1/EE2**2)**2) IF(QERRH3) DEEL3 = SCAL1 / SCAL2 * 1 SQRT((DEEL1/EE2)**2 + (DEEH2*EE1/EE2**2)**2) IF(QERRH3) DEEH3 = SCAL1 / SCAL2 * 1 SQRT((DEEH1/EE2)**2 + (DEEL2*EE1/EE2**2)**2) ELSE EE3 = 0.0 DEEL3 = 0.0 DEEH3 = 0.0 ENDIF ELSEIF(COMND1.EQ.'EFFICIENCY') THEN EE3 = 0.0 DEEL3 = 0.0 C C Use error formula from Frank Linde C C EE3F = (EE1+1.0) / (EE2+2.0) C DISC = (EE1+1.0) * (EE2-EE1+1.0) / C + ((EE2+3.0) * (EE2+2.0)**2) C IF(DISC.GE.0.0) DEEL3F = SQRT(DISC) C C Use the MULFIT formula from Paul Avery for the error on C the efficiency which is more correct for low statistics C IF(EE2.GT.0.0) THEN EE3 = EE1 / EE2 DISC = (1.0/EE2 * (EE3 + 1.0/EE2) * 1 (1.0-EE3 + 1.0/EE2) / 1 ((1+2.0/EE2)**2 * (1.0+3.0/EE2))) IF(DISC.GE.0.0) THEN DEEL3 = SQRT(DISC) C C For EFF = 0 or 1 add to error the value of the C unbiased estimate of Y1/Y2. This will give a better C estimate of the confidence interval C IF(EE3.EQ.0.0 .OR. EE3.EQ.1.0) DEEL3 = 1 (1.0/EE2) / (1.0+2.0/EE2) + DEEL3 ENDIF ENDIF DEEH3 = DEEL3 ELSEIF(COMND1.EQ.'NORMALIZE') THEN EE3 = ANORM / EDENT1 * EE1 IF(QERRL3) DEEL3 = ANORM / EDENT1 * DEEL1 IF(QERRH3) DEEH3 = ANORM / EDENT1 * DEEH1 ELSEIF(COMND1.EQ.'SCALE') THEN EE3 = SCAL * EE1 IF(QERRL3) DEEL3 = SCAL * DEEL1 IF(QERRH3) DEEH3 = SCAL * DEEH1 ELSEIF(COMND1.EQ.'AVERAGE') THEN IF(DEEL1.NE.0.0 .AND. DEEL2.NE.0.0) THEN DEEL3I = 1.0 / DEEL1**2 + 1.0 / DEEL2**2 EE3 = (EE1 / DEEL1**2 + EE2 / DEEL2**2) / DEEL3I DEEL3 = 1.0 / SQRT(DEEL3I) ELSEIF(DEEL1.NE.0.0) THEN DEEL3I = 1.0 / DEEL1**2 EE3 = EE1 DEEL3 = DEEL1 ELSEIF(DEEL2.NE.0.0) THEN DEEL3I = 1.0 / DEEL2**2 EE3 = EE2 DEEL3 = DEEL2 ELSE DEEL3 = 0.0 EE3 = 0.0 ENDIF ELSEIF(COMND1.EQ.'YSHIFT' .OR. COMND1.EQ.'ZSHIFT') THEN EE3 = EE1 + SHIFT IF(QERRL3) DEEL3 = DEEL1 IF(QERRH3) DEEH3 = DEEH1 ELSEIF(COMND1.EQ.'YSCALE' .OR. COMND1.EQ.'ZSCALE') THEN EE3 = EE1 * SCALE IF(QERRL3) DEEL3 = DEEL1 * SCALE IF(QERRH3) DEEH3 = DEEH1 * SCALE ENDIF C IF(COMND1.EQ.'XSHIFT') THEN RDAT(NPTR3+1) = RDAT(NPTR1+1) + SHIFT CALL UCOPY_r(RDAT(NPTR1+2),RDAT(NPTR3+2),NWPPT3-1) ELSEIF(COMND1.EQ.'XSCALE') THEN RDAT(NPTR3+1) = RDAT(NPTR1+1) * SCALE CALL UCOPY_r(RDAT(NPTR1+2),RDAT(NPTR3+2),NWPPT3-1) ELSE IF(.NOT.QERRH3) DEEH3 = DEEL3 EDLO3 = AMIN1(EDLO3,EE3-DEEL3) EDHI3 = AMAX1(EDHI3,EE3+DEEH3) EDENT3 = EDENT3 + EE3 IF(NDIM3.LT.0) 1 CALL UCOPY_r(RDAT(NPTR1+1),RDAT(NPTR3+1),NWPPT3) CALL UMNE(II,NH3,NPTRD3,NDIM3,NWPPT3,NBPPT3,EE3,NERR) IF(QERRL3) 1 CALL UMNDEL(II,NH3,NPTRD3,NDIM3,NWPPT3,NBPPT3,DEEL3,NERR) IF(QERRH3) 1 CALL UMNDEH(II,NH3,NPTRD3,NDIM3,NWPPT3,NBPPT3,DEEH3,NERR) ENDIF 5500 CONTINUE * * Now update the contents also * do i=1,3**min0(3,iabs(ndim)) if(comnd1.eq.'ADD') then acont3(i) = scal1*acont1(i) + scal2*acont2(i) elseif(comnd1.eq.'SUBTRACT') then acont3(i) = scal1*acont1(i) - scal2*acont2(i) elseif(comnd1.eq.'MULTIPLY') then acont3(i) = scal1*acont1(i) * scal2*acont2(i) elseif(comnd1.eq.'DIVIDE' .or. comnd1.eq.'EFFICIENCY') then if(acont2(i).ne.0.0 .and. scal2.ne.0.0) then acont3(i) = (scal1 * acont1(i)) / (scal2 * acont2(i)) else acont3(i) = 0.0 endif elseif(comnd1.eq.'NORMALIZE') then acont3(i) = anorm / edent1 * acont1(i) elseif(comnd1.eq.'SCALE') then acont3(i) = scal * acont1(i) elseif(comnd1.eq.'YSHIFT' .or. comnd1.eq.'ZSHIFT') then if(iabs(ndim).eq.1 .and. i.eq.2) then acont3(i) = acont1(i) + shift * float(npnt3) elseif(ndim.eq.2 .and. i.eq.5) then acont3(i) = acont1(i) + shift * float(npnt3) elseif(ndim.eq.3 .and. i.eq.14) then acont3(i) = acont1(i) + shift * float(npnt3) elseif(acont1(i).ne.0.0) then acont3(i) = shift + acont1(i) else acont3(i) = acont1(i) endif elseif(comnd1.eq.'YSCALE' .or. comnd1.eq.'ZSCALE') then acont3(i) = scale * acont1(i) elseif(comnd1.eq.'AVERAGE') then if(iabs(ndim).eq.1 .and. i.eq.2) then acont3(i) = edent3 elseif(ndim.eq.2 .and. i.eq.5) then acont3(i) = edent3 elseif(ndim.eq.3 .and. i.eq.14) then acont3(i) = edent3 else acont3(i) = 0.0 endif endif enddo C 6000 CONTINUE C C NOW UPDATE THE HEADER C NWDAT = NPNT3 * NWPPT3 NWTOT = NWH3 + NWDAT CALL M_RTIM(NHDAT3,NHTIM3) CALL MN_HDU(RDAT(NPTRH3),NWTOT,NWH3,NWDAT,IDA3,IDB3 + ,NDIM3,NWPPT3,NPNT3,NHDAT3,NHTIM3,NSDAT3,NSTIM3,NTMOD3 + ,EDENT3,EDLO3,EDHI3,IDBIN1,ADLO1,ADHI1,NBPPT3,ACONT3) C IF((COMND1.EQ.'ADD' .OR. COMND1.EQ.'SUBTRACT' .OR. + COMND1.EQ.'MULTIPLY' .OR. COMND1.EQ.'DIVIDE' .OR. + COMND1.EQ.'EFFICIENCY')) then if(TDFIL(NH1).NE.TDFIL(NH2)) THEN TDFIL3 = 'Generated internally' ELSE TDFIL3 = TDFIL(NH1) ENDIF else TDFIL3 = TDFIL(NH1) endif CALL MN_PTU(NH3,NWTOT,IDA3,IDB3,NPTRH3,NPTRD3,TDTIT(NH1) 1 ,TDFIL3,' ',TDNAM(1,NH1)) CALL MN_MSU(IDA3,IDB3,NDIM3,NWH3,NH3) C IF(QRNGE) GOTO 2000 C 9000 CONTINUE RETURN END +DECK,mn_pcp. SUBROUTINE MN_PCP(NPI,NPO) C C COPIES ALL THE PLOT PARAMETERS TO ANOTHER POSITION C INCLUDING COMMENTS AND KEYS C +CDE,MNPAR. +CDE,MNHPJ. C IPLTIA(NPO) = IPLTIA(NPI) IPLTIB(NPO) = IPLTIB(NPI) IPLTSY(NPO) = IPLTSY(NPI) IPLTHA(NPO) = IPLTHA(NPI) IPLTPA(NPO) = IPLTPA(NPI) IPLTCO(1,NPO) = IPLTCO(1,NPI) IPLTCO(2,NPO) = IPLTCO(2,NPI) IPLTCO(3,NPO) = IPLTCO(3,NPI) IPLTFL(NPO) = IPLTFL(NPI) IPLTCL(NPO) = IPLTCL(NPI) IPLTLG(NPO) = IPLTLG(NPI) C C LEGO PLOT ANGLES C CALL UCOPY_r(ALEGP(1,NPI),ALEGP(1,NPO),10) C C SIZES AND MARGINS C AMRGP(1,NPO) = AMRGP(1,NPI) AMRGP(2,NPO) = AMRGP(2,NPI) HSZEP(1,NPO) = HSZEP(1,NPI) HSZEP(2,NPO) = HSZEP(2,NPI) C IF(QWIND) THEN IPWNDP(1,NPO) = IPWNDP(1,NPI) IPWNDP(2,NPO) = IPWNDP(2,NPI) ENDIF WMRGP(1,NPO) = WMRGP(1,NPI) WMRGP(2,NPO) = WMRGP(2,NPI) WSZEP(1,NPO) = WSZEP(1,NPI) WSZEP(2,NPO) = WSZEP(2,NPI) C C PLOT LIMITS C CALL UCOPY_r(ALIMP(1,1,NPI),ALIMP(1,1,NPO),2*3) C C DRAW LINE AT X OR Y = 0 C QZEROP(1,NPO) = QZEROP(1,NPI) QZEROP(2,NPO) = QZEROP(2,NPI) IZEROP(1,NPO) = IZEROP(1,NPI) IZEROP(2,NPO) = IZEROP(2,NPI) C C Draw a grid C IGRIDP(1,1,NPO) = IGRIDP(1,1,NPI) IGRIDP(2,1,NPO) = IGRIDP(2,1,NPI) IGRIDP(1,2,NPO) = IGRIDP(1,2,NPI) IGRIDP(2,2,NPO) = IGRIDP(2,2,NPI) IGRIDP(1,3,NPO) = IGRIDP(1,3,NPI) IGRIDP(2,3,NPO) = IGRIDP(2,3,NPI) C C TEXT AND SYMBOL SIZES C CALL UCOPY_r(TSZEP(1,NPI),TSZEP(1,NPO),10) C C COLOURS C CALL UCOPY_i(ICOLP(1,NPI),ICOLP(1,NPO),20) C C LINE THICKNESSES C CALL UCOPY_r(ATHKP(1,NPI),ATHKP(1,NPO),10) C C Fonts C CALL UCOPY_i(IFNTP(1,NPI),IFNTP(1,NPO),10) C C Bin scale factor and offset C CALL UCOPY_r(ABINP(1,NPI),ABINP(1,NPO),10) C C FRAME ROUND THE PLOT C CALL QCOPY(QFRAMP(1,1,NPI),QFRAMP(1,1,NPO),10*3) C C TICKS C CALL UCOPY_r(TICKP(1,1,NPI),TICKP(1,1,NPO),10*3) CALL QCOPY(QTICKP(1,1,NPI),QTICKP(1,1,NPO),10*3) C C SCALE C CALL UCOPY_i(ISMODP(1,NPI),ISMODP(1,NPO),3) CALL UCOPY_r(SCALP(1,1,NPI),SCALP(1,1,NPO),10*3) CALL QCOPY(QSCALP(1,1,NPI),QSCALP(1,1,NPO),10*3) C C LABELS C CALL UCOPY_r(ALABLP(1,1,NPI),ALABLP(1,1,NPO),10*3) CALL QCOPY(QLABLP(1,1,NPI),QLABLP(1,1,NPO),10*3) CALL UCOPY_i(ILABLP(1,NPI),ILABLP(1,NPO),3) CALL TCOPY(TLABLP(1,NPI),TLABLP(1,NPO),3) C C TITLE POSITION AND OPTIONS C CALL UCOPY_r(TITLP(1,NPI),TITLP(1,NPO),10) CALL UCOPY_r(TITGP(1,NPI),TITGP(1,NPO),10) CALL QCOPY(QTITLP(1,NPI),QTITLP(1,NPO),10) C C COMMENTS C NPLTCM(NPO) = NPLTCM(NPI) CALL UCOPY_i(IPLTCM(1,NPI),IPLTCM(1,NPO),NPLTCM(NPI)) CALL TCOPY(TPLTCM(1,NPI),TPLTCM(1,NPO),NPLTCM(NPI)) CALL UCOPY_r(RPLTCM(1,1,NPI),RPLTCM(1,1,NPO),10*NPLTCM(NPI)) C C KEYS C NPLTKY(NPO) = NPLTKY(NPI) CALL UCOPY_i(IPLTKY(1,NPI),IPLTKY(1,NPO),NPLTKY(NPI)) CALL TCOPY(TPLTKY(1,NPI),TPLTKY(1,NPO),NPLTKY(NPI)) CALL UCOPY_r(RPLTKY(1,1,NPI),RPLTKY(1,1,NPO),10*NPLTKY(NPI)) C C Interface to IGTABL C NIGPARP(NPO) = NIGPARP(NPI) CALL UCOPY_r(AIGPARP(1,NPI),AIGPARP(1,NPO),MIGPAR) TIGOPTP(NPO) = TIGOPTP(NPI) LIGOPTP(NPO) = LIGOPTP(NPI) C C Parameters for special displays - implemented for L3 C CALL MN_DCP(NPI,NPO) C RETURN END +DECK,mn_plh. SUBROUTINE MN_PLH(IDA,IDB,NP,NTYPFL,NOVEFL,NDERR) C C NTYPFL + Ordinary plot C NTYPFL - Fit plot C NTYPFL = 0 Draw the latest plot C NTYPFL = 1 Draw all the stored plots C NTYPFL = 2 Redraw C NTYPFL = 3 Hardcopy C C NOVEFL = 1 Draw an ordinary plot C NOVEFL = 2 or 3 Overlay another picture C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFIT. +CDE,MNINF. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNGRN. +CDE,MNLUN. C LOGICAL QFIT C DATA NCALL/0/ C QFIT = .FALSE. NH = 0 C C FIT PLOT C FIRST PLOT IN A DISPLAY IS ALWAYS THE PLOT WE ARE FITTING C IF(NTYPFL.LT.0 .AND. NCLRU.EQ.1) THEN QFIT = .TRUE. CALL MN_FGT(IDA,IDB,NH) IF(NH.GT.0) GOTO 1000 ENDIF C C ALL OTHERS C QFIT = .FALSE. CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN IERR = 3 GOTO 9100 ENDIF C 1000 CONTINUE NCALL = NCALL + 1 C C DECIDE WHETHER TO ASK FOR A C IF(NCALL.GT.1 .AND. NCLRU.EQ.1 .AND. IABS(NTYPFL).NE.3) THEN IF((.NOT.QRFILE .AND. NP.NE.1) .OR. 1 (QRFILE .AND. 1 ((QSAMDV .AND. QASWCH) .OR. (.NOT.QSAMDV))) .OR. 1 (QSAMDV .AND. NTYPFL.EQ.-1 .AND. NP.EQ.1)) THEN IF(QAWAIT) THEN CALL MN_CRT(0,' ',IERR) IF(IERR.NE.0) NDERR = -1 IF(IERR.NE.0) GOTO 9000 ENDIF ENDIF ENDIF C IF(QFIT) THEN CALL MN_UOF(RFIT(NPTRH),ACONT) CALL MN_PLT(IDA,IDB,RFIT(NPTRD),NDIM,NWPPT,NPNT,NOVEFL 1 ,TFTIT(NH),TFFIL(NH),NHDATE,NHTIME,NSDATE,NSTIME,NTMODE 2 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,AMEAN,ASIG,ACONT,IERR) ELSE CALL MN_UOF(RDAT(NPTRH),ACONT) CALL MN_PLT(IDA,IDB,RDAT(NPTRD),NDIM,NWPPT,NPNT,NOVEFL 1 ,TDTIT(NH),TDFIL(NH),NHDATE,NHTIME,NSDATE,NSTIME,NTMODE 2 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,AMEAN,ASIG,ACONT,IERR) ENDIF C IF(IERR.GT.0) GOTO 9100 C 9000 CONTINUE RETURN C 9100 CONTINUE C C WRITE OUT ERROR MESSAGE C CALL MN_TOF(.FALSE.) IF(IERR.EQ.1) THEN WRITE(TXTERR,91100) IDA,IDB 91100 FORMAT('Histogram',I7,I4,' Error in plot limits.') CALL M_EMSG('MN_PLH',TXTERR) CALL M_EMSG('MN_PLH' + ,'Probably the histogram has no entries or') CALL M_EMSG('MN_PLH','you have' // + ' incorrectly specified the limits for a log scale.') C CALL MN_ERR('MN_PLH','To display this histogram you must' // C + ' set the limits manually') ierr = 0 GOTO 9000 ELSEIF(IERR.EQ.2) THEN WRITE(TXTERR,91200) IDA,IDB 91200 FORMAT('Histogram',I7,I4 1 ,' I can only plot 1 or 2-dimensional histograms') CALL M_EMSG('MN_PLH',TXTERR) WRITE(TXTERR,'(''You asked for a'',I3,''-dimensional one'')') + NDIM CALL MN_ERR('MN_PLH',TXTERR) ELSEIF(IERR.EQ.3) THEN WRITE(TXTERR,91300) IDA,IDB 91300 FORMAT('Histogram',I7,I4,' does not exist') CALL MN_ERR('MN_PLH',TXTERR) ELSEIF(IERR.EQ.4) THEN WRITE(TXTERR,91400) IDA,IDB 91400 FORMAT('Histogram',I7,I4,' is not 2-dimensional' + ,' so you cannot LEGO plot it') CALL MN_ERR('MN_PLH',TXTERR) ELSEIF(IERR.EQ.6) THEN WRITE(TXTERR,91600) 91600 FORMAT('Log scale not allowed for x or y axis' + ,' of a lego or surface plot') CALL MN_ERR('MN_PLH',TXTERR) ENDIF C C SET WINDOW NUMBER BACK IF WE HAD AN ERROR C IF(QWIND .AND. NOVEFL.EQ.1 .AND. 1 (IABS(NTYPFL).EQ.0 .OR. IABS(NTYPFL).EQ.1)) THEN IF(IPWNDS(1).GT.1) THEN IPWNDS(1) = IPWNDS(1) - 1 ELSEIF(IPWNDS(2).GT.1) THEN IPWNDS(2) = IPWNDS(2) - 1 IPWNDS(1) = IWIND(1) ELSE IPWNDS(1) = 0 IPWNDS(2) = 0 ENDIF ENDIF C RETURN END +DECK,mn_ppp. SUBROUTINE MN_PPP (IDA,IDB,IERR) C C STORES IN XPLO,XPHI ETC THE LIMITS FOR A PARTICULAR PLOT C USED WHEN DRAWING IN TERMS OF PLOT CO-ORDINATES C +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNLUN. C IERR = 0 DO 1000 NP=1,NHPLT IF(IDA.EQ.IPLTIA(NP) .AND. IDB.EQ.IPLTIB(NP)) THEN C C PLOT POSITIONS C IF(IPLTFL(NP).EQ.1 .AND. IPLTCL(NP).EQ.0 .AND. + WSZEP(1,NP).GT.0.0 .AND. WSZEP(2,NP).GT.0.0) THEN XPLO = AMRGP(1,NP) + WMRGP(1,NP) XPHI = AMRGP(1,NP) + WMRGP(1,NP) + WSZEP(1,NP) YPLO = AMRGP(2,NP) + WMRGP(2,NP) YPHI = AMRGP(2,NP) + WMRGP(2,NP) + WSZEP(2,NP) ELSEIF(QWIND) THEN XPLO = AMRGP(1,NP) + WMRGP(1,NP) XPHI = AMRGP(1,NP) + WMRGP(1,NP) + WSZEP(1,NP) YPLO = AMRGP(2,NP) + WMRGP(2,NP) YPHI = AMRGP(2,NP) + WMRGP(2,NP) + WSZEP(2,NP) ELSE XPLO = AMRGP(1,NP) XPHI = AMRGP(1,NP) + HSZEP(1,NP) YPLO = AMRGP(2,NP) YPHI = AMRGP(2,NP) + HSZEP(2,NP) ENDIF C C PLOT LIMITS C XLO = ALIMP(1,1,NP) XHI = ALIMP(2,1,NP) YLO = ALIMP(1,2,NP) YHI = ALIMP(2,2,NP) ZLO = ALIMP(1,3,NP) ZHI = ALIMP(2,3,NP) if(ismodp(3,np).eq.2 .and. zlo.gt.0.0) then zllo= 10.0**int(alog10(zlo)) else zllo= zlo endif C GOTO 1010 ENDIF 1000 CONTINUE WRITE(TXTERR,'('' Plot'',I7,I4,'' is not being plotted'')') 1 IDA,IDB CALL MN_ERR('MN_PPP',TXTERR) IERR = 1 1010 CONTINUE C RETURN END +DECK,mn_prn. C SUBROUTINE MN_PRN(IDA1,IDA2,IDB1,IDB2,NNID,NMODE) C C DETAILED MN_FIT ROUTINE FOR PRINTING HISTOGRAMS C NMODE = 0 MEANS ROUTINE IS CALLED FROM MN_FIT C NMODE = 1 MEANS ROUTINE IS CALLED FROM MNBOOK C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCMD. +CDE,MNLUN. C LOGICAL QMNHEX,HEXIST,QEXIST,QHEXST LOGICAL QRNGE C IF(IDA1.NE.0 .AND. IDA1.EQ.IDA2 .AND. IDB1.EQ.IDB2) THEN NH = 0 QEXIST = QMNHEX(IDA1,IDB1,NH) IF(.NOT.QEXIST) THEN WRITE(LUNTTO 1 ,'('' Histogram'',I7,I4,'' does not exist'')') 2 IDA1,IDB1 GOTO 9000 ENDIF NH1 = NH NH2 = NH QRNGE = .FALSE. ELSE NH1 = 1 NH2 = NDHIS QRNGE = .TRUE. ENDIF C DO 2500 NH=NH1,NH2 IDA = IDIDA(NH) IDB = IDIDB(NH) IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) GOTO 2500 IF(QRNGE .AND. IDA1.NE.0 .AND. 1 (IDA.LT.IDA1 .OR. IDA.GT.IDA2 .OR. 2 IDB.LT.IDB1 .OR. IDB.GT.IDB2)) GOTO 2500 C CALL MN_HGT(IDA,IDB,NHD) C + ,NPTRH,NPTRD,NDIM,NWPPT,NPNT C 1 ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT) IF(NHD.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 2 ,'' does not exist'')') IDA,IDB CALL M_EMSG('MN_PRN',TXTERR) IF(.NOT.QRNGE) GOTO 9000 GOTO 2500 ENDIF IF(.NOT.QRNGE .AND. NDIM.EQ.-1) THEN IF(TDDIR(NHD).NE.'//MN_HBIN') THEN WRITE(TXTERR,'(''Histogram'',I7,I4,'':'' 1 ,'' I cannot print a series of data points'')') + IDA,IDB CALL M_EMSG('MN_PRN',TXTERR) GOTO 2500 ENDIF ELSEIF(.NOT.QRNGE .AND. NDIM.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4,'':'' 1 ,'' I cannot print scatter plots'')') IDA,IDB CALL M_EMSG('MN_PRN',TXTERR) GOTO 2500 ELSEIF(.NOT.QRNGE .AND. NDIM.GT.2) THEN WRITE(TXTERR,'(''Histogram'',I7,I4,'':'' 1 ,'' I cannot print histograms with more'' 1 ,'' than 2 dimensions'')') IDA,IDB CALL M_EMSG('MN_PRN',TXTERR) GOTO 2500 ENDIF C cicb IDH = IDB*1000 + IDA IDH = IDA QHEXST = .FALSE. QEXIST = .FALSE. IF(NMODE.EQ.1 .AND. HEXIST(IDH)) THEN QHEXST = .TRUE. CALL HCOPY(IDH,987654,' ') CALL HDELET(IDH) ENDIF C IF(NMODE.EQ.0 .OR. NMODE.EQ.1) THEN CALL MN_HBN(IDA,IDB,IERR) IF(.NOT.HEXIST(IDH)) GOTO 2500 QEXIST = .TRUE. ENDIF C C PRINT THE HISTOGRAM C IF(NMODE.EQ.0) THEN IF(LUNDMP.EQ.LUNTTO) THEN NLINE = 31 ELSE NLINE = 61 ENDIF CALL HPAGSZ(NLINE) CALL HIDOPT(IDH,'ROTA') ENDIF C CALL HPRINT(IDH) C IF(QEXIST) THEN CALL HDELET(IDH) ENDIF C IF(QHEXST) THEN CALL HCOPY(987654,IDH,' ') CALL HDELET(987654) ENDIF 2500 CONTINUE C 9000 CONTINUE RETURN END +DECK,mn_prt. SUBROUTINE MN_PRT C C EITHER PARTITIONS OR REBINS A HISTOGRAM C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCMD. +CDE,MNLUN. C INTEGER IFBIN(MDIMMX),IPLO(MDIMMX),IPHI(MDIMMX) REAL AFLO(MDIMMX),AFHI(MDIMMX) INTEGER IPCMB(MDIMMX) C CHARACTER*255 TEXT,CONCAT INTEGER INUM(10),lent REAL RNUM(10) LOGICAL QERRL,QERRH integer lnblnk LOGICAL HEXIST external lnblnk,hexist C CALL WAITYQ('Give histogram number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(IDA.LE.0) GOTO 9000 C C SEE IF HISTOGRAM EXISTS C CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_PRT',TXTERR) GOTO 9000 ENDIF C C CHECK WHETHER I CAN CARRY OUT THE OPERATION C IF(IABS(NDIM).GT.2) THEN IF(COMND1.EQ.'PARTITION') THEN CALL MN_ERR('MN_PRT' + ,'I can only partition 1 or 2-dimensional histograms') ELSEIF(COMND1.EQ.'REBIN') THEN CALL MN_ERR('MN_PRT' + ,'I can only rebin 1 or 2-dimensional histograms') ENDIF GOTO 9000 ELSE IF(COMND1.EQ.'PARTITION' .AND. NDIM.EQ.-2) THEN CALL MN_ERR('MN_PRT' + ,'I cannot partition a true scatter plot.' // + ' Use the PROJECT command instead') GOTO 9000 ELSE IF(COMND1.EQ.'REBIN' .AND. NDIM.LT.0) THEN CALL MN_ERR('MN_PRT' + ,'I can only rebin binned histograms.') CALL MN_ERR('MN_PRT' + ,'Use the project command to make a binned from' // + ' from an unbinned plot') GOTO 9000 ENDIF C CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) C C GET PARTITION LIMITS C IF(COMND1.EQ.'PARTITION') THEN DO 2500 NAX=1,IABS(NDIM) AFLO(NAX) = ADLO(NAX) AFHI(NAX) = ADHI(NAX) TEXT = CONCAT(TDNAM(NAX,NH),'axis.') IF(IDELIM.LT.0) WRITE(LUNTTO,'(1X,A)') TEXT CALL MN_BLM(2,ntmode,IDELIM,COMND1 + ,NDUM,AFLO(NAX),AFHI(NAX),NNUM,IERR) IF(IERR.NE.0) GOTO 9000 C IF(AFLO(NAX).EQ.0.0 .AND. AFHI(NAX).EQ.0.0) THEN CALL MN_ERR('MN_PRT','No partition done.' // 1 ' Lower and upper edges are 0.0') GOTO 9000 C ELSEIF(AFLO(NAX).GE.AFHI(NAX)) THEN WRITE(TXTERR,'(''Lower edge'',G11.4 1 ,'' greater then upper edge'',G11.4)') 2 AFLO(NAX),AFHI(NAX) CALL MN_ERR('MN_PRT',TXTERR) GOTO 9000 C ELSEIF(ADLO(NAX).GE.ADHI(NAX)) THEN WRITE(TXTERR,'(''Plot'',I7,I4,'' is screwed up!!'')') + IDA,IDB CALL M_EMSG('MN_PRT',TXTERR) WRITE(TXTERR,'('' Lower edge'',G11.4 1 ,'' greater then upper edge'',G11.4)') 2 ADLO(NAX),ADHI(NAX) CALL MN_ERR('MN_PRT',TXTERR) GOTO 9000 C ELSEIF(NDIM.GT.0 .AND. + (ADLO(NAX).GT.AFLO(NAX) .OR. + ADHI(NAX).LT.AFHI(NAX))) THEN WRITE(TXTMES,'('' WARNING: Either the upper'' 1 ,'' or lower limits of the histogram'')') CALL MN_MES(LUNTTO,'M',TXTMES) WRITE(TXTMES,'('' are inside the partition range:'' 1 ,'' Histogram limits:'',2G11.4)') 1 ADLO(NAX),ADHI(NAX) CALL MN_MES(LUNTTO,'ME',TXTMES) ENDIF C IPLO(NAX) = NPNT IPHI(NAX) = 0 NCOMB = 1 IPCMB(NAX) = NCOMB IF(IDBIN(NAX).NE.0) DX = (ADHI(NAX) - ADLO(NAX)) / 1 FLOAT(IDBIN(NAX)) IF(NDIM.LT.0) THEN IUP = 0 DO 2200 II=1,NPNT IF(IUP.EQ.0 .AND. II.GE.2) THEN IF(X.GT.XLAST) THEN IUP = 1 ELSEIF(X.LT.XLAST) THEN IUP = -1 ENDIF ENDIF X = AMNP(II,NH,NAX,1,IERR) IF(X.GE.AFLO(NAX) .AND. X.LE.AFHI(NAX)) + IPLO(NAX) = MIN0(II,IPLO(NAX)) IF(X.GE.AFLO(NAX) .AND. X.LE.AFHI(NAX)) + IPHI(NAX) = MAX0(II,IPHI(NAX)) IF((IUP.EQ.1 .AND. X.LT.XLAST) .OR. + (IUP.EQ.-1 .AND. X.GT.XLAST)) THEN CALL M_EMSG('MN_PRT' + ,'Data is not monotonically increasing or' // + ' decreasing. Partition may not be correct') ENDIF XLAST = X 2200 CONTINUE ELSE IPLO(NAX) = IFIX((AFLO(NAX) - ADLO(NAX))/DX + 0.5) + 1 IPLO(NAX) = MAX0(1,IPLO(NAX)) IPLO(NAX) = MIN0(IDBIN(NAX),IPLO(NAX)) IPHI(NAX) = IFIX((AFHI(NAX) - ADLO(NAX))/DX + 0.5) IPHI(NAX) = MAX0(1,IPHI(NAX)) IPHI(NAX) = MIN0(IDBIN(NAX),IPHI(NAX)) C C RECALCULATE THE PARTITION LIMITS TO CORRESPOND TO THE C THE BIN EDGES C AFLO(NAX) = ADLO(NAX) + FLOAT(IPLO(NAX)-1)*DX AFHI(NAX) = ADLO(NAX) + FLOAT(IPHI(NAX))*DX ENDIF NPCOP = IPHI(NAX) - IPLO(NAX) + 1 IFBIN(NAX) = NPCOP C IF(NPCOP.LE.0) THEN WRITE(TXTERR,'(''Error in partitioning.'' 1 ,'' Limits asked for'',2G12.5 2 ,'' Bins corresponding to them'',2I6)') 3 AFLO(NAX),AFHI(NAX),IPLO(NAX),IPHI(NAX) CALL MN_ERR('MN_PRT',TXTERR) GOTO 9000 ENDIF 2500 CONTINUE C C GET REBIN SPECIFICATION C ELSE IF(COMND1.EQ.'REBIN') THEN DO 3500 NAX=1,IABS(NDIM) TEXT = CONCAT(TDNAM(NAX,NH),'axis.') IF(IDELIM.LT.0) WRITE(LUNTTO,'(1X,A)') TEXT INUM(3) = IDBIN(NAX) RNUM(1) = 1.0 RNUM(2) = FLOAT(IDBIN(NAX)) CALL MN_BLM(3,0,IDELIM,COMND1 + ,INUM(3),RNUM(1),RNUM(2),NNUM,IERR) IF(IERR.NE.0) GOTO 9000 INUM(1) = NINT(RNUM(1)) INUM(2) = NINT(RNUM(2)) C NCOMB = (INUM(2)-INUM(1)+1) / INUM(3) NPCOP = INUM(3) IPLO(NAX) = INUM(1) IPHI(NAX) = IPLO(NAX) + NCOMB*NPCOP - 1 IPCMB(NAX) = NCOMB IFBIN(NAX) = NPCOP lent = lnblnk(tdnam(nax,nh)) WRITE(TXTMES,'(1X,A,'' axis'' 1 ,'' will have'',I5,'' bins,'' 2 ,'' using bins'',I5,'' ->'',I5)') 2 TDNAM(NAX,NH)(:lent),IFBIN(NAX),IPLO(NAX),IPHI(NAX) CALL MN_MES(LUNTTO,'ME',TXTMES) C C SORT OUT THE HISTOGRAM LIMITS C DFXL = 0.0 DFXH = 0.0 DX = (ADHI(NAX) - ADLO(NAX)) / FLOAT(IDBIN(NAX)) XFLO = ADLO(NAX) + FLOAT(IPLO(NAX)-1)*DX + 0.5*DX XFHI = ADLO(NAX) + FLOAT(IPHI(NAX)-1)*DX + 0.5*DX DFXL = 0.5*DX DFXH = 0.5*DX AFLO(NAX) = XFLO - DFXL AFHI(NAX) = XFHI + DFXH 3500 CONTINUE ENDIF C C GET A NEW LOCATION C NPCOP = IFBIN(1) IF(IABS(NDIM).GT.1) NPCOP = NPCOP * IFBIN(2) NWRD = NPCOP * NWPPT NBPPT = 0 CALL MN_HNW(IDA,IDB,NDIM,NWRD,NH2,NPTRH2,NPTRD2,NWH,NBPPT,NTMODE) IF(NH2.LE.0) GOTO 9000 C C DO THE COPYING AND C CALCULATE THE NUMBER OF ENTRIES AND THE LIMITS C EDENT2 = 0.0 EDLO2 = 1.0E+30 EDHI2 = -1.0E+30 NPTR2 = NPTRD2 - 1 - NWPPT IF(IABS(NDIM).LT.2) THEN IFBIN(2) = 1 IPLO(2) = 1 IPCMB(2) = 1 ENDIF DO 5000 JJ=1,IFBIN(2) DO 4900 II=1,IFBIN(1) NPTR2 = NPTR2 + NWPPT XSUM = 0.0 XSUML = 1.0E+30 XSUMH = -1.0E+30 ZSUM = 0.0 DZSUML = 0.0 DZSUMH = 0.0 DXL = 0.0 DXH = 0.0 DO 4500 LL=1,IPCMB(2) NBIN2 = IPLO(2) - 1 + (JJ - 1)*IPCMB(2) + LL DO 4400 KK=1,IPCMB(1) NBIN1 = IPLO(1) - 1 + (II - 1)*IPCMB(1) + KK NBIN12 = IDBIN(1)*(NBIN2-1) + NBIN1 IF(NDIM.LT.0) THEN X = AMNX(NBIN12,NH,IERR) IF(QERRL) DXL = AMNDXN(NBIN12,NH,IERR) DXH = DXL IF(QERRH) DXH = AMNDXP(NBIN12,NH,IERR) XSUM = XSUM + X XSUML = AMIN1(XSUML,X-DXL) XSUMH = AMAX1(XSUMH,X+DXH) ENDIF Z = AMNE(NBIN12,NH,IERR) ZSUM = ZSUM + Z IF(QERRL) THEN DZL = AMNDEN(NBIN12,NH,IERR) DZSUML = DZSUML + DZL*DZL ENDIF IF(QERRH) THEN DZH = AMNDEP(NBIN12,NH,IERR) DZSUMH = DZSUMH + DZH*DZH ENDIF 4400 CONTINUE 4500 CONTINUE C IF(IPCMB(1).GT.1 .OR. IPCMB(2).GT.1) THEN IF(NDIM.LT.0) THEN XSUM = XSUM / FLOAT(IPCMB(1)) ENDIF IF(QERRL) DZSUML = SQRT(DZSUML) IF(QERRH) THEN DZSUMH = SQRT(DZSUMH) ELSE DZSUMH = DZSUML ENDIF ELSE IF(QERRL) DZSUML = DZL IF(QERRH) THEN DZSUMH = DZH ELSE DZSUMH = DZSUML ENDIF ENDIF IF(NDIM.LT.0) THEN DXSUML = XSUM - XSUML DXSUMH = XSUMH - XSUM RDAT(NPTR2+1) = XSUM IF(QERRL) RDAT(NPTR2+NOFF +1) = DXSUML IF(QERRH) RDAT(NPTR2+NOFFL+1) = DXSUMH ENDIF RDAT(NPTR2+NOFF) = ZSUM IF(QERRL) RDAT(NPTR2+NOFFL) = DZSUML IF(QERRH) RDAT(NPTR2+NOFFH) = DZSUMH EDENT2 = EDENT2 + ZSUM EDLO2 = AMIN1(EDLO2,ZSUM-DZSUML) EDHI2 = AMAX1(EDHI2,ZSUM+DZSUMH) 4900 CONTINUE 5000 CONTINUE C C NOW EDIT THE HEADER WORDS THAT HAVE CHANGED C UPDATE THE POINTERS C AND DELETE THE OLD HISTOGRAM C IDPTRH(NH) = -IABS(IDPTRH(NH)) IDPTRD(NH) = -IABS(IDPTRD(NH)) NWTOT = NWH + NWRD CALL M_RTIM(NHDAT2,NHTIM2) CALL MN_HDU(RDAT(NPTRH2),NWTOT,NWH,NWRD,IDA,IDB 1 ,NDIM,NWPPT,NPCOP,NHDAT2,NHTIM2,NSDATE,NSTIME,NTMODE + ,EDENT2,EDLO2,EDHI2,IFBIN,AFLO,AFHI,NBPPT,ACONT) CALL MN_PTU(NH2,NWTOT,IDA,IDB,NPTRH2,NPTRD2 1 ,TDTIT(NH),TDFIL(NH),' ',TDNAM(1,NH)) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH2) C C DELETE THE HBOOK HISTOGRAM IF IT EXISTS C cicb IDH = IDB*1000 + IDA IDH = IDA IF(HEXIST(IDH)) CALL HDELET(IDH) C 9000 CONTINUE RETURN END +DECK,mn_psp. SUBROUTINE MN_PSP(NTYPFL,NP,IERR) C C SUBROUTINE TO SAVE THE CURRENT SET OF PARAMETERS BEFORE A FIT DISPLAY C NTYPFL = 0 MEANS DRAW THE LATEST PLOT C NTYPFL = 1 MEANS DRAW ALL THE PLOTS BEING STORED C NTYPFL = 2 MEANS REDRAW C NTYPFL = 3 MEANS HARDCOPY C implicit none * +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNLUN. * integer ntypfl,np,ierr * integer ida,idb,novefl,nodiff,nn,npi,nax real szew C IERR = 0 IDA = IPLTIA(NP) IDB = IPLTIB(NP) NOVEFL = IPLTFL(NP) C C PLOT SYMBOL, CLEAR AND LEGO FLAG C NSYMU = IPLTSY(NP) NHATU = IPLTHA(NP) NPATU = IPLTPA(NP) NCLRU = IPLTCL(NP) NLEGU = IPLTLG(NP) C C PICTURE MARGIN AND SIZE C SIZEU(1) = SIZES(1) SIZEU(2) = SIZES(2) AMRGU(1) = AMRGS(1) AMRGU(2) = AMRGS(2) C C OVERLAY FIND THE LAST PROPER PLOT AND GET STUFF FROM THERE C IF((IABS(NTYPFL).EQ.0 .OR. IABS(NTYPFL).EQ.1) .AND. 1 (NOVEFL.EQ.2 .OR. NOVEFL.EQ.3)) THEN NODIFF = 0 DO 1000 NN=NP-1,1,-1 IF(IPLTFL(NN).EQ.3) NODIFF = NODIFF + 1 IF(IPLTFL(NN).EQ.1) THEN NPI = NN GOTO 1010 ENDIF 1000 CONTINUE CALL MN_ERR('MN_PSP' 1 ,' You are trying to overlay before you have made a plot') IERR = 1 GOTO 9000 1010 CONTINUE C C SIZES AND MARGINS C AMRGU(1) = AMRGP(1,NPI) AMRGU(2) = AMRGP(2,NPI) HSZEU(1) = HSZEP(1,NPI) HSZEU(2) = HSZEP(2,NPI) C IF(QWIND) THEN IPWNDU(1) = IPWNDP(1,NPI) IPWNDU(2) = IPWNDP(2,NPI) ENDIF WMRGU(1) = WMRGP(1,NPI) WMRGU(2) = WMRGP(2,NPI) WSZEU(1) = WSZEP(1,NPI) WSZEU(2) = WSZEP(2,NPI) C C LEGO PLOT ANGLES C CALL UCOPY_r(ALEGS(1),ALEGU(1),10) C C PLOT LIMITS C IF(NOVEFL.EQ.2) THEN CALL UCOPY_r(ALIMP(1,1,NPI),ALIMU(1,1),2*3) ELSE CALL UCOPY_r(ALIMS(1,1),ALIMU(1,1),2*3) ENDIF C C TEXT AND SYMBOL SIZES C CALL UCOPY_r(TSZES(1),TSZEU(1),10) C C DRAW LINE AT X OR Y = 0 AND SYMBOL C QZEROU(1) = QZEROS(1) IZEROU(1) = IZEROS(1) QZEROU(2) = QZEROS(2) IZEROU(2) = IZEROS(2) C C Draw a grid C IGRIDU(1,1) = IGRIDS(1,1) IGRIDU(2,1) = IGRIDS(2,1) IGRIDU(1,2) = IGRIDS(1,2) IGRIDU(2,2) = IGRIDS(2,2) IGRIDU(1,3) = IGRIDS(1,3) IGRIDU(2,3) = IGRIDS(2,3) C C FRAME ROUND THE PLOT C CALL QCOPY(QFRAMS(1,1),QFRAMU(1,1),10*3) C C TICKS C CALL UCOPY_r(TICKS(1,1),TICKU(1,1),10*3) CALL QCOPY(QTICKS(1,1),QTICKU(1,1),10*3) C C SCALE C CALL UCOPY_i(ISMODS(1),ISMODU(1),3) CALL UCOPY_r(SCALS(1,1),SCALU(1,1),10*3) CALL QCOPY(QSCALS(1,1),QSCALU(1,1),10*3) C C LABELS C CALL UCOPY_r(ALABLS(1,1),ALABLU(1,1),10*3) CALL QCOPY(QLABLS(1,1),QLABLU(1,1),10*3) CALL UCOPY_i(ILABLS(1),ILABLU(1),3) CALL TCOPY(TLABLS(1),TLABLU(1),3) C C TITLE POSITION AND OPTIONS C CALL UCOPY_r(TITLS(1),TITLU(1),10) CALL UCOPY_r(TITGS(1),TITGU(1),10) CALL QCOPY(QTITLS(1),QTITLU(1),10) C C Colours C Override set colours with those given in command line C CALL UCOPY_i(ICOLS(1),ICOLU(1),20) ICOLU(7) = IPLTCO(1,NP) ICOLU(8) = IPLTCO(2,NP) ICOLU(9) = IPLTCO(3,NP) C C Line thicknesses C CALL UCOPY_r(ATHKS(1),ATHKU(1),10) C C Fonts C CALL UCOPY_i(IFNTS(1),IFNTU(1),10) C C Bin scale factor and offset C CALL UCOPY_r(ABINS(1),ABINU(1),10) C C Interface to IGTABL C NIGPARU = NIGPARS CALL UCOPY_r(AIGPARS,AIGPARU,MIGPAR) TIGOPTU = TIGOPTS LIGOPTU = LIGOPTS C C Parameters for special displays - implemented for L3 C CALL MN_DSP(NTYPFL,NOVEFL,NP) C C FOR AN OVERLAY C TURN OFF LINES AT X OR Y = 0 C LEAVE ON THE FRAME C TURN OFF ALL TICKS C TURN OFF THE SCALE C TURN OFF THE LABEL C TURN OFF THE TITLE C QZEROU(1) = .FALSE. QZEROU(2) = .FALSE. DO 1100 NAX=1,3 CICB QFRAMU(1,NAX) = .FALSE. CICB QFRAMU(2,NAX) = .FALSE. QTICKU(1,NAX) = .FALSE. QTICKU(2,NAX) = .FALSE. QTICKU(3,NAX) = .FALSE. QTICKU(4,NAX) = .FALSE. QSCALU(1,NAX) = .FALSE. QSCALU(2,NAX) = .FALSE. QLABLU(1,NAX) = .FALSE. QLABLU(2,NAX) = .FALSE. 1100 CONTINUE QTITLU(1) = .FALSE. C C FOR AN OVERLAY ON A DIFFERENT SCALE C IF WE ARE DRAWING THE ORIGINAL SCALE ON THE LEFT C AND THIS IS THE FIRST PLOT WITH A DIFFERENT SCALE C TURN OFF THE TICKS, SCALE AND LABEL ON THE RIGHT FOR THE ORIGINAL PLOT C For the new plot use the standard settings, except for the scale and C label for which I use the setting for the bottom (left) as the C top (right) is off by default. C Also set lines at x or y = 0 to standard settings C IF(NOVEFL.EQ.3) THEN IF(QFRAMS(2,2) .AND. 1 (QTICKS(3,2) .OR. QTICKS(4,2)) .AND. 1 NODIFF.EQ.0) THEN QZEROU(2) = QZEROS(2) QFRAMU(2,2) = QFRAMS(2,2) QTICKU(3,2) = QTICKS(3,2) QTICKU(4,2) = QTICKS(4,2) QSCALU(2,2) = QSCALS(1,2) IF(.NOT.QLABLS(3,2)) QLABLU(2,2) = QLABLS(1,2) C IF(QTICKU(3,2) .OR. QTICKU(4,2)) THEN QTICKP(3,2,NPI) = .FALSE. QTICKP(4,2,NPI) = .FALSE. QSCALP(2,2,NPI) = .FALSE. QLABLP(2,2,NPI) = .FALSE. ENDIF ENDIF ENDIF C C NEW PLOT - GET EVERYTHING FROM THE SET VALUES C ELSE IF((IABS(NTYPFL).EQ.0 .OR. IABS(NTYPFL).EQ.1) .AND. 1 NOVEFL.EQ.1) THEN C C SET NECESSARY FLAGS C C QLIMCP(1,NP) = .TRUE. C QLIMCP(2,NP) = .TRUE. C QLIMCP(3,NP) = .TRUE. C C SIZES AND MARGINS C AMRGU(1) = AMRGS(1) AMRGU(2) = AMRGS(2) HSZEU(1) = HSZES(1) HSZEU(2) = HSZES(2) C C IF WE ARE WINDOWING INCREASE THE WINDOW NUMBER AND RECALCULATE C THE MARGIN AND PLOT SIZE C HOWEVER IF THE NOCLEAR FLAG IS SET, THIS IS THE SAME AS C AN OVERLAY SO DONT INCREASE WINDOW NUMBER C IF(QWIND) THEN IF(NCLRU.EQ.1) THEN IF(IPWNDS(1).LT.IWIND(1)) THEN IPWNDS(1) = IPWNDS(1) + 1 ELSEIF(IPWNDS(2).LT.IWIND(2)) THEN IPWNDS(2) = IPWNDS(2) + 1 IPWNDS(1) = 1 ELSE IPWNDS(1) = 1 IPWNDS(2) = 1 ENDIF IF(IPWNDS(1).LE.0) IPWNDS(1) = 1 IF(IPWNDS(2).LE.0) IPWNDS(2) = 1 ENDIF C IPWNDU(1) = IPWNDS(1) IPWNDU(2) = IPWNDS(2) C DO 2100 NAX=1,2 SZEW = (HSZES(NAX) - 1 FLOAT(IWIND(NAX)-1)*WSPACE(NAX)) / FLOAT(IWIND(NAX)) IF(WSZES(NAX).EQ.0.0) WSZES(NAX) = SZEW WSZEU(NAX) = WSZES(NAX) C IF(WMRGS(NAX).EQ.0.0) THEN IF(NAX.EQ.1) THEN WMRGU(NAX) = FLOAT(IPWNDU(NAX)-1) * 1 (WSPACE(NAX) + SZEW) ELSE WMRGU(NAX) = FLOAT(IWIND(NAX)-IPWNDU(NAX)) * 1 (WSPACE(NAX) + SZEW) ENDIF ELSE WMRGU(NAX) = WMRGS(NAX) ENDIF 2100 CONTINUE C C IF THIS IS NOT THE FIRST WINDOW C AND THIS IS NOT THE FIRST PLOT IN THE BUFFER C THEN RESET THE CLEAR FLAG C IF(NP.GT.1 .AND. + (IPWNDU(1).NE.1 .OR. IPWNDU(2).NE.1)) NCLRU = 0 ELSE WMRGU(1) = WMRGS(1) WMRGU(2) = WMRGS(2) WSZEU(1) = WSZES(1) WSZEU(2) = WSZES(2) ENDIF C C PLOT LIMITS C CALL UCOPY_r(ALIMS(1,1),ALIMU(1,1),2*3) C C LEGO PLOT ANGLES C CALL UCOPY_r(ALEGS(1),ALEGU(1),10) C C TEXT AND SYMBOL SIZES C CALL UCOPY_r(TSZES(1),TSZEU(1),10) C C Colours C CALL UCOPY_i(ICOLS(1),ICOLU(1),20) ICOLU(7) = IPLTCO(1,NP) ICOLU(8) = IPLTCO(2,NP) ICOLU(9) = IPLTCO(3,NP) C C Line thicknesses C CALL UCOPY_r(ATHKS(1),ATHKU(1),10) C C Fonts C CALL UCOPY_i(IFNTS(1),IFNTU(1),10) C C Bin scale factor and offset C CALL UCOPY_r(ABINS(1),ABINU(1),10) C C Interface to IGTABL C NIGPARU = NIGPARS CALL UCOPY_r(AIGPARS,AIGPARU,MIGPAR) TIGOPTU = TIGOPTS LIGOPTU = LIGOPTS C C DRAW LINE AT X OR Y = 0 AND SYMBOL C QZEROU(1) = QZEROS(1) IZEROU(1) = IZEROS(1) QZEROU(2) = QZEROS(2) IZEROU(2) = IZEROS(2) C C Draw a grid C IGRIDU(1,1) = IGRIDS(1,1) IGRIDU(2,1) = IGRIDS(2,1) IGRIDU(1,2) = IGRIDS(1,2) IGRIDU(2,2) = IGRIDS(2,2) IGRIDU(1,3) = IGRIDS(1,3) IGRIDU(2,3) = IGRIDS(2,3) C C FRAME ROUND THE PLOT C CALL QCOPY(QFRAMS(1,1),QFRAMU(1,1),10*3) C C TICKS C CALL UCOPY_r(TICKS(1,1),TICKU(1,1),10*3) CALL QCOPY(QTICKS(1,1),QTICKU(1,1),10*3) C C SCALE C CALL UCOPY_i(ISMODS(1),ISMODU(1),3) CALL UCOPY_r(SCALS(1,1),SCALU(1,1),10*3) CALL QCOPY(QSCALS(1,1),QSCALU(1,1),10*3) C C TURN OFF THE SCALE IF THE WINDOW SPACING IS ZERO AND THIS IS C NOT A LEGO PLOT C IF(QWIND .AND. (NLEGU.LE.0 .OR. NLEGU.EQ.7)) THEN DO 2300 NAX=1,2 IF((NAX.EQ.1 .AND. WSPACE(2).EQ.0.0 .AND. 1 IPWNDU(2).LT.IWIND(2) .AND. IWIND(2).GT.1) .OR. 2 (NAX.EQ.2 .AND. WSPACE(1).EQ.0.0 .AND. 2 IPWNDU(1).GT.1)) THEN QSCALU(1,NAX) = .FALSE. QSCALU(2,NAX) = .FALSE. ENDIF 2300 CONTINUE ENDIF C C LABELS C CALL UCOPY_r(ALABLS(1,1),ALABLU(1,1),10*3) CALL QCOPY(QLABLS(1,1),QLABLU(1,1),10*3) CALL UCOPY_i(ILABLS(1),ILABLU(1),3) CALL TCOPY(TLABLS(1),TLABLU(1),3) C C TURN OFF LABELS FOR ALL EXCEPT THE FIRST PLOT IF WE C ARE PLOTTING ONE LABEL PER PAGE C DO 2400 NAX=1,3 IF(QLABLS(3,NAX)) THEN IF(NCLRU.NE.1) THEN QLABLU(1,NAX) = .FALSE. QLABLU(2,NAX) = .FALSE. ENDIF ENDIF 2400 CONTINUE C C TITLE POSITION AND OPTIONS C CALL UCOPY_r(TITLS(1),TITLU(1),10) CALL UCOPY_r(TITGS(1),TITGU(1),10) CALL QCOPY(QTITLS(1),QTITLU(1),10) C C Parameters for special displays - implemented for L3 C CALL MN_DSP(NTYPFL,NOVEFL,NP) C C REDRAW OR HARDCOPY - GET EVERYTHING FROM THE PLOT VALUES C ELSE IF(IABS(NTYPFL).EQ.2 .OR. IABS(NTYPFL).EQ.3) THEN C C SIZES AND MARGINS C AMRGU(1) = AMRGP(1,NP) AMRGU(2) = AMRGP(2,NP) HSZEU(1) = HSZEP(1,NP) HSZEU(2) = HSZEP(2,NP) C IF(QWIND) THEN IPWNDU(1) = IPWNDP(1,NP) IPWNDU(2) = IPWNDP(2,NP) ENDIF WMRGU(1) = WMRGP(1,NP) WMRGU(2) = WMRGP(2,NP) WSZEU(1) = WSZEP(1,NP) WSZEU(2) = WSZEP(2,NP) C C PLOT LIMITS C CALL UCOPY_r(ALIMP(1,1,NP),ALIMU(1,1),2*3) C C LEGO PLOT ANGLES C CALL UCOPY_r(ALEGP(1,NP),ALEGU(1),10) C C TEXT AND SYMBOL SIZES C CALL UCOPY_r(TSZEP(1,NP),TSZEU(1),10) C C COLOURS C CALL UCOPY_i(ICOLP(1,NP),ICOLU(1),20) C C LINE THICKNESSES C CALL UCOPY_r(ATHKP(1,NP),ATHKU(1),10) C C Fonts C CALL UCOPY_i(IFNTP(1,NP),IFNTU(1),10) C C Bin scale factor and offset C CALL UCOPY_r(ABINP(1,NP),ABINU(1),10) C C Interface to IGTABL C NIGPARU = NIGPARP(NP) CALL UCOPY_r(AIGPARP(1,NP),AIGPARU,MIGPAR) TIGOPTU = TIGOPTP(NP) LIGOPTU = LIGOPTP(NP) C C DRAW LINE AT X OR Y = 0 AND SYMBOL C QZEROU(1) = QZEROP(1,NP) IZEROU(1) = IZEROP(1,NP) QZEROU(2) = QZEROP(2,NP) IZEROU(2) = IZEROP(2,NP) C C Draw a grid C IGRIDU(1,1) = IGRIDP(1,1,NP) IGRIDU(2,1) = IGRIDP(2,1,NP) IGRIDU(1,2) = IGRIDP(1,2,NP) IGRIDU(2,2) = IGRIDP(2,2,NP) IGRIDU(1,3) = IGRIDP(1,3,NP) IGRIDU(2,3) = IGRIDP(2,3,NP) C C FRAME ROUND THE PLOT C CALL QCOPY(QFRAMP(1,1,NP),QFRAMU(1,1),10*3) C C TICKS C CALL UCOPY_r(TICKP(1,1,NP),TICKU(1,1),10*3) CALL UCOPY(QTICKP(1,1,NP),QTICKU(1,1),10*3) C C SCALE C CALL UCOPY_i(ISMODP(1,NP),ISMODU(1),3) CALL UCOPY_r(SCALP(1,1,NP),SCALU(1,1),10*3) CALL QCOPY(QSCALP(1,1,NP),QSCALU(1,1),10*3) C C LABELS C CALL UCOPY_r(ALABLP(1,1,NP),ALABLU(1,1),10*3) CALL QCOPY(QLABLP(1,1,NP),QLABLU(1,1),10*3) CALL UCOPY_i(ILABLP(1,NP),ILABLU(1),3) CALL TCOPY(TLABLP(1,NP),TLABLU(1),3) C C TITLE POSITION AND OPTIONS C CALL UCOPY_r(TITLP(1,NP),TITLU(1),10) CALL UCOPY_r(TITGP(1,NP),TITGU(1),10) CALL QCOPY(QTITLP(1,NP),QTITLU(1),10) C C Parameters for special displays - implemented for L3 C CALL MN_DSP(NTYPFL,NOVEFL,NP) ELSE WRITE(LUNTTO,'('' MN_PSP: Unknown flags for plot'' 1 ,'' NTYPFL'',I4,'' NOVEFL'',I4)') 1 NTYPFL,NOVEFL IERR = 1 GOTO 9000 ENDIF C QLIMCU(1) = QLIMCP(1,NP) QLIMCU(2) = QLIMCP(2,NP) QLIMCU(3) = QLIMCP(3,NP) C 9000 CONTINUE RETURN END +DECK,mn_pst. C SUBROUTINE MN_PST(NP) C C SUBROUTINE TO STORE THE PARAMETERS FOR A PLOT C FROM THE CURRENTLY USED PARAMETERS C +CDE,MNPAR. +CDE,MNHPJ. C C CLEAR FLAG C IPLTCL(NP) = NCLRU C C SIZES AND MARGINS C AMRGP(1,NP) = AMRGU(1) AMRGP(2,NP) = AMRGU(2) HSZEP(1,NP) = HSZEU(1) HSZEP(2,NP) = HSZEU(2) C IF(QWIND) THEN IPWNDP(1,NP) = IPWNDU(1) IPWNDP(2,NP) = IPWNDU(2) ENDIF WMRGP(1,NP) = WMRGU(1) WMRGP(2,NP) = WMRGU(2) WSZEP(1,NP) = WSZEU(1) WSZEP(2,NP) = WSZEU(2) C C PLOT LIMITS C CALL UCOPY_r(ALIMU(1,1),ALIMP(1,1,NP),2*3) C C LEGO PLOT DEFAULT ANGLES C CALL UCOPY_r(ALEGU(1),ALEGP(1,NP),10) C C TEXT AND SYMBOL SIZES C CALL UCOPY_r(TSZEU(1),TSZEP(1,NP),10) C C COLOURS C CALL UCOPY_i(ICOLU(1),ICOLP(1,NP),20) C C LINE THICKNESSES C CALL UCOPY_r(ATHKU(1),ATHKP(1,NP),10) C C Fonts C CALL UCOPY_i(IFNTU(1),IFNTP(1,NP),10) C C Bin scale factor and offset C CALL UCOPY_r(ABINU(1),ABINP(1,NP),10) C C Interface to IGTABL C NIGPARP(NP) = NIGPARU CALL UCOPY_r(AIGPARU,AIGPARP(1,NP),MIGPAR) TIGOPTP(NP) = TIGOPTU LIGOPTP(NP) = LIGOPTU C C DRAW LINE AT X OR Y = 0 AND SYMBOL C QZEROP(1,NP) = QZEROU(1) IZEROP(1,NP) = IZEROU(1) QZEROP(2,NP) = QZEROU(2) IZEROP(2,NP) = IZEROU(2) C C Draw a grid C IGRIDP(1,1,NP) = IGRIDU(1,1) IGRIDP(2,1,NP) = IGRIDU(2,1) IGRIDP(1,2,NP) = IGRIDU(1,2) IGRIDP(2,2,NP) = IGRIDU(2,2) IGRIDP(1,3,NP) = IGRIDU(1,3) IGRIDP(2,3,NP) = IGRIDU(2,3) C C FRAME AROUND THE PLOT C CALL QCOPY(QFRAMU(1,1),QFRAMP(1,1,NP),10*3) C C TICKS C CALL UCOPY_r(TICKU(1,1),TICKP(1,1,NP),10*3) CALL QCOPY(QTICKU(1,1),QTICKP(1,1,NP),10*3) C C SCALE C CALL UCOPY_i(ISMODU(1),ISMODP(1,NP),3) CALL UCOPY_r(SCALU(1,1),SCALP(1,1,NP),10*3) CALL QCOPY(QSCALU(1,1),QSCALP(1,1,NP),10*3) C C LABELS C CALL UCOPY_r(ALABLU(1,1),ALABLP(1,1,NP),10*3) CALL QCOPY(QLABLU(1,1),QLABLP(1,1,NP),10*3) CALL UCOPY_i(ILABLU(1),ILABLP(1,NP),3) CALL TCOPY(TLABLU(1),TLABLP(1,NP),3) C C TITLE POSITION AND OPTIONS C CALL UCOPY_r(TITLU(1),TITLP(1,NP),10) CALL UCOPY_r(TITGU(1),TITGP(1,NP),10) CALL QCOPY(QTITLU(1),QTITLP(1,NP),10) C C Parameters for special displays - implemented for L3 C CALL MN_DST(NP) C QLIMCP(1,NP) = .FALSE. QLIMCP(2,NP) = .FALSE. QLIMCP(3,NP) = .FALSE. C RETURN END +DECK,mn_ptu. SUBROUTINE MN_PTU(NHD,NWTOT,IDA,IDB,NPTRHI,NPTRDI,TITLE,TFILE + ,TDIR,TNAME) C C Subroutine to update the pointers and set the cuts to what C I want. C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNLUN. C CHARACTER*(*) TITLE,TFILE,TDIR CHARACTER*(*) TNAME(*) C INTEGER IDBINT(MDIMMX) REAL ADLOT(MDIMMX),ADHIT(MDIMMX),AMEANT(MDIMMX),ASIGT(MDIMMX) C INTEGER LTIT,LFIL,LNAM C C CHECK THE LENGTH OF THE CHARACTER VARIABLES C LTIT = LEN(TITLE) LFIL = LEN(TFILE) LDIR = LEN(TDIR) LNAM = LEN(TNAME(1)) C C Get the plot dimensions etc. C CALL MN_HDR(RDAT(NPTRHI),NDIMT,NWPPTT,NPNTT + ,NHDATT,NHTIMT,NSDATT,NSTIMT,NTMODT 1 ,EDENTT,EDLOT,EDHIT,IDBINT,ADLOT,ADHIT,NBPPTT,AMEANT,ASIGT) C IF(LTIT.LE.0 .OR. LFIL.LE.0 .OR. LNAM.LE.0) THEN CALL M_EMSG('MN_PTU' + ,'Something screwed up with length of character strings:') WRITE(TXTERR,'(''Title'',I6,1X,A)') LTIT,TITLE CALL M_EMSG('MN_PTU',TXTERR) WRITE(TXTERR,'(''File'',I6,1X,A)') LFIL,TFILE CALL M_EMSG('MN_PTU',TXTERR) WRITE(TXTERR,'(''Names'',I6,1X,4A)',IOSTAT=IOERR) + (TNAME(II),II=1,IABS(NDIM)) CALL MN_ERR('MN_PTU',TXTERR) ENDIF C NDHIS = NDHIS + 1 NDPTE = NDPTE + NWTOT IDIDA(NHD) = IDA IDIDB(NHD) = IDB IDPTRH(NHD) = NPTRHI IDPTRD(NHD) = NPTRDI TDTIT(NHD) = ' ' TDFIL(NHD) = ' ' TDDIR(NHD) = ' ' IF(LTIT.GT.0) TDTIT(NHD) = TITLE IF(LFIL.GT.0) TDFIL(NHD) = TFILE IF(LDIR.GT.0) TDDIR(NHD) = TDIR C CICB CALL TCOPY(TNAME(1),TDNAM(1,NHD),IABS(NDIMT)) DO 500 II=1,IABS(NDIMT) TDNAM(II,NHD) = ' ' IF(LNAM.GT.0) TDNAM(II,NHD) = TNAME(II) 500 CONTINUE C C See if this histogram already exists and if it does set its C pointers negative C DO 1000 NNH=1,NDHIS IF(NHD.EQ.NNH) GOTO 1000 IF(IDA.EQ.IDIDA(NNH) .AND. IDB.EQ.IDIDB(NNH)) THEN C IF(IDPTRH(NNH).GT.0 .OR. IDPTRD(NNH).GT.0) THEN C WRITE(LUNTTO,'('' Histogram'',I7,I4 C 1 ,'' already exists'' C 2 ,'' and will be overwritten'')') IDA2,IDB2 C ENDIF IDPTRH(NNH) = -IABS(IDPTRH(NNH)) IDPTRD(NNH) = -IABS(IDPTRD(NNH)) ENDIF 1000 CONTINUE C C Check the pointer consistency C CALL MN_HGT(IDA,IDB,NHT) C 9000 CONTINUE RETURN END +DECK,mn_rom. SUBROUTINE MN_ROM(NRQUST,NGOT,IPTR) C====== C AFTER CALL, EITHER NGOT=IPTR=0 IF IT DIDNT WORK OUT, OR C IADR(IPTR+1),IADR(IPTR+2),...,IADR(IPTR+NGOT) IS AVAILABLE SPACE C====== C +CDE,MNSCR. INTEGER IADR(40000) EQUIVALENCE(SCRATCH(1),IADR(1)) C IPTR=0 NGOT=40000 C RETURN END +DECK,mn_scf. SUBROUTINE MN_SCF(IDELIM) C C READS IN AN AVEHST TRUE SCATTER PLOT C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNCMD. +CDE,MNLUN. C C COMMON/MNSCR/ARRAY(511) +CDE,MNSCR. REAL ARRAY(511) EQUIVALENCE(SCRATCH(1),ARRAY(1)) C INTEGER IARRAY(511) EQUIVALENCE (IARRAY,ARRAY) C INTEGER IDBIN(2) REAL ADLO(2),ADHI(2) REAL ACONT(3**2) C CHARACTER*32 TNAME(2),TNDEF(2) INTEGER IDLST1(100),IDLST2(100),IDGOT(MHSTMX) C CHARACTER*80 TITLE LOGICAL QRNGE,QSPACE C DATA TNDEF/'X', 'Y'/ C IF(IDELIM.EQ.0) THEN NJUNK = INTTYQ(.TRUE.,IDELIM) CALL RESTYQ ENDIF C NDHIS0 = NDHIS C IF(FIL_SC.EQ.' ' .OR. 1 (IDELIM.GT.0 .AND. IDELIM.NE.ICHAR(':'))) THEN CALL MN_FIL(1,LUNSIN,FIL_SC,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 ELSE REWIND LUNSIN ENDIF C NIDL = 0 qrnge = .false. 2000 CONTINUE CALL WAITYQ('Give histogram number(s): ') CALL MN_HRN(IDA1,IDA2,IDB1,IDB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 8000 IF(NNID.GT.1) THEN WRITE(LUNTTO,'('' MN_SCF: AVEHST does not know about'' 1 ,'' secondary identifiers'' 1 ,/,9X,''It will be ignored'')') ENDIF C IF(NIDL.GE.100) THEN WRITE(LUNTTO,'('' *** MN_SCF: Ran out of space to store plot'' 1 ,'' numbers to get'' 2 ,/,13X,'' Issue SCT_FETCH command again to get'' 2 ,'' more plots.'')') GOTO 2200 ENDIF C IF(IDA1.EQ.0 .OR. IDA1.NE.IDA2) QRNGE = .TRUE. NIDL = NIDL + 1 IDLST1(NIDL) = IDA1 IDLST2(NIDL) = IDA2 IF(IDELIM.GE.0) GOTO 2000 2200 CONTINUE IF(NIDL.LE.0) GOTO 8000 C IDB = NDIDB QSPACE = .FALSE. NGOT = 0 CALL VZERO_i(IDGOT,MHSTMX) C 3000 CONTINUE IDA = 0 NPNT = 0 EDLO = 0.0 EDHI = 1.0 EDENT = 0.0 XDLO = 1.0E+30 XDHI = -1.0E+30 YDLO = 1.0E+30 YDHI = -1.0E+30 C 4000 CONTINUE READ(LUNSIN,ERR=9100,END=5000) ARRAY C C EXTRACT THE DATA C NPOINT = IARRAY(1) C DO 4200 I=1,NPOINT K = 3*I-2 NHST = IARRAY(K+1) X = ARRAY(K+2) Y = ARRAY(K+3) C C SEE IF THIS IS THE HISTOGRAM I AM CURRENTLY READING C OR IF I HAVE NOT YET GOT IT C IF(IDA.EQ.0) THEN DO 4050 NG=1,NGOT IF(NHST.EQ.IDGOT(NG)) GOTO 4200 4050 CONTINUE C IDA = NHST NGOT = NGOT + 1 IDGOT(NGOT) = NHST C C SEE IF I WANT THIS ONE C DO 4100 NL=1,NIDL IF(IDLST1(NL).EQ.0 .OR. 1 (NHST.GE.IDLST1(NL) .AND. NHST.LE.IDLST2(NL))) THEN GOTO 4150 ENDIF 4100 CONTINUE C C I DON'T WANT IT. RESET ID AND GO TO NEXT POINT C IDA = 0 GOTO 4200 ELSE IF(NHST.NE.IDA) THEN GOTO 4200 ENDIF C 4150 CONTINUE NPNT = NPNT + 1 C C BOOK THE NEW HISTOGRAM C IF(NPNT.EQ.1) THEN NDIM = -2 NWPPT = 2 NWRD = 0 NBPPT = 0 NTMODE = 0 CALL MN_HNW(IDA,IDB,NDIM,NWRD,NH,NPTRH,NPTRD,NWH + ,NBPPT,NTMODE) ENDIF C NPTR = NPTRD + NWPPT*(NPNT-1) - 1 IF(NPTR+NWPPT.GT.MHSTWD) THEN WRITE(LUNTTO,'('' *** MN_SCF:'' 1 ,'' Ran out of storage space'')') QSPACE = .TRUE. NPNT = NPNT - 1 GOTO 5000 ENDIF RDAT(NPTR + 1) = X RDAT(NPTR + 2) = Y EDENT = EDENT + 1.0 XDLO = AMIN1(XDLO,X) XDHI = AMAX1(XDHI,X) YDLO = AMIN1(YDLO,Y) YDHI = AMAX1(YDHI,Y) 4200 CONTINUE GOTO 4000 C C READ IN ALL THE DATA CHECK IT OUT AND FILL THE HEADER C 5000 CONTINUE IF(NPNT.EQ.0) GOTO 8000 C C WRITE(LUNTTO,'('' Histogram'',I7,I4 C 1,'' Data for'',I6,'' points read in'')') C 1IDA,IDB,NPNT C NWDAT = NWPPT * NPNT NWTOT = NWH + NWDAT IDBIN(1) = 0 ADLO(1) = XDLO ADHI(1) = XDHI IDBIN(2) = 0 ADLO(2) = YDLO ADHI(2) = YDHI TNAME(1) = TNDEF(1) TNAME(2) = TNDEF(2) TITLE = 'No Name' NHDATE = 0 NHTIME = 0 NSDATE = 0 NSTIME = 0 CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB + ,NDIM,NWPPT,NPNT,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE,FIL_SC,' ',TNAME) CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) C 6000 CONTINUE IF(QSPACE) GOTO 8000 REWIND LUNSIN GOTO 3000 C 8000 CONTINUE C C CHECK THAT I GOT THE HISTOGRAMS I WANTED C NNID = 1 CALL MN_HNG('MN_SCF',NNID,NDHIS0,NIDL,IDLST1,IDLST2,IDB,IDB) C 9000 CONTINUE GOTO 9900 C C ERROR READING IN THE DATA C 9100 CONTINUE WRITE(TXTERR,'(''Error reading in scatter plot'' 1 ,I7)') IDA CALL MN_ERR('MN_SCF',TXTERR) GOTO 9900 C 9900 CONTINUE RETURN END +DECK,mn_sqz. SUBROUTINE MN_SQZ C C ROUTINE TO CLAIM BACK UNUSED STORAGE SPACE C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNLST. +CDE,MNLUN. C C NHLAST = 1 NHLAST = NDHIS NNDHIS = NDHIS 1000 CONTINUE NDHIS = NNDHIS C DO 2000 NH=NHLAST,NDHIS DO 2000 NH=NHLAST,1,-1 IF(IDPTRH(NH).LE.0 .OR. IDPTRD(NH).LE.0) THEN NDPTRH = IABS(IDPTRH(NH)) NWTOT = NINT(RDAT(NDPTRH)) NWLEF = NDPTE - NDPTRH - NWTOT + 1 WRITE(TXTMES,'('' Removing plot'',I5,'' out of '',I5 + ,''.'',I8,'' words to copy'')' + ,IOSTAT=IOERR) NH,NDHIS,NWLEF CALL MN_MES(LUNTTO,'ME',TXTMES) CALL UCOPY_r(RDAT(NDPTRH+NWTOT),RDAT(NDPTRH),NWLEF) DO 1800 NN=NH,NDHIS-1 IDIDA(NN) = IDIDA(NN+1) IDIDB(NN) = IDIDB(NN+1) NNH = IDPTRH(NN+1) NND = IDPTRD(NN+1) IDPTRH(NN) = IABS(IDPTRH(NN+1)) - NWTOT IDPTRD(NN) = IABS(IDPTRD(NN+1)) - NWTOT IF(NNH.LE.0) IDPTRH(NN) = -IABS(IDPTRH(NN)) IF(NND.LE.0) IDPTRD(NN) = -IABS(IDPTRD(NN)) TDTIT(NN) = TDTIT(NN+1) TDFIL(NN) = TDFIL(NN+1) TDDIR(NN) = TDDIR(NN+1) C C COPY VARIABLE NAMES C DO 1500 ND=1,MDIMMX TDNAM(ND,NN) = TDNAM(ND,NN+1) 1500 CONTINUE C 1800 CONTINUE C NHLAST = NH NHLAST = NH - 1 NNDHIS = NDHIS - 1 NDPTE = NDPTE - NWTOT GOTO 1000 ENDIF 2000 CONTINUE C C CHECK THE POINTERS ARE STILL CONSISTENT C DO 3000 NN=1,NDHIS CALL MN_HGT(IDIDA(NN),IDIDB(NN),NNH) 3000 CONTINUE C NWL = NHSTWD - NDPTE IF(NWL.LT.1000) THEN WRITE(TXTERR,'(''I have only'',I6,'' words of'' + ,'' storage space left'')') CALL M_EMSG('MN_SQZ',TXTERR) WRITE(TXTERR,'(''Delete some histograms and issue command'' + ,'' SQUEEZE again if you need more space'')') CALL MN_ERR('MN_SQZ',TXTERR) ENDIF C C Set the flag on the last plot referenced in AMNX etc. negative as C things have been reshuffled C NHALST = -1 C 9000 CONTINUE RETURN END +DECK,mn_sum. SUBROUTINE MN_SUM(COMAND,IDELIM) C C Sums a histogram or integrates a function over a range C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNFUN. +CDE,MNFIT. +CDE,MNPRS. +CDE,MNUSR. +CDE,MNLUN. C CHARACTER*(*) COMAND C LOGICAL QCHLG REAL AFLO(MDIMMX),AFHI(MDIMMX) C INTEGER IUSEE(20),lent integer lnblnk external lnblnk C IF(COMAND.EQ.'SUM') THEN CALL WAITYQ('Give histogram number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA.LE.0) GOTO 9000 C CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('MN_CMD',TXTERR) GOTO 9000 ENDIF C IF(NDIM.LT.-1) THEN CALL MN_ERR('MN_SUM','I cannot sum Ntuples') GOTO 9000 ELSEIF(NDIM.GT.2) THEN CALL MN_ERR('MN_SUM' + ,'I cannot sum more than 2-d histogram') GOTO 9000 ENDIF C IF(NDIM.LT.0) THEN NBX = NPNT NBY = 1 ELSEIF(NDIM.EQ.1) THEN NBX = IDBIN(1) NBY = 1 ELSEIF(NDIM.EQ.2) THEN NBX = IDBIN(1) NBY = IDBIN(2) ENDIF C DO 5600 II=1,IABS(NDIM) IF(IDELIM.LT.0) THEN lent = lnblnk(tdnam(ii,nh)) WRITE(TXTMES,'(1X,A,'' axis: '')') + TDNAM(II,NH)(:lent) CALL MN_MES(LUNTTO,'ME',TXTMES) ENDIF CALL MN_BLM(2,ntmode,IDELIM,COMAND + ,NDUM,AFLO(II),AFHI(II),NNUM,IERR) IF(IERR.NE.0) GOTO 9000 C IF(AFLO(II).GT.ADHI(II) .OR. AFHI(II).LT.ADLO(II)) THEN CALL MN_MES(LUNTTO,'M' + ,' WARNING: The summing range is' // + ' outside the histogram limits') WRITE(TXTMES,'('' Histogram limits:'',2G11.4)') 1 ADLO(II),ADHI(II) CALL MN_MES(LUNTTO,'E',TXTMES) ENDIF 5600 CONTINUE C NSUM = 0 SUM = 0.0 NERR = 0 NPT = 0 DO 5660 JJ=1,NBY DO 5650 II=1,NBX NPT = NPT + 1 DO 5640 KK=1,IABS(NDIM) IF(KK.EQ.1)THEN XX = AMNP(II,NH,KK,1,NERR) ELSE XX = AMNP(JJ,NH,KK,1,NERR) ENDIF IF(XX.LT.AFLO(KK) .OR. XX.GT.AFHI(KK)) THEN GOTO 5650 ENDIF 5640 CONTINUE C EE = AMNE(NPT,NH,NERR) NSUM = NSUM + 1 SUM = SUM + EE 5650 CONTINUE 5660 CONTINUE C REGIS(101) = SUM REGIS(102) = FLOAT(NSUM) IF(IABS(NDIM).GT.1) THEN DO 6000 II=1,IABS(NDIM) IF(II.EQ.1) THEN WRITE(TXTMES,'('' Sum from'',1X,A,'' axis'' 1 ,1PG11.4,'' ->'',1PG11.4)') TDNAM(II,NH) 2 ,AFLO(II),AFHI(II) ELSE IF(II.LT.IABS(NDIM)) THEN WRITE(TXTMES,'(9X,1X,A,'' axis'' 1 ,1PG11.4,'' ->'',1PG11.4)') 2 TDNAM(II,NH),AFLO(II),AFHI(II) ELSE WRITE(TXTMES,'(9X,1X,A,'' axis'' 1 ,1PG11.4,'' ->'',1PG11.4,'' is'',1PG12.5)') 2 TDNAM(II,NH),AFLO(II),AFHI(II),SUM ENDIF CALL MN_MES(LUNTTO,'ME',TXTMES) 6000 CONTINUE ELSE WRITE(TXTMES,'('' Sum from'',1PG11.4,'' ->'',1PG11.4 1 ,'' is'',1PG12.5)') AFLO(1),AFHI(1),SUM CALL MN_MES(LUNTTO,'ME',TXTMES) ENDIF C C INTEGRATE A FUNCTION OVER A RANGE C ELSEIF(COMAND.EQ.'INTEGRATE') THEN C CALL WAITYQ('Give function number(s): ') CALL MN_FQU(IUSEE,0,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 C CALL MN_BLM(2,0,IDELIM,COMAND + ,NDUM,AFLO(1),AFHI(1),NNUM,IERR) IF(IERR.NE.0) GOTO 9000 C C. If you are integrating a Cheby or Legendre, you don't want to C. redefine XMINNM&XMAXNM. DN Brown 06/02/92. C QCHLG = .FALSE. DO 7200 IF=1,NFUN_MN IF(IUSEF(IF).EQ.0) GOTO 7200 IF(IUSEE(IF).EQ.0) GOTO 7200 IF(TUSEF(IF)(1: 9).EQ.'Chebyshev' .OR. + TUSEF(IF)(1: 8).EQ.'Legendre' .OR. + TUSEF(IF)(2:10).EQ.'Chebyshev' .OR. + TUSEF(IF)(2: 9).EQ.'Legendre') QCHLG = .TRUE. 7200 CONTINUE IF(QCHLG .AND. XMINNM .GE. XMAXNM) QCHLG = .FALSE. IF(.NOT.QSORTH .AND. .NOT.QCHLG .AND. NHFIT.LE.0) THEN XMINNM = AFLO(1) XMAXNM = AFHI(1) ENDIF XBINNM = 1.0 * * Check that the integration limits do not exceed the * orthogonality limits * IF(QCHLG .AND. + (AFLO(1).LT.XMINNM .OR. AFHI(1).GT.XMAXNM)) THEN TXTERR = 'Integration limits are outside' // + ' orthogonality limits for Chebyshev or Legendre' CALL M_EMSG('MN_SUM',TXTERR) WRITE(TXTERR,'('' Orthogonality limits'',2(1PG11.4))' + ,IOSTAT=IOERR) XMINNM,XMAXNM CALL MN_ERR('MN_SUM',TXTERR) GOTO 9000 ENDIF C SUM = 0.0 NH = 1 DO 7500 IF=1,NFUN_MN IF(IUSEF(IF).EQ.0) GOTO 7500 IF(IUSEE(IF).EQ.0) GOTO 7500 SUM = SUM + AMNINT(IF,NH,AFLO(1),AFHI(1),IERR) 7500 CONTINUE C REGIS(101) = SUM WRITE(TXTMES,'('' Integral from'',1PG11.4,'' ->'',1PG11.4 1 ,'' is'',1PG12.5)') AFLO(1),AFHI(1),SUM CALL MN_MES(LUNTTO,'ME',TXTMES) C ENDIF C 9000 CONTINUE END +DECK,mn_twr. SUBROUTINE MN_TWR C C WRITES OUT THE TEMPORARY HISTOGRAM BUFFER TO THE TEMPORARY FILE C ONCE THIS IS DONE YOU CAN NO LONGER UPDATE THE HISTOGRAMS C +CDE,MNPAR. +CDE,MNTMP. +CDE,MNLUN. C C MAKE SURE THE UNBINNED HISTOGRAMS ARE ALL WRITTEN TO THE TEMPORARY FILE C IF(QMNOPN) THEN DO 1000 NN=1,NUBIN NPTR = IPTR(NN) IF(NPTR.GT.0) THEN IDA = IDTA(NN) IDB = IDTB(NN) NWD = NPTR WRITE(LUNMNU,ERR=9100) IDA,IDB,NWD 1 ,(RTMP(II,NN),II=1,NWD) NPTR = 0 IDWR(NN) = IDWR(NN) + 1 ENDIF 1000 CONTINUE ENDIF C 9000 CONTINUE GOTO 9900 C C ERROR WRITING TEMPORARY FILE C 9100 CONTINUE WRITE(LUNTTO,'('' *** MN_TWR: Error writing to temporary file'' 1 ,'' for plot'',I7,I4)') IDA,IDB GOTO 9900 C 9900 CONTINUE RETURN END +DECK,mn_uof. SUBROUTINE MN_UOF(RBUF,ACONT) C C SUBROUTINE TO GET THE NUMBER OF UNDERFLOWS AND OVERFLOWS C IN A PLOT C +CDE,MNPAR. C REAL RBUF(*) REAL ACONT(*) C INTEGER IDBINT(MDIMMX) REAL ADLOT(MDIMMX),ADHIT(MDIMMX),AMEANT(MDIMMX),ASIGT(MDIMMX) C NWH = RBUF(2) CALL MN_HDR(RBUF,NDIMT,NWPPTT,NPNTT + ,NHDATT,NHTIMT,NSDATT,NSTIMT,NTMODT + ,EDENTT,EDLOT,EDHIT,IDBINT,ADLOT,ADHIT,NBPPTT,AMEANT,ASIGT) NDIM = NDIMT C NN = 11 + 3*IABS(NDIM) + 1 C IF(ndim.gt.-3 .and. ndim.le.3) THEN NUOF = 3**IABS(NDIM) IF(NN+NUOF.LE.NWH) THEN CALL UCOPY_r(RBUF(NN+1),ACONT,NUOF) ELSE CALL VZERO_r(ACONT,NUOF) ENDIF ENDIF C RETURN END +DECK,mn_vrs. SUBROUTINE MN_VRS * *------------------------------------------------------------------------------ * Writes out the latest version and comments associated with it * Also writes out the news *------------------------------------------------------------------------------ * +CDE,MNDIR. +CDE,MNLUN. * CHARACTER*80 TFILE CHARACTER*80 TEXT * TFILE = TMNHLP(1:LMNHLP) // 'mn_news.fil' CALL MN_FIL(52,LUNTMP,TFILE,IDELIM,IERR) IF(IERR.NE.0) GOTO 9000 * 1000 CONTINUE READ(LUNTMP,'(A)',ERR=2000,END=2000) TEXT IF(TEXT(1:4).EQ.'!END') GOTO 2000 IF(TEXT(1:1).EQ.'!' .OR. TEXT(2:2).EQ.'!') GOTO 1000 * LENT = MAX0(1,MIN0(79,LENOCC(TEXT))) WRITE(LUNTTO,'(1X,A)') TEXT(1:LENT) GOTO 1000 * 2000 CONTINUE CLOSE(UNIT=LUNTMP) * 9000 CONTINUE END +DECK,mn_wnd. SUBROUTINE MN_WND(NMODE,IDELIM,QPLOT,NPS1,NPS2) C C SETS UP WINDOWING C C NMODE = -1 MEANS TURN OFF WINDOWING C NMODE = 0 MEANS CHANGE CURRENT WINDOW NUMBER C NMODE = 1 MEANS SET UP FOR WINDOWING C +CDE,MNPAR. +CDE,MNCMD. +CDE,MNHPJ. +CDE,MNLUN. C INTEGER INUM(10) LOGICAL QPLOT C C TURN OFF WINDOWING C IF(NMODE.EQ.-1) THEN QWIND = .FALSE. IPWNDS(1) = 0 IPWNDS(2) = 0 IWIND(1) = 1 IWIND(2) = 1 IF(QDFIT) THEN QPWIND = .FALSE. IPWIND(1) = 1 IPWIND(2) = 1 ENDIF C C SET THE TITLE AND SCALE BACK TO DEFAULT SIZE C TITLS(3) = TITLD(3) SCALS(3,1) = SCALD(3,1) SCALS(3,2) = SCALD(3,2) SCALS(3,3) = SCALD(3,3) TICKS(4,1) = TICKD(4,1) TICKS(4,2) = TICKD(4,2) TICKS(4,3) = TICKD(4,3) TICKS(5,1) = TICKD(5,1) TICKS(5,2) = TICKD(5,2) TICKS(5,3) = TICKD(5,3) SCALS(2,1) = SCALD(2,1) alabls(3,1)= alabld(3,1) alabls(3,2)= alabld(3,2) alabls(3,3)= alabld(3,3) alabls(1,1)= alabld(1,1) alabls(2,1)= alabld(2,1) alabls(1,2)= alabld(1,2) alabls(2,2)= alabld(2,2) alabls(1,3)= alabld(1,3) alabls(2,3)= alabld(2,3) C C CHANGE THE CURRENT WINDOW NUMBER C ELSE IF(NMODE.EQ.0) THEN NNUM = 0 2000 CONTINUE IF(QPLOT) THEN CALL WAITYQ('Give x and y window numbers for plot: ') ELSE CALL WAITYQ( 1 'Give x and y window numbers for next plot: ') ENDIF NVAL = IVLTYQ(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.GT.0) GOTO 9000 C NNUM = NNUM + 1 INUM(NNUM) = NVAL IF(NNUM.LT.2 .AND. IDELIM.EQ.0) GOTO 2000 C IF(INUM(1).LE.0 .OR. INUM(1).GT.IWIND(1) .OR. 1 INUM(2).LE.0 .OR. INUM(2).GT.IWIND(2)) THEN WRITE(LUNTTO,'('' Invalid window number'',2I4 1 ,'' It will be set to'',2I4)') 1 INUM(1),INUM(2),IPWNDS(1),IPWNDS(2) INUM(1) = IPWNDS(1) INUM(2) = IPWNDS(2) ENDIF C IF(QPLOT) THEN DO 2100 NP=NPS1,NPS2 DO 2050 II=1,2 IPWNDP(II,NP) = INUM(II) C C RECALCULATE THE CORNER POSITION OF THE PLOT C WMRGP(II,NP) = FLOAT(IPWNDP(II,NP)) * 1 (WSPACE(II) + WSZEP(II,NP)) 2050 CONTINUE 2100 CONTINUE ELSE IF(INUM(1).GT.1) THEN INUM(1) = INUM(1) - 1 ELSE IF(INUM(2).GT.1) THEN INUM(2) = INUM(2) - 1 INUM(1) = IWIND(1) ELSE INUM(1) = 0 INUM(2) = 0 ENDIF IPWNDS(1) = INUM(1) IPWNDS(2) = INUM(2) ENDIF C C SET UP FOR WINDOWING C ELSE IF(NMODE.EQ.1) THEN C C IF LAST PLOT WAS A FIT GET BACK THE PARAMETERS FOR C A NORMAL PLOT C IF(QDFIT) CALL MN_FRP C NNUM = 0 IF(.NOT.QRFILE .AND. IDELIM.LT.0) THEN WRITE(LUNTTO,'('' Present numbers of windows are'' 1 ,'' x='',I2,'' y='',I2 2 ,/,'' Hit to keep these numbers'')') 3 IWIND(1),IWIND(2) ENDIF 3000 CONTINUE CALL WAITYQ('Give number of windows' // 1 ' in x and y directions: ') NVAL = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 3100 IF(IERR.GT.0) THEN IF(QRFILE) THEN GOTO 3100 ELSE NNUM = 0 CALL ZERTYQ('.FALSE.') GOTO 3000 ENDIF ENDIF NNUM = NNUM + 1 IWIND(NNUM) = NVAL IPWIND(NNUM) = NVAL IF(IDELIM.EQ.0 .AND. NNUM.LT.2) GOTO 3000 C 3100 CONTINUE NNUM = 0 IF(QRFILE .AND. IDELIM.LT.0) THEN WRITE(LUNTTO,'('' Present separations between plots are'' 1 ,'' x='',F7.2,'' y='',F7.2 2 ,/,'' Hit to keep these separations'')') 3 WSPACE(1),WSPACE(2) ENDIF 3200 CONTINUE CALL WAITYQ('Give separation between plots' // 1 ' in x and y directions: ') RVAL = RELTYQ(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.EQ.2) GOTO 3300 IF(IERR.GT.0) THEN IF(QRFILE) THEN CALL RESTYQ GOTO 3300 ELSE NNUM = 0 CALL ZERTYQ('.FALSE.') GOTO 3200 ENDIF ENDIF NNUM = NNUM + 1 WSPACE(NNUM) = RVAL WPSPAC(NNUM) = RVAL IF(IDELIM.EQ.0 .AND. NNUM.LT.2) GOTO 3200 C C CHECK THAT THE NEXT WINDOW NUMBER IS REASONABLE AND C WHETHER WE ARE REALLY STILL WINDOWING C 3300 CONTINUE DO 3310 NAX=1,2 IF(IWIND(NAX).LE.0) THEN IWIND(NAX) = 1 IPWIND(NAX) = 1 ENDIF 3310 CONTINUE C IF(IWIND(1).GT.1 .OR. IWIND(2).GT.1) THEN QWIND = .TRUE. QPWIND = .TRUE. C C Set the next window number to 1,1. C If you do not like this use SET NEXT_WINDOW to change again C IPWNDS(1) = 0 IPWNDS(2) = 0 cicb IF(IPWNDS(1).GT.IWIND(1) .OR. IPWNDS(2).GT.IWIND(2) .OR. cicb 1 (IWIND(1).EQ.1 .AND. IWIND(2).EQ.1)) THEN cicb IPWNDS(1) = 0 cicb IPWNDS(2) = 0 cicb ENDIF C C SET UP THE PLOT SIZES AND MARGINS IN THE WINDOW C DO 3400 NAX=1,2 WMRGS(NAX) = 0.0 WSZES(NAX) = (HSZES(NAX) - 1 FLOAT(IWIND(NAX)-1)*WSPACE(NAX)) / FLOAT(IWIND(NAX)) 3400 CONTINUE C C Change the title, tick and scale sizes if necessary C Also change the scale spacing from the x-axis and the C title offset in y C IF(IWIND(1).GT.1 .and. qascal) THEN AW1 = FLOAT(IWIND(1)) AW2 = FLOAT(IWIND(2)) IF(.NOT.QTUSER .AND. 1 ABS(TITLS(3)-TITLD(3)).LT.1.0E-03) THEN TITLS(3) = AMAX1(TITLS(3)/AW1,0.20) ENDIF IF(.NOT.QTUSER .AND. 1 ABS(TITLS(2)-TITLD(2)).LT.1.0E-03) THEN TITLS(2) = AMAX1(TITLS(2)/AW1,0.20) ENDIF * Tick sizes IF(ABS(TICKS(4,1)-TICKD(4,1)).LT.1.0E-03 .AND. 1 ABS(TICKS(5,1)-TICKD(5,1)).LT.1.0E-03 .AND. 1 ABS(TICKS(4,2)-TICKD(4,2)).LT.1.0E-03 .AND. 1 ABS(TICKS(5,2)-TICKD(5,2)).LT.1.0E-03)THEN TICKS(4,1) = AMAX1(TICKS(4,1)/(0.66*AW1),0.10) TICKS(4,2) = TICKS(4,1) TICKS(4,3) = TICKS(4,1) TICKS(5,1) = AMAX1(TICKS(5,1)/(0.66*AW1),0.20) TICKS(5,2) = TICKS(5,1) TICKS(5,3) = TICKS(5,1) ENDIF * Scale sizes IF(ABS(SCALS(3,1)-SCALD(3,1)).LT.1.0E-03 .AND. 1 ABS(SCALS(3,2)-SCALD(3,2)).LT.1.0E-03) THEN SCALS(3,1) = AMAX1(SCALS(3,1)/(0.66*AW1),0.25) SCALS(3,2) = SCALS(3,1) SCALS(3,3) = SCALS(3,1) ENDIF * Offset of scale on x-axis IF(IWIND(2).GT.1 .AND. + ABS(SCALS(2,1)-SCALD(2,1)).LT.1.0E-03) THEN SCALS(2,1) = SCALS(2,1)/(0.66*AW2) ENDIF * Label sizes IF(ABS(alablS(3,1)-alablD(3,1)).LT.1.0E-03 .AND. 1 ABS(alablS(3,2)-alablD(3,2)).LT.1.0E-03) THEN alablS(3,1) = AMAX1(alablS(3,1)/(0.66*AW1),0.25) alablS(3,2) = alablS(3,1) alablS(3,3) = alablS(3,1) ENDIF * Offset of label on all axes IF(IWIND(2).GT.1 .AND. + ABS(ALABLS(2,1)-ALABLD(2,1)).LT.1.0E-03) THEN ALABLS(1,1) = ALABLS(1,1)/(0.66*AW2) ALABLS(2,1) = ALABLS(2,1)/(0.66*AW2) ENDIF IF(IWIND(2).GT.1 .AND. + ABS(ALABLS(1,2)-ALABLD(1,2)).LT.1.0E-03) THEN ALABLS(1,2) = ALABLS(1,2)/(0.66*AW2) ALABLS(2,2) = ALABLS(2,2)/(0.66*AW2) ENDIF IF(IWIND(2).GT.1 .AND. + ABS(ALABLS(1,3)-ALABLD(1,3)).LT.1.0E-03) THEN ALABLS(1,3) = ALABLS(1,3)/(0.66*AW2) ALABLS(2,3) = ALABLS(2,3)/(0.66*AW2) ENDIF ENDIF C ELSEif(iwind(1).eq.1) then QWIND = .FALSE. QPWIND = .FALSE. C C SET THE TITLE AND SCALE BACK TO DEFAULT SIZE C TITLS(3) = TITLD(3) SCALS(3,1) = SCALD(3,1) SCALS(3,2) = SCALD(3,2) SCALS(3,3) = SCALD(3,3) TICKS(4,1) = TICKD(4,1) TICKS(4,2) = TICKD(4,2) TICKS(4,3) = TICKD(4,3) TICKS(5,1) = TICKD(5,1) TICKS(5,2) = TICKD(5,2) TICKS(5,3) = TICKD(5,3) SCALS(2,1) = SCALD(2,1) alabls(3,1)= alabld(3,1) alabls(3,2)= alabld(3,2) alabls(3,3)= alabld(3,3) alabls(1,1)= alabld(1,1) alabls(2,1)= alabld(2,1) alabls(1,2)= alabld(1,2) alabls(2,2)= alabld(2,2) alabls(1,3)= alabld(1,3) alabls(2,3)= alabld(2,3) ENDIF ENDIF C 9000 CONTINUE RETURN END +DECK,mn_zer. SUBROUTINE MN_ZER(NP,IDELIM) C C ASK IF WANT TO GET RID OF COMMENTS AND KEY EXPLANATIONS C Always get rid of them when reading commands from a file C implicit none * +CDE,MNPAR. +CDE,MNHPJ. +CDE,MNCMD. * integer np,idelim C CHARACTER*40 TPRMPT CHARACTER*80 TCMD integer ida,idb,istr,ntcmd,ncmmod,nncmt,lnblnk,jcmd,jdelim * integer istrnq,icmtyq external istrnq,icmtyq C IDA = IPLTIA(NP) IDB = IPLTIB(NP) C IF(QRFILE) THEN NPLTCM(NP) = 0 NPLTKY(NP) = 0 GOTO 9000 ENDIF C C Keep the rest of the command C TCMD = ' ' IF(IDELIM.EQ.0) ISTR = ISTRNQ(.TRUE.,TCMD,NTCMD) C C SEE IF COMMENTS ALREADY EXIST C DO 3000 NCMMOD=1,2 IF(NCMMOD.EQ.1) THEN NNCMT = NPLTCM(NP) TPRMPT = 'Keep the comment(s) [Y/N]?' ELSE NNCMT = NPLTKY(NP) TPRMPT = 'Keep the key(s) [Y/N]?' ENDIF IF(NNCMT.GT.0) THEN IF(.NOT.QRFILE) CALL MN_CMP(NCMMOD,IDA,IDB) 1100 CONTINUE CALL WAITYQ(TPRMPT(1:lnblnk(TPRMPT)+1)) JCMD = ICMTYQ(.TRUE.,JDELIM,LOGNAM) IF(JCMD.LE.0 .OR. JDELIM.GT.0) GOTO 1100 IF(MOD(JCMD,2).EQ.1) THEN ELSE IF(NCMMOD.EQ.1) THEN NPLTCM(NP) = 0 ELSE NPLTKY(NP) = 0 ENDIF ENDIF ENDIF 3000 CONTINUE C C Restore the TYPSCN buffer C IF(TCMD.NE.' ') CALL QUOTYQ(TCMD(1:NTCMD)) C 9000 CONTINUE END +DECK,m_call. SUBROUTINE M_CALL C C----------------------------------------------------------------------- C C Calls a Comis subroutine in a file given by the user C C Called by MN_CMD C C----------------------------------------------------------------------- C implicit none C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNCMD. +CDE,MNLUN. C CHARACTER*80 TXT1 CHARACTER*80 TFIL1,TFIL2,TFUNC CHARACTER*20 TARG INTEGER NCHR1,NADR,IERR,ind1,ind2,nh,kcmd,idelim + ,nnid,id1,idb,ndhis0 REAL ARG LOGICAL QEXIST,accessf integer icmtyq,isltyq real valtyq external icmtyq,isltyq,valtyq C CALL WAITYQ('Give the filename: ') NCHR1 = ISLTYQ(.TRUE.,IDELIM,TFIL1) IF(NCHR1.LE.0 .OR. IDELIM.GT.0) GOTO 9000 C C Look for an argument in the call C IND1 = INDEX(TFIL1(1:NCHR1),'(') IND2 = INDEX(TFIL1(1:NCHR1),')') TARG = ' ' IF(IND1.GT.1 .AND. IND2.GT.IND1) THEN NCHR1 = IND1 - 1 IF(IND2.GT.IND1+1) TARG = TFIL1(IND1+1:IND2-1) ENDIF C C See if the file exists and if not edit it C tfil2 = tfil1(:nchr1) call m_pfil(1,tfil2,ierr) if(ierr.ne.0) goto 9000 +SELF,IF=UNIX. qexist = accessf(tfil2,0) +SELF,IF=VMS. INQUIRE(FILE=TFIL2,EXIST=QEXIST) +SELF. IF(.NOT.QEXIST) THEN NH = 0 CALL M_SKEL(3,LUNTMP,NH,IERR,TFIL2) IF(IERR.NE.0) GOTO 9000 ENDIF C C Edit the COMIS function C CALL WAITYQ('Edit the COMIS function file [Y/N]: ') KCMD = ICMTYQ(.TRUE.,IDELIM,LOGNAM) IF(MOD(KCMD,2).EQ.1) THEN CALL QUOTYQ(TFIL2) TXT1 = 'EDIT' CALL MN_SPW(TXT1,IDELIM) ENDIF C C Compile the COMIS function C CALL M_FCMS(-1,TFIL2,TFIL1,TFUNC,NADR,IERR) IF(IERR.NE.0) GOTO 9000 C C Convert the argument to a real number (if there is one) C IF(TARG.NE.' ') THEN CALL QUOTYQ(TARG) ARG = VALTYQ(.TRUE.,IDELIM) CALL ZERTYQ('.FALSE.') CALL MN_RCK(ARG,IDELIM,IERR) IF(IERR.NE.0) THEN TXTERR = 'Error interpreting subroutine argument: ' // + TARG CALL MN_ERR('M_CALL',TXTERR) GOTO 9000 ENDIF ELSE ARG = 0.0 ENDIF C C Call the Comis subroutine C CALL CSJCAL(NADR,1,ARG) C C Update the Mn_Fit histograms from the current HBOOK directory C ndhis0 = ndhis call m_hbmn(0,0,ndidb,4) nnid = 1 id1 = 0 idb = ndidb call mn_hng('M_CALL',nnid,ndhis0,1,id1,id1,idb,idb) C 9000 CONTINUE END +DECK,m_defi. SUBROUTINE M_DEFI(IDELIM,COMAND) C C------------------------------------------------------------------------------ C Define and undefine internal commands. C The command FDEFINE_ means define the fit commands C------------------------------------------------------------------------------ C +CDE,MNCMD. +CDE,MNTYQ. +CDE,MNLUN. C character comand*(*) C CHARACTER*255 TXT1 CHARACTER*10 TCOMM,TNAME C IF(COMAND.EQ.'DEFINE') THEN CALL WAITYQ('Give the name of new command: ') NCHR = ISTTYQ(.TRUE.,IDELIM,TCOMM) IF(NCHR.LE.0) GOTO 9000 C C Command ALL not allowed C IF(TCOMM.EQ.'ALL') THEN CALL MN_ERR('M_DEFI' + ,'You are not allowed to define ALL') GOTO 9000 ENDIF C C Check whether the command already exists C DO 8100 I=1,NOPR IF(TCOMM.EQ.OPRNAM(I)) THEN CALL M_EMSG('M_DEFI','Command ' // TCOMM // 1 ' already exists') CALL MN_ERR('M_DEFI','You must UNDEFINE it first') GOTO 9000 ENDIF 8100 CONTINUE C IF(NOPR.GE.MOPR) THEN CALL MN_ERR('M_DEFI' + ,'Maximum number of defined commands reached') GOTO 9000 ENDIF C NPTR = 0 IF(NOPR.GT.0) NPTR = IOPRP2(NOPR) NPTR0 = NPTR + 1 TNAME = TCOMM C CALL WAITYQ('DEFINE> ') 2000 CONTINUE ISTR = ISTRNQ(.TRUE.,TXT1,NCHAR) TCOMM = ' ' IF(NCHAR.LE.0) THEN NCHAR = 1 TXT1 = ' ' ELSE CALL QUOTYQ(TXT1(1:NCHAR)) NCHR = ISTTYQ(.TRUE.,IDELIM,TCOMM) ENDIF CALL ZERTYQ('.FALSE.') IF(TCOMM(1:6).EQ.'ENDDEF') THEN NOPR = NOPR + 1 OPRNAM(NOPR) = TNAME IOPRP1(NOPR) = NPTR0 IOPRP2(NOPR) = NPTR ELSE NPTR = NPTR + 1 IF(NPTR.GT.MOPRBF) THEN NPTR = NPTR - 1 CALL MN_ERR('M_DEFI' + ,'Buffer for storing defined commands is full') GOTO 9000 ENDIF TOPRBF(NPTR) = TXT1(1:NCHAR) GOTO 2000 ENDIF C C Define the fit commands C ELSEIF(COMAND.EQ.'FDEFINE_') THEN NPTR = 0 IF(NOPR.GT.0) NPTR = IOPRP2(NOPR) NPTR0 = NPTR + 1 DO I=1,NFSTKU NPTR = NPTR + 1 TOPRBF(NPTR) = TFSTK(I) ENDDO NOPR = NOPR + 1 OPRNAM(NOPR) = 'QUICK_FIT_' IOPRP1(NOPR) = NPTR0 IOPRP2(NOPR) = NPTR C C GET RID OF AN INTERNALLY DEFINED COMMAND C ELSEIF(COMAND.EQ.'UNDEFINE') THEN NCHR = ISTTYQ(.TRUE.,IDELIM,TCOMM) IF(NCHR.LE.0) GOTO 9000 IF(TCOMM.EQ.'ALL') THEN NOPR = 0 CALL TZERO(OPRNAM,MOPR) CALL VZERO_i(IOPRP1,MOPR) CALL VZERO_i(IOPRP2,MOPR) GOTO 9000 ENDIF DO 3500 I=1,NOPR IF(TCOMM.EQ.OPRNAM(I)) THEN N1 = IOPRP1(I) N2 = IOPRP2(I) NCOP = N2 - N1 + 1 DO 3000 J=I+1,NOPR OPRNAM(J-1) = OPRNAM(J) IOPRP1(J-1) = IOPRP1(J) - NCOP IOPRP2(J-1) = IOPRP2(J) - NCOP 3000 CONTINUE NCOP = IOPRP2(NOPR) - N2 CICB CALL TCOPY(TOPRBF(N2+1),TOPRBF(N1),NCOP) DO 3100 II=1,NCOP TOPRBF(N1+II-1) = TOPRBF(N2+II) 3100 CONTINUE OPRNAM(NOPR) = ' ' NOPR = NOPR - 1 GOTO 3501 ENDIF 3500 CONTINUE IF(.NOT.QRFILE) THEN WRITE(TXTERR,'(''Defined command: '' 1 ,A,'' not found'')') TCOMM(1:MNLLEN(TCOMM)) CALL M_EMSG('MN_CMD',TXTERR) ENDIF 3501 CONTINUE ENDIF C 9000 CONTINUE END +DECK,m_fdfl. SUBROUTINE M_FDFL C C----------------------------------------------------------------------- C C Sets all parameters for fitting to default C C Called by MN_FIT, M_SFIT C C----------------------------------------------------------------------- IMPLICIT NONE C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNTYQ. C C Show fit iterations C QFITER = .FALSE. C C Integrate function across bins C QFINTG = .FALSE. C C Use bin width when calculating function values C QFBINW = .TRUE. C C Convolute the function with a Gaussian C RFCONV(1) is the width of the Gaussian C RFCONV(2) is the number of intervals for the Simpson integration C RFCONV(3) is the number of sigmas to integrate over C QFCONV = .FALSE. RFCONV(1) = 1.0 RFCONV(2) = 100.0 RFCONV(3) = 3.0 C C Calculate the AREA of fragmentation or dipion functions C QFAREA = .FALSE. C C Use ratio of areas when fitting more than 1 plot C QRATIO = .TRUE. C C Display mode C NDMODE = 1 C C Stack of commands for quick fitting C NFSTKU = 0 NFSTKD = 2 TFSTK(1) = 'MINIMIZE' TFSTK(2) = 'DISPLAY' C END +DECK,m_filb. C SUBROUTINE M_FILB(IDA,IDB,ADAT,WTIN) C +CDE,MNPAR. C REAL ADAT(MDIMMX),AERN(MDIMMX),AERP(MDIMMX) LOGICAL QERRI C WEIGHT = WTIN QERRI = .FALSE. C CALL M_FILG(IDA,IDB,ADAT,AERN,AERP,WEIGHT,QERRI) C RETURN END +DECK,m_filg. C SUBROUTINE M_FILG(IDA,IDB,ADAT,AERN,AERP,WEIGHT,QERRI) C C Filling routine for MNBOOK C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNTMP. +CDE,MNLUN. C REAL ADAT(*),AERN(*),AERP(*) C INTEGER IERR LOGICAL QINS,QERRI,QERRL,QERRH C DATA IERR/0/ C NERR = 0 C CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) GOTO 9000 C CALL AMNOFF(NDIM,NWPPT,NOFF,NOFFL,NOFFH,QERRL,QERRH) C NWTOT = NINT(RDAT(NPTRH)) NWH = NINT(RDAT(NPTRH+1)) NWDAT = NINT(RDAT(NPTRH+2)) C C GET THE NUMBER OF UNDERFLOWS AND OVERFLOWS C CALL MN_UOF(RDAT(NPTRH),ACONT) C C FOR BINNED HISTOGRAMS INCREMENT THE BIN CONTENTS C IF(NDIM.GT.0) THEN C C SORT OUT WHICH BIN I AM IN AND THE POINTER TO IT C NDEL = 0 NUOF = 0 NBTOT = 1 QINS = .TRUE. DO 1000 ND=1,NDIM FBIN = (ADAT(ND)-ADLO(ND)) / (ADHI(ND)-ADLO(ND)) CICB IF(FBIN.LT.0.0 .OR. FBIN.GT.1.0) GOTO 9000 IF(FBIN.GE.0.0) THEN NBIN = IFIX(FBIN*FLOAT(IDBIN(ND))) + 1 ELSE NBIN = IFIX(FBIN*FLOAT(IDBIN(ND))) ENDIF NBIN = MIN0(MAX0(NBIN,0),IDBIN(ND)+1) IF(NBIN.LE.0) THEN NUOF = 1 QINS = .FALSE. ELSE IF(NBIN.GT.IDBIN(ND)) THEN NUOF = 3 QINS = .FALSE. ELSE NUOF = 2 ENDIF C IF(QINS) THEN IF(ND.EQ.1) THEN NDEL = NBIN - 1 ELSE NBTOT = NBTOT * IDBIN(ND-1) NDEL = NDEL + NBTOT*(NBIN-1) ENDIF ENDIF C IF(NDIM.LE.3) THEN IF(ND.EQ.1) THEN NDUOF = NUOF - 1 ELSE NDUOF = NDUOF + (3**(ND-1))*(NUOF-1) ENDIF ENDIF 1000 CONTINUE C IF(QINS) THEN NPT = NDEL + 1 EE = AMNE(NPT,NH,NERR) EE = EE + WEIGHT CALL UMNE(NPT,NH,NPTRD,NDIM,NWPPT,NBPPT,EE,NERR) DEE = 0.0 IF(QERRL) THEN DEE = AMNDEN(NPT,NH,NERR) DEE = SQRT(DEE*DEE + WEIGHT*WEIGHT) CALL UMNDE(NPT,NH,NPTRD,NDIM,NWPPT,NBPPT,DEE,NERR) ENDIF ENDIF C IF(NDIM.LE.3) ACONT(NDUOF+1) = ACONT(NDUOF+1) + WEIGHT EDHI = AMAX1(EDHI,EE+DEE) EDENT = EDENT + WEIGHT C C UNBINNED HISTOGRAMS C FILL UP THE BUFFER AND IF NECESSARY WRITE IT OUT C OR JUST ADD THE EXTRA DATA POINT C ELSEIF(NDIM.LT.0) THEN C IF(NWDAT.EQ.0 .AND.QMNOPN) THEN C NN = 0 C DO 3000 NNN=1,NUBIN C IF(IDA.EQ.IDTA(NNN) .AND. IDB.EQ.IDTB(NNN)) THEN C NN = NNN C NPTRT = IPTR(NN) C GOTO 3001 C ENDIF C3000 CONTINUE C GOTO 9000 C3001 CONTINUE CC C CALL UCOPY_r(ADAT,RTMP(NPTRT+1,NN),IABS(NDIM)) C NPTRT = NPTRT + IABS(NDIM) C IF(QERRL) THEN C IF(QERRI) CALL UCOPY_r(AERN,RTMP(NPTRT+1,NN),IABS(NDIM)) C NPTRT = NPTRT + IABS(NDIM) C ENDIF C IF(QERRH) THEN C IF(QERRI) CALL UCOPY_r(AERP,RTMP(NPTRT+1,NN),IABS(NDIM)) C NPTRT = NPTRT + IABS(NDIM) C ENDIF C C IF(NPTRT.GT.MNBLOK) THEN C NWD = MNBLOK C WRITE(LUNMNU) IDA,IDB,NWD,(RTMP(II,NN),II=1,NWD) C NPTRT = NPTRT - MNBLOK C IDWR(NN) = IDWR(NN) + 1 C CALL UCOPY_r(RTMP(MNBLOK+1,NN),RTMP(1,NN),NPTRT) C ENDIF C IPTR(NN) = NPTRT C C ELSE IF(NWDAT.GT.0) THEN IF(NWPPT*NPNT.LT.NWDAT) THEN NWCOP = IABS(NDIM) IF(NDIM.EQ.-1) NWCOP = NWCOP + 1 NPTR = NPTRD + NWPPT*NPNT CALL UCOPY_r(ADAT,RDAT(NPTR),NWCOP) IF(QERRL) THEN NPTR = NPTR + NWCOP IF(QERRI) CALL UCOPY_r(AERN,RDAT(NPTR),NWCOP) ENDIF IF(QERRH) THEN NPTR = NPTR + NWCOP IF(QERRI) CALL UCOPY_r(AERP,RDAT(NPTR),NWCOP) ENDIF ELSE IERR = IERR + 1 IF(IERR.LE.10 .OR. MOD(IERR,100).EQ.1) THEN WRITE(TXTERR,'(''No more room to store data'' 1 ,'' for plot'',I7,I4)') IDA,IDB CALL M_EMSG('M_FILG',TXTERR) ENDIF GOTO 9000 ENDIF C ENDIF C C UPDATE THE POINTERS AND NUMBER OF ENTRIES C DO 3100 ND=1,IABS(NDIM) IF(QERRH) THEN ADLO(ND) = AMIN1(ADLO(ND),ADAT(ND)-AERN(ND)) ADHI(ND) = AMAX1(ADHI(ND),ADAT(ND)+AERP(ND)) ELSEIF(QERRL) THEN ADLO(ND) = AMIN1(ADLO(ND),ADAT(ND)-AERN(ND)) ADHI(ND) = AMAX1(ADHI(ND),ADAT(ND)+AERN(ND)) ELSE ADLO(ND) = AMIN1(ADLO(ND),ADAT(ND)) ADHI(ND) = AMAX1(ADHI(ND),ADAT(ND)) ENDIF 3100 CONTINUE NPNT = NPNT + 1 EDENT = FLOAT(NPNT) IF(NDIM.EQ.-1) THEN IF(QERRH) THEN EDLO = AMIN1(EDLO,ADAT(2)-AERN(2)) EDHI = AMAX1(EDHI,ADAT(2)+AERP(2)) ELSEIF(QERRL) THEN EDLO = AMIN1(EDLO,ADAT(2)-AERN(2)) EDHI = AMAX1(EDHI,ADAT(2)+AERN(2)) ELSE EDLO = AMIN1(EDLO,ADAT(2)) EDHI = AMAX1(EDHI,ADAT(2)) ENDIF acont(2) = edent elseif(ndim.eq.-2) then acont(5) = edent ENDIF ENDIF C CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB,NDIM,NWPPT,NPNT 1 ,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) C 9000 CONTINUE RETURN END +DECK,m_hbmn. SUBROUTINE M_HBMN(IDA1I,IDA2I,IDB,NMODE) C C----------------------------------------------------------------------------- C Converts an HBOOK histogram or Ntuple to a Mn_Fit one C C Called by MN_HBF, M_NTPSCN, M_CALL C----------------------------------------------------------------------------- C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFLG. +CDE,MNLUN. C *ICB+CDE,HCBITS. C INTEGER IDA1I,IDA2I,IDB,NMODE C INTEGER MVDIM,MNTPMX,MHIST PARAMETER (MVDIM = 1) PARAMETER (MNTPMX = 50 000) PARAMETER (MHIST = 200) C INTEGER IQUEST COMMON/QUEST/IQUEST(100) C REAL VECT(1) INTEGER KIND(32) C CHARACTER*80 TITLE CHARACTER*32 TNAME(MDIMMX),TNDEF(MDIMMX) CHARACTER*4 TPART INTEGER IDVECT(MHIST) INTEGER IDBIN(MDIMMX) REAL ADLO(MDIMMX),ADHI(MDIMMX) REAL ACONT(3**3) INTEGER NWPPTX,NWDATX C INTEGER I,II,IDH,NHIST,IERR,NHDATE,NHTIME,LENN INTEGER IDA,NFILE,ICYCLE,NBINX,NBINY,NWT,IAD,NDIM + ,NPNT,NWPPT,NWDAT,NBPPT,NTMODE,NH,NPTRH,NPTRD,NWH,NP + ,NPTR,NWTOT,NSDATE,NSTIME REAL XLO,XHI,YLO,YHI,EDENT,EDLO,EDHI C logical hntnew,qcwntp external hntnew C LOGICAL QSTART SAVE TNDEF DATA QSTART/.TRUE./ C IF(QSTART) THEN QSTART = .FALSE. DO 100 II=1,MDIMMX IF(II.EQ.1) THEN TNDEF(II) = 'X' ELSE IF(II.EQ.2) THEN TNDEF(II) = 'Y' ELSE IF(II.EQ.3) THEN TNDEF(II) = 'Z' ELSE TNDEF(II) = ' ' ENDIF 100 CONTINUE ENDIF C IDH = IDA1I IF(IDH.EQ.0) THEN CALL HIDALL(IDVECT,NHIST) IF(NHIST.GT.MHIST) THEN WRITE(TXTERR,'(''I will only copy'',I4 + ,'' histograms into Mn_Fit memory'')') MHIST CALL M_EMSG('M_HBMN',TXTERR) nhist = mhist ENDIF ELSEIF(IDA1I.LT.IDA2I) THEN CALL HIDALL(IDVECT,NHIST) IF(NHIST.GT.MHIST) THEN WRITE(TXTERR,'(''I can copy'',I4 + ,'' a maximum of histograms into Mn_Fit memory'')') MHIST CALL M_EMSG('M_HBMN',TXTERR) ENDIF ELSE NHIST = 1 IDVECT(1) = IDH ENDIF IERR = 0 C C Loop over the histograms C DO 5000 I=1,NHIST IDH = IDVECT(I) IDA = IDH C C See if the histogram is in the range requested C if(ida1i.lt.ida2i) then if(idh.lt.ida1i .or. idh.gt.ida2i) goto 5000 endif C C Find the date and time of the histogram creation C IF(NMODE.EQ.3) THEN NHDATE = 0 NHTIME = 0 call vzero_i(kind,32) ELSE CALL HKIND(IDH,KIND,'A') icycle = 999999 CALL RZVIN(VECT,MVDIM,NFILE,IDH,ICYCLE,'D') C WRITE(6,*) 'Histogram: ',IDH,' Nfile: ',NFILE C WRITE(6,'('' IQUEST(1->20)'',/,(1X,5I12))') C + (IQUEST(II),II=1,20) CALL RZDATE(IQUEST(14),NHDATE,NHTIME,1) C WRITE(6,'('' Date'',I8,'' Time'',I8)') NHdate,NHtime ENDIF C C Get the histogram title, binning etc. C CALL HGIVE(IDH,TITLE,NBINX,XLO,XHI,NBINY,YLO,YHI,NWT,IAD) if(nmode.eq.3) then if(nbiny.eq.0) then kind(1) = 1 else kind(2) = 1 endif endif C C Ntuple - CWN or RWN? C cicb if(i4.ne.0) then if(kind(4).ne.0) then qcwntp = hntnew(idh) else qcwntp = .false. endif C C An Ntuple C *ICB IF(I4.NE.0) THEN if(kind(4).ne.0) then NDIM = MDIMMX CALL HGIVEN(IDH,TITLE,NDIM,TNAME,ADLO,ADHI) IF(NDIM.GT.MDIMMX) THEN WRITE(TXTERR,'(''Plot'',I7,'' has'',I4 1 ,'' dimensions, but I can only store'',I4)') 2 IDH,NDIM,MDIMMX CALL M_EMSG('MN_HBF',TXTERR) GOTO 5000 ENDIF C C Make sure all the tags are left-justified C LENN = LEN(TNAME(1)) DO 4100 II=1,NDIM CALL CLEFT(TNAME(II),1,LENN) 4100 CONTINUE C CALL HNOENT(IDH,NPNT) NDIM = -NDIM NWPPT = IABS(NDIM) NWPPTX = NWPPT ELSE IF(NBINY.LE.0) THEN C C SEE IF THE HISTOGRAM HAS VARIABLE BIN WIDTH C *ICB IF(I6.NE.0) THEN IF(kind(6).NE.0) THEN NDIM = -1 NWPPT = 4 ELSE NDIM = 1 NWPPT = 2 ENDIF NWPPTX = NWPPT + 1 NPNT = NBINX TNAME(1) = TNDEF(1) ELSE NDIM = 2 NWPPT = 2 NWPPTX = NWPPT + 1 NPNT = NBINX*NBINY TNAME(1) = TNDEF(1) TNAME(2) = TNDEF(2) ENDIF C C Allow extra space for sorting HBOOK data to Mn_Fit order C NWDAT = NPNT*NWPPT NWDATX = NPNT*NWPPTX NBPPT = 0 NTMODE = 0 C C Ntuples of more than 50000 words will not be read into memory C CWN's are never read into memory! C IF(NDIM.LT.0 .AND. (NWDAT.GT.MNTPMX .or. qcwntp)) THEN NWDAT = 0 NWDATX = 0 ENDIF C C GET THE HISTOGRAM NUMBER AND THE POINTER C RESERVE SPACE FOR THE HISTOGRAM C CALL MN_HNW(IDA,IDB,NDIM,NWDATX,NH,NPTRH,NPTRD,NWH + ,NBPPT,NTMODE) IF(NH.LE.0) THEN IERR = 1 GOTO 9000 ENDIF C C GET THE HISTOGRAM CONTENTS C IF(NDIM.EQ.1 .OR. NDIM.EQ.2 .OR. cicb + (NDIM.EQ.-1 .AND. NBINX.GT.0)) THEN + (NDIM.EQ.-1 .AND. kind(4).eq.0)) THEN TPART = ' ' CALL MN_HEX(IDH,TPART,0,RDAT(NPTRD),NDIM,NWPPT,NPNT + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,TITLE,ACONT,IERR) IF(IERR.NE.0) GOTO 9000 ELSE CALL VZERO_i(IDBIN,MDIMMX) C C Read the Ntuple into memory - set the directories properly C IF(NWDAT.GT.0) THEN CALL M_SDIR(0,IERR) IF(IERR.NE.0) GOTO 5000 if(qcwntp) then else CALL HGNPAR(IDH,'M_HBMN') endif DO 4700 NP=1,NPNT NPTR = NPTRD + NWPPT*(NP-1) if(qcwntp) then else CALL HGNF(IDH,NP,RDAT(NPTR),IERR) endif IF(IERR.NE.0) THEN WRITE(TXTERR + ,'(''Error unpacking Ntuple'',I7)') IDH CALL M_EMSG('MN_HBF',TXTERR) GOTO 5000 ENDIF 4700 CONTINUE ENDIF EDENT = FLOAT(NPNT) EDLO = 0.0 EDHI = 1.0 ENDIF C C FILL IN THE HEADER INFORMATION AND THE POINTERS C NWTOT = NWH + NWDAT NSDATE = 0 NSTIME = 0 CALL MN_HDU(RDAT(NPTRH),NWTOT,NWH,NWDAT,IDA,IDB 1 ,NDIM,NWPPT,NPNT,NHDATE,NHTIME,NSDATE,NSTIME,NTMODE + ,EDENT,EDLO,EDHI,IDBIN,ADLO,ADHI,NBPPT,ACONT) CALL MN_PTU(NH,NWTOT,IDA,IDB,NPTRH,NPTRD,TITLE,FIL_HB 1 ,DIR_HC,TNAME) if(.not.qcwntp) then CALL MN_MSU(IDA,IDB,NDIM,NWH,NH) endif C 5000 CONTINUE C 9000 CONTINUE C END +DECK,m_hclean. subroutine m_hclean(mode) * *------------------------------------------------------------------------------ * Deletes any columnwise Ntuples that are in memory before calling HREND * Seeems to be necessary * Use the explicit strucutre of Mn_Fit storage as this routine * can be called when the histogram wanted has already been setup using * MN_HGT. * Make sure any current value of dir_hb is saved and restored. *------------------------------------------------------------------------------ * implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNLUN. +CDE,MNFLG. * +CDE,HCDIR. * integer mode * integer ida,idb,idh,ierr,i,nptrht,nwdatt,ndimt + ,lenf,nch logical hexist integer lnblnk character dir_sv*80 * external hexist * * Input files * if(mode.eq.0 .or. mode.eq.1) then * * See of the input file is open * *ICB write(6,'('' Looking for input file'')') do nch=1,nchtop lenf = lnblnk(hfname(nch)) *ICB write(6,'(1X,A,'' File: '',A)') chtop(nch),hfname(nch)(:lenf) if(chtop(nch).eq.'MN_HBIN') then dir_sv = dir_hb do 1000 i=1,ndhis if(idptrh(i).le.0 .or. idptrd(i).le.0) goto 1000 ida = idida(i) idb = ididb(i) idh = ida nptrht = idptrh(i) nwdatt = nint(rdat(nptrht+2)) ndimt = nint(rdat(nptrht+5)) if(ndimt.lt.0 .and. nwdatt.eq.0 .and. + tddir(i).ne.' ' .and. tdfil(i)(1:1).ne.'*') then dir_hb = tddir(i) call m_sdir(0,ierr) * if(hexist(idh)) then call hdelet(idh) endif endif 1000 continue * write(6,'('' Closing MN_HBIN: '',A)') hfname(nch)(:lenf) call hrendc('MN_HBIN') * ICB close(lunhin) dir_hb = dir_sv endif enddo endif * * Output files * if(mode.eq.0 .or. mode.eq.1) then * * See of the output file is open * *ICB write(6,'('' Looking for output file'')') do nch=1,nchtop lenf = lnblnk(hfname(nch)) write(6,'(1X,A,'' File: '',A)') chtop(nch),hfname(nch)(:lenf) if(chtop(nch).eq.'MN_HBOUT') then write(6,'('' Closing MN_HBOUT: '',A)') hfname(nch)(:lenf) call hrendc('MN_HBOUT') endif enddo endif * end +DECK,m_hcop. SUBROUTINE M_HCOP(IDELIM) C C------------------------------------------------------------------------------ C Copies or renames histograms, both Mn_Fit and HBOOK C------------------------------------------------------------------------------ C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNINF. +CDE,MNCMD. +CDE,MNLUN. C integer idelim * character title*80 LOGICAL QZERO,QMNHEX,HEXIST integer ida1,idb1,ida2,idb2,idh1,idh2 + ,nh,nh2,nnid,nloop,nptrh2,nptrd2 + ,nwtot,nwhead,nwh2,ierr,ii,kind(32) + ,nbinx,nbiny,nwt,locate,ioerr real xlo,xhi,ylo,yhi C CALL WAITYQ('Give input, output histogram numbers: ') CALL MN_HNO(IDA1,IDB1,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA1.LT.0) GOTO 9000 CALL WAITYP('Give output histogram number: ') CALL MN_HNO(IDA2,IDB2,IDELIM,NNID) IF(IDA2.LT.0) GOTO 9000 IF(NNID.LE.0) GOTO 9000 C IF(COMND1.EQ.'HCOPY' .OR. COMND1.EQ.'HRENAME') THEN IF(IDA1.LE.0 .OR. IDA2.LE.0) THEN WRITE(TXTERR,'('' Input or output histogram'' 1 ,'' number is not valid:'',2I7)') IDA1,IDA2 CALL MN_ERR('M_HCOP',TXTERR) GOTO 9000 ENDIF ENDIF C QZERO = .FALSE. NLOOP = 1 IF(IDA1.EQ.0 .AND. IDA2.EQ.0) THEN QZERO = .TRUE. NLOOP = NDHIS ENDIF DO 4830 II=1,NLOOP IF(QZERO) THEN IF(IDPTRH(II).LE.0 .OR. IDPTRD(II).LE.0) 1 GOTO 4830 IDA1 = IDIDA(II) IF(IDB1.NE.IDIDB(II)) GOTO 4830 IDA2 = IDA1 ENDIF CALL MN_HGT(IDA1,IDB1,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA1,IDB1 CALL MN_ERR('M_HCOP',TXTERR) GOTO 4830 ENDIF NWTOT = NINT(RDAT(NPTRH)) NWHEAD = NINT(RDAT(NPTRH+1)) C C Ntuples which are not in memory cannot be renamed or copied C IF(NWDAT.LE.0 .AND. IDA1.NE.IDA2) THEN WRITE(TXTERR,'(''You cannot rename or copy'' + ,'' the primary id for Ntuple'',I7)') IDA1 CALL M_EMSG('M_HCOP',TXTERR) CALL M_EMSG('M_HCOP','It is not stored in memory') GOTO 4830 ENDIF C IF(COMND1.EQ.'COPY') THEN CALL MN_HNW(IDA2,IDB2,NDIM,NWDAT 1 ,NH2,NPTRH2,NPTRD2,NWH2,NBPPT,NTMODE) IF(NH2.LE.0) GOTO 4831 C C Copy the header and data separately to allow for C change in the header length C Zero any words of header not copied C CALL UCOPY_r(RDAT(NPTRH),RDAT(NPTRH2),NWHEAD) CALL UCOPY_r(RDAT(NPTRD),RDAT(NPTRD2),NWDAT) IF(NWHEAD.LT.NWH2) THEN CALL VZERO_r(RDAT(NPTRH2+NWHEAD+1),NWH2-NWHEAD) NWTOT = NWH2 + NWDAT RDAT(NPTRH2) = NWTOT RDAT(NPTRH2+1) = NWH2 ENDIF RDAT(NPTRH2+3) = IDA2 RDAT(NPTRH2+4) = IDB2 CALL MN_PTU(NH2,NWTOT,IDA2,IDB2,NPTRH2,NPTRD2 1 ,TDTIT(NH),TDFIL(NH),TDDIR(NH),TDNAM(1,NH)) ELSEIF(COMND1.EQ.'RENAME') THEN IF(QMNHEX(IDA2,IDB2,NH2)) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' already exists'' 2 ,'' and will be overwritten'')') IDA2,IDB2 CALL M_EMSG('M_HCOP',TXTERR) IDPTRH(NH2) = -IABS(IDPTRH(NH2)) IDPTRD(NH2) = -IABS(IDPTRD(NH2)) ENDIF IDIDA(NH) = IDA2 IDIDB(NH) = IDB2 RDAT(NPTRH+3) = IDA2 RDAT(NPTRH+4) = IDB2 ENDIF C C COPY OR RENAME HBOOK HISTOGRAM C IF(COMND1.EQ.'COPY' .OR. COMND1.EQ.'RENAME') THEN cicb IDH1 = IDB1*1000 + IDA1 cicb IDH2 = IDB2*1000 + IDA2 IDH1 = IDA1 IDH2 = IDA2 ELSEIF(COMND1.EQ.'HCOPY' .OR. COMND1.EQ.'HRENAME') THEN IDH1 = IDA1 IDH2 = IDA2 ENDIF * * Initialize the HBOOK file if this is an HBOOK histogram * if(tdfil(nh)(1:1).ne.'*' .and. tddir(nh).ne.' ') then call m_intp(ida1,idb1,nh,ierr) if(ierr.ne.0) then WRITE(TXTERR,'(''Error initializing'',I7 1 ,'' copy of HBOOK histogram'')') IDH1 CALL M_EMSG('M_HCOP',TXTERR) goto 4830 endif elseif(comnd1.eq.'HCOPY' .or. comnd1.eq.'HRENAME') then write(txterr,'(''Histogram '',I7,I4 + ,'' is not an HBOOK histogram'')',iostat=ioerr) + ida1,idb1 call m_emsg('M_HCOP',txterr) goto 4830 endif * * Copy the HBOOK histogram only if it matches the Mn_Fit one * IF(HEXIST(IDH1) .AND. IDH1.NE.IDH2) THEN IF(HEXIST(IDH2)) CALL HDELET(IDH2) * if(ndim.lt.0) then WRITE(TXTERR,'(''HBOOK Ntuple'',I7 1 ,'' will not be copied or renamed'')') IDH1 CALL M_EMSG('M_HCOP',TXTERR) goto 4830 elseif(ndim.gt.2) then WRITE(TXTERR,'(''Mn_Fit histogram is > 2-D.'' + ,'' HBOOK histogram'',I7 1 ,'' will not be copied or renamed'')') IDH1 CALL M_EMSG('M_HCOP',TXTERR) goto 4830 * * Histogram is a projection. HBOOK copy does not exist * elseif(tdfil(nh)(1:1).eq.'*') then goto 4830 endif * * Check that the HBOOK histogram is the correct one * Do not try to copy Ntuples * call hkind(idh1,kind,' ') if(kind(1).gt.0 .and. kind(1).ne.4) then call hgive(idh1,title,nbinx,xlo,xhi,nbiny,ylo,yhi + ,nwt,locate) if(idbin(1).ne.nbinx .or. + (ndim.eq.2 .and. idbin(2).ne.nbiny)) then WRITE(TXTERR,'(''HBOOK histogram'',I7 1 ,'' does not match Mn_Fit histogram'')') IDH1 CALL M_EMSG('M_HCOP',TXTERR) WRITE(TXTERR + ,'(''It will not be copied or renamed'')') CALL M_EMSG('M_HCOP',TXTERR) goto 4830 endif * CALL HCOPY(IDH1,IDH2,' ') IF(COMND1.EQ.'RENAME' .OR. COMND1.EQ.'HRENAME') 1 CALL HDELET(IDH1) elseif(kind(1).eq.4) then write(txtmes,'('' HBOOK histogram'',I7 + ,'' is an Ntuple.'' + ,'' It will not be copied or renamed'')') *ICB call m_emsg('M_HCOP',txterr) endif ELSEIF(COMND1.EQ.'HCOPY' .OR. COMND1.EQ.'HRENAME') THEN WRITE(TXTERR,'('' Histogram'',I7,'' does not exist'' + ,'' in the current HBOOK directory'')') IDH1 CALL M_EMSG('M_HCOP',TXTERR) ENDIF 4830 CONTINUE 4831 CONTINUE C 9000 CONTINUE END +DECK,m_hdel. SUBROUTINE M_HDEL(IDELIM) C C------------------------------------------------------------------------------ C Deletes histograms, both Mn_Fit and HBOOK C------------------------------------------------------------------------------ C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNLST. +CDE,MNTMP. +CDE,MNCMD. +CDE,MNLUN. * integer idelim C integer idwa1,idwa2,idwb1,idwb2,nnid,nloop,ida,idb,idh + ,ii,nh LOGICAL QZERO,HEXIST C 1000 CONTINUE CALL WAITYQ('Give histogram number: ') CALL MN_HRN(IDWA1,IDWA2,IDWB1,IDWB2,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 C C DELETE ALL HISTOGRAMS C IF(IDWA1.EQ.0 .AND. 1 ((COMND1.EQ.'DELETE' .AND. NNID.EQ.1) .OR. 2 (COMND1.EQ.'HDELETE'))) THEN IF(COMND1.EQ.'DELETE') THEN CALL VZERO_i(IDIDA,MHSTMX) CALL VZERO_i(IDIDB,MHSTMX) CALL VZERO_i(IDPTRH,MHSTMX) CALL VZERO_i(IDPTRD,MHSTMX) NDHIS = 0 NDPTE = 0 NUBIN = 0 NHALST = -1 ENDIF CALL HDELET(0) WRITE(TXTMES,'('' All histograms deleted'')') CALL MN_MES(LUNTTO,'ME',TXTMES) C C DELETE SOME HISTOGRAMS C ELSE C C DELETE ONLY ONE C IF((NNID.EQ.1 .AND. IDWA1.NE.0 .AND. IDWA1.EQ.IDWA2) .OR. 1 (NNID.EQ.2 .AND. IDWA1.NE.0 .AND. IDWA1.EQ.IDWA2 .AND. 1 IDWB1.EQ.IDWB2)) THEN QZERO = .FALSE. NLOOP = 1 IDA = IDWA1 IDB = IDWB1 C C DELETE A RANGE C ELSE QZERO = .TRUE. NLOOP = NDHIS ENDIF C DO 4845 II=1,NLOOP IF(QZERO) THEN IF(IDPTRH(II).LE.0 .OR. IDPTRD(II).LE.0) 1 GOTO 4845 IDA = IDIDA(II) IDB = IDIDB(II) IF((IDWA1.NE.0 .AND. 1 (IDA.LT.IDWA1 .OR. IDA.GT.IDWA2)) .OR. 2 (NNID.GT.1 .AND. 2 (IDB.LT.IDWB1 .OR. IDB.GT.IDWB2))) GOTO 4845 NH = II ELSE CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('M_HDEL',TXTERR) GOTO 4845 ENDIF ENDIF C IDPTRH(NH) = -IABS(IDPTRH(NH)) IDPTRD(NH) = -IABS(IDPTRD(NH)) WRITE(TXTMES,'('' Histogram'',I7,I4 1 ,'' deleted'')') IDA,IDB CALL MN_MES(LUNTTO,'ME',TXTMES) C C DELETE HBOOK HISTOGRAM C cicb IDH = IDB*1000 + IDA IDH = IDA IF(HEXIST(IDH)) THEN CALL HDELET(IDH) IF(COMND1.EQ.'HDELETE') THEN WRITE(TXTMES, 1 '('' HBOOK histogram'',I7,'' deleted'')') 1 IDH CALL MN_MES(LUNTTO,'ME',TXTMES) ENDIF ELSEIF(COMND1.EQ.'HDELETE') THEN WRITE(TXTERR,'(''Histogram'',I7 1 ,'' does not exist'')') IDH CALL MN_ERR('M_HDEL',TXTERR) ENDIF 4845 CONTINUE IF(IDELIM.GE.0) GOTO 1000 ENDIF C 9000 CONTINUE END +DECK,m_htit. SUBROUTINE M_HTIT(IDELIM) C C------------------------------------------------------------------------------ C Gives a new title to a plot C------------------------------------------------------------------------------ C implicit none * +CDE,MNPAR. +CDE,MNDAT. +CDE,MNFIT. +CDE,MNCMD. +CDE,MNLUN. * integer idelim C CHARACTER*80 TXT1,TXT2 LOGICAL HEXIST integer ida,idb,idh,nnid,nh,nchar * integer iqstyq external iqstyq C CALL WAITYQ('Give histogram number: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA.LT.0) GOTO 9000 CALL MN_HGT(IDA,IDB,NH) IF(NH.LE.0) THEN WRITE(TXTERR,'(''Histogram'',I7,I4 1 ,'' does not exist'')') IDA,IDB CALL MN_ERR('M_HTIT',TXTERR) GOTO 9000 ENDIF CALL WAITYQ('Give new title: ') NCHAR = IQSTYQ(.TRUE.,IDELIM,TXT1) IF(NCHAR.LE.0) TXT1 = ' ' C C See if there are any registers, parameters etc to convert C CALL MN_TVL(TXT1,TXT2) TXT1 = TXT2 C TDTIT(NH) = TXT1 C C Give fitted histogram the new title also C CALL MN_FGT(IDA,IDB,NH) IF(NH.GT.0) THEN TFTIT(NH) = TXT1 ENDIF C C GIVE HBOOK HISTOGRAM NEW TITLE ALSO C cicb IDH = IDB*1000 + IDA IDH = IDA IF(HEXIST(IDH)) THEN CALL HCOPY(IDH,98765,' ') CALL HDELET(IDH) CALL HCOPY(98765,IDH,TXT1) CALL HDELET(98765) ENDIF C 9000 CONTINUE END +DECK,m_loop. SUBROUTINE M_LOOP(IDELIM,IERR) C C------------------------------------------------------------------------------ C Start a DO loop C C Called from MN_CMD C------------------------------------------------------------------------------ C IMPLICIT NONE C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNCMD. +CDE,MNTYQ. +CDE,MNLUN. +CDE,MNDBG. C INTEGER IDELIM,IERR C INTEGER JCMD,IEQUL,K,NMIN,NMAX,NSTEP,NFDEP,NFDEPO,NTDEPO LOGICAL QSAVE CHARACTER TCOMM*10,TJUNK(2)*10 CHARACTER TXT1*80 C INTEGER ICMTYQ,ICHTYP,LNBLNK REAL VALTYQ EXTERNAL ICMTYQ,ICHTYP,VALTYQ C DATA TJUNK/'DO',' '/ C ierr = 0 * IF(.NOT.QRFILE) THEN CALL MN_ERR('MN_CMD','Command only valid' // 1 ' inside a file or an internally defined command') ierr = 1 GOTO 9000 ENDIF IF(NFORDP(NTDEP).GE.MFORDP) THEN WRITE(TXT1,'(''You cannot nest more than'',I3 1 ,'' DO loops'')') MTDEP CALL MN_ERR('MN_CMD',TXT1) ierr = 2 GOTO 9000 ENDIF IF(IDELIM.LT.0) THEN CALL MN_ERR('MN_CMD','Variable name is missing') ierr = 3 GOTO 9000 ENDIF CALL WAITYQ('Give variable, start, maximum and step size: ') JCMD = ICMTYQ(.TRUE.,IDELIM,TJUNK) TCOMM = ' ' CALL ICMSTR(TCOMM) IF(LNBLNK(TCOMM).GT.1) CALL MN_ERR('MN_CMD' 1 ,'Variable names can only have 1 letter. ' // 2 'It will be trimmed') C C LOOK FOR THE EQUALS SIGN C IF(IDELIM.NE.ICHAR('=')) THEN IEQUL = INDEX(STRING,'=') IF(IEQUL.LT.0) THEN CALL MN_ERR('MN_CMD','Equals sign is missing') ierr = 4 GOTO 9000 ENDIF 2300 CONTINUE K = ICHTYP(.TRUE.) IF(K.EQ.ICHAR(' ')) GOTO 2300 ENDIF C IF(IDELIM.LT.0) THEN CALL MN_ERR('MN_CMD','Starting value for loop missing') ierr = 5 GOTO 9000 ENDIF NMIN = NINT(VALTYQ(.TRUE.,IDELIM)) IF(IDELIM.LT.0) THEN CALL MN_ERR('MN_CMD','Maximum value for loop missing') ierr = 6 GOTO 9000 ENDIF NMAX = NINT(VALTYQ(.TRUE.,IDELIM)) C IF(IDELIM.EQ.0) THEN NSTEP = NINT(VALTYQ(.TRUE.,IDELIM)) IF(NSTEP.EQ.0) THEN CALL MN_ERR('MN_CMD','Step value of 0 is illegal' // 1 '. It will be set to 1') NSTEP = 1 ENDIF ELSE NSTEP = 1 ENDIF C NFORDP(NTDEP) = NFORDP(NTDEP) + 1 NFDEP = NFORDP(NTDEP) IF(LUNCMD.GT.0) THEN IFORBG(NFDEP,NTDEP) = IUNREC(NTDEP) ELSE IFORBG(NFDEP,NTDEP) = IP1CMD(NTDEP) ENDIF C C STORE THE VARIABLE AS UPPER CASE C CALL M_LUPC(TCOMM(1:1),TCOMM(1:1)) TFORNM(NFDEP,NTDEP) = TCOMM(1:1) IFORVL(NFDEP,NTDEP) = NMIN IFORMX(NFDEP,NTDEP) = NMAX IFORST(NFDEP,NTDEP) = NSTEP * if(qdebug .and. ndebug.ge.110) then write(luntto,'('' DO loop set up NFDEP/NTDEP'',2I4 + ,'', Line'',I6)') + nfdep,ntdep,iforbg(nfdep,ntdep) endif C C NOW CHECK WHETHER THE LOOP SHOULD BE EXECUTED C IF((NSTEP.GT.0 .AND. NMIN.GT.NMAX) .OR. 1 (NSTEP.LT.0 .AND. NMIN.LT.NMAX)) THEN QDSKIP = .TRUE. NFDEPO = NFDEP NTDEPO = NTDEP IF(NHFIT.GT.0) THEN CALL WAITYQ('MINUIT_SKIP> ') ELSE CALL WAITYQ('MN_CMD_SKIP> ') ENDIF 2310 CONTINUE QSAVE = QECHO CICB QECHO = .FALSE. JCMD = ICMTYQ(.TRUE.,IDELIM,TJUNK) COMND2 = ' ' IF(JCMD.GT.0) CALL ICMSTR(COMND2) CICB IF(JCMD.GT.0) COMND2 = TJUNK(JCMD) IF(COMND2.EQ.'DO') THEN NFORDP(NTDEP) = NFORDP(NTDEP) + 1 ENDIF CALL ZERTYQ('.FALSE.') QECHO = QSAVE IF(NTDEP.GE.NTDEPO .AND. NFORDP(NTDEP).GE.NFDEPO) THEN GOTO 2310 ELSE C C CLEAR OUT THE COMMAND AND SET UP FOR NORMAL COMMAND C PROCESSING AGAIN C QDSKIP = .FALSE. GOTO 9000 ENDIF ENDIF C 9000 CONTINUE END +DECK,m_more. SUBROUTINE M_MORE(NPTRH2,NPTRD2,NWRD,IERR) C C Expand a plot by a given number of words. C Check that there is space available and that the histogram is OK. C C NPTRH2 is the pointer to the header C NPTRD2 is the pointer to the data C NMORE is the number of extra words C IERR is an error return C implicit none * +CDE,MNPAR. +CDE,MNDAT. * integer nptrh2,nptrd2,nwrd,ierr * integer nw,nh,nwneed C IERR = 0 C C SEE IF I HAVE ENOUGH SPACE LEFT C NW = NDPTE NH = NPTRD2 - NPTRH2 + 1 IF(NWRD.GT.0) THEN NWNEED = NH + NWRD IF(NW+NWNEED.GT.NHSTWD) THEN CALL M_EMSG('MN_HNW' + ,'I have run out of space for expanding this plot') CALL MN_ERR('MN_HNW' + ,'Issue the command SQUEEZE to get unused space back') IERR = 1 GOTO 9000 ENDIF ENDIF C 9000 CONTINUE END +DECK,m_tsub. subroutine m_tsub(nmode,nh,nsub,isub,nelem,text,lent) * *------------------------------------------------------------------------ * Converts the number of subscripts to a string * nmode = 1 Put in variable name * nmode = 2 Put in dimension *------------------------------------------------------------------------ * implicit none * +cde,mnpar. +cde,mndat. +cde,slate. * integer nmode,nh,nsub,isub(*),nelem,lent character text*(*) * integer i,n1,n2,nfact,nval * integer lnblnk * if(nsub.le.0) then text = ' ' lent = 0 return endif * text = '(' n1 = 2 nfact = 1 do i=1,nsub if(isub(i).gt.0) then n2 = n1 + 4 call csetdi(isub(i),text,n1,n2) call cleft(text,n1,n2) n1 = n1 + nd elseif(nmode.eq.1) then text(n1:) = tdnam(-isub(i),nh) call cutol(text(n1:)) n1 = n1 + lnblnk(tdnam(-isub(i),nh)) elseif(nmode.eq.2) then n2 = n1 + 4 nval = nelem / nfact call csetdi(nval,text,n1,n2) call cleft(text,n1,n2) n1 = n1 + nd endif if(i.lt.nsub) then text(n1:n1) = ',' n1 = n1 + 1 else nfact = nfact * isub(i) endif enddo text(n1:n1) = ')' lent = n1 * end +DECK,qmnfex. C LOGICAL FUNCTION QMNFEX(IDA,IDB,NH) C C IDA,IDB IS THE HISTOGRAM ID WHICH I WANT POINTERS ON C +CDE,MNPAR. +CDE,MNFIT. C C SEE IF THIS HISTOGRAM EXISTS C QMNFEX = .FALSE. NH = 0 DO 1000 NNH=1,NDFIT IF(IDA.EQ.IDFITA(NNH) .AND. IDB.EQ.IDFITB(NNH) .AND. 1 IFPTRH(NNH).GT.0 .AND. IFPTRD(NNH).GT.0) THEN QMNFEX = .TRUE. NH = NNH GOTO 9000 ENDIF 1000 CONTINUE C 9000 CONTINUE RETURN END +DECK,qmnhex. LOGICAL FUNCTION QMNHEX(IDA,IDB,NH) C C IDA,IDB IS THE HISTOGRAM ID WHICH I WANT POINTERS ON C +CDE,MNPAR. +CDE,MNDAT. C C SEE IF THIS HISTOGRAM EXISTS C QMNHEX = .FALSE. NH = 0 DO 1000 NNH=1,NDHIS IF(IDA.EQ.IDIDA(NNH) .AND. IDB.EQ.IDIDB(NNH) .AND. 1 IDPTRH(NNH).GT.0 .AND. IDPTRD(NNH).GT.0) THEN QMNHEX = .TRUE. NH = NNH GOTO 9000 ENDIF 1000 CONTINUE C 9000 CONTINUE RETURN END +DECK,m_clear. subroutine m_clear(ierr) * *------------------------------------------------------------------------------ * Clears the screen and resets everything. *------------------------------------------------------------------------------ * implicit none * +cde,mnpar. +cde,mnhpj. +cde,mnprs. * integer ierr * call mn_ton(ierr) call tvshow call tvnext call mn_tof(.false.) * nhplt = 0 ndrwln = 0 call vzero_i(npltcm,mhplt) call vzero_i(npltky,mhplt) * end +DECK,m_spage subroutine m_spage * *------------------------------------------------------------------------------ * Sets up the page if only drawing lines or text *------------------------------------------------------------------------------ * implicit none * +cde,mnpar. +cde,mnhpj. +cde,mnprs. * real xpt(5),ypt(5),thick,xunit integer ncol,nsegm * call tvrng(.false.,0.0,0.0,sizes(1),sizes(2)) if((alims(1,1).ne.0.0 .or. alims(2,1).ne.0.0) .and. + (alims(1,2).ne.0.0 .or. alims(2,2).ne.0.0)) then xplo = amrgs(1) xphi = amrgs(1) + hszes(1) yplo = amrgs(2) yphi = amrgs(2) + hszes(2) xlo = alims(1,1) xhi = alims(2,1) ylo = alims(1,2) yhi = alims(2,2) call ucopy_r(alims,alimu,2*3) else xplo = 0.0 xphi = sizes(1) yplo = 0.0 yphi = sizes(2) xlo = xplo xhi = xphi ylo = yplo yhi = yphi alimu(1,1) = xlo alimu(2,1) = xhi alimu(1,1) = ylo alimu(2,1) = yhi endif C C Store the limits in registers C regis(201) = xplo regis(202) = xphi regis(203) = yplo regis(204) = yphi regis(205) = xlo regis(206) = xhi regis(207) = ylo regis(208) = yhi * sizeu(1) = sizes(1) sizeu(2) = sizes(2) * * Draw the box and create a segment to store the box in * if(qsbox)then nsegm = 101 call m_crsg(nsegm) ncol = icols(1) thick = athks(1) xunit = tszes(5) xpt(1) = 0.0 + 0.002*sizes(1) ypt(1) = 0.0 + 0.002*sizes(2) xpt(2) = 0.998*sizes(1) ypt(2) = 0.0 + 0.002*sizes(2) xpt(3) = 0.998*sizes(1) ypt(3) = 0.998*sizes(2) xpt(4) = 0.0 + 0.002*sizes(1) ypt(4) = 0.998*sizes(2) xpt(5) = 0.0 + 0.002*sizes(1) ypt(5) = 0.0 + 0.002*sizes(2) call mn_lin(xpt,ypt,5,1,xunit,ncol,thick) endif * end +DECK,m_hmerge. subroutine m_hmerge(idelim,ierr) C C----------------------------------------------------------------------- C C Merges 2 or more RZ files C C Called by MN_CMD C C----------------------------------------------------------------------- * implicit none * +CDE,MNPAR. +CDE,MNCMD. +CDE,MNLUN. +CDE,QUEST. * integer idelim, ierr integer mfili parameter (mfili = 100) character*255 tfili(mfili),tfilo,txt1 integer nchri,nchro,nfili,lenf logical qexist,accessf integer isltyq,lnblnk C C Close any histogram files that are open C CALL M_HCLS C CALL WAITYQ('Give output filename: ') NCHRO = ISLTYQ(.TRUE.,IDELIM,TFILO) IF(IDELIM.GT.0 .OR. NCHRO.LE.0) GOTO 9000 C txt1 = tfilo call m_pfil(2,txt1,ierr) lenf = lnblnk(txt1) +SELF,IF=UNIX. qexist = accessf(txt1(:lenf),0) +SELF,IF=VMS. INQUIRE(FILE=txt1(:lenf),EXIST=QEXIST) +SELF. if(qexist) then write(txtmes,'('' File: '',A,'' will be overwritten'')') + txt1(:lenf) call mn_mes(luntto,'ME',txtmes) endif tfilo = txt1 C C Loop over the input filenames C nfili = 0 CALL WAITYQ('Give list of input filenames ( when finished): ') 2000 CONTINUE IERR = 1 nfili = nfili + 1 TFILI(nfili) = ' ' NCHRI = ISLTYQ(.TRUE.,IDELIM,TFILI(nfili)) IF(NCHRI.LE.0) THEN IF(nfili.eq.0) then ierr = 0 GOTO 9000 else nfili = nfili - 1 goto 3000 endif else C txt1 = tfili(nfili) call m_pfil(2,txt1,ierr) lenf = lnblnk(txt1) +SELF,IF=UNIX. qexist = accessf(txt1(:lenf),0) +SELF,IF=VMS. INQUIRE(FILE=txt1(:lenf),EXIST=QEXIST) +SELF. if(.not.qexist) then txterr = 'File' // txt1(:lenf) // ' does not exist' call m_emsg('M_HMERGE',txterr) nfili = nfili - 1 else tfili(nfili) = txt1(:lenf) endif goto 2000 endif * 3000 continue if(nfili.gt.0) then write(txtmes,'('' Will merge'',I4,'' files'')') nfili call mn_mes(luntto,'ME',txtmes) * call hmerge(nfili,tfili,tfilo) ierr = iquest(1) else txterr = 'No valid input filenames given' call mn_err('M_HMERGE',txterr) endif * 9000 continue * end +PATCH,MINUIT. +DECK,comand,IF=MIN_CGR. SUBROUTINE COMAND(IRETRN) C C MAIN COMMAND ROUTINE FOR MINUIT C EXTERNAL FCN,FUTIL C +CDE,MINPAR,PARINT,PAREXT,LIMITS,UNIT,CONVER. +CDE,MNPAR. +CDE,MNCMD. +CDE,MNTYQ. C PARAMETER (MMIN=45) CHARACTER*10 MINNAM(MMIN) C CHARACTER*80 TXT1,TXT2 C REAL*4 RNUMB(20) LOGICAL GIVNUM(20) INTEGER LMI(MIN30) C DATA MINNAM/ 2 'MODIFY', 'HELP', 'MINOS', 'MAX_CALLS','PRECISION', 3 'FCN_DRAW', 'FCN_PLOT', 'PROB_PLOT', 'CHI_PLOT', 'INFO', 3 'FORCE_ISW','STANDARD', 'UNIT', 'SEEK', 'CONTOUR', 4 'IMPROVE', 'MINIMIZE', 'SIMPLEX', 'MIGRAD', 5 'PUNCH', 'PRINTOUT', 'FIX', 'FLOAT', 'RESTORE', 6 'STOP', 'EXIT', 7 'GRADIENT', 'NO_GRADIEN','CALL_FCN', 'MATOUT', 8 'HESSE', 'COVARIANCE', 9 'ERROR_DEF','PAGE', A 'FIT_INFO', 'DUMP', 'DISPLAY', 1 'EXCLUDE', 'NO_EXCLUDE','INCLUDE', 'NO_INCLUDE', 2 'ITERATIONS','NO_ITERATI', 3 'BACK_SUB', Z ' '/ C NFCNMX_0=2000 PRECISION=0.1 C C MAIN LOOP FOR COMMANDS C 1000 CONTINUE C CALL WAITYQ('MINUIT> ') ICMD = ICMTYQ(.TRUE.,IDELIM,MINNAM) IF(ICMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 1000 ENDIF COMND1 = ' ' IF(ICMD.GT.0) COMND1 = MINNAM(ICMD) CALL MN_DCK(IDELIM,ICMD,MMIN,MINNAM,IERR) IF(ICMD.LT.0 .OR. (IERR.NE.0 .AND. IERR.NE.2)) THEN GOTO 1000 ENDIF C IF(IERR.EQ.2) THEN CALL RESTYQ C C UPDATE THE VALUES OF THE FUNCTION PARAMETERS C CALL MN_FUP(1) C C SEE IF THE COMMAND IS A STANDARD MN_FIT COMMAND C CALL RESTYQ NCFLG = -1 CALL MN_CMD(NCFLG,NCERR) C C SEE IF THE COMMAND IS AN INTERNALLY DEFINED COMMAND C IF(NOPR.GT.0 .AND. NCERR.EQ.2) THEN CALL RESTYQ CALL MN_CIN(NCERR) ENDIF C C ERROR IN COMMAND C IF(NCERR.EQ.2) CALL MN_UNK('COMAND') GOTO 1000 ENDIF C C EXECUTE THE COMMAND C IF(COMND1.EQ.'EXCLUDE' .OR. COMND1.EQ.'NO_EXCLUDE' .OR. + COMND1.EQ.'INCLUDE' .OR. COMND1.EQ.'NO_INCLUDE' .OR. + COMND1.EQ.'ITERATIONS' .OR. COMND1.EQ.'NO_ITERATI' .OR. + COMND1.EQ.'BACK_SUB') THEN CALL MIN_CM2(IDELIM,FCN,FUTIL) GOTO 1000 ENDIF C C GET ALL THE NUMBERS OUT FOR THE MINUIT COMMAND C NARGS = 1 CALL VZERO_l(GIVNUM,20) CALL VZERO_r(RNUMB,20) IF(COMND1.NE.'HELP' .AND. COMND1.NE.'MODIFY' .AND. 1 COMND1.NE.'MAX_CALLS' .AND. COMND1.NE.'PRECISION' .AND. 1 COMND1.NE.'FCN_PLOT' .AND. COMND1.NE.'PROB_PLOT' .AND. 2 COMND1.NE.'FCN_DRAW' .AND. comnd1.ne.'CHI_PLOT' .and. + COMND1.NE.'FORCE_ISW' .AND. + COMND1.NE.'DISPLAY') THEN NNUM = 0 1600 CONTINUE IF(NNUM.LE.20 .AND. IDELIM.EQ.0) THEN CICB RVAL = RELTYQ(.TRUE.,IDELIM) RVAL = VALTYQ(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.NE.0) GOTO 1600 NNUM = NNUM + 1 NARGS = NARGS + 1 GIVNUM(NNUM) = .TRUE. RNUMB(NNUM) = RVAL GOTO 1600 ENDIF ENDIF C C HELP COMMAND C IF(COMND1.EQ.'HELP') THEN CALL MN_HLP(IDELIM,IERR) GOTO 1000 C C MODIFY COMMAND C ELSE IF(COMND1.EQ.'MODIFY') THEN CALL WAITYQ('Give parameter number: ') NUMQ = INTTYQ(.TRUE.,IDELIM) CALL MN_NCK(NUMQ,IDELIM,NERR) IF(NERR.GT.0) THEN CALL ZERTYQ('.FALSE') GOTO 1000 ENDIF IF(NUMQ.LE.0 .OR. NUMQ.GT.NU) THEN WRITE(ISYSWR,'('' Error in parameter number'',I4)') 1 NUMQ CALL ZERTYQ('.FALSE.') GOTO 1000 ENDIF L = NUMQ NNUM = 0 CALL WAITYQ('Give new values: ') 2210 CONTINUE RVAL = VALTYQ(.TRUE.,IDELIM) IF(IDELIM.EQ.ICHAR('=')) THEN NNUM = NNUM + 1 IF(NNUM.EQ.1) RNUMB(NNUM) = U(L) IF(NNUM.EQ.2) RNUMB(NNUM) = W(L) IF(NNUM.EQ.3) RNUMB(NNUM) = ALIM(L) IF(NNUM.EQ.4) RNUMB(NNUM) = BLIM(L) ELSE CALL MN_RCK(RVAL,IDELIM,NERR) IF(NERR.EQ.0) THEN NNUM = NNUM + 1 RNUMB(NNUM) = RVAL ELSEIF(NERR.NE.2) THEN CALL ZERTYQ('.FALSE.') GOTO 1000 ENDIF ENDIF IF(IDELIM.GE.0) GOTO 2210 C DO 2250 K=1,4 IF(K.GT.NNUM) THEN IF(K.EQ.1) WWK=U(L) IF(K.EQ.2) WWK=W(L) IF(K.EQ.3) WWK=ALIM(L) IF(K.EQ.4) WWK=BLIM(L) ELSE WWK=RNUMB(K) ENDIF IF(K.EQ.1) WW1=WWK IF(K.EQ.2) WW2=WWK IF(K.EQ.3) WW3=WWK IF(K.EQ.4) WW4=WWK 2250 CONTINUE LMODIFY=L CALL MODIFY(LMODIFY,WW1,WW2,WW3,WW4) GOTO 1000 C C CHANGE THE NUMBER OF CALLS C ELSE IF(COMND1.EQ.'MAX_CALLS') THEN TXT1 = 'Give number of calls ( =' WRITE(TXT1(29:),'(I6)',IOSTAT=IOERR) NFCNMX_0 LENT = LENOCC(TXT1) TXT2 = TXT1(1:LENT) // '):' LENT = LENT + 2 CALL WAITYQ(TXT2(1:LENT)) NVAL = INTTYQ(.TRUE.,IDELIM) IF(NVAL.GT.0) NFCNMX_0 = NVAL GOTO 1000 C C CHANGE THE PRECISION C ELSE IF(COMND1.EQ.'PRECISION') THEN TXT1 = 'Give precision ( =' WRITE(TXT1(23:),'(F10.5)',IOSTAT=IOERR) PRECISION LENT = LENOCC(TXT1) TXT2 = TXT1(1:LENT) // '):' LENT = LENT + 2 CALL WAITYQ(TXT2(1:LENT)) RVAL = RELTYQ(.TRUE.,IDELIM) IF(RVAL.GT.0.0) PRECISION = RVAL GOTO 1000 ENDIF C NFCNMX=NFCNMX_0 EPSI=PRECISION*UP ISW(1)=0 C C FCN_DRAW COMMAND C IF(COMND1.EQ.'FCN_DRAW') THEN CALL MN_FUP(1) CALL MIN_DRAW(FCN,NNUM,RNUMB,FUTIL) C C FCN_PLOT, PROB_PLOT and CHI_PLOT COMMANDS C ELSE IF(COMND1.EQ.'FCN_PLOT' .OR. COMND1.EQ.'PROB_PLOT' .or. + comnd1.eq.'CHI_PLOT') THEN CALL MN_FUP(1) IF(COMND1.EQ.'FCN_PLOT') THEN NMODE = 1 ELSEIF(COMND1.EQ.'PROB_PLOT') THEN NMODE = 2 ELSEIF(COMND1.EQ.'CHI_PLOT') THEN NMODE = 3 ENDIF CALL MIN_PLOT(FCN,NMODE,FUTIL) C C INFO COMMAND C ELSE IF(COMND1.EQ.'INFO') THEN IQW123=ISW(5) ISW(5)=1 CALL MPRINT(1,AMIN) IF(ISW(2).GE.2) CALL MATOUT(0.0,1) ISW(5)=IQW123 C C FORCE ISW TO SOME VALUE C ELSE IF(COMND1.EQ.'FORCE_ISW') THEN WRITE(ISYSWR,'(/,'' ISW='',7I4)') ISW CALL WAITYQ('Modify which ISW: ') ISWII = INTTYQ(.TRUE.,IDELIM) IF(ISWII.LE.0.OR.ISWII.GT.7) GOTO 1000 CALL WAITYQ('Give new value: ') ISW(ISWII) = INTTYQ(.TRUE.,IDELIM) WRITE(ISYSWR,'(/,'' NEW ISW='',7I4)') ISW C C CALL STANDARD ROUTINE C ELSE IF(COMND1.EQ.'STANDARD') THEN CALL STAND C C CHANGE THE INPUT UNIT C ELSE IF(COMND1.EQ.'UNIT') THEN IF(.NOT.GIVNUM(1)) GOTO 8000 ISYSRD = NINT(RNUMB(1)) CALL UNITYQ(ISYSRD,ISYSWR) C C SEEK COMMAND C ELSE IF(COMND1.EQ.'SEEK') THEN CALL SEEK(RNUMB(1)) C C CONTOUR COMMAND C ELSE IF(COMND1.EQ.'CONTOUR') THEN CALL CONTOUR(GIVNUM,RNUMB) C C SIMPLEX COMMAND C ELSE IF(COMND1.EQ.'SIMPLEX') THEN CALL SIMPLX C C MIGRAD, MINIMIZE AND IMPROVE COMMANDS C ELSE IF(COMND1.EQ.'MIGRAD' .OR. 1 COMND1.EQ.'IMPROVE' .OR. COMND1.EQ.'MINIMIZE') THEN IF(COMND1.EQ.'MIGRAD') THEN VTEST=RNUMB(1) IF(VTEST.LE.0.) VTEST=0.04 CALL MIGRADSET(0,VTEST) ELSE IF(COMND1.EQ.'IMPROVE') THEN NLOOP=RNUMB(1) IF(NLOOP.LE.0) NLOOP=NPAR+4 IF(ISW(2).LT.2) THEN CALL HESSE IF(ISW(2).LT.2) THEN WRITE(ISYSWR,'('' *** Command ignored, because'' 1 ,'' fit did not converge properly or HESSE'' 2 ,'' gave an error'')') GOTO 1000 ENDIF CALL MPRINT(1,AMIN) ENDIF CALL IMPROV(NEWMIN,NLOOP) IF(NEWMIN.EQ.0) GOTO 1000 CALL MIGRADSET(0,0.04) ELSE IF(COMND1.EQ.'MINIMIZE') THEN CALL SIMPLX IF(ISW(1).EQ.1) GOTO 1000 CALL MIGRADSET(0,0.04) ENDIF C NF=NFCN CALL MIGRAD IF(ISW(2) .GT. 2) GOTO 1000 IF(ISW(1) .EQ. 1) GOTO 1000 NFCNMX=NFCNMX+NF-NFCN NF=NFCN CALL SIMPLX IF(ISW(1) .EQ. 1) GOTO 1000 NFCNMX=NFCNMX+NF-NFCN CALL MIGRAD C C MINOS COMMAND C ELSE IF(COMND1.EQ.'MINOS') THEN C C INTERPRET MINOS PARAMETERS C KNT=0 CALL VZERO_i(LMI,MIN30) DO 4100 II=1,20 IF(.NOT.GIVNUM(II)) GOTO 4110 LMIKNT=RNUMB(II) IF(LMIKNT.LE.0.OR.LMIKNT.GT.NU) GOTO 8000 IF(LCORSP(LMIKNT).EQ.0) GOTO 8000 KNT=KNT+1 LMI(KNT)=LMIKNT 4100 CONTINUE 4110 CONTINUE IF(KNT.EQ.0) THEN DO 4150 I=1,NPAR LMI(I)=MCORSP(I) 4150 CONTINUE ENDIF C IF(ISW(2).LT.2) THEN CALL HESSE IF(ISW(2).LT.2) GOTO 5900 CALL MPRINT(1,AMIN) ENDIF CALL MIGRADSET(1,0.20) CALL MINOS(NEWMIN,LMI) IF(NEWMIN.GE.1) THEN NQQ=NFCNMX IF(NFCNMX .LT. 10*NPAR) NFCNMX = 10*NPAR WRITE(ISYSWR,'('' *** Try for another triplet'' 1 ,'' SIMPLEX+MIGRAD+MINOS ***'')') ISW(2) = 1 CALL SIMPLX CALL MIGRAD NFCNMX=NQQ IF(ISW(2) .LT. 2) GO TO 5910 CALL MIGRADSET(1,0.05) CALL MINOS(NEWMIN,LMI) IF(NEWMIN .GE.1) THEN WRITE(ISYSWR,'('' *** Try just for one more'' 1 ,'' SIMPLEX ***'')') ISW(2) = 1 CALL SIMPLX ENDIF ENDIF GOTO 1000 5900 CONTINUE WRITE(ISYSWR,'('' *** Command ignored ***'')') 5910 CONTINUE WRITE(ISYSWR,'('' MINOS cannot be executed because an'' 1 ,'' error matrix estimate does not exist.'' 2 ,/,'' Either MIGRAD was unsuccessful or'' 3 ,'' no covariance matrix was supplied on cards.'',/)') GOTO 1000 C C PUNCH COMMAND C ELSE IF(COMND1.EQ.'PUNCH') THEN CALL MPUNCH C C PRINTOUT COMMAND C ELSE IF(COMND1.EQ.'PRINTOUT') THEN ISW(5) = NINT(RNUMB(1)) C C FIX COMMAND C ELSE IF(COMND1.EQ.'FIX') THEN DO 6500 IW45=1,7 IT= NINT(RNUMB(IW45)) IF(IT.NE.0) CALL FIXPAR(IT,0,ILAX) 6500 CONTINUE C C FLOAT COMMAND C ELSE IF(COMND1.EQ.'FLOAT') THEN DO 6600 IW45=1,7 IT= NINT(RNUMB(IW45)) IF(IT.NE.0) CALL RESTOR00(IT) 6600 CONTINUE C C RESTORE COMMAND C ELSE IF(COMND1.EQ.'RESTORE') THEN IT = NINT(RNUMB(1)) CALL RESTOR(IT) C C STOP, EXIT AND END COMMANDS C ELSE IF(COMND1.EQ.'STOP' .OR. COMND1.EQ.'EXIT') THEN IT = NINT(RNUMB(1)) IF(ISW(4) .NE. 1 .AND. IT .LE. 0) THEN IFLAG=3 WRITE(ISYSWR,'('' CALL TO FCN WITH IFLAG = 3 '',/)') CALL FCN(NPAR,G,F,U,IFLAG) NFCN=NFCN+1 ENDIF IF(COMND1.EQ.'STOP') THEN STOP C C STOP MINNEW...GO BACK TO MAIN PROGRAM C ELSE IF(COMND1.EQ.'EXIT') THEN IRETRN = 1 ENDIF RETURN C C GRADIENT COMMAND C ELSE IF(COMND1.EQ.'GRADIENT') THEN ISW(3)=1 C C TURN OFF GRADIENT COMMAND C ELSE IF(COMND1.EQ.'NO_GRADIEN') THEN ISW(3)=0 C C CALL FCN WITH SOME FLAG C ELSE IF(COMND1.EQ.'CALL_FCN') THEN IFLAG = NINT(RNUMB(1)) IF(IFLAG .EQ. 3) ISW(4) = 1 CALL FCN(NPAR,G,F,U,IFLAG) NFCN=NFCN+1 C--- C IF(IFLAG.GT.5) THEN C CALL EXTOIN C CALL FCN(NPAR,G,AMIN,U,4) C NFCN=NFCN+1 C CALL MPRINT(1,AMIN) C END IF C--- C C CALCULATE OR OUTPUT THE COVARIANCE MATRIX C ELSE IF(COMND1.EQ.'MATOUT' .OR. COMND1.EQ.'HESSE') THEN IF(COMND1.EQ.'HESSE' .OR. ISW(2).LE.1) THEN CALL HESSE CALL MPRINT(1, AMIN) ENDIF CALL MATOUT(0.,1) C C COVARIANCE COMMAND C ELSE IF(COMND1.EQ.'COVARIANCE') THEN NRAPE = NINT(RNUMB(1)) CALL MAT_IN(NRAPE) C C CHANGE THE ERROR DEFINITION C ELSE IF(COMND1.EQ.'ERROR_DEF') THEN UP=RNUMB(1) IF(UP.LE.0.)UP=1.0 C C START A NEW PAGE C ELSE IF(COMND1.EQ.'PAGE') THEN WRITE(ISYSWR,'(''1'')') C C FIT_INFO COMMAND C ELSE IF(COMND1.EQ.'FIT_INFO') THEN IFLAG = 11 CALL FCN(NPAR,G,F,U,IFLAG) NFCN=NFCN+1 C C DUMP COMMAND C ELSE IF(COMND1.EQ.'DUMP') THEN IFLAG = 12 CALL FCN(NPAR,G,F,U,IFLAG) NFCN=NFCN+1 C C DISPLAY COMMAND C ELSE IF(COMND1.EQ.'DISPLAY') THEN IFLAG = 13 CALL FCN(NPAR,G,F,U,IFLAG) NFCN=NFCN+1 C ELSE WRITE(ISYSWR,'('' *** COMAND: Command '',A 1 ,'' not valid here'')') COMND1(1:MNLLEN(COMND1)) ENDIF GOTO 1000 C 8000 CONTINUE WRITE(ISYSWR,'('' *** COMAND: Error in command'')') GOTO 1000 C END +DECK,contour,IF=MIN_CGR. SUBROUTINE CONTOUR(GG,DD) C C C +CDE,MINPAR,PARINT,PAREXT,LIMITS,UNIT,CONVER. +CDE,MNPAR. +CDE,MNCMD. C LOGICAL GG(20) REAL*4 DD(20) CHARACTER*80 LINE CHARACTER*1 ALFA(37) CHARACTER*1 BLANK,DASH,DASV,PLUS,STAR C DATA ALFA/'0','1','2','3','4','5','6','7','8','9', 1 'A','B','C','D','E','F','G','H','I','J', 2 'K','L','M','N','O','P','Q','R','S','T', 3 'U','V','W','X','Y','Z','*'/ DATA BLANK/' '/,DASH/'-'/,DASV/'|'/,PLUS/'+'/,STAR/'*'/ DATA IMID/42/ C C Change the output unit C ISYSSS = ISYSWR ISYSWR = LUNDMP I1 = DD(1) + 0.5 I2 = DD(2) + 0.5 IF(I1.EQ.0) I1=1 IF(I2.EQ.0) I2=2 U1SAV=U(I1) U2SAV=U(I2) IF(.NOT.(GG(4).OR.GG(5).OR.GG(6))) THEN DEVS = DD(3) IF (DEVS .LE. 0.D0) DEVS=2.5D0 DEVS=AMAX1(0.1,AMIN1(9.,DEVS)) C XLO = U(I1) - DEVS*WERR(I1) XUP = U(I1) + DEVS*WERR(I1) YLO = U(I2) - DEVS*WERR(I2) YUP = U(I2) + DEVS*WERR(I2) NXA = 36.*SQRT(DEVS) NYA = 30.*SQRT(DEVS) CALL BINSIZ(XLO,XUP,NXA,XLO,XUP,NX,BWIDX) CALL BINSIZ(YLO,YUP,NYA,YLO,YUP,NY,BWIDY) ELSE XLO=DD(3) XUP=DD(4) YLO=DD(5) YUP=DD(6) NX=51 NY=51 BWIDX=(XUP-XLO)/(NX-1) BWIDY=(YUP-YLO)/(NY-1) ENDIF C WRITE(ISYSWR,'('' CONTOUR MAP FOR VARIABLES'',2I3)') I1,I2 WRITE(ISYSWR,'('' CURRENT MINIMUM FCN='',G15.5)') AMIN WRITE(ISYSWR,'('' AT VAR1='',G15.5,'', VAR2='',G15.5)') 1 U(I1),U(I2) WRITE(ISYSWR,'('' ERR1='',G15.5,'', ERR2='',G15.5)') 1 WERR(I1),WERR(I2) WRITE(ISYSWR,'('' EACH STEP IS 1 SQUARED INCREMENT OF FCN BY'' 1 ,G15.5,'' UNITS'')') UP XMID=(XLO+XUP)/2.0 YMID=(YLO+YUP)/2.0 NX=(NX+1)/2 NY=(NY+1)/2 NX=MAX0(5,MIN0(30,NX)) NY=MAX0(5,MIN0(25,NY)) LINE = ' ' LINE(IMID:IMID)=STAR DO 1000 I=1,NX LINE(IMID-I:IMID-I)=DASH LINE(IMID+I:IMID+I)=DASH 1000 CONTINUE DO 1100 I=5,NX+4,5 LINE(IMID-I:IMID-I)=PLUS LINE(IMID+I:IMID+I)=PLUS 1100 CONTINUE LINE(IMID-NX-1:IMID-NX-1)=STAR LINE(IMID+NX+1:IMID+NX+1)=STAR WRITE(ISYSWR,'(1X,A)') LINE C DO LY=+NY,-NY,-1 LINE = ' ' YY=YMID+LY*BWIDY IF(LCODE(I2).NE.1.AND.(YY.LT.ALIM(I2).OR.YY.GT.BLIM(I2))) 1 GOTO 5500 DO 2000 LX=-NX,+NX,+1 XX=XMID+LX*BWIDX LINE(IMID+LX:IMID+LX)=BLANK IF(LCODE(I1).EQ.1 .OR. 1 (XX.GE.ALIM(I1).AND.XX.LE.BLIM(I1))) THEN U(I1)=XX U(I2)=YY CALL FCN(NPAR,G,F,U,4) STEPP=SQRT(AMAX1(0.,(F-AMIN)/UP)) NSTEPP=STEPP NSTEPP=MIN0(NSTEPP,36) STEPP=STEPP-NSTEPP IC=0 IF(STEPP.LE.0.2) IC=NSTEPP IF(STEPP.GE.0.8) THEN IC=MIN0(NSTEPP+1,36) IF(STEPP.GE.1.2) IC=0 ENDIF IF(IC.NE.0) LINE(IMID+LX:IMID+LX)=ALFA(IC+1) ENDIF 2000 CONTINUE 5500 CONTINUE CALL UU_ENCOD IF(MOD(IABS(LY),5).NE.0) CALL SS_ENCOD(' ;',10) IF(MOD(IABS(LY),5).EQ.0) THEN CALL FF_ENCOD(YY,7) CALL SS_ENCOD(' ',3) ENDIF DO LO=11,IMID-NX-2 CALL SS_ENCOD(' ',1) END DO DO LP=1,2 IF(MOD(IABS(LY),5).NE.0) CALL SS_ENCOD('|',1) IF(MOD(IABS(LY),5).EQ.0) THEN IF(LY.NE.0) CALL SS_ENCOD('+',1) IF(LY.EQ.0) CALL SS_ENCOD('*',1) ENDIF IF(LP.EQ.1) CALL SS_ENCOD(LINE(IMID-NX:),2*NX+1) END DO CALL OO_ENCOD END DO LINE = ' ' LINE(IMID:IMID)=STAR DO I=1,NX LINE(IMID-I:IMID-I)=DASH LINE(IMID+I:IMID+I)=DASH END DO DO I=5,NX+4,5 LINE(IMID-I:IMID-I)=PLUS LINE(IMID+I:IMID+I)=PLUS END DO LINE(IMID-NX-1:IMID-NX-1)=STAR LINE(IMID+NX+1:IMID+NX+1)=STAR WRITE(ISYSWR,'(1X,A)') LINE C CALL UU_ENCOD DO I=1,13 CALL SS_ENCOD(' ',1) END DO DO I=14,64,10 IX=I+3 IF(IX.LT.IMID-NX-3) CALL SS_ENCOD(' ;',10) IF(IX.GT.IMID+NX+3) CALL SS_ENCOD(' ;',10) IF(IABS(IMID-IX).LE.NX+3) THEN CALL FF_ENCOD(XMID+(IX-IMID)*BWIDX,7) CALL SS_ENCOD(' ',3) ENDIF END DO C CALL OO_ENCOD U(I1)=U1SAV U(I2)=U2SAV C C Change back the output unit C ISYSWR = ISYSSS RETURN END +DECK,fcn. +SELF,IF=-MIN_CGR. SUBROUTINE FCN(NPAR,G,F,WXPARI,IFLAG,FUTIL) +SELF,IF=MIN_CGR. SUBROUTINE FCN(NPAR,G,F,XPARI,IFLAG) +SELF. * implicit none C EXTERNAL FUTIL C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNFUN. +CDE,MNGRN. +CDE,MNHPJ. +CDE,MNCMD. +CDE,MNPRS. +CDE,MNUSR. +CDE,MNLUN. C INTEGER NPAR,IFLAG +SELF,IF=-MIN_CGR. DOUBLE PRECISION WXPARI(*),G(*),F DOUBLE PRECISION WXPAR(MINMAX) DOUBLE PRECISION FMIN,FEDM,ERRDEF real up +SELF,IF=MIN_CGR. +CDE,MINCOM. REAL XPARI(*),G(*),F DOUBLE PRECISION WXPAR(MIN30) +SELF. C DOUBLE PRECISION XMNDFUN,WMNHER,WFUN,WFERR2,WF00 DOUBLE PRECISION WFCHI,WFLIK,WDCHI,WDLIK DOUBLE PRECISION WEE,WDEEL,WDEEL2,WDEEH,WDEEH2 DOUBLE PRECISION WVAL(0:MFINTG),WVL2(0:MFINTG) + ,WXXL,WXXH,WYYL,WYYH DOUBLE PRECISION DMNV1,DMXV1,DMNV2,DMXV2 C CHARACTER*80 TXT1,TXT2 CHARACTER*1 STAR C INTEGER JDAF(MFITMX),JDBF(MFITMX) INTEGER IUSEE(MFUNMX) LOGICAL QERRL,QERRH * +SELF,IF=-MIN_CGR. integer npari,nparx +SELF. C integer ncall1,ncall2,ncall3,ncall4,nmessb,ndumpb + ,nf,np1,nfn0,nh,idau,idbu,nptrhu,nptrdu,ndimu,nwpptu,npfitu + ,noff,noffl,noffh,npp,i,ii,jj,kk,nptr,ioerr + ,ndsmod,nderr,nmode,idaf,idbf,istat + ,nsfpar + ,ndf,ndimmx,ndh + ,lent,lenf,lnblnk + ,idelim,npart,n1,nfun,nparf,nnl,jjmode,ierr,nmods + ,nn1,nn2,nn,nsym,idas,idbs,nf1,nf2 real wsum,ee,deel,deeh,xx,dxxl,dxxh,yy,dyyl,dyyh,deel2,deeh2 + ,delxx,delyy,xxx,yyy,fun,df,djnk,fff,ffft,edm LOGICAL QFHIST,QFHSTS,QFTEMP * save qfhist * real prob DOUBLE PRECISION DSIMPS external dsimps,prob C DATA DMNV1/1.7D-38/, DMXV1/1.7D+38/ DATA DMNV2/1.0D-31/, DMXV2/1.0D+31/ DATA NCALL1/0/,NCALL2/0/,NCALL3/0/,NCALL4/0/ DATA NMESSB/0/,NDUMPB/0/ C IF(IABS(IFLAG).GE.20) GOTO 6000 C C INITIALIZATION C IF(IFLAG.EQ.1) THEN IF(QDFIT) CALL MN_FRP NCALL1 = 0 NCALL2 = 0 NCALL3 = 0 NCALL4 = 0 NMESSB = 0 NDUMPB = 0 NCALL1 = NCALL1 + 1 CALL VZERO_i(IDBCKA,MFITMX) CALL VZERO_i(IDBCKB,MFITMX) CALL MN_TOF(.FALSE.) C C DECIDE WHETHER WE ARE FITTING WITH A HISTOGRAM C QFHIST = .FALSE. DO 1050 NF=1,NFUN_MN IF(IUSEF(NF).EQ.0) GOTO 1050 IF(TUSEF(NF)(1:4).EQ.'Hist') THEN QFHIST = .TRUE. GOTO 1051 ENDIF 1050 CONTINUE 1051 CONTINUE C C FINAL OUTPUT C ELSEIF(IFLAG.EQ.3) THEN NCALL3 = NCALL3 + 1 ENDIF C C STANDARD ENTRY C IF(IFLAG.EQ.4) THEN NCALL4 = NCALL4 + 1 ELSE NCALL4 = 0 ENDIF C C TURN OFF TEKTRONIX BIT IF NECESSARY C CALL MN_TOF(.FALSE.) C C Set up the bin width if it is not being used C IF(.NOT.QFBINW) THEN XBINNM = 1.0 YBINNM = 1.0 ENDIF C +SELF,IF=-MIN_CGR. C C Copy the parameters to internal storage C CALL UCOPY_r(WXPARI,WXPAR,2*NPAR_MN) +SELF,IF=MIN_CGR. C C Convert the parameters to double precision C DO 3400 I=1,NPAR_MN WXPAR(I) = DBLE(XPARI(I)) 3400 CONTINUE +SELF. C C Apply any constraints C IF(NCNSTR.GT.0) CALL M_CST0(NPAR_MN,WXPAR) C C For parameter type 1 set the last parameter to (1 - the others) C IF(NPARTP.EQ.1) THEN WSUM = 0.0D0 NP1 = 1 IF(QSNORM) NP1 = 2 DO 2100 NF=1,NFUN_MN IF(IUSEF(NF).EQ.0) GOTO 2100 cicb IF(IASSF(NF,NH).EQ.0) GOTO 2090 IF(NF.LT.NFUSEL) THEN WSUM = WSUM + WXPAR(NP1) ENDIF 2090 CONTINUE IF(NF.LT.NFUSEL) NP1 = NP1 + IPARF(NF) 2100 CONTINUE WXPAR(NP1) = 1.0D0 - WSUM FPAR(1,NFUSEL) = SNGL(WXPAR(NP1)) ENDIF C C LOOP OVER THE HISTOGRAMS TO FIT C F=0. WFCHI = 0.0D0 WFLIK = 0.0D0 NPTTOT = 0 NFN0 = 0 DO 3500 NH=1,NHFIT IDAU = IDFITA(NH) IDBU = IDFITB(NH) NPTRHU = IFPTRH(NH) NPTRDU = IFPTRD(NH) NDIMU = IFNDIM(NH) NWPPTU = IFWPPT(NH) NPFITU = IFPFIT(NH) FICHI(NH) = 0.0 FILIK(NH) = 0.0 AHTTOT(NH) = 0.0 AHFTOT(NH) = 0.0 C NOFF = IABS(NDIMU) + 1 NOFFL = 2*(IABS(NDIMU) + 1) NOFFH = 3*(IABS(NDIMU) + 1) QERRL = NWPPTU.GT.1*(IABS(NDIMU)+1) QERRH = NWPPTU.GT.2*(IABS(NDIMU)+1) C IF(IFLAG.EQ.12) THEN IF(NFITTP.EQ.0) THEN TXT1 = ' Chi**2 Total' ELSE TXT1 = ' Likelihood Total' ENDIF C IF(IABS(NDIMU).EQ.1) THEN IF(.NOT.QERRH) THEN WRITE(LUNDMP,'(/,'' Histogram'',I8,I4 1 ,'' Number of points'',I6 2 ,/,2X,''Pnt'',4X,''X +/- DX'',10X 2 ,''Y +/- DY'',9X,''Yfit'',A21)') 2 IDAU,IDBU,NPFITU,TXT1(1:21) ELSE WRITE(LUNDMP,'(/,'' Histogram'',I8,I4 1 ,'' Number of points'',I6 2 ,/,2X,''Pnt'',4X,''X - DX + DX'',10X 2 ,''Y - DY + DY'',9X,''Yfit'',A21)') 2 IDAU,IDBU,NPFITU,TXT1(1:21) ENDIF ELSE WRITE(LUNDMP,'(/,'' Histogram'',I8,I4 1 ,'' Number of points'',I6 2 ,/,2X,''Pnt'',4X,''X'',10X,''Y'',10X 2 ,''Entries +/- Error'',5X,''Yfit'',A21)') 2 IDAU,IDBU,NPFITU,TXT1(1:21) ENDIF ENDIF C DEEL = 0.0 DEEH = 0.0 C NPP = NPFITU C C FILL IN THE FUNCTION VALUES C IFPUSE(NH) = 0 DO 3200 I=1,NPP NPTR = NPTRDU + NWPPTU*(I-1) - 1 XX = RFIT(NPTR + 1) DXXL = RFIT(NPTR+ NOFF + 1) IF(.NOT.QERRH) THEN DXXH = DXXL ELSE DXXH = RFIT(NPTR + NOFFL + 1) ENDIF IF(QFBINW) XBINNM = DXXL + DXXH IF(XBINNM.LE.0.0) THEN NDUMPB = NDUMPB + 1 IF(NDUMPB.LE.10) THEN WRITE(LUNTTO,'('' FCN: Bin width wrong:'' 1 ,1PG11.4,'' Hist'',I8,I4,'' Bin'',I6 2 ,/,9X,''It will be set to 1.0'')') 2 XBINNM,IDAU,IDBU,I ENDIF XBINNM = 1.0 ENDIF C IF(IABS(NDIMU).GT.1) THEN YY = RFIT(NPTR + 2) DYYL = RFIT(NPTR+ NOFF + 2) DYYH = DYYL IF(QFBINW) YBINNM = DYYL + DYYH IF(YBINNM.LE.0.0) THEN NDUMPB = NDUMPB + 1 IF(NDUMPB.LE.10) THEN WRITE(LUNTTO,'('' FCN: Bin width wrong:'' 1 ,1PG11.4,'' Hist'',I8,I4,'' Bin'',I6 2 ,/,9X,''It will be set to 1.0'')') 2 YBINNM,IDAU,IDBU,I ENDIF YBINNM = 1.0 ENDIF ENDIF EE = RFIT(NPTR + NOFF) DEEL = RFIT(NPTR + NOFFL) AHTTOT(NH) = AHTTOT(NH) + EE C C Check whether point is excluded C DO 3050 JJ=1,IXEXCL(NH) IF(XX.GE.XLEXCL(JJ,NH) .AND. 1 XX.LE.XHEXCL(JJ,NH)) GOTO 3200 3050 CONTINUE IF(IABS(NDIMU).GT.1) THEN DO 3055 JJ=1,IYEXCL(NH) IF(YY.GE.YLEXCL(JJ,NH) .AND. 1 YY.LE.YHEXCL(JJ,NH)) GOTO 3200 3055 CONTINUE ENDIF C C Check whether point is included C IF(IXINCL(NH).LE.0) GOTO 3062 DO 3060 JJ=1,IXINCL(NH) IF(XX.GE.XLINCL(JJ,NH) .AND. 1 XX.LE.XHINCL(JJ,NH)) GOTO 3062 3060 CONTINUE GOTO 3200 3062 CONTINUE IF(IABS(NDIMU).GT.1) THEN IF(IYINCL(NH).LE.0) GOTO 3067 DO 3065 JJ=1,IYINCL(NH) IF(YY.GE.YLINCL(JJ,NH) .AND. 1 YY.LE.YHINCL(JJ,NH)) GOTO 3067 3065 CONTINUE GOTO 3200 3067 CONTINUE ENDIF C C Use this point when fitting C NPTTOT = NPTTOT + 1 IFPUSE(NH) = IFPUSE(NH) + 1 AHFTOT(NH) = AHFTOT(NH) + EE C DEEL2 = DEEL*DEEL WEE = DBLE(EE) WDEEL = DBLE(DEEL) WDEEL2 = DBLE(DEEL2) IF(QERRH) THEN DEEH = RFIT(NPTR + NOFFH) DEEH2 = DEEH * DEEH WDEEH = DBLE(DEEH) WDEEH2 = DBLE(DEEH2) ELSE DEEH = DEEL DEEH2 = DEEL2 WDEEH = WDEEL WDEEH2 = WDEEL2 ENDIF C C SKIP THE FUNCTION CALCULATION IF WE ARE CHI**2 FITTING C AND THE ERRORS ON THE POINT ARE 0 C IF(IFLAG.EQ.4 .AND. NFITTP.EQ.0 .AND. 1 DEEL.EQ.0.0 .AND. DEEH.EQ.0.0) GOTO 3200 C C FIRST CALCULATE THE VALUE OF THE FUNCTION C FUN = 0.0 WFUN = 0.0 WFERR2 = 0.0 C C LOOP OVER THE FUNCTIONS IM USING C NP1 = 1 IF(QSNORM) NP1 = 2 DO 3100 NF=1,NFUN_MN IF(IUSEF(NF).EQ.0) GOTO 3100 IF(IASSF(NF,NH).EQ.0) GOTO 3090 C C Integrate the function over each bin C IF(QFINTG) THEN WXXL = DBLE(XX - DXXL) WXXH = DBLE(XX + DXXH) IF(IABS(NDIMU).EQ.1) THEN DELXX = XBINNM / FLOAT(NFINTG) XXX = XX - DXXL - DELXX DO 3070 JJ=0,NFINTG XXX = XXX + DELXX WVAL(JJ) = XMNDFUN(XXX,YY,NF,NH,WXPAR(NP1) + ,WMNHER) 3070 CONTINUE WFUN = WFUN + + DSIMPS(WVAL,WXXL,WXXH,NFINTG) / DBLE(XBINNM) ELSE WYYL = DBLE(YY - DYYL) WYYH = DBLE(YY + DYYH) DELYY = YBINNM / FLOAT(NFINTG) YYY = YY - DYYL - DELYY DO 3080 KK=0,NFINTG YYY = YYY + DELYY DELXX = XBINNM / FLOAT(NFINTG) XXX = XX - DXXL - DELXX DO 3075 JJ=0,NFINTG XXX = XXX + DELXX WVAL(JJ) = XMNDFUN(XX,YYY,NF,NH + ,WXPAR(NP1),WMNHER) 3075 CONTINUE WVL2(KK) = DSIMPS(WVAL,WXXL,WXXH,NFINTG) / + DBLE(XBINNM) 3080 CONTINUE WFUN = WFUN + + DSIMPS(WVL2,WYYL,WYYH,NFINTG) / DBLE(YBINNM) ENDIF C C Take the function value at the centre of the bin C ELSE WFUN = WFUN + XMNDFUN(XX,YY,NF,NH,WXPAR(NP1) + ,WMNHER) WFERR2 = WFERR2 + WMNHER*WMNHER ENDIF 3090 CONTINUE NP1 = NP1 + IPARF(NF) 3100 CONTINUE IF(QSNORM) THEN WF00 = WXPAR(1) WFUN = WF00 * WFUN WFERR2 = WF00 * WF00 * WFERR2 ENDIF C C STORE FUNCTION VALUES FOR DRAWING C FUN = SNGL(DSIGN(DMAX1(DMNV1,DMIN1(DMXV1,DABS(WFUN))) + ,WFUN)) DF = SNGL(DSIGN(DMAX1(DMNV1 + ,DMIN1(DMXV1,DABS(WEE - WFUN))),(WEE - WFUN))) C C CALCULATE CHI**2 OR LIKELIHOOD C CALL MN_LKC(NFITTP,WEE,WFUN,WXPAR(1) + ,WDEEL2,WDEEH2,WFERR2,WDCHI,WDLIK,NFN0,NMESSB) C C CHI**2 FIT C IF(NFITTP.EQ.0) THEN WFCHI = WFCHI + WDCHI FICHI(NH) = FICHI(NH) + + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDCHI))) + ,WDCHI)) C C LIKELIHOOD FIT C ELSE WFLIK = WFLIK + WDLIK FILIK(NH) = FILIK(NH) + + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDLIK))) + ,WDLIK)) C WFCHI = WFCHI + WDCHI FICHI(NH) = FICHI(NH) + + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDCHI))) + ,WDCHI)) ENDIF C IF(IFLAG.EQ.12) THEN IF(NFITTP.EQ.0) THEN DJNK = SIGN( + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDCHI))) + ,WDCHI)),DF) FFF = + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDCHI))) + ,WDCHI)) ffft = wfchi ELSE DJNK = SIGN( + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDLIK))) + ,WDLIK)),DF) FFF = + SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WDLIK))) + ,WDLIK)) ffft = wflik ENDIF C IF(IABS(NDIMU).EQ.1) THEN IF(.NOT.QERRH) THEN WRITE(LUNDMP,13200,IOSTAT=IOERR) I 1 ,XX,DXXL,EE,DEEL,WFUN,DJNK,FFFt 13200 FORMAT(1X,I4,1PG11.4,1PG9.3,2X,1PG11.4,1PG9.3 1 ,2X,1PG11.4,2(0PF9.3)) ELSE WRITE(LUNDMP,13205,IOSTAT=IOERR) I 1 ,XX,DXXL,DXXH,EE,DEEL,DEEH,WFUN,DJNK,FFFt 13205 FORMAT(1X,I4,1PG11.4,2(1PG10.3) + ,2X,1PG11.4,2(10PG9.3),2X,1PG11.4,2(0PF9.3)) ENDIF ELSE WRITE(LUNDMP,13210,IOSTAT=IOERR) I,XX,YY 1 ,EE,DEEL,WFUN,DJNK,FFFt 13210 FORMAT(1X,I4,1PG11.4,1PG11.4,2X,1PG11.4,1PG9.3 1 ,2X,1PG11.4,2(0PF9.3)) ENDIF C ENDIF 3200 CONTINUE C IF(QFITER .AND. NH.EQ.1 .AND. IABS(NDIMU).EQ.1) THEN NDSMOD = NDMODE NDMODE = 1 IF(MOD(NCALL4-1,NFITER).EQ.0) THEN C C IF THIS IS THE FIRST PLOT MAKE A DISPLAY C IF(NCALL4.EQ.1) THEN CALL MN_FSP NHPLT = 1 IPLTIA(NHPLT) = IDAU IPLTIB(NHPLT) = IDBU IPLTSY(NHPLT) = NSYMS IPLTHA(NHPLT) = 0 IPLTPA(NHPLT) = 0 IPLTCO(1,NHPLT) = ICOLS(7) IPLTCO(2,NHPLT) = ICOLS(8) IPLTCO(3,NHPLT) = ICOLS(9) IPLTFL(NHPLT) = 1 IPLTCL(NHPLT) = 1 IPLTLG(NHPLT) = 0 CALL MN_DRW(-1,NDERR) ENDIF C C FILL THE FUNCTION C CALL VFILL(IUSEE,MFUNMX,1) IF(QFHIST) THEN NMODE = 1 ELSE NMODE = 0 ENDIF NDFUN = NDFUN + 1 IDBF = -1 CALL MN_FFL(IUSEE,NMODE,NH,IDAF,IDBF) C C PLOT ONLY THE INCLUDED PARTS OF THE FUNCTION C NHPLT = NHPLT + 1 IF(NHPLT.GT.MHPLT) THEN NHPLT = MHPLT ENDIF IPLTIA(NHPLT) = IDAF IPLTIB(NHPLT) = IDBF IF(QFHIST) THEN IPLTSY(NHPLT) = 1 ELSE IPLTSY(NHPLT) = -1 ENDIF IPLTHA(NHPLT) = 0 IPLTPA(NHPLT) = 0 IPLTCO(1,NHPLT) = ICOLS(12) IPLTCO(2,NHPLT) = icols(12) IPLTCO(3,NHPLT) = icols(12) IPLTFL(NHPLT) = 2 IPLTCL(NHPLT) = 0 IPLTLG(NHPLT) = 0 NPLTCM(NHPLT) = 0 NPLTKY(NHPLT) = 0 C CALL MN_DRW(0,NDERR) ENDIF NDMODE = NDSMOD ENDIF 3500 CONTINUE C C STORE FUNCTION VALUE C C FIT TYPES 8 and 9 MEAN DO A LIKELIHOOD FIT, BUT RETURN THE C PROPER CHI**2 - USED BY ROUTINE MIN_PLOT C IF(NFITTP.EQ.0 .OR. NFITTP.EQ.8 .OR. NFITTP.EQ.9) THEN +SELF,IF=-MIN_CGR. F = WFCHI +SELF,IF=MIN_CGR. F = SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WFCHI))) + ,WFCHI)) +SELF. ELSE IF(NFITTP.EQ.1 .OR. NFITTP.EQ.2) THEN +SELF,IF=-MIN_CGR. F = WFLIK +SELF,IF=MIN_CGR. F = SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WFLIK))) + ,WFLIK)) +SELF. ENDIF C IF(IFLAG.EQ.4) RETURN C C FILL IN THE VALUES OF THE FUNCTION C IF(IFLAG.EQ.3 .OR. IFLAG.EQ.11 .OR. 1 IFLAG.EQ.13) THEN C C UPDATE THE FUNCTION PARAMETER VALUES IN FPAR ETC C CALL MN_FUP(1) C C Get the fit status C +SELF,IF=-MIN_CGR. CALL MNSTAT(FMIN,FEDM,ERRDEF,NPARI,NPARX,ISTAT) UP = SNGL(ERRDEF) EDM = SNGL(FEDM) NFRE_MN = NPARI +SELF,IF=MIN_CGR. ISTAT = ISW(2) C C Calculate the number of degrees of freedom C NFRE_MN = NPAR +SELF. C CHI2_MN = SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WFCHI))) + ,WFCHI)) ALIK_MN = SNGL(DSIGN(DMAX1(DMNV2,DMIN1(DMXV2,DABS(WFLIK))) + ,WFLIK)) NDF = NPTTOT - NFRE_MN IF(NDF.GT.50 .AND. CHI2_MN/MAX0(1,NDF).LT.0.1) THEN WRITE(TXTMES,'('' Confidence level set to 1 as'' + ,'' chi**2 ='',F8.2,'' for'',I4,'' d.o.f.'')' + ,IOSTAT=IOERR) CHI2_MN,NDF CALL MN_MES(LUNTTO,'ME',TXTMES) CONLEV = 1.0 ELSE CONLEV = PROB(CHI2_MN,NPTTOT-NFRE_MN) ENDIF C C Store the function value in register 111 C and the confidence level in register 112 C REGIS(111) = F REGIS(112) = CONLEV C C WRITE OUT THE FIT RESULTS C IF(IFLAG.EQ.11 .OR. IFLAG.EQ.13) THEN C IF(LUNDMP.NE.LUNTTO) WRITE(LUNDMP,'(//,1X,79(''-''))') WRITE(LUNDMP,'('' Results of Fit to Plot(s):'' 1 ,1X,5(I8,I4,'';''))') 2 (IDFITA(II),IDFITB(II),II=1,NHFIT) IF(ISTAT.NE.3 .OR. + ((NFITTP.EQ.1 .OR. NFITTP.EQ.2) .AND. NFN0.GT.0)) THEN WRITE(LUNDMP,'(1X,78(''*''))') IF(ISTAT.NE.3) WRITE(LUNDMP 1 ,'('' *** WARNING... Fit did not converge properly'' 1 ,'' or you did not run MIGRAD'')') IF((NFITTP.EQ.1 .OR. NFITTP.EQ.2) .AND. NFN0.GT.0) + WRITE(LUNDMP 1 ,'('' *** WARNING... Function is =< 0 for'',I4 1 ,'' points'')') NFN0 WRITE(LUNDMP,'(1X,78(''*''))') ENDIF IF(QFINTG) WRITE(LUNDMP,'('' Integrating over each bin'' + ,'' using '',I4,'' intervals'')',IOSTAT=IOERR) NFINTG IF(QFCONV) WRITE(LUNDMP + ,'('' Function convoluted with a Gaussian of width '' + ,1PG11.4)',IOSTAT=IOERR) RFCONV(1) IF(NFITTP.EQ.1 .OR. NFITTP.EQ.2) + WRITE(LUNDMP,'('' Likelihood ='' 1 ,F8.1)',IOSTAT=IOERR) ALIK_MN WRITE(LUNDMP,'('' Chi**2 = '',F8.1,'' for'',I4 1 ,'' -'',I4,'' d.o.f.'',T60,''C.L. ='',1PG9.3,''%'')' 1 ,IOSTAT=IOERR) CHI2_MN 1 ,NPTTOT,NFRE_MN,CONLEV*100. IF(NHFIT.GT.1) THEN IF(NFITTP.EQ.0) THEN WRITE(LUNDMP,'('' Individual chi**2 ='' 1 ,5(F8.1,'',''))',IOSTAT=IOERR) 2 (FICHI(II),II=1,NHFIT) ELSE WRITE(LUNDMP,'('' Individual Likelihoods ='' 1 ,5(F8.1,'',''))',IOSTAT=IOERR) 2 (FILIK(II),II=1,NHFIT) ENDIF ENDIF C C FILL IN THE FUNCTION VALUES C CALL VFILL(IUSEE,MFUNMX,1) IF(QFHIST) THEN NMODE = 1 ELSE NMODE = 0 ENDIF C C WRITE OUT THE AREA UNDER THE CURVES C NDIMMX = 0 NDFUN = 0 DO 4050 NH=1,NHFIT C C STORE THE FUNCTION IN A PLOT AND GET ITS AREA C NDFUN = NDFUN + 1 JDBF(NH) = -1 CALL MN_FFL(IUSEE,NMODE,NH,JDAF(NH),JDBF(NH)) C IDAU = IDFITA(NH) IDBU = IDFITB(NH) CALL MN_FGT(IDAU,IDBU,NDH) NDIMMX = MAX0(NDIMMX,IABS(NDIMU)) C IF(NHFIT.GT.1) WRITE(LUNDMP,'('' Hist'',I8,I4)' 1 ,IOSTAT=IOERR) IDFITA(NH),IDFITB(NH) IF(LUNDMP.NE.LUNTTO) THEN TXT1 = ' ' TXT2 = ' ' CALL M_TTIM(TXT1,TXT2) LENT = MAX0(1,LNBLNK(TFTIT(NH))) LENF = MAX0(1,LNBLNK(TFFIL(NH))) WRITE(LUNDMP,'('' Title: '',A 1 ,/,'' File: '',A,T61,A,1X,A)') TFTIT(NH)(1:LENT) + ,TFFIL(NH)(1:LENF),TXT1(1:11),TXT2(1:8) CALL M_EXCL(0,NH,LUNDMP,IDELIM) END IF C IF(NH.EQ.1) THEN WRITE(LUNDMP,'( + '' Plot Area Total/Fit'',1PG13.6,''/'',1PG13.6 + ,T60,''Fit Status'',I3 + ,/,'' Func Area Total/Fit'',1PG13.6,''/'',1PG13.6 + ,T60,''E.D.M.'',1PG10.3)',IOSTAT=IOERR) + AHTTOT(NH),AHFTOT(NH),ISTAT + ,AFTTOT(1,NH),AFFTOT(1,NH),EDM ELSE WRITE(LUNDMP,'( + '' Plot Area Total/Fit'',1PG13.6,''/'',1PG13.6 + ,/,'' Func Area Total/Fit'',1PG13.6,''/'',1PG13.6 + )',IOSTAT=IOERR) + AHTTOT(NH),AHFTOT(NH) + ,AFTTOT(1,NH),AFFTOT(1,NH) ENDIF C C WRITE OUT ANY LIMITS SET TO DUMP FILE C IF(LUNDMP.NE.LUNTTO) THEN WRITE(LUNDMP,'('' The following parameters'' + ,'' have limits set: '')') NPART = 0 N1 = 1 IF(QSNORM) N1 = 0 DO 4040 NF=N1,NFUN_MN IF(NF.GT.0) then if(IUSEF(NF).EQ.0) GOTO 4040 endif IF(NF.GT.0) THEN NFUN = INUMF(NF) NPARF = IPARF(NF) TXT1 = 'Function : ' // TUSEF(NF) ELSE NFUN = 0 NPARF = 1 TXT1 = 'Function : ' // + 'Overall Normalization' ENDIF WRITE(TXT1(9:11),'(I3)') NF WRITE(LUNDMP,'(1X,A70)') TXT1(1:70) NNL = 0 DO 4035 II=1,NPARF IF(FPARLO(II,NF).EQ.0.0 .AND. + FPARHI(II,NF).EQ.0.0) GOTO 4035 C NNL = NNL + 1 NPART = NPART + 1 IF(NF.GT.0) THEN WRITE(LUNDMP,14035) II,TPARF(II,NF) 1 ,FPARLO(II,NF),FPARHI(II,NF) ELSE WRITE(LUNDMP,14035) II,'NORM00 ' 1 ,F00LO,F00HI ENDIF 14035 FORMAT(1X,I2,1X,A10 1 ,'Lower limit ',1PG12.5,2X 3 ,'Upper limit ',1PG12.5) 4035 CONTINUE IF(NNL.EQ.0) WRITE(LUNDMP + ,'('' No limits set'')') 4040 CONTINUE ENDIF 4050 CONTINUE C IF(ABS(UP-1.0).GT.1.0E-3) THEN WRITE(LUNDMP,'(/,'' *** Errors correspond to a'' 1 ,'' chi**2 change of'',F8.3, ''***'')',IOSTAT=IOERR) 2 UP ENDIF C WRITE(LUNDMP,'(/,12X,''Name'',7X,''Value'',21X,''Errors'' 1 ,/,39X,''Parabolic'',14X,''Minos'')') C NPART = 0 N1 = 1 IF(QSNORM) N1 = 0 DO 4100 NF=N1,NFUN_MN IF(NF.GT.0) then if(IUSEF(NF).EQ.0) GOTO 4100 endif IF(NF.GT.0) THEN NFUN = INUMF(NF) NPARF = IPARF(NF) TXT1 = 'Function : ' // TUSEF(NF) ELSE NFUN = 0 NPARF = 1 TXT1 = 'Function : ' // 'Overall Normalization' ENDIF WRITE(TXT1(9:11),'(I3)') NF WRITE(LUNDMP,'(1X,A70)') TXT1(1:70) C C Flag fixed and constrained parameters C DO 4080 II=1,NPARF NPART = NPART + 1 if(nf.gt.0) then nsfpar = isfpar(ii,nf) else nsfpar = 0 endif IF((NF.GT.0 .AND. NSFPAR.LE.0) .OR. + (NF.EQ.0 .AND. ISF00.LE.0)) THEN IF(JCNSTX(NPART).GT.0) THEN STAR = '#' ELSE STAR = '*' ENDIF ELSE STAR = ' ' ENDIF IF(NF.GT.0) THEN WRITE(LUNDMP,14100) STAR,NF,II,NPART 1 ,TPARF(II,NF),FPAR(II,NF),DFPAR(II,NF) 2 ,ABS(DNFPAR(II,NF)),DPFPAR(II,NF) ELSE WRITE(LUNDMP,14100) STAR,NF,II,NPART 1 ,'NORM00 ',F00,DF00,ABS(DNF00),DPF00 ENDIF 14100 FORMAT(1X,A1,I2,'(',I2,')',1X,I2,1X,A10 1 ,1PG12.5,' +/-',1PG12.5 3 ,' -',1PG12.5,' +',1PG12.5) 4080 CONTINUE 4100 CONTINUE C ENDIF ENDIF C C DRAW THE RESULTS C IF(IFLAG.EQ.13) THEN NHPLT = 0 NDRWLN = 0 C C SET UP EVERYTHING FOR THE DISPLAY C CALL MN_FSP C IF(IABS(NDIMMX).EQ.1 .AND. 1 (IABS(NDMODE).EQ.2 .OR. IABS(NDMODE).EQ.3)) THEN JJMODE = 1 IF(NDMODE.LT.0) JJMODE = 2 IDELIM = -1 CALL MN_BSB(JJMODE,IDELIM,IERR) IF(IERR.NE.0) GOTO 4900 C C SEE IF THE SIGNAL IS A HISTOGRAM C QFHSTS = .FALSE. DO 4350 NF=1,NFUN_MN IF(IUSEF(NF).EQ.0) GOTO 4350 IF(ISIGF(NF).EQ.0) GOTO 4350 IF(TUSEF(NF)(1:4).EQ.'Hist') THEN QFHSTS = .TRUE. GOTO 4351 ENDIF 4350 CONTINUE 4351 CONTINUE IF(QFHSTS) THEN NMODS = 1 ELSE NMODS = 0 ENDIF ENDIF C IF(IABS(NDIMMX).GE.2 .OR. IABS(NDMODE).EQ.1) THEN NN1 = 1 NN2 = 1 ELSEIF(IABS(NDMODE).EQ.2) THEN NN1 = 2 NN2 = 2 ELSEIF(IABS(NDMODE).EQ.3) THEN NN1 = 1 NN2 = 2 ENDIF C DO 4500 NH=1,NHFIT NDIMU = IFNDIM(NH) DO 4490 NN=NN1,NN2 IF(IABS(NDIMU).EQ.1 .AND. NN.EQ.1) THEN IDAU = IDFITA(NH) IDBU = IDFITB(NH) IDAF = JDAF(NH) IDBF = JDBF(NH) NSYM = NSYMS QFTEMP = QFHIST ELSE IF(NN.EQ.1) THEN IDAU = IDFITA(NH) IDBU = JDBF(NH) + 1 NSYM = -12 QFTEMP = QFHIST ELSE IDAU = IDBCKA(NH) IDBU = IDBCKB(NH) NSYM = NSYMS C C GET THE FUNCTION VALUES FOR THE SIGNAL C NDFUN = NDFUN + 1 IDBS = -1 CALL MN_FFL(ISIGF,NMODS,NH,IDAS,IDBS) QFTEMP = QFHSTS ENDIF C C HISTOGRAM C NHPLT = NHPLT + 1 IPLTIA(NHPLT) = IDAU IPLTIB(NHPLT) = IDBU IPLTSY(NHPLT) = NSYM IPLTHA(NHPLT) = NHATS IPLTPA(NHPLT) = NPATS IPLTCO(1,NHPLT) = ICOLS(7) IPLTCO(2,NHPLT) = ICOLS(8) IPLTCO(3,NHPLT) = ICOLS(9) IPLTFL(NHPLT) = 1 IPLTCL(NHPLT) = 1 IPLTLG(NHPLT) = 0 C IF(NN.EQ.NN1) THEN IDELIM = -1 CALL MN_ZER(NHPLT,IDELIM) ELSE NPLTCM(NHPLT) = 0 NPLTKY(NHPLT) = 0 ENDIF C C FUNCTION C SHOW INCLUDED AND EXCLUDED PARTS C IF(IABS(NDIMU).EQ.1) THEN NF1 = 1 NF2 = 2 IF(IXEXCL(NH).LE.0 .AND. IYEXCL(NH).LE.0 .AND. 1 IXINCL(NH).LE.0 .AND. IYINCL(NH).LE.0) NF2 = 1 IF(.NOT.QSEXCL) NF2 = 1 DO 4450 II=NF1,NF2 NHPLT = NHPLT + 1 IF(NN.EQ.1) THEN IPLTIA(NHPLT) = IDAF IPLTIB(NHPLT) = IDBF + (II-1) ELSE IPLTIA(NHPLT) = IDAS IPLTIB(NHPLT) = IDBS + (II-1) ENDIF IF(QFTEMP) THEN IF(II.EQ.1) THEN IPLTSY(NHPLT) = 1 ELSE IPLTSY(NHPLT) = 3 ENDIF ELSE IF(II.EQ.1) THEN IPLTSY(NHPLT) = -1 ELSE IPLTSY(NHPLT) = -3 ENDIF ENDIF IPLTHA(NHPLT) = 0 IPLTPA(NHPLT) = 0 IPLTCO(1,NHPLT) = ICOLS(12) IPLTCO(2,NHPLT) = icols(12) IPLTCO(3,NHPLT) = icols(12) IPLTFL(NHPLT) = 2 IPLTCL(NHPLT) = 0 IPLTLG(NHPLT) = 0 NPLTCM(NHPLT) = 0 NPLTKY(NHPLT) = 0 4450 CONTINUE ENDIF 4490 CONTINUE 4500 CONTINUE C C NOW MAKE THE PLOTS C CALL MN_DRW(-1,NDERR) 4900 CONTINUE ENDIF C RETURN C 6000 CONTINUE IF(IFLAG.EQ.99) THEN TXTMES = ' +++ MINUIT will start from scratch' ELSE WRITE(TXTMES,'('' *** FCN called with an unknown flag'' 1 ,I4)',IOSTAT=IOERR) IFLAG ENDIF CALL MN_MES(LUNTTO,'ME',TXTMES) C RETURN END +DECK,futil. DOUBLE PRECISION FUNCTION FUTIL(XX) C C----------------------------------------------------------------------- C C Dummy optional function that can be called by FCN C C----------------------------------------------------------------------- C DOUBLE PRECISION XX C FUTIL = 0.0D0 C END +DECK,midata,IF=MIN_CGR. SUBROUTINE MIDATA +CDE,MINPAR,PARINT,PAREXT,LIMITS,UNIT,MINFIX,CONVER,VARIAN,MINERR. +CDE,MNPAR. +CDE,MNCMD. C CHARACTER*10 TJUNK(1),TCOMM CHARACTER*8 TNAME DATA TJUNK/' '/ DATA NBLUCK/0/ C CALL ICMSYM(TCMSYM) C IF (NBLUCK.EQ.0) THEN NBLUCK=1 NBLOCK=0 ENDIF NBLOCK=NBLOCK+1 C IF(ISYSRD.EQ.5) THEN C IF(ISW(5).GE.0) THEN C WRITE(ISYSWR,1000) NBLOCK C10000 FORMAT(//,50X,'====================='/ C 1 50X,'= D506 MINUITS ='/ C 2 50X,'= VERSION 5.71 ='/ C 3 50X '= DATA BLOCK NO.',I3,' =' C 4 ,/'' (FEEL FREE TO ASK AT ANY TIME FOR HELP)'')') WRITE(ISYSWR,'(/,1X,76(''=''))') C END IF ENDIF UP=1.0 C SET DEFAULT VALUES AT PROGRAM START CALL VZERO_i(ISW,7) CALL VZERO_r(ERP,MAXEXT) CALL VZERO_r(ERN,MAXEXT) SIGMA=0.0 ISW(5) = 1 NPFIX=0 NU=0 NPAR=0 LIMSET=0 CALL VZERO_r(U,MAXEXT) CALL VZERO_i(LCODE,MAXEXT) CALL VZERO_i(LCORSP,MAXEXT) CALL VZERO_r(DIRIN,MAXINT) CALL TZERO(NAME,MAXEXT) C C READ FIRST CARD IF(ISYSRD.EQ.5) WRITE(ISYSWR,'('' Give title card: '',$)') READ(ISYSRD,'(A)') TITLE CALL DATEZB(DATE) CALL MFTIME(TIME) IF(ISW(5).GE.0) WRITE(ISYSWR,13000) TITLE,DATE 13000 FORMAT(1X,A,/1X,A,/1X,76('=')) C IF(ISYSRD.EQ.5) WRITE(ISYSWR 1 ,'('' Give datacards: NUMBER,NAME,VALUE,ERROR,LOWLIM,HILIM'')') C 2000 CONTINUE CALL WAITYP('DATA> ') C C GET THE PARAMETER NUMBER C K = INTTYP(.TRUE.,IDELIM) C C SEE IF THE COMMAND IS HELP OR END C IF(IDELIM.NE.0) THEN CALL RESTYP ICMD = ICMTYP(.TRUE.,IDELIM,TJUNK) TCOMM = ' ' CALL ICMSTR(TCOMM) IF(ICMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN IDELIM = 0 CALL QUOTYP('MINUIT DATACARDS') CALL MN_HLP(IDELIM,IERR) CALL ICMSYM(TCMSYM) GOTO 2000 ELSE IF(TCOMM(1:1).EQ.'E') THEN GOTO 5000 ELSE GOTO 4900 ENDIF ENDIF IF(K.LE.0 .OR. IDELIM.NE.0) GOTO 4800 C C GET THE PARAMETER NAME C ICHR = ISTTYP(.TRUE.,IDELIM,TCOMM) IF(ICHR.LE.0 .OR. TCOMM.EQ.' ' .OR. IDELIM.NE.0) GOTO 4800 TNAME = TCOMM C C GET THE PARAMETER VALUES C UK = 0.0 WK = 0.0 A = 0.0 B = 0.0 NNUM = 0 2500 CONTINUE RVAL = RELTYP(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 4800 NNUM = NNUM + 1 IF(NNUM.EQ.1) THEN UK = RVAL ELSE IF(NNUM.EQ.2) THEN WK = RVAL ELSE IF(NNUM.EQ.3) THEN A = RVAL ELSE IF(NNUM.EQ.4) THEN B = RVAL ENDIF IF(NNUM.LT.4 .AND. IDELIM.EQ.0) GOTO 2500 C IREDO=0 IF(NAME(K).NE.' ') THEN WRITE(ISYSWR 1 ,'('' *** Overiding datacard for parameter'',I3 2 ,'' ***'')') K IREDO=1 ENDIF C NU=MAX0(NU,K) NAME(K) = TNAME U(K) = UK W(K) = WK WERR(K) = WK C CALL UU_ENCOD CALL II_ENCOD(K,7) CALL SS_ENCOD(' ',5) CALL SS_ENCOD(NAME(K),8) CALL FF_ENCOD(U(K),15) IF(W(K).GT.0.) THEN CALL FF_ENCOD(W(K),13) CALL FF_ENCOD(A,13) CALL FF_ENCOD(B,13) ENDIF CALL OO_ENCOD C IF(W(K).LE.0.) THEN LCORSP(K)=0 LCODE(K)=0 ELSE IF(IREDO.EQ.0) THEN JPAR = NPAR + 1 NPAR = NPAR + 1 LCORSP(K) = NPAR ELSE JPAR=LCORSP(K) ENDIF IF (A.EQ.0..AND.B.EQ.0.) THEN LCODE(K) = 1 ALIM(K) = 0.0 BLIM(K) = 0.0 ELSE IF (A.EQ.B) GOTO 4900 IF (B.LT.A) THEN SAV=B B=A A=SAV WRITE(ISYSWR,'('' *** MIDATA:'' 1 ,'' Warning - above limits have been reversed.'')') ENDIF ALIM(K) = A BLIM(K) = B ABLIM1(K)=(A+B)/2. ABLIM2(K)=(B-A)/2. LCODE(K) = 4 IF (UK.LT.A.OR.UK.GT.B) GOTO 4900 IF (UK.EQ.A.OR.UK.EQ.B) WRITE(ISYSWR,'('' *** MIDATA:'' 1 ,'' Warning - above parameter is at limit'')') ENDIF CALL EXTOIN0(K,JPAR) SAV = U(K) SAVX= X(JPAR) U(K) = SAV + W(K) CALL EXTOIN0(K,JPAR) B=X(JPAR) U(K) = SAV - W(K) CALL EXTOIN0(K,JPAR) A=X(JPAR) U(K) = SAV X(JPAR) = SAVX DIRIN(JPAR) = (ABS(A-SAVX) + ABS(B-SAVX) ) / 2.0 XT(JPAR) = SAVX ENDIF GOTO 2000 C 4800 CONTINUE WRITE(ISYSWR,'('' *** MIDATA: Error on datacard.'' 1 ,'' You must supply at least number, name, value'')') CALL ZERTYP('.FALSE.') GOTO 2000 4900 CONTINUE WRITE(ISYSWR,'('' *** MIDATA: Error on datacard'')') CALL ZERTYP('.FALSE.') GOTO 2000 C 5000 CONTINUE WRITE(ISYSWR,'(1X,76(''=''))') DO 5100 I=1,NU IF(NAME(I).EQ.' ') THEN WRITE(ISYSWR,'('' *** MIDATA:'' 1 ,'' You forgot to specify parameter'',I3,'' ***'')') I GOTO 2000 ENDIF 5100 CONTINUE CALL VZERO_i(MCODE,MAXINT) CALL VZERO_i(MCORSP,MAXINT) DO 5200 J=1,NU I=LCORSP(J) IF(I.GT.0) THEN MCODE(I)=LCODE(J) MCORSP(I)=J ENDIF 5200 CONTINUE C CALL ICMSYM(TSPSYM) C RETURN END +DECK,min_cm2. C SUBROUTINE MIN_CM2(IDELIM,FCN,FUTIL) C C SEES IS COMMAND IS AN EXTRA MINUIT COMMAND C EXTERNAL FCN,FUTIL C +CDE,MNPAR. +CDE,MNCMD. +CDE,MNFIT. +CDE,MNLUN. +SELF,IF=MIN_CGR. +CDE,MINCOM. +SELF. C +SELF,IF=-MIN_CGR. CHARACTER*20 TCMD DOUBLE PRECISION RNUMB(1) +SELF. C LOGICAL QEXIST,QMNFEX,QQCHGE C C Exclude parts of histogram from fit C IF(COMND1.EQ.'EXCLUDE') THEN IF(.NOT.QRFILE .AND. IDELIM.LT.0) 1 WRITE(LUNTTO,'('' Hit when finished'')') NH = 1 CALL M_EXCL(1,NH,LUNTTO,IDELIM) QQCHGE = .TRUE. C C Include parts of histogram from fit C ELSEIF(COMND1.EQ.'INCLUDE') THEN IF(.NOT.QRFILE .AND. IDELIM.LT.0) 1 WRITE(LUNTTO,'('' Hit when finished'')') NH = 1 CALL M_EXCL(2,NH,LUNTTO,IDELIM) QQCHGE = .TRUE. C C REMOVE ANY EXCLUSIONS C ELSEIF(COMND1.EQ.'NO_EXCLUDE' .OR. COMND1.EQ.'NO_INCLUDE') THEN IF(NHFIT.EQ.1) THEN NH = 1 ELSE 6200 CONTINUE CALL WAITYQ('Give histogram number or 0 for all: ') CALL MN_HNO(IDA,IDB,IDELIM,NNID) IF(NNID.LE.0) GOTO 9000 IF(IDA.GT.0) THEN QEXIST = QMNFEX(IDA,IDB,NH) IF(.NOT.QEXIST) THEN WRITE(LUNTTO,'('' Plot'',I7,I4 1 ,'' is not being fit'')') IDA,IDB GOTO 9000 ENDIF ELSE NH = 0 ENDIF ENDIF 6210 CONTINUE C IF(COMND1.EQ.'NO_EXCLUDE') THEN CALL M_EXCL(-1,NH,LUNTTO,IDELIM) ELSEIF(COMND1.EQ.'NO_INCLUDE') THEN CALL M_EXCL(-2,NH,LUNTTO,IDELIM) ENDIF QQCHGE = .TRUE. C C TURN ON PLOTTING OF FIT ITERATIONS OPTION C ELSEIF(COMND1.EQ.'ITERATIONS') THEN QFITER = .TRUE. 6300 CONTINUE CALL WAITYQ(' Every how many iterations do you want' // 1 ' to see the fit? ') NFITER = 1 NN = INTTYQ(.TRUE.,IDELIM) IF(IDELIM.GT.0) GOTO 6300 IF(NN.GT.0) NFITER = NN IF(NHFIT.GT.1) THEN WRITE(LUNTTO,'('' Will only show fit'' 1 ,'' iterations for histogram'',I6)') IDFITA(1) ENDIF QQCHGE = .FALSE. C C TURN OFF PLOTTING OF FIT ITERATIONS OPTION C ELSEIF(COMND1.EQ.'NO_ITERATI') THEN QFITER = .FALSE. QQCHGE = .FALSE. C C MAKE A HISTOGRAM OF THE BACKGROUND SUBTRACTED PLOT C ELSEIF(COMND1.EQ.'BACK_SUB') THEN CALL MN_BSB(0,IDELIM,IERR) QQCHGE = .FALSE. C C Put a constraint on a parameter C ELSEIF(COMND1.EQ.'CONSTRAIN') THEN CALL M_CSTR(1,IDELIM,FCN,FUTIL) QQCHGE = .TRUE. C C Remove a constraint on a parameter C ELSEIF(COMND1.EQ.'UNCONSTRAI') THEN CALL M_CSTR(-1,IDELIM,FCN,FUTIL) QQCHGE = .TRUE. ENDIF C C If something changed tell MINUIT to start from scratch C IF(QQCHGE) THEN +SELF,IF=-MIN_CGR. TCMD = 'CALL FCN' RNUMB(1) = DBLE(99) CALL MNEXCM(FCN,TCMD,RNUMB,1,IERFLG,FUTIL) +SELF,IF=MIN_CGR. ISW(2) = 0 +SELF. ENDIF C 9000 CONTINUE RETURN END +DECK,min_cmd,IF=-MIN_CGR. SUBROUTINE MIN_CMD C C Routine for interpreting MINUIT commands and passing them to MINUIT C EXTERNAL FCN,FUTIL C +CDE,MNPAR. +CDE,MNFIT. +CDE,MNCMD. +CDE,MNTYQ. +CDE,MNLUN. C PARAMETER (MMIN=52) CHARACTER*10 MINNAM(MMIN) C CHARACTER*20 TCMD CHARACTER*80 TXT1,TXT2 C DOUBLE PRECISION RNUMB(20),PVAL(MINMAX) DOUBLE PRECISION G,F DOUBLE PRECISION FMIN,FEDM,ERRDEF,VAL,ERROR,BND1,BND2 DOUBLE PRECISION EPSI_0,EPSI DOUBLE PRECISION WWK,WW1,WW2,WW3,WW4 CHARACTER*10 TPNAME INTEGER NSTK,NPRLEV C DATA MINNAM/'HELP', 'EXIT', 'MINUIT', 2 'MODIFY', 'MINOS', 'MAX_CALLS', 'PRECISION', 3 'FCN_DRAW', 'FCN_PLOT', 'PROB_PLOT', 'CHI_PLOT', 'INFO', 3 'FORCE_ISW', 'STANDARD', 'UNIT', 'STRATEGY', + 'CONTOUR', 'MNCONTOUR', 'SCAN', 4 'SEEK', 'IMPROVE', 'MINIMIZE', 'SIMPLEX', 'MIGRAD', 5 'PUNCH', 'SAVE', 'PRINTOUT', + 'FIX', 'FLOAT', 'RELEASE', 'RESTORE', 7 'GRADIENT', 'NO_GRADIEN','CALL_FCN', 'MATOUT', 8 'HESSE', 'COVARIANCE', 9 'ERROR_DEF', 'PAGE', A 'FIT_INFO', 'DUMP', 'DISPLAY', 1 'EXCLUDE', 'NO_EXCLUDE', 'INCLUDE', 'NO_INCLUDE', 2 'ITERATIONS','NO_ITERATI', 3 'BACK_SUB', 'CONSTRAIN', 'UNCONSTRAI', Z ' '/ DATA NPRLEV/0/ C NFCNMX_0= 2000 EPSI_0 = 0.1 NSTK = 0 C C MAIN LOOP FOR COMMANDS C 1000 CONTINUE C CALL WAITYQ('MINUIT> ') ICMD = ICMTYQ(.TRUE.,IDELIM,MINNAM) IF(ICMD.LT.0 .AND. IDELIM.EQ.ICHAR('?')) THEN IDELIM = 0 CALL MN_HLP(IDELIM,IERR) GOTO 1000 ENDIF COMND1 = ' ' IF(ICMD.GT.0) COMND1 = MINNAM(ICMD) CALL MN_DCK(IDELIM,ICMD,MMIN,MINNAM,IERR) IF(ICMD.LT.0 .OR. (IERR.NE.0 .AND. IERR.NE.2)) THEN GOTO 1000 ENDIF C IF(IERR.EQ.2) THEN CALL RESTYQ C C UPDATE THE VALUES OF THE FUNCTION PARAMETERS C CALL MN_FUP(1) C C SEE IF THE COMMAND IS A STANDARD MN_FIT COMMAND C CALL RESTYQ NCFLG = -1 CALL MN_CMD(NCFLG,NCERR) C C SEE IF THE COMMAND IS AN INTERNALLY DEFINED COMMAND C IF(NOPR.GT.0 .AND. NCERR.EQ.2) THEN CALL RESTYQ CALL MN_CIN(NCERR) ENDIF C C ERROR IN COMMAND C IF(NCERR.EQ.2) CALL MN_UNK('MIN_CMD') GOTO 1000 ENDIF C C EXECUTE THE COMMAND C NFCNMX = NFCNMX_0 EPSI = EPSI_0 C C HELP COMMAND C IF(COMND1.EQ.'HELP') THEN CALL MN_HLP(IDELIM,IERR) GOTO 1000 C C EXIT C ELSEIF(COMND1.EQ.'EXIT') THEN RETURN C C Get the MINUIT command C ELSEIF(COMND1.EQ.'MINUIT') THEN CALL WAITYQ( + 'Give the MINUIT command and parameters: ') NCHAR2 = ISTTYP(.TRUE.,IDELIM,COMND2) IF(NCHAR2.LE.0 .OR. IDELIM.GT.0) THEN CALL ZERTYQ('.TRUE.') GOTO 1000 ENDIF IF(COMND2(1:3).EQ.'SET' .OR. COMND2(1:3).EQ.'SHO') THEN CALL WAITYQ('SET or SHOW what: ') NCHAR3 = ISTTYP(.TRUE.,IDELIM,COMND3) IF(NCHAR3.LE.0 .OR. IDELIM.GT.0) THEN CALL ZERTYQ('.TRUE.') GOTO 1000 ENDIF COMND2 = COMND2(1:NCHAR2) // ' ' // COMND3(1:NCHAR3) ENDIF C C Extra MINUIT commands, that don't really use MINUIT C ELSEIF( + COMND1.EQ.'EXCLUDE' .OR. COMND1.EQ.'NO_EXCLUDE' .OR. + COMND1.EQ.'INCLUDE' .OR. COMND1.EQ.'NO_INCLUDE' .OR. + COMND1.EQ.'ITERATIONS' .OR. COMND1.EQ.'NO_ITERATI' .OR. + COMND1.EQ.'BACK_SUB' .OR. + COMND1.EQ.'CONSTRAIN' .OR. COMND1.EQ.'UNCONSTRAI') THEN CALL MN_FUP(1) CALL MIN_CM2(IDELIM,FCN,FUTIL) GOTO 1000 ENDIF C C Get all the numbers out for the MINUIT command. C NNUM = 0 CALL VZERO_r(RNUMB,2*20) IF(COMND1.EQ.'MINUIT' .OR. COMND1.EQ.'MINOS' .OR. + COMND1.EQ.'CONTOUR' .OR. COMND1.EQ.'MNCONTOUR' .OR. + COMND1.EQ.'SEEK' .OR. COMND1.EQ.'STRATEGY' .OR. + COMND1.EQ.'PRINTOUT' .OR. + COMND1.EQ.'FIX' .OR. COMND1.EQ.'FLOAT' .OR. + COMND1.EQ.'RELEASE' .OR. COMND1.EQ.'RESTORE' .OR. + COMND1.EQ.'CALL_FCN' .OR. COMND1.EQ.'ERROR_DEF') THEN 1600 CONTINUE IF(NNUM.LE.20 .AND. IDELIM.EQ.0) THEN RVAL = VALTYQ(.TRUE.,IDELIM) CALL MN_RCK(RVAL,IDELIM,IERR) IF(IERR.NE.0) GOTO 1600 NNUM = NNUM + 1 RNUMB(NNUM) = RVAL GOTO 1600 ENDIF ENDIF C C Execute a MINUIT command C IF(COMND1.EQ.'MINUIT') THEN LENC = LENOCC(COMND2) TCMD = COMND2(1:LENC) CALL MNEXCM(FCN,TCMD,RNUMB,NNUM,IERFLG,FUTIL) C C MODIFY COMMAND C ELSEIF(COMND1.EQ.'MODIFY') THEN CALL MNSTAT(FMIN,FEDM,ERRDEF,NPARI,NPARX,ISTAT) CALL WAITYQ('Give parameter number: ') NUMQ = IVLTYQ(.TRUE.,IDELIM) CALL MN_NCK(NUMQ,IDELIM,NERR) IF(NERR.GT.0) THEN CALL ZERTYQ('.FALSE') GOTO 1000 ENDIF IF(NUMQ.LE.0 .OR. NUMQ.GT.NPARX) THEN WRITE(TXTERR,'(''Error in parameter number'',I4)') 1 NUMQ CALL MN_ERR('MIN_CMD',TXTERR) GOTO 1000 ENDIF L = NUMQ CALL MNPOUT(NUMQ,TPNAME,VAL,ERROR,BND1,BND2,IVARBL) NNUM = 0 CALL WAITYQ('Give new values: ') 2210 CONTINUE RVAL = VALTYQ(.TRUE.,IDELIM) IF(IDELIM.EQ.ICHAR('=')) THEN NNUM = NNUM + 1 IF(NNUM.EQ.1) RNUMB(NNUM) = VAL IF(NNUM.EQ.2) RNUMB(NNUM) = ERROR IF(NNUM.EQ.3) RNUMB(NNUM) = BND1 IF(NNUM.EQ.4) RNUMB(NNUM) = BND2 ELSE CALL MN_RCK(RVAL,IDELIM,NERR) IF(NERR.EQ.0) THEN NNUM = NNUM + 1 RNUMB(NNUM) = RVAL ELSEIF(NERR.NE.2) THEN CALL ZERTYQ('.FALSE.') GOTO 1000 ENDIF ENDIF IF(IDELIM.GE.0) GOTO 2210 C DO 2250 K=1,4 IF(K.GT.NNUM) THEN IF(K.EQ.1) WWK=VAL IF(K.EQ.2) WWK=ERROR IF(K.EQ.3) WWK=BND1 IF(K.EQ.4) WWK=BND2 ELSE WWK=RNUMB(K) ENDIF IF(K.EQ.1) WW1=WWK IF(K.EQ.2) WW2=WWK IF(K.EQ.3) WW3=WWK IF(K.EQ.4) WW4=WWK 2250 CONTINUE CALL MNPARM(L,TPNAME,WW1,WW2,WW3,WW4,IERFLG) IF(IERFLG.NE.0) CALL MN_ERR('MIN_CMD' + ,'Error modifying parameter') GOTO 1000 C C CHANGE THE NUMBER OF CALLS C ELSEIF(COMND1.EQ.'MAX_CALLS') THEN TXT1 = 'Give number of calls ( =' WRITE(TXT1(29:),'(I6)',IOSTAT=IOERR) NFCNMX_0 LENT = LENOCC(TXT1) TXT2 = TXT1(1:LENT) // '):' LENT = LENT + 2 CALL WAITYQ(TXT2(1:LENT)) NVAL = IVLTYQ(.TRUE.,IDELIM) IF(NVAL.GT.0) NFCNMX_0 = NVAL GOTO 1000 C C CHANGE THE PRECISION C EL