From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- sys/gio/README | 6 + sys/gio/aelogd.x | 16 + sys/gio/aelogr.x | 16 + sys/gio/calcomp/README | 34 + sys/gio/calcomp/ccp.com | 38 + sys/gio/calcomp/ccp.h | 92 + sys/gio/calcomp/ccpclear.x | 29 + sys/gio/calcomp/ccpclose.x | 22 + sys/gio/calcomp/ccpclws.x | 17 + sys/gio/calcomp/ccpcolor.x | 36 + sys/gio/calcomp/ccpcseg.x | 207 ++ sys/gio/calcomp/ccpdrawch.x | 233 ++ sys/gio/calcomp/ccpdseg.x | 208 ++ sys/gio/calcomp/ccpescape.x | 65 + sys/gio/calcomp/ccpfa.x | 16 + sys/gio/calcomp/ccpfaset.x | 18 + sys/gio/calcomp/ccpfont.x | 34 + sys/gio/calcomp/ccpinit.x | 165 ++ sys/gio/calcomp/ccpltype.x | 27 + sys/gio/calcomp/ccplwidth.x | 32 + sys/gio/calcomp/ccpopen.x | 77 + sys/gio/calcomp/ccpopenws.x | 87 + sys/gio/calcomp/ccppl.x | 105 + sys/gio/calcomp/ccpplset.x | 20 + sys/gio/calcomp/ccppm.x | 73 + sys/gio/calcomp/ccppmset.x | 19 + sys/gio/calcomp/ccpreset.x | 48 + sys/gio/calcomp/ccptx.x | 463 ++++ sys/gio/calcomp/ccptxset.x | 29 + sys/gio/calcomp/doc/ccpspecs.hlp | 384 +++ sys/gio/calcomp/font.com | 207 ++ sys/gio/calcomp/font.h | 29 + sys/gio/calcomp/mkpkg | 52 + sys/gio/calcomp/rptheta4.x | 37 + sys/gio/calcomp/t_calcomp.x | 125 + sys/gio/calcomp/vttest.par | 10 + sys/gio/calcomp/vttest.x | 608 +++++ sys/gio/calcomp/x_calcomp.x | 3 + sys/gio/cursor/README | 9 + sys/gio/cursor/doc/cursor.hlp | 194 ++ sys/gio/cursor/doc/giotr.notes | 330 +++ sys/gio/cursor/giotr.x | 183 ++ sys/gio/cursor/grc.h | 20 + sys/gio/cursor/grcaxes.x | 402 +++ sys/gio/cursor/grcclose.x | 42 + sys/gio/cursor/grccmd.x | 533 ++++ sys/gio/cursor/grcinit.x | 32 + sys/gio/cursor/grcopen.x | 105 + sys/gio/cursor/grcpl.x | 69 + sys/gio/cursor/grcread.x | 60 + sys/gio/cursor/grcredraw.x | 21 + sys/gio/cursor/grcscr.x | 49 + sys/gio/cursor/grcstatus.x | 49 + sys/gio/cursor/grctext.x | 57 + sys/gio/cursor/grcwarn.x | 27 + sys/gio/cursor/grcwcs.x | 282 +++ sys/gio/cursor/grcwrite.x | 66 + sys/gio/cursor/gtr.com | 25 + sys/gio/cursor/gtr.h | 51 + sys/gio/cursor/gtrbackup.x | 74 + sys/gio/cursor/gtrconn.x | 78 + sys/gio/cursor/gtrctrl.x | 122 + sys/gio/cursor/gtrdelete.x | 45 + sys/gio/cursor/gtrdiscon.x | 66 + sys/gio/cursor/gtrfetch.x | 48 + sys/gio/cursor/gtrframe.x | 41 + sys/gio/cursor/gtrgflush.x | 45 + sys/gio/cursor/gtrgtran.x | 28 + sys/gio/cursor/gtrgtty.x | 20 + sys/gio/cursor/gtrinit.x | 136 + sys/gio/cursor/gtropenws.x | 206 ++ sys/gio/cursor/gtrpage.x | 30 + sys/gio/cursor/gtrptran.x | 74 + sys/gio/cursor/gtrrcur.x | 32 + sys/gio/cursor/gtrredraw.x | 48 + sys/gio/cursor/gtrreset.x | 53 + sys/gio/cursor/gtrset.x | 28 + sys/gio/cursor/gtrstatus.x | 100 + sys/gio/cursor/gtrtrunc.x | 39 + sys/gio/cursor/gtrundo.x | 76 + sys/gio/cursor/gtrwaitp.x | 94 + sys/gio/cursor/gtrwcur.x | 19 + sys/gio/cursor/gtrwritep.x | 68 + sys/gio/cursor/gtrwsclip.x | 144 ++ sys/gio/cursor/gtrwstran.x | 490 ++++ sys/gio/cursor/mkpkg | 57 + sys/gio/cursor/prpsinit.x | 15 + sys/gio/cursor/rcursor.x | 692 +++++ sys/gio/doc/gio.hlp | 3498 ++++++++++++++++++++++++++ sys/gio/elogd.x | 27 + sys/gio/elogr.x | 27 + sys/gio/fonts/README | 42 + sys/gio/fonts/font.com | 746 ++++++ sys/gio/fonts/greek.com | 501 ++++ sys/gio/fonts/greekc.txt | 96 + sys/gio/fonts/mkfont.c | 199 ++ sys/gio/fpequald.x | 41 + sys/gio/fpequalr.x | 41 + sys/gio/fpfixd.x | 43 + sys/gio/fpfixr.x | 43 + sys/gio/fpndgr.x | 21 + sys/gio/fpnormd.x | 40 + sys/gio/fpnormr.x | 40 + sys/gio/gactivate.x | 72 + sys/gio/gadraw.x | 284 +++ sys/gio/gamove.x | 27 + sys/gio/gascale.x | 62 + sys/gio/gcancel.x | 32 + sys/gio/gclear.x | 20 + sys/gio/gclose.x | 45 + sys/gio/gctran.x | 138 + sys/gio/gcurpos.x | 41 + sys/gio/gdeact.x | 28 + sys/gio/gescape.x | 19 + sys/gio/gfill.x | 30 + sys/gio/gflush.x | 18 + sys/gio/gframe.x | 18 + sys/gio/gfrinit.x | 26 + sys/gio/ggcell.x | 55 + sys/gio/ggcur.x | 37 + sys/gio/ggetb.x | 18 + sys/gio/ggeti.x | 17 + sys/gio/ggetr.x | 17 + sys/gio/ggets.x | 22 + sys/gio/ggscale.x | 64 + sys/gio/ggview.x | 21 + sys/gio/ggwind.x | 22 + sys/gio/gim/README | 215 ++ sys/gio/gim/gimcpras.x | 56 + sys/gio/gim/gimcrras.x | 26 + sys/gio/gim/gimderas.x | 17 + sys/gio/gim/gimdsmap.x | 21 + sys/gio/gim/gimenmap.x | 21 + sys/gio/gim/gimfcmap.x | 17 + sys/gio/gim/gimfmap.x | 17 + sys/gio/gim/gimgetmap.x | 85 + sys/gio/gim/gimimap.x | 13 + sys/gio/gim/gimlcmap.x | 51 + sys/gio/gim/gimqras.x | 46 + sys/gio/gim/gimrasini.x | 14 + sys/gio/gim/gimrcmap.x | 68 + sys/gio/gim/gimref.x | 18 + sys/gio/gim/gimrefpix.x | 38 + sys/gio/gim/gimriomap.x | 56 + sys/gio/gim/gimrpix.x | 62 + sys/gio/gim/gimsetmap.x | 80 + sys/gio/gim/gimsetpix.x | 41 + sys/gio/gim/gimsetras.x | 28 + sys/gio/gim/gimwcmap.x | 42 + sys/gio/gim/gimwiomap.x | 37 + sys/gio/gim/gimwpix.x | 47 + sys/gio/gim/mkpkg | 32 + sys/gio/gki/README | 84 + sys/gio/gki/gki.com | 8 + sys/gio/gki/gkicancel.x | 28 + sys/gio/gki/gkiclear.x | 28 + sys/gio/gki/gkiclose.x | 65 + sys/gio/gki/gkideact.x | 42 + sys/gio/gki/gkieof.x | 23 + sys/gio/gki/gkiesc.x | 40 + sys/gio/gki/gkiexe.x | 178 ++ sys/gio/gki/gkifa.x | 37 + sys/gio/gki/gkifaset.x | 35 + sys/gio/gki/gkifetch.x | 80 + sys/gio/gki/gkifflush.x | 24 + sys/gio/gki/gkiflush.x | 40 + sys/gio/gki/gkigca.x | 87 + sys/gio/gki/gkigcur.x | 106 + sys/gio/gki/gkigetwcs.x | 44 + sys/gio/gki/gkiinit.x | 22 + sys/gio/gki/gkiinline.x | 23 + sys/gio/gki/gkikern.x | 30 + sys/gio/gki/gkiopen.x | 67 + sys/gio/gki/gkipca.x | 47 + sys/gio/gki/gkipl.x | 37 + sys/gio/gki/gkiplset.x | 37 + sys/gio/gki/gkipm.x | 37 + sys/gio/gki/gkipmset.x | 37 + sys/gio/gki/gkiprint.x | 820 ++++++ sys/gio/gki/gkirca.x | 30 + sys/gio/gki/gkircval.x | 51 + sys/gio/gki/gkireact.x | 42 + sys/gio/gki/gkiredir.x | 34 + sys/gio/gki/gkiscur.x | 37 + sys/gio/gki/gkisetwcs.x | 46 + sys/gio/gki/gkititle.x | 51 + sys/gio/gki/gkitx.x | 57 + sys/gio/gki/gkitxset.x | 51 + sys/gio/gki/gkiwesc.x | 59 + sys/gio/gki/gkiwrite.x | 26 + sys/gio/gki/gkptxparg.x | 47 + sys/gio/gki/mkpkg | 46 + sys/gio/gki/zzdebug.x | 44 + sys/gio/gks/README | 50 + sys/gio/gks/gacwk.x | 20 + sys/gio/gks/gca.x | 36 + sys/gio/gks/gcas.x | 46 + sys/gio/gks/gclks.x | 9 + sys/gio/gks/gclrwk.x | 19 + sys/gio/gks/gclwk.x | 14 + sys/gio/gks/gdawk.x | 32 + sys/gio/gks/gfa.x | 22 + sys/gio/gks/gks.com | 10 + sys/gio/gks/gks.h | 40 + sys/gio/gks/gopks.x | 24 + sys/gio/gks/gopwk.x | 23 + sys/gio/gks/gpl.x | 20 + sys/gio/gks/gpm.x | 25 + sys/gio/gks/gqasf.x | 18 + sys/gio/gks/gqchh.x | 39 + sys/gio/gks/gqchup.x | 39 + sys/gio/gks/gqclip.x | 40 + sys/gio/gks/gqcntn.x | 30 + sys/gio/gks/gqmk.x | 31 + sys/gio/gks/gqnt.x | 70 + sys/gio/gks/gqopwk.x | 56 + sys/gio/gks/gqplci.x | 30 + sys/gio/gks/gqpmci.x | 30 + sys/gio/gks/gqpmi.x | 17 + sys/gio/gks/gqtxal.x | 65 + sys/gio/gks/gqtxci.x | 30 + sys/gio/gks/gqtxp.x | 45 + sys/gio/gks/gqwks.x | 21 + sys/gio/gks/gsasf.x | 30 + sys/gio/gks/gsaw.x | 37 + sys/gio/gks/gschh.x | 26 + sys/gio/gks/gschup.x | 23 + sys/gio/gks/gsclip.x | 13 + sys/gio/gks/gscr.x | 17 + sys/gio/gks/gselnt.x | 13 + sys/gio/gks/gsfaci.x | 16 + sys/gio/gks/gsfais.x | 28 + sys/gio/gks/gslwsc.x | 16 + sys/gio/gks/gsmk.x | 29 + sys/gio/gks/gsmksc.x | 16 + sys/gio/gks/gsplci.x | 14 + sys/gio/gks/gspmci.x | 14 + sys/gio/gks/gspmi.x | 14 + sys/gio/gks/gstxal.x | 43 + sys/gio/gks/gstxci.x | 18 + sys/gio/gks/gstxp.x | 25 + sys/gio/gks/gsvp.x | 30 + sys/gio/gks/gswn.x | 29 + sys/gio/gks/gtx.f | 16 + sys/gio/gks/gxgtx.x | 22 + sys/gio/gks/mkpkg | 58 + sys/gio/glabax/README | 1 + sys/gio/glabax/glabax.h | 46 + sys/gio/glabax/glabax.x | 264 ++ sys/gio/glabax/glbencode.x | 66 + sys/gio/glabax/glbfind.x | 339 +++ sys/gio/glabax/glbgrid.x | 54 + sys/gio/glabax/glbgtick.x | 252 ++ sys/gio/glabax/glblabel.x | 84 + sys/gio/glabax/glbloglab.x | 139 + sys/gio/glabax/glbsetax.x | 130 + sys/gio/glabax/glbsetup.x | 51 + sys/gio/glabax/glbsview.x | 117 + sys/gio/glabax/glbticlen.x | 42 + sys/gio/glabax/glbtitle.x | 76 + sys/gio/glabax/glbverify.x | 36 + sys/gio/glabax/mkpkg | 22 + sys/gio/gline.x | 14 + sys/gio/gmark.x | 55 + sys/gio/gmftitle.x | 17 + sys/gio/gmprintf.x | 27 + sys/gio/gmsg.x | 232 ++ sys/gio/gopen.x | 187 ++ sys/gio/gpagefile.x | 29 + sys/gio/gpcell.x | 77 + sys/gio/gpl.com | 20 + sys/gio/gplcache.x | 101 + sys/gio/gplcancel.x | 13 + sys/gio/gplflush.x | 51 + sys/gio/gpline.x | 18 + sys/gio/gploto.x | 23 + sys/gio/gplotv.x | 22 + sys/gio/gplreset.x | 27 + sys/gio/gplstype.x | 25 + sys/gio/gpmark.x | 28 + sys/gio/gqverify.x | 32 + sys/gio/grdraw.x | 24 + sys/gio/grdwcs.x | 106 + sys/gio/greact.x | 32 + sys/gio/greset.x | 238 ++ sys/gio/grmove.x | 23 + sys/gio/grscale.x | 63 + sys/gio/gscan.x | 11 + sys/gio/gscur.x | 18 + sys/gio/gseti.x | 15 + sys/gio/gsetr.x | 276 ++ sys/gio/gsets.x | 32 + sys/gio/gstati.x | 16 + sys/gio/gstatr.x | 215 ++ sys/gio/gstats.x | 35 + sys/gio/gsview.x | 25 + sys/gio/gswind.x | 30 + sys/gio/gtext.x | 77 + sys/gio/gtick.gx | 192 ++ sys/gio/gtickr.x | 192 ++ sys/gio/gtxset.x | 144 ++ sys/gio/gumark.x | 108 + sys/gio/gvline.x | 23 + sys/gio/gvmark.x | 35 + sys/gio/imdkern/README | 85 + sys/gio/imdkern/font.com | 207 ++ sys/gio/imdkern/font.h | 29 + sys/gio/imdkern/idk.com | 50 + sys/gio/imdkern/idk.x | 509 ++++ sys/gio/imdkern/imd.com | 18 + sys/gio/imdkern/imd.h | 77 + sys/gio/imdkern/imdcancel.x | 16 + sys/gio/imdkern/imdclear.x | 55 + sys/gio/imdkern/imdclose.x | 37 + sys/gio/imdkern/imdclws.x | 22 + sys/gio/imdkern/imdcolor.x | 20 + sys/gio/imdkern/imddrawch.x | 70 + sys/gio/imdkern/imdescape.x | 13 + sys/gio/imdkern/imdfa.x | 16 + sys/gio/imdkern/imdfaset.x | 18 + sys/gio/imdkern/imdflush.x | 14 + sys/gio/imdkern/imdfont.x | 32 + sys/gio/imdkern/imdgcell.x | 14 + sys/gio/imdkern/imdinit.x | 162 ++ sys/gio/imdkern/imdline.x | 31 + sys/gio/imdkern/imdopen.x | 81 + sys/gio/imdkern/imdopenws.x | 98 + sys/gio/imdkern/imdpcell.x | 195 ++ sys/gio/imdkern/imdpl.x | 183 ++ sys/gio/imdkern/imdplset.x | 20 + sys/gio/imdkern/imdpm.x | 56 + sys/gio/imdkern/imdpmset.x | 19 + sys/gio/imdkern/imdreset.x | 50 + sys/gio/imdkern/imdtx.x | 430 ++++ sys/gio/imdkern/imdtxset.x | 29 + sys/gio/imdkern/ltype.dat | 28 + sys/gio/imdkern/mkpkg | 50 + sys/gio/imdkern/t_imdkern.x | 89 + sys/gio/imdkern/x_imdkern.x | 3 + sys/gio/markers.inc | 71 + sys/gio/mkpkg | 140 ++ sys/gio/ncarutil/README | 219 ++ sys/gio/ncarutil/autograph/README | 46 + sys/gio/ncarutil/autograph/agaxis.f | 1851 ++++++++++++++ sys/gio/ncarutil/autograph/agback.f | 152 ++ sys/gio/ncarutil/autograph/agbnch.f | 35 + sys/gio/ncarutil/autograph/agchax.f | 41 + sys/gio/ncarutil/autograph/agchcu.f | 44 + sys/gio/ncarutil/autograph/agchil.f | 36 + sys/gio/ncarutil/autograph/agchnl.f | 65 + sys/gio/ncarutil/autograph/agctcs.f | 79 + sys/gio/ncarutil/autograph/agctko.f | 150 ++ sys/gio/ncarutil/autograph/agcurv.f | 149 ++ sys/gio/ncarutil/autograph/agdash.f | 69 + sys/gio/ncarutil/autograph/agdflt.bd | 414 +++ sys/gio/ncarutil/autograph/agdflt.f | 690 +++++ sys/gio/ncarutil/autograph/agdlch.f | 60 + sys/gio/ncarutil/autograph/agdshn.f | 34 + sys/gio/ncarutil/autograph/agexax.f | 415 +++ sys/gio/ncarutil/autograph/agexus.f | 89 + sys/gio/ncarutil/autograph/agezsu.f | 104 + sys/gio/ncarutil/autograph/agfpbn.f | 37 + sys/gio/ncarutil/autograph/agftol.f | 119 + sys/gio/ncarutil/autograph/aggetc.f | 51 + sys/gio/ncarutil/autograph/aggetf.f | 28 + sys/gio/ncarutil/autograph/aggeti.f | 28 + sys/gio/ncarutil/autograph/aggetp.f | 104 + sys/gio/ncarutil/autograph/aggtch.f | 78 + sys/gio/ncarutil/autograph/aginit.f | 113 + sys/gio/ncarutil/autograph/agkurv.f | 145 ++ sys/gio/ncarutil/autograph/aglbls.f | 616 +++++ sys/gio/ncarutil/autograph/agmaxi.f | 60 + sys/gio/ncarutil/autograph/agmini.f | 60 + sys/gio/ncarutil/autograph/agnumb.f | 491 ++++ sys/gio/ncarutil/autograph/agppid.f | 65 + sys/gio/ncarutil/autograph/agpwrt.f | 31 + sys/gio/ncarutil/autograph/agqurv.f | 322 +++ sys/gio/ncarutil/autograph/agrpch.f | 86 + sys/gio/ncarutil/autograph/agrstr.f | 88 + sys/gio/ncarutil/autograph/agsave.f | 93 + sys/gio/ncarutil/autograph/agscan.f | 628 +++++ sys/gio/ncarutil/autograph/agsetc.f | 100 + sys/gio/ncarutil/autograph/agsetf.f | 28 + sys/gio/ncarutil/autograph/agseti.f | 28 + sys/gio/ncarutil/autograph/agsetp.f | 447 ++++ sys/gio/ncarutil/autograph/agsrch.f | 96 + sys/gio/ncarutil/autograph/agstch.f | 124 + sys/gio/ncarutil/autograph/agstup.f | 543 ++++ sys/gio/ncarutil/autograph/agutol.f | 49 + sys/gio/ncarutil/autograph/anotat.f | 63 + sys/gio/ncarutil/autograph/displa.f | 33 + sys/gio/ncarutil/autograph/ezmxy.f | 67 + sys/gio/ncarutil/autograph/ezmy.f | 65 + sys/gio/ncarutil/autograph/ezxy.f | 57 + sys/gio/ncarutil/autograph/ezy.f | 57 + sys/gio/ncarutil/autograph/idiot.f | 64 + sys/gio/ncarutil/autograph/mkpkg | 62 + sys/gio/ncarutil/autograph/pstr.x | 14 + sys/gio/ncarutil/conbd.f | 111 + sys/gio/ncarutil/conbdn.f | 342 +++ sys/gio/ncarutil/conlib/README | 3 + sys/gio/ncarutil/conlib/concal.f | 340 +++ sys/gio/ncarutil/conlib/concld.f | 314 +++ sys/gio/ncarutil/conlib/concls.f | 177 ++ sys/gio/ncarutil/conlib/concom.f | 78 + sys/gio/ncarutil/conlib/condet.f | 128 + sys/gio/ncarutil/conlib/condrw.f | 253 ++ sys/gio/ncarutil/conlib/condsd.f | 54 + sys/gio/ncarutil/conlib/conecd.f | 178 ++ sys/gio/ncarutil/conlib/congen.f | 454 ++++ sys/gio/ncarutil/conlib/conint.f | 147 ++ sys/gio/ncarutil/conlib/conlcm.f | 65 + sys/gio/ncarutil/conlib/conlin.f | 68 + sys/gio/ncarutil/conlib/conloc.f | 256 ++ sys/gio/ncarutil/conlib/conlod.f | 194 ++ sys/gio/ncarutil/conlib/conop1.f | 465 ++++ sys/gio/ncarutil/conlib/conop2.f | 316 +++ sys/gio/ncarutil/conlib/conop3.f | 266 ++ sys/gio/ncarutil/conlib/conop4.f | 197 ++ sys/gio/ncarutil/conlib/conot2.f | 178 ++ sys/gio/ncarutil/conlib/conout.f | 350 +++ sys/gio/ncarutil/conlib/conpdv.f | 118 + sys/gio/ncarutil/conlib/conreo.f | 129 + sys/gio/ncarutil/conlib/consld.f | 165 ++ sys/gio/ncarutil/conlib/conssd.f | 61 + sys/gio/ncarutil/conlib/constp.f | 135 + sys/gio/ncarutil/conlib/contlk.f | 98 + sys/gio/ncarutil/conlib/contng.f | 432 ++++ sys/gio/ncarutil/conlib/conxch.f | 67 + sys/gio/ncarutil/conlib/mkpkg | 37 + sys/gio/ncarutil/conran.f | 1976 +++++++++++++++ sys/gio/ncarutil/conrec.f | 1313 ++++++++++ sys/gio/ncarutil/dashbd.f | 143 ++ sys/gio/ncarutil/dashsmth.f | 1224 +++++++++ sys/gio/ncarutil/ezmap.f | 4598 ++++++++++++++++++++++++++++++++++ sys/gio/ncarutil/gridal.f | 1583 ++++++++++++ sys/gio/ncarutil/gridt.f | 65 + sys/gio/ncarutil/hafton.f | 830 ++++++ sys/gio/ncarutil/hfinit.f | 229 ++ sys/gio/ncarutil/isosrb.f | 98 + sys/gio/ncarutil/isosrf.f | 1696 +++++++++++++ sys/gio/ncarutil/kurv.f | 451 ++++ sys/gio/ncarutil/mkpkg | 51 + sys/gio/ncarutil/pwrity.f | 604 +++++ sys/gio/ncarutil/pwrzi.f | 732 ++++++ sys/gio/ncarutil/pwrzs.f | 772 ++++++ sys/gio/ncarutil/pwrzt.f | 731 ++++++ sys/gio/ncarutil/srfabd.f | 89 + sys/gio/ncarutil/srface.f | 1347 ++++++++++ sys/gio/ncarutil/strmln.f | 957 +++++++ sys/gio/ncarutil/sysint/README | 2 + sys/gio/ncarutil/sysint/fencode.x | 80 + sys/gio/ncarutil/sysint/fulib.x | 29 + sys/gio/ncarutil/sysint/gbytes.x | 30 + sys/gio/ncarutil/sysint/ishift.x | 55 + sys/gio/ncarutil/sysint/mkpkg | 16 + sys/gio/ncarutil/sysint/sbytes.x | 40 + sys/gio/ncarutil/sysint/spps.f | 1797 +++++++++++++ sys/gio/ncarutil/sysint/support.f | 581 +++++ sys/gio/ncarutil/tests/README | 2 + sys/gio/ncarutil/tests/auto10t.f | 262 ++ sys/gio/ncarutil/tests/autograph.x | 33 + sys/gio/ncarutil/tests/autographt.f | 186 ++ sys/gio/ncarutil/tests/conran.x | 37 + sys/gio/ncarutil/tests/conrant.f | 97 + sys/gio/ncarutil/tests/conraq.x | 35 + sys/gio/ncarutil/tests/conraqt.f | 139 + sys/gio/ncarutil/tests/conras.x | 35 + sys/gio/ncarutil/tests/conrast.f | 147 ++ sys/gio/ncarutil/tests/conrcqckt.f | 114 + sys/gio/ncarutil/tests/conrcsmtht.f | 122 + sys/gio/ncarutil/tests/conrcsprt.f | 110 + sys/gio/ncarutil/tests/conrec.x | 35 + sys/gio/ncarutil/tests/conrect.f | 118 + sys/gio/ncarutil/tests/dashchar.x | 32 + sys/gio/ncarutil/tests/dashchart.f | 145 ++ sys/gio/ncarutil/tests/dashlinet.f | 138 + sys/gio/ncarutil/tests/dashsmth.x | 32 + sys/gio/ncarutil/tests/dashsmtht.f | 144 ++ sys/gio/ncarutil/tests/dashsuprt.f | 151 ++ sys/gio/ncarutil/tests/ezconrec.x | 35 + sys/gio/ncarutil/tests/ezhafton.x | 30 + sys/gio/ncarutil/tests/ezhaftont.f | 123 + sys/gio/ncarutil/tests/ezisosrf.x | 32 + sys/gio/ncarutil/tests/ezmapg.x | 32 + sys/gio/ncarutil/tests/ezmapgt.f | 318 +++ sys/gio/ncarutil/tests/ezmapt.f | 300 +++ sys/gio/ncarutil/tests/ezsurface.x | 32 + sys/gio/ncarutil/tests/ezvelvect.x | 32 + sys/gio/ncarutil/tests/ezytst.x | 39 + sys/gio/ncarutil/tests/hafton.x | 30 + sys/gio/ncarutil/tests/haftont.f | 123 + sys/gio/ncarutil/tests/isosrf.x | 32 + sys/gio/ncarutil/tests/isosrfhrt.f | 165 ++ sys/gio/ncarutil/tests/isosrft.f | 137 + sys/gio/ncarutil/tests/mkpkg | 65 + sys/gio/ncarutil/tests/oldauto.x | 41 + sys/gio/ncarutil/tests/oldautot.f | 833 ++++++ sys/gio/ncarutil/tests/preal.x | 12 + sys/gio/ncarutil/tests/pwrity.x | 32 + sys/gio/ncarutil/tests/pwrityt.f | 90 + sys/gio/ncarutil/tests/pwrzit.f | 132 + sys/gio/ncarutil/tests/pwrzs.x | 32 + sys/gio/ncarutil/tests/pwrzst.f | 127 + sys/gio/ncarutil/tests/pwrztt.f | 116 + sys/gio/ncarutil/tests/srf.com | 4 + sys/gio/ncarutil/tests/srfacet.f | 150 ++ sys/gio/ncarutil/tests/srftest.x | 68 + sys/gio/ncarutil/tests/srftestd.x | 29 + sys/gio/ncarutil/tests/strmln.x | 32 + sys/gio/ncarutil/tests/strmlnt.f | 101 + sys/gio/ncarutil/tests/surface.x | 32 + sys/gio/ncarutil/tests/threed.x | 32 + sys/gio/ncarutil/tests/threed2.x | 32 + sys/gio/ncarutil/tests/threed2t.f | 26 + sys/gio/ncarutil/tests/threedt.f | 129 + sys/gio/ncarutil/tests/velvctt.f | 126 + sys/gio/ncarutil/tests/velvect.x | 32 + sys/gio/ncarutil/tests/x_ncartest.x | 24 + sys/gio/ncarutil/threbd.f | 56 + sys/gio/ncarutil/threed.f | 826 ++++++ sys/gio/ncarutil/veldat.f | 67 + sys/gio/ncarutil/velvct.f | 821 ++++++ sys/gio/nspp/README | 9 + sys/gio/nspp/mkpkg | 11 + sys/gio/nspp/portlib/README | 28 + sys/gio/nspp/portlib/axes.f | 6 + sys/gio/nspp/portlib/curve.f | 41 + sys/gio/nspp/portlib/dashln.f | 5 + sys/gio/nspp/portlib/fl2int.f | 31 + sys/gio/nspp/portlib/flash1.f | 42 + sys/gio/nspp/portlib/flash2.f | 71 + sys/gio/nspp/portlib/flash3.f | 70 + sys/gio/nspp/portlib/flash4.f | 46 + sys/gio/nspp/portlib/flush.f | 22 + sys/gio/nspp/portlib/flushb.f | 41 + sys/gio/nspp/portlib/frame.f | 70 + sys/gio/nspp/portlib/frstpt.f | 30 + sys/gio/nspp/portlib/getopt.f | 37 + sys/gio/nspp/portlib/getset.f | 28 + sys/gio/nspp/portlib/getsi.f | 21 + sys/gio/nspp/portlib/grid.f | 4 + sys/gio/nspp/portlib/gridal.f | 218 ++ sys/gio/nspp/portlib/gridl.f | 4 + sys/gio/nspp/portlib/halfax.f | 4 + sys/gio/nspp/portlib/jlm2.f | 7 + sys/gio/nspp/portlib/justfy.f | 14 + sys/gio/nspp/portlib/labmod.f | 53 + sys/gio/nspp/portlib/line.f | 32 + sys/gio/nspp/portlib/mkpkg | 56 + sys/gio/nspp/portlib/mxmy.f | 21 + sys/gio/nspp/portlib/option.f | 8 + sys/gio/nspp/portlib/optn.f | 99 + sys/gio/nspp/portlib/perim.f | 4 + sys/gio/nspp/portlib/periml.f | 4 + sys/gio/nspp/portlib/plotit.f | 23 + sys/gio/nspp/portlib/point.f | 43 + sys/gio/nspp/portlib/points.f | 57 + sys/gio/nspp/portlib/porgn.f | 27 + sys/gio/nspp/portlib/preout.f | 116 + sys/gio/nspp/portlib/pscale.f | 21 + sys/gio/nspp/portlib/psym.f | 27 + sys/gio/nspp/portlib/put42.f | 60 + sys/gio/nspp/portlib/putins.f | 59 + sys/gio/nspp/portlib/pwrit.f | 95 + sys/gio/nspp/portlib/pwrt.f | 12 + sys/gio/nspp/portlib/set.f | 140 ++ sys/gio/nspp/portlib/seti.f | 37 + sys/gio/nspp/portlib/tick4.f | 30 + sys/gio/nspp/portlib/ticks.f | 4 + sys/gio/nspp/portlib/trans.f | 52 + sys/gio/nspp/portlib/vector.f | 27 + sys/gio/nspp/portlib/z8zpbd.f | 6 + sys/gio/nspp/portlib/z8zpii.f | 362 +++ sys/gio/nspp/sysint/README | 1 + sys/gio/nspp/sysint/encd.f | 78 + sys/gio/nspp/sysint/encode.f | 15 + sys/gio/nspp/sysint/erprt77.f | 441 ++++ sys/gio/nspp/sysint/fencode.x | 79 + sys/gio/nspp/sysint/fulib.x | 29 + sys/gio/nspp/sysint/intt.x | 16 + sys/gio/nspp/sysint/ishift.x | 55 + sys/gio/nspp/sysint/loc.x | 23 + sys/gio/nspp/sysint/mcswap.x | 17 + sys/gio/nspp/sysint/mkpkg | 24 + sys/gio/nspp/sysint/ncgchr.x | 22 + sys/gio/nspp/sysint/ncpchr.x | 20 + sys/gio/nspp/sysint/nspp.com | 40 + sys/gio/nspp/sysint/packum.x | 43 + sys/gio/nspp/sysint/perror.x | 9 + sys/gio/nspp/sysint/q8qst4.f | 24 + sys/gio/nspp/sysint/uliber.f | 14 + sys/gio/nsppkern/README | 399 +++ sys/gio/nsppkern/font.com | 207 ++ sys/gio/nsppkern/font.h | 29 + sys/gio/nsppkern/gkt.com | 17 + sys/gio/nsppkern/gkt.h | 75 + sys/gio/nsppkern/gktcancel.x | 27 + sys/gio/nsppkern/gktclear.x | 60 + sys/gio/nsppkern/gktclose.x | 35 + sys/gio/nsppkern/gktclws.x | 17 + sys/gio/nsppkern/gktcolor.x | 33 + sys/gio/nsppkern/gktdrawch.x | 68 + sys/gio/nsppkern/gktescape.x | 13 + sys/gio/nsppkern/gktfa.x | 16 + sys/gio/nsppkern/gktfaset.x | 18 + sys/gio/nsppkern/gktflush.x | 15 + sys/gio/nsppkern/gktfont.x | 38 + sys/gio/nsppkern/gktgcell.x | 14 + sys/gio/nsppkern/gktinit.x | 194 ++ sys/gio/nsppkern/gktline.x | 30 + sys/gio/nsppkern/gktmfopen.x | 45 + sys/gio/nsppkern/gktopen.x | 77 + sys/gio/nsppkern/gktopenws.x | 104 + sys/gio/nsppkern/gktpcell.x | 383 +++ sys/gio/nsppkern/gktpl.x | 64 + sys/gio/nsppkern/gktplset.x | 20 + sys/gio/nsppkern/gktpm.x | 64 + sys/gio/nsppkern/gktpmset.x | 19 + sys/gio/nsppkern/gktreset.x | 59 + sys/gio/nsppkern/gkttx.x | 428 ++++ sys/gio/nsppkern/gkttxset.x | 29 + sys/gio/nsppkern/mkpkg | 56 + sys/gio/nsppkern/nspp.com | 40 + sys/gio/nsppkern/pixel0.f | 58 + sys/gio/nsppkern/pixels.f | 74 + sys/gio/nsppkern/t_nsppkern.x | 67 + sys/gio/nsppkern/tran16.f | 64 + sys/gio/nsppkern/writeb.x | 40 + sys/gio/nsppkern/x_nsppkern.x | 3 + sys/gio/nsppkern/zzdebug.x | 472 ++++ sys/gio/sgikern/README | 12 + sys/gio/sgikern/font.com | 746 ++++++ sys/gio/sgikern/font.h | 29 + sys/gio/sgikern/greek.com | 501 ++++ sys/gio/sgikern/ltype.dat | 28 + sys/gio/sgikern/mkpkg | 53 + sys/gio/sgikern/sgi.com | 17 + sys/gio/sgikern/sgi.h | 76 + sys/gio/sgikern/sgicancel.x | 16 + sys/gio/sgikern/sgiclear.x | 54 + sys/gio/sgikern/sgiclose.x | 30 + sys/gio/sgikern/sgiclws.x | 17 + sys/gio/sgikern/sgicolor.x | 20 + sys/gio/sgikern/sgidrawch.x | 84 + sys/gio/sgikern/sgiescape.x | 13 + sys/gio/sgikern/sgifa.x | 20 + sys/gio/sgikern/sgifaset.x | 18 + sys/gio/sgikern/sgiflush.x | 14 + sys/gio/sgikern/sgifont.x | 42 + sys/gio/sgikern/sgigcell.x | 14 + sys/gio/sgikern/sgiinit.x | 162 ++ sys/gio/sgikern/sgiline.x | 31 + sys/gio/sgikern/sgiopen.x | 77 + sys/gio/sgikern/sgiopenws.x | 98 + sys/gio/sgikern/sgipcell.x | 195 ++ sys/gio/sgikern/sgipl.x | 183 ++ sys/gio/sgikern/sgiplset.x | 20 + sys/gio/sgikern/sgipm.x | 56 + sys/gio/sgikern/sgipmset.x | 19 + sys/gio/sgikern/sgireset.x | 50 + sys/gio/sgikern/sgitx.x | 459 ++++ sys/gio/sgikern/sgitxset.x | 29 + sys/gio/sgikern/sgk.com | 49 + sys/gio/sgikern/sgk.h | 7 + sys/gio/sgikern/sgk.x | 853 +++++++ sys/gio/sgikern/t_sgideco.x | 106 + sys/gio/sgikern/t_sgikern.x | 67 + sys/gio/sgikern/x_sgikern.x | 5 + sys/gio/stdgraph/README | 77 + sys/gio/stdgraph/font.com | 207 ++ sys/gio/stdgraph/font.h | 29 + sys/gio/stdgraph/mkpkg | 80 + sys/gio/stdgraph/stdgraph.com | 46 + sys/gio/stdgraph/stdgraph.h | 98 + sys/gio/stdgraph/stgcancel.x | 16 + sys/gio/stdgraph/stgclear.x | 16 + sys/gio/stdgraph/stgclose.x | 47 + sys/gio/stdgraph/stgclws.x | 28 + sys/gio/stdgraph/stgctrl.x | 82 + sys/gio/stdgraph/stgdeact.x | 54 + sys/gio/stdgraph/stgdraw.x | 27 + sys/gio/stdgraph/stgdrawch.x | 144 ++ sys/gio/stdgraph/stgencode.x | 539 ++++ sys/gio/stdgraph/stgescape.x | 99 + sys/gio/stdgraph/stgfa.x | 115 + sys/gio/stdgraph/stgfaset.x | 18 + sys/gio/stdgraph/stgfilter.x | 165 ++ sys/gio/stdgraph/stgflush.x | 14 + sys/gio/stdgraph/stggcell.x | 15 + sys/gio/stdgraph/stggcur.x | 52 + sys/gio/stdgraph/stggdisab.x | 17 + sys/gio/stdgraph/stggenab.x | 17 + sys/gio/stdgraph/stggim.x | 919 +++++++ sys/gio/stdgraph/stggrstr.x | 16 + sys/gio/stdgraph/stginit.x | 193 ++ sys/gio/stdgraph/stglkcur.x | 18 + sys/gio/stdgraph/stgmove.x | 27 + sys/gio/stdgraph/stgonerr.x | 17 + sys/gio/stdgraph/stgonint.x | 21 + sys/gio/stdgraph/stgopen.x | 103 + sys/gio/stdgraph/stgopenws.x | 220 ++ sys/gio/stdgraph/stgoutput.x | 28 + sys/gio/stdgraph/stgoutstr.x | 30 + sys/gio/stdgraph/stgpcell.x | 85 + sys/gio/stdgraph/stgpl.x | 126 + sys/gio/stdgraph/stgplset.x | 20 + sys/gio/stdgraph/stgpm.x | 118 + sys/gio/stdgraph/stgpmset.x | 19 + sys/gio/stdgraph/stgrcur.x | 425 ++++ sys/gio/stdgraph/stgreact.x | 41 + sys/gio/stdgraph/stgres.x | 85 + sys/gio/stdgraph/stgreset.x | 54 + sys/gio/stdgraph/stgrtty.x | 137 + sys/gio/stdgraph/stgscur.x | 36 + sys/gio/stdgraph/stgtx.x | 528 ++++ sys/gio/stdgraph/stgtxqual.x | 17 + sys/gio/stdgraph/stgtxset.x | 34 + sys/gio/stdgraph/stgtxsize.x | 31 + sys/gio/stdgraph/stgunkown.x | 14 + sys/gio/stdgraph/stgwtty.x | 118 + sys/gio/stdgraph/t_gkideco.x | 63 + sys/gio/stdgraph/t_showcap.x | 210 ++ sys/gio/stdgraph/t_stdgraph.x | 110 + sys/gio/stdgraph/x_stdgraph.x | 5 + sys/gio/stdgraph/zzdebug.x | 37 + sys/gio/wcstogki.x | 61 + sys/gio/zzdebug.x | 392 +++ 728 files changed, 92060 insertions(+) create mode 100644 sys/gio/README create mode 100644 sys/gio/aelogd.x create mode 100644 sys/gio/aelogr.x create mode 100644 sys/gio/calcomp/README create mode 100644 sys/gio/calcomp/ccp.com create mode 100644 sys/gio/calcomp/ccp.h create mode 100644 sys/gio/calcomp/ccpclear.x create mode 100644 sys/gio/calcomp/ccpclose.x create mode 100644 sys/gio/calcomp/ccpclws.x create mode 100644 sys/gio/calcomp/ccpcolor.x create mode 100644 sys/gio/calcomp/ccpcseg.x create mode 100644 sys/gio/calcomp/ccpdrawch.x create mode 100644 sys/gio/calcomp/ccpdseg.x create mode 100644 sys/gio/calcomp/ccpescape.x create mode 100644 sys/gio/calcomp/ccpfa.x create mode 100644 sys/gio/calcomp/ccpfaset.x create mode 100644 sys/gio/calcomp/ccpfont.x create mode 100644 sys/gio/calcomp/ccpinit.x create mode 100644 sys/gio/calcomp/ccpltype.x create mode 100644 sys/gio/calcomp/ccplwidth.x create mode 100644 sys/gio/calcomp/ccpopen.x create mode 100644 sys/gio/calcomp/ccpopenws.x create mode 100644 sys/gio/calcomp/ccppl.x create mode 100644 sys/gio/calcomp/ccpplset.x create mode 100644 sys/gio/calcomp/ccppm.x create mode 100644 sys/gio/calcomp/ccppmset.x create mode 100644 sys/gio/calcomp/ccpreset.x create mode 100644 sys/gio/calcomp/ccptx.x create mode 100644 sys/gio/calcomp/ccptxset.x create mode 100644 sys/gio/calcomp/doc/ccpspecs.hlp create mode 100644 sys/gio/calcomp/font.com create mode 100644 sys/gio/calcomp/font.h create mode 100644 sys/gio/calcomp/mkpkg create mode 100644 sys/gio/calcomp/rptheta4.x create mode 100644 sys/gio/calcomp/t_calcomp.x create mode 100644 sys/gio/calcomp/vttest.par create mode 100644 sys/gio/calcomp/vttest.x create mode 100644 sys/gio/calcomp/x_calcomp.x create mode 100644 sys/gio/cursor/README create mode 100644 sys/gio/cursor/doc/cursor.hlp create mode 100644 sys/gio/cursor/doc/giotr.notes create mode 100644 sys/gio/cursor/giotr.x create mode 100644 sys/gio/cursor/grc.h create mode 100644 sys/gio/cursor/grcaxes.x create mode 100644 sys/gio/cursor/grcclose.x create mode 100644 sys/gio/cursor/grccmd.x create mode 100644 sys/gio/cursor/grcinit.x create mode 100644 sys/gio/cursor/grcopen.x create mode 100644 sys/gio/cursor/grcpl.x create mode 100644 sys/gio/cursor/grcread.x create mode 100644 sys/gio/cursor/grcredraw.x create mode 100644 sys/gio/cursor/grcscr.x create mode 100644 sys/gio/cursor/grcstatus.x create mode 100644 sys/gio/cursor/grctext.x create mode 100644 sys/gio/cursor/grcwarn.x create mode 100644 sys/gio/cursor/grcwcs.x create mode 100644 sys/gio/cursor/grcwrite.x create mode 100644 sys/gio/cursor/gtr.com create mode 100644 sys/gio/cursor/gtr.h create mode 100644 sys/gio/cursor/gtrbackup.x create mode 100644 sys/gio/cursor/gtrconn.x create mode 100644 sys/gio/cursor/gtrctrl.x create mode 100644 sys/gio/cursor/gtrdelete.x create mode 100644 sys/gio/cursor/gtrdiscon.x create mode 100644 sys/gio/cursor/gtrfetch.x create mode 100644 sys/gio/cursor/gtrframe.x create mode 100644 sys/gio/cursor/gtrgflush.x create mode 100644 sys/gio/cursor/gtrgtran.x create mode 100644 sys/gio/cursor/gtrgtty.x create mode 100644 sys/gio/cursor/gtrinit.x create mode 100644 sys/gio/cursor/gtropenws.x create mode 100644 sys/gio/cursor/gtrpage.x create mode 100644 sys/gio/cursor/gtrptran.x create mode 100644 sys/gio/cursor/gtrrcur.x create mode 100644 sys/gio/cursor/gtrredraw.x create mode 100644 sys/gio/cursor/gtrreset.x create mode 100644 sys/gio/cursor/gtrset.x create mode 100644 sys/gio/cursor/gtrstatus.x create mode 100644 sys/gio/cursor/gtrtrunc.x create mode 100644 sys/gio/cursor/gtrundo.x create mode 100644 sys/gio/cursor/gtrwaitp.x create mode 100644 sys/gio/cursor/gtrwcur.x create mode 100644 sys/gio/cursor/gtrwritep.x create mode 100644 sys/gio/cursor/gtrwsclip.x create mode 100644 sys/gio/cursor/gtrwstran.x create mode 100644 sys/gio/cursor/mkpkg create mode 100644 sys/gio/cursor/prpsinit.x create mode 100644 sys/gio/cursor/rcursor.x create mode 100644 sys/gio/doc/gio.hlp create mode 100644 sys/gio/elogd.x create mode 100644 sys/gio/elogr.x create mode 100644 sys/gio/fonts/README create mode 100644 sys/gio/fonts/font.com create mode 100644 sys/gio/fonts/greek.com create mode 100644 sys/gio/fonts/greekc.txt create mode 100644 sys/gio/fonts/mkfont.c create mode 100644 sys/gio/fpequald.x create mode 100644 sys/gio/fpequalr.x create mode 100644 sys/gio/fpfixd.x create mode 100644 sys/gio/fpfixr.x create mode 100644 sys/gio/fpndgr.x create mode 100644 sys/gio/fpnormd.x create mode 100644 sys/gio/fpnormr.x create mode 100644 sys/gio/gactivate.x create mode 100644 sys/gio/gadraw.x create mode 100644 sys/gio/gamove.x create mode 100644 sys/gio/gascale.x create mode 100644 sys/gio/gcancel.x create mode 100644 sys/gio/gclear.x create mode 100644 sys/gio/gclose.x create mode 100644 sys/gio/gctran.x create mode 100644 sys/gio/gcurpos.x create mode 100644 sys/gio/gdeact.x create mode 100644 sys/gio/gescape.x create mode 100644 sys/gio/gfill.x create mode 100644 sys/gio/gflush.x create mode 100644 sys/gio/gframe.x create mode 100644 sys/gio/gfrinit.x create mode 100644 sys/gio/ggcell.x create mode 100644 sys/gio/ggcur.x create mode 100644 sys/gio/ggetb.x create mode 100644 sys/gio/ggeti.x create mode 100644 sys/gio/ggetr.x create mode 100644 sys/gio/ggets.x create mode 100644 sys/gio/ggscale.x create mode 100644 sys/gio/ggview.x create mode 100644 sys/gio/ggwind.x create mode 100644 sys/gio/gim/README create mode 100644 sys/gio/gim/gimcpras.x create mode 100644 sys/gio/gim/gimcrras.x create mode 100644 sys/gio/gim/gimderas.x create mode 100644 sys/gio/gim/gimdsmap.x create mode 100644 sys/gio/gim/gimenmap.x create mode 100644 sys/gio/gim/gimfcmap.x create mode 100644 sys/gio/gim/gimfmap.x create mode 100644 sys/gio/gim/gimgetmap.x create mode 100644 sys/gio/gim/gimimap.x create mode 100644 sys/gio/gim/gimlcmap.x create mode 100644 sys/gio/gim/gimqras.x create mode 100644 sys/gio/gim/gimrasini.x create mode 100644 sys/gio/gim/gimrcmap.x create mode 100644 sys/gio/gim/gimref.x create mode 100644 sys/gio/gim/gimrefpix.x create mode 100644 sys/gio/gim/gimriomap.x create mode 100644 sys/gio/gim/gimrpix.x create mode 100644 sys/gio/gim/gimsetmap.x create mode 100644 sys/gio/gim/gimsetpix.x create mode 100644 sys/gio/gim/gimsetras.x create mode 100644 sys/gio/gim/gimwcmap.x create mode 100644 sys/gio/gim/gimwiomap.x create mode 100644 sys/gio/gim/gimwpix.x create mode 100644 sys/gio/gim/mkpkg create mode 100644 sys/gio/gki/README create mode 100644 sys/gio/gki/gki.com create mode 100644 sys/gio/gki/gkicancel.x create mode 100644 sys/gio/gki/gkiclear.x create mode 100644 sys/gio/gki/gkiclose.x create mode 100644 sys/gio/gki/gkideact.x create mode 100644 sys/gio/gki/gkieof.x create mode 100644 sys/gio/gki/gkiesc.x create mode 100644 sys/gio/gki/gkiexe.x create mode 100644 sys/gio/gki/gkifa.x create mode 100644 sys/gio/gki/gkifaset.x create mode 100644 sys/gio/gki/gkifetch.x create mode 100644 sys/gio/gki/gkifflush.x create mode 100644 sys/gio/gki/gkiflush.x create mode 100644 sys/gio/gki/gkigca.x create mode 100644 sys/gio/gki/gkigcur.x create mode 100644 sys/gio/gki/gkigetwcs.x create mode 100644 sys/gio/gki/gkiinit.x create mode 100644 sys/gio/gki/gkiinline.x create mode 100644 sys/gio/gki/gkikern.x create mode 100644 sys/gio/gki/gkiopen.x create mode 100644 sys/gio/gki/gkipca.x create mode 100644 sys/gio/gki/gkipl.x create mode 100644 sys/gio/gki/gkiplset.x create mode 100644 sys/gio/gki/gkipm.x create mode 100644 sys/gio/gki/gkipmset.x create mode 100644 sys/gio/gki/gkiprint.x create mode 100644 sys/gio/gki/gkirca.x create mode 100644 sys/gio/gki/gkircval.x create mode 100644 sys/gio/gki/gkireact.x create mode 100644 sys/gio/gki/gkiredir.x create mode 100644 sys/gio/gki/gkiscur.x create mode 100644 sys/gio/gki/gkisetwcs.x create mode 100644 sys/gio/gki/gkititle.x create mode 100644 sys/gio/gki/gkitx.x create mode 100644 sys/gio/gki/gkitxset.x create mode 100644 sys/gio/gki/gkiwesc.x create mode 100644 sys/gio/gki/gkiwrite.x create mode 100644 sys/gio/gki/gkptxparg.x create mode 100644 sys/gio/gki/mkpkg create mode 100644 sys/gio/gki/zzdebug.x create mode 100644 sys/gio/gks/README create mode 100644 sys/gio/gks/gacwk.x create mode 100644 sys/gio/gks/gca.x create mode 100644 sys/gio/gks/gcas.x create mode 100644 sys/gio/gks/gclks.x create mode 100644 sys/gio/gks/gclrwk.x create mode 100644 sys/gio/gks/gclwk.x create mode 100644 sys/gio/gks/gdawk.x create mode 100644 sys/gio/gks/gfa.x create mode 100644 sys/gio/gks/gks.com create mode 100644 sys/gio/gks/gks.h create mode 100644 sys/gio/gks/gopks.x create mode 100644 sys/gio/gks/gopwk.x create mode 100644 sys/gio/gks/gpl.x create mode 100644 sys/gio/gks/gpm.x create mode 100644 sys/gio/gks/gqasf.x create mode 100644 sys/gio/gks/gqchh.x create mode 100644 sys/gio/gks/gqchup.x create mode 100644 sys/gio/gks/gqclip.x create mode 100644 sys/gio/gks/gqcntn.x create mode 100644 sys/gio/gks/gqmk.x create mode 100644 sys/gio/gks/gqnt.x create mode 100644 sys/gio/gks/gqopwk.x create mode 100644 sys/gio/gks/gqplci.x create mode 100644 sys/gio/gks/gqpmci.x create mode 100644 sys/gio/gks/gqpmi.x create mode 100644 sys/gio/gks/gqtxal.x create mode 100644 sys/gio/gks/gqtxci.x create mode 100644 sys/gio/gks/gqtxp.x create mode 100644 sys/gio/gks/gqwks.x create mode 100644 sys/gio/gks/gsasf.x create mode 100644 sys/gio/gks/gsaw.x create mode 100644 sys/gio/gks/gschh.x create mode 100644 sys/gio/gks/gschup.x create mode 100644 sys/gio/gks/gsclip.x create mode 100644 sys/gio/gks/gscr.x create mode 100644 sys/gio/gks/gselnt.x create mode 100644 sys/gio/gks/gsfaci.x create mode 100644 sys/gio/gks/gsfais.x create mode 100644 sys/gio/gks/gslwsc.x create mode 100644 sys/gio/gks/gsmk.x create mode 100644 sys/gio/gks/gsmksc.x create mode 100644 sys/gio/gks/gsplci.x create mode 100644 sys/gio/gks/gspmci.x create mode 100644 sys/gio/gks/gspmi.x create mode 100644 sys/gio/gks/gstxal.x create mode 100644 sys/gio/gks/gstxci.x create mode 100644 sys/gio/gks/gstxp.x create mode 100644 sys/gio/gks/gsvp.x create mode 100644 sys/gio/gks/gswn.x create mode 100644 sys/gio/gks/gtx.f create mode 100644 sys/gio/gks/gxgtx.x create mode 100644 sys/gio/gks/mkpkg create mode 100644 sys/gio/glabax/README create mode 100644 sys/gio/glabax/glabax.h create mode 100644 sys/gio/glabax/glabax.x create mode 100644 sys/gio/glabax/glbencode.x create mode 100644 sys/gio/glabax/glbfind.x create mode 100644 sys/gio/glabax/glbgrid.x create mode 100644 sys/gio/glabax/glbgtick.x create mode 100644 sys/gio/glabax/glblabel.x create mode 100644 sys/gio/glabax/glbloglab.x create mode 100644 sys/gio/glabax/glbsetax.x create mode 100644 sys/gio/glabax/glbsetup.x create mode 100644 sys/gio/glabax/glbsview.x create mode 100644 sys/gio/glabax/glbticlen.x create mode 100644 sys/gio/glabax/glbtitle.x create mode 100644 sys/gio/glabax/glbverify.x create mode 100644 sys/gio/glabax/mkpkg create mode 100644 sys/gio/gline.x create mode 100644 sys/gio/gmark.x create mode 100644 sys/gio/gmftitle.x create mode 100644 sys/gio/gmprintf.x create mode 100644 sys/gio/gmsg.x create mode 100644 sys/gio/gopen.x create mode 100644 sys/gio/gpagefile.x create mode 100644 sys/gio/gpcell.x create mode 100644 sys/gio/gpl.com create mode 100644 sys/gio/gplcache.x create mode 100644 sys/gio/gplcancel.x create mode 100644 sys/gio/gplflush.x create mode 100644 sys/gio/gpline.x create mode 100644 sys/gio/gploto.x create mode 100644 sys/gio/gplotv.x create mode 100644 sys/gio/gplreset.x create mode 100644 sys/gio/gplstype.x create mode 100644 sys/gio/gpmark.x create mode 100644 sys/gio/gqverify.x create mode 100644 sys/gio/grdraw.x create mode 100644 sys/gio/grdwcs.x create mode 100644 sys/gio/greact.x create mode 100644 sys/gio/greset.x create mode 100644 sys/gio/grmove.x create mode 100644 sys/gio/grscale.x create mode 100644 sys/gio/gscan.x create mode 100644 sys/gio/gscur.x create mode 100644 sys/gio/gseti.x create mode 100644 sys/gio/gsetr.x create mode 100644 sys/gio/gsets.x create mode 100644 sys/gio/gstati.x create mode 100644 sys/gio/gstatr.x create mode 100644 sys/gio/gstats.x create mode 100644 sys/gio/gsview.x create mode 100644 sys/gio/gswind.x create mode 100644 sys/gio/gtext.x create mode 100644 sys/gio/gtick.gx create mode 100644 sys/gio/gtickr.x create mode 100644 sys/gio/gtxset.x create mode 100644 sys/gio/gumark.x create mode 100644 sys/gio/gvline.x create mode 100644 sys/gio/gvmark.x create mode 100644 sys/gio/imdkern/README create mode 100644 sys/gio/imdkern/font.com create mode 100644 sys/gio/imdkern/font.h create mode 100644 sys/gio/imdkern/idk.com create mode 100644 sys/gio/imdkern/idk.x create mode 100644 sys/gio/imdkern/imd.com create mode 100644 sys/gio/imdkern/imd.h create mode 100644 sys/gio/imdkern/imdcancel.x create mode 100644 sys/gio/imdkern/imdclear.x create mode 100644 sys/gio/imdkern/imdclose.x create mode 100644 sys/gio/imdkern/imdclws.x create mode 100644 sys/gio/imdkern/imdcolor.x create mode 100644 sys/gio/imdkern/imddrawch.x create mode 100644 sys/gio/imdkern/imdescape.x create mode 100644 sys/gio/imdkern/imdfa.x create mode 100644 sys/gio/imdkern/imdfaset.x create mode 100644 sys/gio/imdkern/imdflush.x create mode 100644 sys/gio/imdkern/imdfont.x create mode 100644 sys/gio/imdkern/imdgcell.x create mode 100644 sys/gio/imdkern/imdinit.x create mode 100644 sys/gio/imdkern/imdline.x create mode 100644 sys/gio/imdkern/imdopen.x create mode 100644 sys/gio/imdkern/imdopenws.x create mode 100644 sys/gio/imdkern/imdpcell.x create mode 100644 sys/gio/imdkern/imdpl.x create mode 100644 sys/gio/imdkern/imdplset.x create mode 100644 sys/gio/imdkern/imdpm.x create mode 100644 sys/gio/imdkern/imdpmset.x create mode 100644 sys/gio/imdkern/imdreset.x create mode 100644 sys/gio/imdkern/imdtx.x create mode 100644 sys/gio/imdkern/imdtxset.x create mode 100644 sys/gio/imdkern/ltype.dat create mode 100644 sys/gio/imdkern/mkpkg create mode 100644 sys/gio/imdkern/t_imdkern.x create mode 100644 sys/gio/imdkern/x_imdkern.x create mode 100644 sys/gio/markers.inc create mode 100644 sys/gio/mkpkg create mode 100644 sys/gio/ncarutil/README create mode 100644 sys/gio/ncarutil/autograph/README create mode 100644 sys/gio/ncarutil/autograph/agaxis.f create mode 100644 sys/gio/ncarutil/autograph/agback.f create mode 100644 sys/gio/ncarutil/autograph/agbnch.f create mode 100644 sys/gio/ncarutil/autograph/agchax.f create mode 100644 sys/gio/ncarutil/autograph/agchcu.f create mode 100644 sys/gio/ncarutil/autograph/agchil.f create mode 100644 sys/gio/ncarutil/autograph/agchnl.f create mode 100644 sys/gio/ncarutil/autograph/agctcs.f create mode 100644 sys/gio/ncarutil/autograph/agctko.f create mode 100644 sys/gio/ncarutil/autograph/agcurv.f create mode 100644 sys/gio/ncarutil/autograph/agdash.f create mode 100644 sys/gio/ncarutil/autograph/agdflt.bd create mode 100644 sys/gio/ncarutil/autograph/agdflt.f create mode 100644 sys/gio/ncarutil/autograph/agdlch.f create mode 100644 sys/gio/ncarutil/autograph/agdshn.f create mode 100644 sys/gio/ncarutil/autograph/agexax.f create mode 100644 sys/gio/ncarutil/autograph/agexus.f create mode 100644 sys/gio/ncarutil/autograph/agezsu.f create mode 100644 sys/gio/ncarutil/autograph/agfpbn.f create mode 100644 sys/gio/ncarutil/autograph/agftol.f create mode 100644 sys/gio/ncarutil/autograph/aggetc.f create mode 100644 sys/gio/ncarutil/autograph/aggetf.f create mode 100644 sys/gio/ncarutil/autograph/aggeti.f create mode 100644 sys/gio/ncarutil/autograph/aggetp.f create mode 100644 sys/gio/ncarutil/autograph/aggtch.f create mode 100644 sys/gio/ncarutil/autograph/aginit.f create mode 100644 sys/gio/ncarutil/autograph/agkurv.f create mode 100644 sys/gio/ncarutil/autograph/aglbls.f create mode 100644 sys/gio/ncarutil/autograph/agmaxi.f create mode 100644 sys/gio/ncarutil/autograph/agmini.f create mode 100644 sys/gio/ncarutil/autograph/agnumb.f create mode 100644 sys/gio/ncarutil/autograph/agppid.f create mode 100644 sys/gio/ncarutil/autograph/agpwrt.f create mode 100644 sys/gio/ncarutil/autograph/agqurv.f create mode 100644 sys/gio/ncarutil/autograph/agrpch.f create mode 100644 sys/gio/ncarutil/autograph/agrstr.f create mode 100644 sys/gio/ncarutil/autograph/agsave.f create mode 100644 sys/gio/ncarutil/autograph/agscan.f create mode 100644 sys/gio/ncarutil/autograph/agsetc.f create mode 100644 sys/gio/ncarutil/autograph/agsetf.f create mode 100644 sys/gio/ncarutil/autograph/agseti.f create mode 100644 sys/gio/ncarutil/autograph/agsetp.f create mode 100644 sys/gio/ncarutil/autograph/agsrch.f create mode 100644 sys/gio/ncarutil/autograph/agstch.f create mode 100644 sys/gio/ncarutil/autograph/agstup.f create mode 100644 sys/gio/ncarutil/autograph/agutol.f create mode 100644 sys/gio/ncarutil/autograph/anotat.f create mode 100644 sys/gio/ncarutil/autograph/displa.f create mode 100644 sys/gio/ncarutil/autograph/ezmxy.f create mode 100644 sys/gio/ncarutil/autograph/ezmy.f create mode 100644 sys/gio/ncarutil/autograph/ezxy.f create mode 100644 sys/gio/ncarutil/autograph/ezy.f create mode 100644 sys/gio/ncarutil/autograph/idiot.f create mode 100644 sys/gio/ncarutil/autograph/mkpkg create mode 100644 sys/gio/ncarutil/autograph/pstr.x create mode 100644 sys/gio/ncarutil/conbd.f create mode 100644 sys/gio/ncarutil/conbdn.f create mode 100644 sys/gio/ncarutil/conlib/README create mode 100644 sys/gio/ncarutil/conlib/concal.f create mode 100644 sys/gio/ncarutil/conlib/concld.f create mode 100644 sys/gio/ncarutil/conlib/concls.f create mode 100644 sys/gio/ncarutil/conlib/concom.f create mode 100644 sys/gio/ncarutil/conlib/condet.f create mode 100644 sys/gio/ncarutil/conlib/condrw.f create mode 100644 sys/gio/ncarutil/conlib/condsd.f create mode 100644 sys/gio/ncarutil/conlib/conecd.f create mode 100644 sys/gio/ncarutil/conlib/congen.f create mode 100644 sys/gio/ncarutil/conlib/conint.f create mode 100644 sys/gio/ncarutil/conlib/conlcm.f create mode 100644 sys/gio/ncarutil/conlib/conlin.f create mode 100644 sys/gio/ncarutil/conlib/conloc.f create mode 100644 sys/gio/ncarutil/conlib/conlod.f create mode 100644 sys/gio/ncarutil/conlib/conop1.f create mode 100644 sys/gio/ncarutil/conlib/conop2.f create mode 100644 sys/gio/ncarutil/conlib/conop3.f create mode 100644 sys/gio/ncarutil/conlib/conop4.f create mode 100644 sys/gio/ncarutil/conlib/conot2.f create mode 100644 sys/gio/ncarutil/conlib/conout.f create mode 100644 sys/gio/ncarutil/conlib/conpdv.f create mode 100644 sys/gio/ncarutil/conlib/conreo.f create mode 100644 sys/gio/ncarutil/conlib/consld.f create mode 100644 sys/gio/ncarutil/conlib/conssd.f create mode 100644 sys/gio/ncarutil/conlib/constp.f create mode 100644 sys/gio/ncarutil/conlib/contlk.f create mode 100644 sys/gio/ncarutil/conlib/contng.f create mode 100644 sys/gio/ncarutil/conlib/conxch.f create mode 100644 sys/gio/ncarutil/conlib/mkpkg create mode 100644 sys/gio/ncarutil/conran.f create mode 100644 sys/gio/ncarutil/conrec.f create mode 100644 sys/gio/ncarutil/dashbd.f create mode 100644 sys/gio/ncarutil/dashsmth.f create mode 100644 sys/gio/ncarutil/ezmap.f create mode 100644 sys/gio/ncarutil/gridal.f create mode 100644 sys/gio/ncarutil/gridt.f create mode 100644 sys/gio/ncarutil/hafton.f create mode 100644 sys/gio/ncarutil/hfinit.f create mode 100644 sys/gio/ncarutil/isosrb.f create mode 100644 sys/gio/ncarutil/isosrf.f create mode 100644 sys/gio/ncarutil/kurv.f create mode 100644 sys/gio/ncarutil/mkpkg create mode 100644 sys/gio/ncarutil/pwrity.f create mode 100644 sys/gio/ncarutil/pwrzi.f create mode 100644 sys/gio/ncarutil/pwrzs.f create mode 100644 sys/gio/ncarutil/pwrzt.f create mode 100644 sys/gio/ncarutil/srfabd.f create mode 100644 sys/gio/ncarutil/srface.f create mode 100644 sys/gio/ncarutil/strmln.f create mode 100644 sys/gio/ncarutil/sysint/README create mode 100644 sys/gio/ncarutil/sysint/fencode.x create mode 100644 sys/gio/ncarutil/sysint/fulib.x create mode 100644 sys/gio/ncarutil/sysint/gbytes.x create mode 100644 sys/gio/ncarutil/sysint/ishift.x create mode 100644 sys/gio/ncarutil/sysint/mkpkg create mode 100644 sys/gio/ncarutil/sysint/sbytes.x create mode 100644 sys/gio/ncarutil/sysint/spps.f create mode 100644 sys/gio/ncarutil/sysint/support.f create mode 100644 sys/gio/ncarutil/tests/README create mode 100644 sys/gio/ncarutil/tests/auto10t.f create mode 100644 sys/gio/ncarutil/tests/autograph.x create mode 100644 sys/gio/ncarutil/tests/autographt.f create mode 100644 sys/gio/ncarutil/tests/conran.x create mode 100644 sys/gio/ncarutil/tests/conrant.f create mode 100644 sys/gio/ncarutil/tests/conraq.x create mode 100644 sys/gio/ncarutil/tests/conraqt.f create mode 100644 sys/gio/ncarutil/tests/conras.x create mode 100644 sys/gio/ncarutil/tests/conrast.f create mode 100644 sys/gio/ncarutil/tests/conrcqckt.f create mode 100644 sys/gio/ncarutil/tests/conrcsmtht.f create mode 100644 sys/gio/ncarutil/tests/conrcsprt.f create mode 100644 sys/gio/ncarutil/tests/conrec.x create mode 100644 sys/gio/ncarutil/tests/conrect.f create mode 100644 sys/gio/ncarutil/tests/dashchar.x create mode 100644 sys/gio/ncarutil/tests/dashchart.f create mode 100644 sys/gio/ncarutil/tests/dashlinet.f create mode 100644 sys/gio/ncarutil/tests/dashsmth.x create mode 100644 sys/gio/ncarutil/tests/dashsmtht.f create mode 100644 sys/gio/ncarutil/tests/dashsuprt.f create mode 100644 sys/gio/ncarutil/tests/ezconrec.x create mode 100644 sys/gio/ncarutil/tests/ezhafton.x create mode 100644 sys/gio/ncarutil/tests/ezhaftont.f create mode 100644 sys/gio/ncarutil/tests/ezisosrf.x create mode 100644 sys/gio/ncarutil/tests/ezmapg.x create mode 100644 sys/gio/ncarutil/tests/ezmapgt.f create mode 100644 sys/gio/ncarutil/tests/ezmapt.f create mode 100644 sys/gio/ncarutil/tests/ezsurface.x create mode 100644 sys/gio/ncarutil/tests/ezvelvect.x create mode 100644 sys/gio/ncarutil/tests/ezytst.x create mode 100644 sys/gio/ncarutil/tests/hafton.x create mode 100644 sys/gio/ncarutil/tests/haftont.f create mode 100644 sys/gio/ncarutil/tests/isosrf.x create mode 100644 sys/gio/ncarutil/tests/isosrfhrt.f create mode 100644 sys/gio/ncarutil/tests/isosrft.f create mode 100644 sys/gio/ncarutil/tests/mkpkg create mode 100644 sys/gio/ncarutil/tests/oldauto.x create mode 100644 sys/gio/ncarutil/tests/oldautot.f create mode 100644 sys/gio/ncarutil/tests/preal.x create mode 100644 sys/gio/ncarutil/tests/pwrity.x create mode 100644 sys/gio/ncarutil/tests/pwrityt.f create mode 100644 sys/gio/ncarutil/tests/pwrzit.f create mode 100644 sys/gio/ncarutil/tests/pwrzs.x create mode 100644 sys/gio/ncarutil/tests/pwrzst.f create mode 100644 sys/gio/ncarutil/tests/pwrztt.f create mode 100644 sys/gio/ncarutil/tests/srf.com create mode 100644 sys/gio/ncarutil/tests/srfacet.f create mode 100644 sys/gio/ncarutil/tests/srftest.x create mode 100644 sys/gio/ncarutil/tests/srftestd.x create mode 100644 sys/gio/ncarutil/tests/strmln.x create mode 100644 sys/gio/ncarutil/tests/strmlnt.f create mode 100644 sys/gio/ncarutil/tests/surface.x create mode 100644 sys/gio/ncarutil/tests/threed.x create mode 100644 sys/gio/ncarutil/tests/threed2.x create mode 100644 sys/gio/ncarutil/tests/threed2t.f create mode 100644 sys/gio/ncarutil/tests/threedt.f create mode 100644 sys/gio/ncarutil/tests/velvctt.f create mode 100644 sys/gio/ncarutil/tests/velvect.x create mode 100644 sys/gio/ncarutil/tests/x_ncartest.x create mode 100644 sys/gio/ncarutil/threbd.f create mode 100644 sys/gio/ncarutil/threed.f create mode 100644 sys/gio/ncarutil/veldat.f create mode 100644 sys/gio/ncarutil/velvct.f create mode 100644 sys/gio/nspp/README create mode 100644 sys/gio/nspp/mkpkg create mode 100644 sys/gio/nspp/portlib/README create mode 100644 sys/gio/nspp/portlib/axes.f create mode 100644 sys/gio/nspp/portlib/curve.f create mode 100644 sys/gio/nspp/portlib/dashln.f create mode 100644 sys/gio/nspp/portlib/fl2int.f create mode 100644 sys/gio/nspp/portlib/flash1.f create mode 100644 sys/gio/nspp/portlib/flash2.f create mode 100644 sys/gio/nspp/portlib/flash3.f create mode 100644 sys/gio/nspp/portlib/flash4.f create mode 100644 sys/gio/nspp/portlib/flush.f create mode 100644 sys/gio/nspp/portlib/flushb.f create mode 100644 sys/gio/nspp/portlib/frame.f create mode 100644 sys/gio/nspp/portlib/frstpt.f create mode 100644 sys/gio/nspp/portlib/getopt.f create mode 100644 sys/gio/nspp/portlib/getset.f create mode 100644 sys/gio/nspp/portlib/getsi.f create mode 100644 sys/gio/nspp/portlib/grid.f create mode 100644 sys/gio/nspp/portlib/gridal.f create mode 100644 sys/gio/nspp/portlib/gridl.f create mode 100644 sys/gio/nspp/portlib/halfax.f create mode 100644 sys/gio/nspp/portlib/jlm2.f create mode 100644 sys/gio/nspp/portlib/justfy.f create mode 100644 sys/gio/nspp/portlib/labmod.f create mode 100644 sys/gio/nspp/portlib/line.f create mode 100644 sys/gio/nspp/portlib/mkpkg create mode 100644 sys/gio/nspp/portlib/mxmy.f create mode 100644 sys/gio/nspp/portlib/option.f create mode 100644 sys/gio/nspp/portlib/optn.f create mode 100644 sys/gio/nspp/portlib/perim.f create mode 100644 sys/gio/nspp/portlib/periml.f create mode 100644 sys/gio/nspp/portlib/plotit.f create mode 100644 sys/gio/nspp/portlib/point.f create mode 100644 sys/gio/nspp/portlib/points.f create mode 100644 sys/gio/nspp/portlib/porgn.f create mode 100644 sys/gio/nspp/portlib/preout.f create mode 100644 sys/gio/nspp/portlib/pscale.f create mode 100644 sys/gio/nspp/portlib/psym.f create mode 100644 sys/gio/nspp/portlib/put42.f create mode 100644 sys/gio/nspp/portlib/putins.f create mode 100644 sys/gio/nspp/portlib/pwrit.f create mode 100644 sys/gio/nspp/portlib/pwrt.f create mode 100644 sys/gio/nspp/portlib/set.f create mode 100644 sys/gio/nspp/portlib/seti.f create mode 100644 sys/gio/nspp/portlib/tick4.f create mode 100644 sys/gio/nspp/portlib/ticks.f create mode 100644 sys/gio/nspp/portlib/trans.f create mode 100644 sys/gio/nspp/portlib/vector.f create mode 100644 sys/gio/nspp/portlib/z8zpbd.f create mode 100644 sys/gio/nspp/portlib/z8zpii.f create mode 100644 sys/gio/nspp/sysint/README create mode 100644 sys/gio/nspp/sysint/encd.f create mode 100644 sys/gio/nspp/sysint/encode.f create mode 100644 sys/gio/nspp/sysint/erprt77.f create mode 100644 sys/gio/nspp/sysint/fencode.x create mode 100644 sys/gio/nspp/sysint/fulib.x create mode 100644 sys/gio/nspp/sysint/intt.x create mode 100644 sys/gio/nspp/sysint/ishift.x create mode 100644 sys/gio/nspp/sysint/loc.x create mode 100644 sys/gio/nspp/sysint/mcswap.x create mode 100644 sys/gio/nspp/sysint/mkpkg create mode 100644 sys/gio/nspp/sysint/ncgchr.x create mode 100644 sys/gio/nspp/sysint/ncpchr.x create mode 100644 sys/gio/nspp/sysint/nspp.com create mode 100644 sys/gio/nspp/sysint/packum.x create mode 100644 sys/gio/nspp/sysint/perror.x create mode 100644 sys/gio/nspp/sysint/q8qst4.f create mode 100644 sys/gio/nspp/sysint/uliber.f create mode 100644 sys/gio/nsppkern/README create mode 100644 sys/gio/nsppkern/font.com create mode 100644 sys/gio/nsppkern/font.h create mode 100644 sys/gio/nsppkern/gkt.com create mode 100644 sys/gio/nsppkern/gkt.h create mode 100644 sys/gio/nsppkern/gktcancel.x create mode 100644 sys/gio/nsppkern/gktclear.x create mode 100644 sys/gio/nsppkern/gktclose.x create mode 100644 sys/gio/nsppkern/gktclws.x create mode 100644 sys/gio/nsppkern/gktcolor.x create mode 100644 sys/gio/nsppkern/gktdrawch.x create mode 100644 sys/gio/nsppkern/gktescape.x create mode 100644 sys/gio/nsppkern/gktfa.x create mode 100644 sys/gio/nsppkern/gktfaset.x create mode 100644 sys/gio/nsppkern/gktflush.x create mode 100644 sys/gio/nsppkern/gktfont.x create mode 100644 sys/gio/nsppkern/gktgcell.x create mode 100644 sys/gio/nsppkern/gktinit.x create mode 100644 sys/gio/nsppkern/gktline.x create mode 100644 sys/gio/nsppkern/gktmfopen.x create mode 100644 sys/gio/nsppkern/gktopen.x create mode 100644 sys/gio/nsppkern/gktopenws.x create mode 100644 sys/gio/nsppkern/gktpcell.x create mode 100644 sys/gio/nsppkern/gktpl.x create mode 100644 sys/gio/nsppkern/gktplset.x create mode 100644 sys/gio/nsppkern/gktpm.x create mode 100644 sys/gio/nsppkern/gktpmset.x create mode 100644 sys/gio/nsppkern/gktreset.x create mode 100644 sys/gio/nsppkern/gkttx.x create mode 100644 sys/gio/nsppkern/gkttxset.x create mode 100644 sys/gio/nsppkern/mkpkg create mode 100644 sys/gio/nsppkern/nspp.com create mode 100644 sys/gio/nsppkern/pixel0.f create mode 100644 sys/gio/nsppkern/pixels.f create mode 100644 sys/gio/nsppkern/t_nsppkern.x create mode 100644 sys/gio/nsppkern/tran16.f create mode 100644 sys/gio/nsppkern/writeb.x create mode 100644 sys/gio/nsppkern/x_nsppkern.x create mode 100644 sys/gio/nsppkern/zzdebug.x create mode 100644 sys/gio/sgikern/README create mode 100644 sys/gio/sgikern/font.com create mode 100644 sys/gio/sgikern/font.h create mode 100644 sys/gio/sgikern/greek.com create mode 100644 sys/gio/sgikern/ltype.dat create mode 100644 sys/gio/sgikern/mkpkg create mode 100644 sys/gio/sgikern/sgi.com create mode 100644 sys/gio/sgikern/sgi.h create mode 100644 sys/gio/sgikern/sgicancel.x create mode 100644 sys/gio/sgikern/sgiclear.x create mode 100644 sys/gio/sgikern/sgiclose.x create mode 100644 sys/gio/sgikern/sgiclws.x create mode 100644 sys/gio/sgikern/sgicolor.x create mode 100644 sys/gio/sgikern/sgidrawch.x create mode 100644 sys/gio/sgikern/sgiescape.x create mode 100644 sys/gio/sgikern/sgifa.x create mode 100644 sys/gio/sgikern/sgifaset.x create mode 100644 sys/gio/sgikern/sgiflush.x create mode 100644 sys/gio/sgikern/sgifont.x create mode 100644 sys/gio/sgikern/sgigcell.x create mode 100644 sys/gio/sgikern/sgiinit.x create mode 100644 sys/gio/sgikern/sgiline.x create mode 100644 sys/gio/sgikern/sgiopen.x create mode 100644 sys/gio/sgikern/sgiopenws.x create mode 100644 sys/gio/sgikern/sgipcell.x create mode 100644 sys/gio/sgikern/sgipl.x create mode 100644 sys/gio/sgikern/sgiplset.x create mode 100644 sys/gio/sgikern/sgipm.x create mode 100644 sys/gio/sgikern/sgipmset.x create mode 100644 sys/gio/sgikern/sgireset.x create mode 100644 sys/gio/sgikern/sgitx.x create mode 100644 sys/gio/sgikern/sgitxset.x create mode 100644 sys/gio/sgikern/sgk.com create mode 100644 sys/gio/sgikern/sgk.h create mode 100644 sys/gio/sgikern/sgk.x create mode 100644 sys/gio/sgikern/t_sgideco.x create mode 100644 sys/gio/sgikern/t_sgikern.x create mode 100644 sys/gio/sgikern/x_sgikern.x create mode 100644 sys/gio/stdgraph/README create mode 100644 sys/gio/stdgraph/font.com create mode 100644 sys/gio/stdgraph/font.h create mode 100644 sys/gio/stdgraph/mkpkg create mode 100644 sys/gio/stdgraph/stdgraph.com create mode 100644 sys/gio/stdgraph/stdgraph.h create mode 100644 sys/gio/stdgraph/stgcancel.x create mode 100644 sys/gio/stdgraph/stgclear.x create mode 100644 sys/gio/stdgraph/stgclose.x create mode 100644 sys/gio/stdgraph/stgclws.x create mode 100644 sys/gio/stdgraph/stgctrl.x create mode 100644 sys/gio/stdgraph/stgdeact.x create mode 100644 sys/gio/stdgraph/stgdraw.x create mode 100644 sys/gio/stdgraph/stgdrawch.x create mode 100644 sys/gio/stdgraph/stgencode.x create mode 100644 sys/gio/stdgraph/stgescape.x create mode 100644 sys/gio/stdgraph/stgfa.x create mode 100644 sys/gio/stdgraph/stgfaset.x create mode 100644 sys/gio/stdgraph/stgfilter.x create mode 100644 sys/gio/stdgraph/stgflush.x create mode 100644 sys/gio/stdgraph/stggcell.x create mode 100644 sys/gio/stdgraph/stggcur.x create mode 100644 sys/gio/stdgraph/stggdisab.x create mode 100644 sys/gio/stdgraph/stggenab.x create mode 100644 sys/gio/stdgraph/stggim.x create mode 100644 sys/gio/stdgraph/stggrstr.x create mode 100644 sys/gio/stdgraph/stginit.x create mode 100644 sys/gio/stdgraph/stglkcur.x create mode 100644 sys/gio/stdgraph/stgmove.x create mode 100644 sys/gio/stdgraph/stgonerr.x create mode 100644 sys/gio/stdgraph/stgonint.x create mode 100644 sys/gio/stdgraph/stgopen.x create mode 100644 sys/gio/stdgraph/stgopenws.x create mode 100644 sys/gio/stdgraph/stgoutput.x create mode 100644 sys/gio/stdgraph/stgoutstr.x create mode 100644 sys/gio/stdgraph/stgpcell.x create mode 100644 sys/gio/stdgraph/stgpl.x create mode 100644 sys/gio/stdgraph/stgplset.x create mode 100644 sys/gio/stdgraph/stgpm.x create mode 100644 sys/gio/stdgraph/stgpmset.x create mode 100644 sys/gio/stdgraph/stgrcur.x create mode 100644 sys/gio/stdgraph/stgreact.x create mode 100644 sys/gio/stdgraph/stgres.x create mode 100644 sys/gio/stdgraph/stgreset.x create mode 100644 sys/gio/stdgraph/stgrtty.x create mode 100644 sys/gio/stdgraph/stgscur.x create mode 100644 sys/gio/stdgraph/stgtx.x create mode 100644 sys/gio/stdgraph/stgtxqual.x create mode 100644 sys/gio/stdgraph/stgtxset.x create mode 100644 sys/gio/stdgraph/stgtxsize.x create mode 100644 sys/gio/stdgraph/stgunkown.x create mode 100644 sys/gio/stdgraph/stgwtty.x create mode 100644 sys/gio/stdgraph/t_gkideco.x create mode 100644 sys/gio/stdgraph/t_showcap.x create mode 100644 sys/gio/stdgraph/t_stdgraph.x create mode 100644 sys/gio/stdgraph/x_stdgraph.x create mode 100644 sys/gio/stdgraph/zzdebug.x create mode 100644 sys/gio/wcstogki.x create mode 100644 sys/gio/zzdebug.x (limited to 'sys/gio') diff --git a/sys/gio/README b/sys/gio/README new file mode 100644 index 00000000..e7db4cdd --- /dev/null +++ b/sys/gio/README @@ -0,0 +1,6 @@ +GIO + + This directory contains the source for the IRAF GIO (graphics i/o) +interface. The interface is documented in the file "Gio.hlp". Source for +the STDGRAPH kernel will be found in the subdirectory "stdgraph". Source +for the NSPP kernel will be found in the subdirectory "nspp". diff --git a/sys/gio/aelogd.x b/sys/gio/aelogd.x new file mode 100644 index 00000000..0a3d3b26 --- /dev/null +++ b/sys/gio/aelogd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AELOGD -- Inverse of the elogd function. + +double procedure aelogd (x) + +double x + +begin + if (x > 1.0D0) + return (10.0D0 ** x) + else if (x >= -1.0D0) + return (x * 10.0D0) + else + return (- (10.0D0 ** (-x))) +end diff --git a/sys/gio/aelogr.x b/sys/gio/aelogr.x new file mode 100644 index 00000000..81920a9a --- /dev/null +++ b/sys/gio/aelogr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AELOGR -- Inverse of the elogr function. + +real procedure aelogr (x) + +real x + +begin + if (x > 1.0) + return (10.0 ** x) + else if (x >= -1.0) + return (x * 10.0) + else + return (-(10.0 ** (-x))) +end diff --git a/sys/gio/calcomp/README b/sys/gio/calcomp/README new file mode 100644 index 00000000..c3dd017f --- /dev/null +++ b/sys/gio/calcomp/README @@ -0,0 +1,34 @@ +GIO Calcomp kernel + +This directory contains source for the IRAF calcomp graphics kernel. +Specifications may be found in ccpspecs.hlp. Installation involves +building the kernel task, which is accomplished using "make" (Makefile) +with argument "install" to move the executable into lib$. + +In addition to the kernel task routines, the vttest.x routine contains code +to simulate calcomp software on standard gio graphics devices. vttest.x +contains all the source for the simulation, using parameter file vttest.par. +Here, the calcomp routines "plot", "plots", "newpen", and "symbol" are +replaced with appropriate gio calls (violating interfaces) and to be used +mainly for testing text fonts, line type and width simulation. + +TODO: + +- super-bold font +- bold + italic + +- multiples of dash, dot for linetypes numbered higher than 4 + +-------------------------------------------------------------------------------- +FUTURE ENHANCEMENTS (much work): + +1) Sophisticated parallel-tracing algorithm that looks at entire array + and merges intersections so that all adjacent segments are parallel + to each other and do not cross the acute bisector. Implemented by + parallel array segments rather than drawing each parallel segment + individually, to avoid pen overtravel on short choppy lines. + +2) Panelling: when plot width exceeds available paper width, wrap graphics + to beyond maximum x so that paper can be cut and pasted. + +3) Versatec extension with area-fill. diff --git a/sys/gio/calcomp/ccp.com b/sys/gio/calcomp/ccp.com new file mode 100644 index 00000000..d9e9ac69 --- /dev/null +++ b/sys/gio/calcomp/ccp.com @@ -0,0 +1,38 @@ +# CCP common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The kernel data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_cc # kernel graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in # input file +real g_xres # x resolution of plotter +real g_yres # y resolution of plotter +real g_max_x # maximum x drawn, in plotter units +real g_xndcto_p # x(pltr) = GKI*g_xndcto_p; final scale +real g_yndcto_p # y(pltr) = GKI*g_yndcto_p; final scale +real g_xtask_scale # x scale determined from task params +real g_ytask_scale # y scale determined from task params +real g_xdefault_scale # x scale from graphcap or compile-time +real g_ydefault_scale # y scale from graphcap or compile-time +int g_ltype # line type +real g_dashlen # length of dash in dashed line, p_units +real g_gaplen # width of gap in dash/dot line, p_units +real g_plwsep # polyline width separation for ntracing +int g_txquality # text quality parameter +bool g_ltover # user override of line-type generator +bool g_lwover # user override of line width simulation +bool g_lcover # user override of line color generator +char g_lwtype # line width mode parameter +char g_device[SZ_GDEVICE] # force output to named device + +common /ccpcom/ g_cc, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_xres, g_yres, g_max_x, g_xndcto_p, g_yndcto_p, + g_xtask_scale, g_ytask_scale, + g_xdefault_scale, g_ydefault_scale, + g_ltype, g_dashlen, g_gaplen, g_plwsep, g_txquality, + g_ltover, g_lwover, g_lcover, g_lwtype, g_device diff --git a/sys/gio/calcomp/ccp.h b/sys/gio/calcomp/ccp.h new file mode 100644 index 00000000..037dbc6a --- /dev/null +++ b/sys/gio/calcomp/ccp.h @@ -0,0 +1,92 @@ +# CCP definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_GDEVICE 31 # maxsize forced device name +define CCP_LDEV 5 # device for "plots(0,0,ldev") +define CCP_UP 3 # "pen-up" code +define CCP_DOWN 2 # "pen-down" code +define PL_SINGLE 1 # rel width of single-width line +define MAXTRACES 15 # maximum adjacent bold traces +define SEGSIZE 256 # segment buffer size +define XSEG Memr[xseg + $1 - 1] # segment buffer for ccp_calcseg +define YSEG Memr[yseg + $1 - 1] # " +define DIS sqrt ((($3)-($1))**2+(($4)-($2))**2) #dis (x1,y1, x2,y2) +define XTRAN ($1) * g_xndcto_p # convert NDC to plotter coords +define YTRAN ($1) * g_yndcto_p # " +define FRAME_OFFSET 1.0 # pltr units between [new]frames +define MAX_PL_XWIDTH 0.3307 # max pltr x (m) if no graphcap +define MAX_PL_YHEIGHT 0.2540 # max pltr y (m) if no graphcap +define DEF_MPER_PUNIT 0.0254 # default meters / plotter unit +define DEF_DASHLEN 0.1000 # default dash length, pltr unit +define DEF_GAPLEN 0.0500 # default gap length, pltr units +define DEF_PLWSEP 0.0050 # default ntracing sep. in pu + +# CCP state device descriptor: + +define LEN_CCP 81 + +define CCP_SBUF Memi[$1] # string buffer +define CCP_SZSBUF Memi[$1+1] # size of string buffer +define CCP_NEXTCH Memi[$1+2] # next char pos in string buf +define CCP_NCHARSIZES Memi[$1+3] # number of character sizes +define CCP_POLYLINE Memi[$1+4] # device supports polyline +define CCP_POLYMARKER Memi[$1+5] # device supports polymarker +define CCP_FILLAREA Memi[$1+6] # device supports fillarea +define CCP_CELLARRAY Memi[$1+7] # device supports cell array +define CCP_ZRES Memi[$1+8] # device resolution in Z +define CCP_FILLSTYLE Memi[$1+9] # number of fill styles +define CCP_ROAM Memi[$1+10] # device supports roam +define CCP_ZOOM Memi[$1+11] # device supports zoom +define CCP_SELERASE Memi[$1+12] # device has selective erase +define CCP_PIXREP Memi[$1+13] # device supports pixel replic. +define CCP_STARTFRAME Memi[$1+14] # frame advance at metafile BOF +define CCP_ENDFRAME Memi[$1+15] # frame advance at metafile EOF + # extra space +define CCP_CURSOR Memi[$1+20] # last cursor accessed +define CCP_COLOR Memi[$1+21] # last color set +define CCP_TXSIZE Memi[$1+22] # last text size set +define CCP_TXFONT Memi[$1+23] # last text font set +define CCP_LTYPE Memi[$1+24] # last line type set +define CCP_WIDTH Memi[$1+25] # last line width set +define CCP_DEVNAME Memi[$1+26] # name of open device +define CCP_DEVCHAN Memi[$1+27] # channel for "plots(0,0,ldev)" + # extra space +define CCP_CHARHEIGHT Memi[$1+30+$2-1] # character height +define CCP_CHARWIDTH Memi[$1+40+$2-1] # character width +define CCP_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define CCP_PLAP ($1+60) # polyline attributes +define CCP_PMAP ($1+64) # polymarker attributes +define CCP_FAAP ($1+68) # fill area attributes +define CCP_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/calcomp/ccpclear.x b/sys/gio/calcomp/ccpclear.x new file mode 100644 index 00000000..9ff17c20 --- /dev/null +++ b/sys/gio/calcomp/ccpclear.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure ccp_clear (dummy) + +int dummy # not used at present +include "ccp.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_cc == NULL || g_ndraw == 0) + return + + # Start a new frame. This is by resetting the origin to the last + # x-position drawn plus a compile-time offset. + + call plot (g_max_x + FRAME_OFFSET, 0.0, -3) + g_max_x = 0.0 + + # Init kernel data structures. + call ccp_reset() + g_ndraw = 0 +end diff --git a/sys/gio/calcomp/ccpclose.x b/sys/gio/calcomp/ccpclose.x new file mode 100644 index 00000000..3d433eb0 --- /dev/null +++ b/sys/gio/calcomp/ccpclose.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# CCP_CLOSE -- Close the calcomp kernel. Free up storage. + +procedure ccp_close() + +include "ccp.com" + +begin + # Signal end of plot. + call plot (0, 0, 999) + # call plots (0, 0, CCP_DEVCHAN(g_cc)) #do we really want to do this? + # (calcomp may get into funny state without, but may mess up APPEND + + # Free kernel data structures. + call mfree (CCP_SBUF(g_cc), TY_CHAR) + call mfree (g_cc, TY_STRUCT) + + g_cc = NULL +end diff --git a/sys/gio/calcomp/ccpclws.x b/sys/gio/calcomp/ccpclws.x new file mode 100644 index 00000000..f536d7ab --- /dev/null +++ b/sys/gio/calcomp/ccpclws.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# include "ccp.h" + +# CCP_CLOSEWS -- Close the named workstation. +# If the plot were terminated (plot (0, 0, 999)) APPEND mode would not work. + +procedure ccp_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +# include "ccp.com" + +begin + # noop + return +end diff --git a/sys/gio/calcomp/ccpcolor.x b/sys/gio/calcomp/ccpcolor.x new file mode 100644 index 00000000..98b701d0 --- /dev/null +++ b/sys/gio/calcomp/ccpcolor.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# Calcomp pen colors +define BLACK 1 +define WHITE 2 +define RED 3 +define GREEN 4 +define BLUE 5 + +# CCP_COLOR set pen color + +procedure ccp_color(index) + +int index # index for color switch statement +include "ccp.com" + +begin + if (g_lcover) # CL param lcover, line color override is on; noop + return + + switch (index) { + + case WHITE: + call newpen (WHITE) + case RED: + call newpen (RED) + case GREEN: + call newpen (GREEN) + case BLUE: + call newpen (BLUE) + default: + call newpen (BLACK) + } +end diff --git a/sys/gio/calcomp/ccpcseg.x b/sys/gio/calcomp/ccpcseg.x new file mode 100644 index 00000000..7b55adc7 --- /dev/null +++ b/sys/gio/calcomp/ccpcseg.x @@ -0,0 +1,207 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +# CCP_CALCSEG -- Calculate a contiguous line segment; used to return individual +# line segments under the various options of line type simulation. (Width is +# not simulated here). Each segment returned is actually drawable, guaranteeing +# constant-length dashes and gaps along the exact length of the input polyline. +# Normally called by ccp_polyline. + +procedure ccp_calcseg (p, npts, ltype, curpl_pt, segsize, xseg,yseg, nsegpts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int ltype # line type; CCP_CLEAR <= ltype <= CCP_DASHDOT +int curpl_pt # current polyline point; input and output +int segsize # current segment memory size +pointer xseg,yseg # plotter-unit contiguous line segment, output +int nsegpts # number of points in segment, output + +int i, j +real lastp_x, lastp_y, x, y, curseglen +bool toggle + +include "ccp.com" + +begin + if (curpl_pt == 1) { # always start line w/beginning of dash, etc. + lastp_x = XTRAN(p[1]) + lastp_y = YTRAN(p[2]) + curpl_pt = curpl_pt + 1 + toggle = false + } + + XSEG(1) = lastp_x + YSEG(1) = lastp_y + nsegpts = 1 + curseglen = 0.0 + + switch (ltype) { + case GL_CLEAR: + nsegpts = 0 + + case GL_DASHED: + # Return one contiguous polyline segment worth one dash: + call ccx_dash (p, npts, curpl_pt, curseglen, nsegpts, segsize, + xseg,yseg, lastp_x,lastp_y) + + # Now increment internal counters for gap width for next call + call ccx_gap (p, npts, curpl_pt, curseglen, g_dashlen + g_gaplen, + lastp_x,lastp_y) + + case GL_DOTTED: + # Since we already built one point, we need only the following gap: + call ccx_gap (p, npts, curpl_pt, curseglen, g_gaplen, + lastp_x,lastp_y) + + case GL_DOTDASH: + # Implement as dash/gap/dot/gap/: + if (toggle) { # build dot/gap/ + x = lastp_x #XTRAN(p[i]) + y = lastp_y #YTRAN(p[i+1]) + nsegpts = 0 + call ccx_addsegpt (x,y, xseg,yseg, nsegpts, segsize) + toggle = false + call ccx_gap (p, npts, curpl_pt, curseglen, g_gaplen, + lastp_x,lastp_y) + + } else { # build dash/gap/ + call ccx_dash (p, npts, curpl_pt, curseglen, nsegpts, + segsize, xseg,yseg, lastp_x,lastp_y) + call ccx_gap (p, npts, curpl_pt, curseglen, + g_dashlen + g_gaplen, lastp_x,lastp_y) + toggle = true + } + + default: # solid line + do i = curpl_pt, npts { + j = (i-1) * 2 + 1 + x = XTRAN(p[j]) + y = YTRAN(p[j+1]) + call ccx_addsegpt (x,y, xseg,yseg, nsegpts, segsize) + } + curpl_pt = npts + } +end + + +# CCX_DASH -- Do the actual work of building a dashed line segment (no gap) + +procedure ccx_dash (p, npts, curpl_pt, curseglen, cursegpt, segsize, + xseg,yseg, lastp_x,lastp_y) + +short p[ARB] # Input: points defining line +int npts # Input: number of points, i.e., (x,y) pairs +int curpl_pt # In/Output: current polyline point +real curseglen # Output: length of current simulated ltype unit (._) +int cursegpt # Output: index of current drawable point in segment +int segsize # In/Output: current segment size +pointer xseg,yseg # Output: plotter-units, contiguous line segment +real lastp_x,lastp_y # Output: last point in segment (visible or invisible) + +int i +real temppl_dis, x, y, delx, dely +real actual_dis, rem_dashlen + +include "ccp.com" + +begin + rem_dashlen = g_dashlen + + # Build up current "dash" (may be bent any number of times). + + while (curseglen + EPSILON < g_dashlen && curpl_pt <= npts) { + i = (curpl_pt-1) * 2 + 1 + x = XTRAN(p[i]) + y = YTRAN(p[i+1]) + temppl_dis = DIS(lastp_x, lastp_y, x, y) + if (temppl_dis >= EPSILON) { + actual_dis = min (temppl_dis, rem_dashlen) + rem_dashlen = rem_dashlen - actual_dis + + delx = x - lastp_x + dely = y - lastp_y + x = lastp_x + delx * actual_dis / temppl_dis + y = lastp_y + dely * actual_dis / temppl_dis + + call ccx_addsegpt (x,y, xseg,yseg, cursegpt, segsize) + curseglen = curseglen + actual_dis + lastp_x = XSEG(cursegpt) + lastp_y = YSEG(cursegpt) + } + if (curseglen + EPSILON < g_dashlen) + curpl_pt = curpl_pt + 1 + } +end + + +# CCX_GAP -- Do the actual work of building an invisible gap along original +# polyline. + +procedure ccx_gap (p, npts, curpl_pt, curseglen, matchlen, lastp_x,lastp_y) + +short p[ARB] # Input: points defining line +int npts # Input: number of points, i.e., (x,y) pairs +int curpl_pt # In/Output: current polyline point +real curseglen # In/Output: length of current simulated ltype unit (._) +real matchlen # Output: length to build curseglen up to +real lastp_x,lastp_y # Output: last point in segment (visible, invisible) + +int i +real x, y, delx, dely +real temppl_dis, actual_dis, rem_gaplen + +include "ccp.com" + +begin + rem_gaplen = g_gaplen + + # Build up current "gap" (may be bent any number of times). + + while ((curseglen + EPSILON < (matchlen)) && (curpl_pt <= npts)) { + i = (curpl_pt-1) * 2 + 1 + x = XTRAN(p[i]) + y = YTRAN(p[i+1]) + + temppl_dis = DIS(lastp_x, lastp_y, x, y) + if (temppl_dis >= EPSILON) { + actual_dis = min (temppl_dis, rem_gaplen) + rem_gaplen = rem_gaplen - actual_dis + + delx = x - lastp_x + dely = y - lastp_y + curseglen = curseglen + actual_dis + lastp_x = lastp_x + delx * actual_dis / temppl_dis + lastp_y = lastp_y + dely * actual_dis / temppl_dis + } + if (curseglen + EPSILON < matchlen) + curpl_pt = curpl_pt + 1 + } +end + + +# CCX_ADDSEGPT -- add a point to the segment structure; handle memory needs + +procedure ccx_addsegpt (x,y, xseg,yseg, cursegpt,segsize) + +real x,y # point to be added to output segment +pointer xseg,yseg # NDC-coord contiguous line segment, output +int cursegpt # index of current drawable point in segment +int segsize # current segment size + +begin + cursegpt = cursegpt + 1 + + if (cursegpt > segsize) { + segsize = segsize + SEGSIZE + call realloc (xseg, segsize, TY_REAL) + call realloc (yseg, segsize, TY_REAL) + } + + XSEG(cursegpt) = x + YSEG(cursegpt) = y +end diff --git a/sys/gio/calcomp/ccpdrawch.x b/sys/gio/calcomp/ccpdrawch.x new file mode 100644 index 00000000..dab89158 --- /dev/null +++ b/sys/gio/calcomp/ccpdrawch.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top +define MAX_STROKESIZE 32 # max number of vectors making up one stroke +define CALCOMP_CHSTART 16 # maximum calcomp special symbol plus 1 +define SYMBOL_ASPECT 1.17 # calcomp height = 7/6 width for normal spacing. +define LOW_REDRAWS 5 # multiple traces for low-quality bold text +define HIGH_REDRAWS 9 # multiple traces for high-quality bold text + + +# CCP_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure ccp_drawchar (ch, x, y, xsize, ysize, orien, font, quality) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # char width and height in unscaled GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font +int quality # quality control -- low(calcomp); other(iraf) + +real px, py, coso, sino, theta, xto_nicesize, yto_nicesize +real sx[MAX_STROKESIZE], sy[MAX_STROKESIZE] +int stroke, tab1, tab2, i, j, pen +int bitupk() + +include "ccp.com" +include "font.com" + +begin + # Compute correction factor for absolute physical character size. + # This also corrects for distortion of high-qual text if xscale<>yscale. + xto_nicesize = g_xdefault_scale / g_xndcto_p + yto_nicesize = g_ydefault_scale / g_yndcto_p + + # Set the font. + call ccp_font (font) + + if (quality == GT_LOW) { + # If low text quality requested, draw with Calcomp's SYMBOL call. + # We avoid machine-dependency word-size problems by always + # calling SYMBOL only from here, one char per call. + # Calcomp's SYMBOL expects height as only size; aspect is height + # = 7/6 (width) for normal character spacing. + + call ccx_intersymbol (XTRAN(x),YTRAN(y), real(xsize) * xto_nicesize, + real(ysize) * yto_nicesize, ch, real(orien)) + + } else { + # Text quality requested is not low; draw font either with single- + # width line or bold, via ccp_drawseg. + + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + if (tab2 - tab1 + 1 > MAX_STROKESIZE) { + call eprintf ( + "CCP KERNEL WARNING: up-dimension MAX_STROKESIZE\n") + call eprintf ( + "in module ccp_drawch; new stroke size %d, char %s\n") + call pargi (tab2 - tab1 + 1) + call pargc (ch) + tab2 = tab1 + MAX_STROKESIZE - 1 + } + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + j = 0 + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character in unwarped (xscale == yscale) system. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + if (pen == 0 && j > 0) { # new stroke segment; draw last + if (j > 1) + call ccx_interpoly (sx, sy, j, quality) + j = 0 + } + + # Rotate, shift (unwarped), then correct for xscale <> yscale. + j = j + 1 + sx[j] = XTRAN(x + ( px * coso + py * sino) * xto_nicesize) + sy[j] = YTRAN(y + (-px * sino + py * coso) * yto_nicesize) + } + + # last stroke segment: + if (j > 1) + call ccx_interpoly (sx, sy, j, quality) + } +end + + +# CCX_INTERPOLY -- intermediate routine to 1) pass simple draw instruction to +# calcomp plot routines if linewidth single or bold method = penchange, or +# 2) simulate bold text by offsetting to the four corners and four edges +# of a box surrounding the character. + +procedure ccx_interpoly (x, y, npts, quality) + +real x[ARB],y[ARB] # plotter-unit coordinates to be drawn as polyline +int npts # number points in x,y +int quality # text quality (distinguish between medium and high) + +int i, j, num_redraws, twidth +real xp, yp +real xoff[HIGH_REDRAWS],yoff[HIGH_REDRAWS] + +include "ccp.com" + +data xoff/0., 1., 0., -1., 0., 1., -1., -1., 1./ +data yoff/0., 0., 1., 0., -1., 1., 1., -1., -1./ + +begin + if (npts <= 0) + return + + # If line width override is on, or linewidth is single, do simple move + # and draws. + + num_redraws = 1 + twidth = nint(GKI_UNPACKREAL(CCP_WIDTH(g_cc))) + if (!g_lwover) + if (g_lwtype == 'p' && twidth >= 1) + call ccp_lwidth (twidth) + else if (twidth > 1 && quality == GT_HIGH) + num_redraws = HIGH_REDRAWS + else + num_redraws = LOW_REDRAWS + + if (num_redraws == 1) { + call plot (x[1], y[1], CCP_UP) + g_max_x = max (x[1], g_max_x) + + if (npts == 1) { # single pt is special case; drop pen + call plot (x[1], y[1], CCP_DOWN) + } else { # draw normally + do i = 2, npts { + call plot (x[i], y[i], CCP_DOWN) + g_max_x = max (x[i], g_max_x) + } + } + } else { + do i = 1, num_redraws { + xp = x[1] + xoff[i] * g_plwsep + yp = y[1] + yoff[i] * g_plwsep + call plot (xp, yp, CCP_UP) + g_max_x = max (xp, g_max_x) + + if (npts == 1) { # single pt is special case; drop pen + call plot (xp, yp, CCP_DOWN) + } else { # draw normally + do j = 2, npts { + xp = x[j] + xoff[i] * g_plwsep + yp = y[j] + yoff[i] * g_plwsep + call plot (xp, yp, CCP_DOWN) + g_max_x = max (xp, g_max_x) + } + } + } + } +end + + +# CCX_INTERSYMBOL -- routine intermediate to Calcomp SYMBOL routine; handles +# bold text. + +procedure ccx_intersymbol (x,y, xsize,ysize, ch, orien) + +real x,y # plotter-unit coords of lower left of character +real xsize,ysize # char width, height in GKI units scaled to "nice" sizes +char ch # character to be drawn +real orien # degrees counterclockwise from +x axis to text path + +int i, nsym, symchar, num_redraws +real xp,yp, xoff[HIGH_REDRAWS],yoff[HIGH_REDRAWS], csize + +include "ccp.com" + +data xoff/0., 1., 0., -1., 0., 1., -1., -1., 1./ +data yoff/0., 0., 1., 0., -1., 1., 1., -1., -1./ + +begin + symchar = int (ch) + nsym = 1 + + if (ch < CALCOMP_CHSTART && ch >= 0) { + nsym = -1 + } else if (ch < ' ' || ch > '~') + ch = '~' + + # Since we are only called if text_quality == low, implement + # bold text with only the center and edge positions (LOW_REDRAWS). + num_redraws = 1 + if (!g_lwover && nint(GKI_UNPACKREAL(CCP_WIDTH(g_cc))) > 1) + num_redraws = LOW_REDRAWS + + # Set the size as the height of the character in device units; we + # start with the width to avoid overlapping, and we use the default + # scale, which results in reasonable-sized characters; the specified + # scale would produce strange results as orien passes from 0 to 90. + + csize = min (xsize * g_xndcto_p * SYMBOL_ASPECT, ysize * g_yndcto_p) + + do i = 1, num_redraws { + xp = x + xoff[i] * g_plwsep + yp = y + yoff[i] * g_plwsep + call symbol (xp, yp, csize, symchar, orien, nsym) + g_max_x = max (xp + csize, g_max_x) + } +end diff --git a/sys/gio/calcomp/ccpdseg.x b/sys/gio/calcomp/ccpdseg.x new file mode 100644 index 00000000..2d5d1c76 --- /dev/null +++ b/sys/gio/calcomp/ccpdseg.x @@ -0,0 +1,208 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +define DIAGSEP (g_plwsep / 0.8660254) # distance to vertex of hexagon +define PIOVER3 (PI / 3.0) +define PIOVER6 (PI / 6.0) +define SIN_MIN_HALFBISECTOR 0.1 # sine of minimum half-bisector + + +# CCP_DRAWSEG -- Draw a polyline segment, optionally simulating variable +# widths. + +procedure ccp_drawseg (xseg, yseg, nsegpts, lwidth) + +real xseg[ARB] # plotter coordinate array of contiguous points +real yseg[ARB] +int nsegpts # number of pts in array +int lwidth # line width relative to single width + +int i, j +real pleft_x[MAXTRACES], pleft_y[MAXTRACES] +real pright_x[MAXTRACES], pright_y[MAXTRACES], lastp_x,lastp_y +real ahp2p1, theta, delx,dely, dx,dy, tx,ty +real rptheta4 () +include "ccp.com" +data lastp_x/0.0/, lastp_y/0.0/ + +begin + if (nsegpts < 1) + return + if (lwidth > MAXTRACES) { + call eprintf ("WARNING: line width > MAXTRACES in ccp_drawseg\n") + call eprintf (" line width reset to %d\n") + call pargi (MAXTRACES) + lwidth = MAXTRACES + } + + if (nsegpts == 1) { # 1 pt spcl bold + + # Draw a single point as a hexagon lined up in the direction from + # the preceding point. Start bounding hexagon 60 degrees cc from + # projection of last point drawn (0,0 initially) through current pt. + # 'ahp2p1' = Angle from Horizontal at P1 to line P1 -> P2, etc. + + ahp2p1 = rptheta4 (xseg[1], yseg[1], lastp_x, lastp_y) + lastp_x = xseg[1] + lastp_y = yseg[1] + theta = ahp2p1 - PIOVER6 + + # do even a single, interior point as a hexagon, up to lwidth times + do i = 1, lwidth { + tx = xseg[1] + (2 + i) * DIAGSEP * cos (theta) + ty = yseg[1] + (2 + i) * DIAGSEP * sin (theta) + call plot (tx, ty, CCP_UP) + + # draw a bounding hexagon around point: + do j = 1, 6 { + theta = theta + PIOVER3 + tx = xseg[1] + (2 + i) * DIAGSEP * cos (theta) + ty = yseg[1] + (2 + i) * DIAGSEP * sin (theta) + call plot (tx, ty, CCP_DOWN) + + # Store maximum-x plotted for a "newframe" in ccp_clear. + g_max_x = max (tx, g_max_x) + } + + # fill in a diagonal line across hexagon: + tx = xseg[1] + (2 + i) * DIAGSEP * cos (theta + PI) + ty = yseg[1] + (2 + i) * DIAGSEP * sin (theta + PI) + call plot (tx, ty, CCP_DOWN) + theta = theta + PIOVER3 # rotate spokes + } + + } else { # nsegpts > 1 + + if (g_lwover || lwidth == PL_SINGLE) { + call plot (xseg[1], yseg[1], CCP_UP) + g_max_x = max (xseg[1], g_max_x) + + do i = 2, nsegpts { + call plot (xseg[i], yseg[i], CCP_DOWN) + g_max_x = max (xseg[i], g_max_x) + } + } else if (lwidth > PL_SINGLE) { + + # compute flanking points; by definition +-90 deg. from p1-p2, + # so first point is special case; do for all thicknesses: + + call ccx_offsets (xseg[1]-xseg[2]+xseg[1], + yseg[1]-yseg[2]+yseg[1], xseg[1],yseg[1], + xseg[2],yseg[2], delx,dely) + + do i = 1, lwidth - 1 { + pleft_x[i] = xseg[1] + i * delx + pleft_y[i] = yseg[1] + i * dely + pright_x[i] = xseg[1] - i * delx + pright_y[i] = yseg[1] - i * dely + } + + # must draw each segment individually, to make flanks meet. + do i = 1, nsegpts - 2 { + + # actual line segment in data: + call plot (xseg[i], yseg[i], CCP_UP) + call plot (xseg[i+1], yseg[i+1], CCP_DOWN) + g_max_x = max (xseg[i], g_max_x) + + call ccx_offsets (xseg[i],yseg[i], xseg[i+1],yseg[i+1], + xseg[i+2],yseg[i+2], delx,dely) + + # for each flanking line; p2 in middle, at temp origin + do j = 1, lwidth - 1 { + + # point to left of p1-p2, facing p2: + dx = j * delx + dy = j * dely + tx = xseg[i+1] + dx + ty = yseg[i+1] + dy + call plot (pleft_x[j], pleft_y[j], CCP_UP) + call plot (tx, ty, CCP_DOWN) + pleft_x[j] = tx + pleft_y[j] = ty + + # point to right of p1-p2, facing p2: + tx = xseg[i+1] - dx + ty = yseg[i+1] - dy + call plot (pright_x[j], pright_y[j], CCP_UP) + call plot (tx, ty, CCP_DOWN) + pright_x[j] = tx + pright_y[j] = ty + } + } + + # last point: + call plot (xseg[nsegpts-1], yseg[nsegpts-1], CCP_UP) + call plot (xseg[nsegpts], yseg[nsegpts], CCP_DOWN) + g_max_x = max (xseg[nsegpts-1], g_max_x) + g_max_x = max (xseg[nsegpts], g_max_x) + + # save this point for a possible following dotted line segment: + lastp_x = xseg[nsegpts] + lastp_y = yseg[nsegpts] + + # square the flanking lines: + call ccx_offsets (xseg[nsegpts-1], yseg[nsegpts-1], + xseg[nsegpts], yseg[nsegpts], + xseg[nsegpts] * 2.0 - xseg[nsegpts-1], + yseg[nsegpts] * 2.0 - yseg[nsegpts-1], + delx, dely) + + do i = 1, lwidth - 1 { + tx = xseg[nsegpts] + i * delx + ty = yseg[nsegpts] + i * dely + call plot (pleft_x[i], pleft_y[i], CCP_UP) + call plot (tx, ty, CCP_DOWN) + tx = xseg[nsegpts] - i * delx + ty = yseg[nsegpts] - i * dely + call plot (pright_x[i], pright_y[i], CCP_UP) + call plot (tx, ty, CCP_DOWN) + } + } + } +end + + +# CCX_OFFSETS -- return offsets in x, y from point 2 to one level of line width +# simulation, given points 1, 2, 3. + +procedure ccx_offsets (p1x,p1y, p2x,p2y, p3x,p3y, delx,dely) + +real p1x,p1y # input: point 1 is previous point +real p2x,p2y # input: point 2 is current point (middle of the three) +real p3x,p3y # input: point 3 is succeeding point +real delx,dely # output: offsets from point 2 to one flanking point + +real ahp2p1 # Angle from Horizontal to line p2-->p1, etc. +real ahp2p3, ap1p2p3, ahbisector, sintheta, r +real rptheta4 () +include "ccp.com" + +begin + # convention is that p2 is current point, at temporary origin; p1 + # is "behind", and p3 is "ahead" of the current point, p2. + # "ahp2p1" = angle from horizontal to segment p2->p1 + # "ap1p2p3" = angle from p1 to p2 to p3 + # "ahbisector" = angle from horizontal (+x) to bisector of p1->p2->p3 + + ahp2p1 = rptheta4 (p2x,p2y, p1x,p1y) + ahp2p3 = rptheta4 (p2x,p2y, p3x,p3y) + ap1p2p3 = ahp2p1 - ahp2p3 + ahbisector = ahp2p3 + 0.5 * ap1p2p3 + sintheta = sin (ahp2p1 - ahbisector) + + # very small angles cause extremely exaggerated vertices; truncate + # at arbitrary multiple of plwsep; 10*plwsep is eqv. to 11.5 deg. bisect + + if (abs (sintheta) < SIN_MIN_HALFBISECTOR) { + r = g_plwsep / SIN_MIN_HALFBISECTOR + if (sintheta < 0.0) + r = -r + } else + r = g_plwsep / sintheta + + delx = r * cos (ahbisector) + dely = r * sin (ahbisector) +end diff --git a/sys/gio/calcomp/ccpescape.x b/sys/gio/calcomp/ccpescape.x new file mode 100644 index 00000000..37e81972 --- /dev/null +++ b/sys/gio/calcomp/ccpescape.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_ESCAPE -- Pass a device dependent instruction on to the kernel. +# used for passing exact scaling factors through gki metacode + +procedure ccp_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +int ip +real tempr +char scale_str[SZ_LINE] +int ctod () + +include "ccp.com" + +string warnx "Warning: ccpkern unable to convert gki_escape xscale\n" +string warny "Warning: ccpkern unable to convert gki_escape yscale\n" + +begin + call achtsc (instruction, scale_str, nwords) + scale_str[nwords+1] = EOS + ip = 1 + + switch (fn) { + + case GSC_X_GKITODEV: + + # if kernel task scale params were not specified, set actual scale + # params to those passed from metacode if translatable, set to + # default scale from ccp_init/graphcap if untranslatable. If + # kernel task did specify scale, this is a no op. + + if (IS_INDEF (g_xtask_scale)) { + if (ctod (scale_str, ip, tempr) < 1) { + g_xndcto_p = g_xdefault_scale + call eprintf (warnx) + call eprintf ("scale string: %s\n") + call pargstr (scale_str) + call eprintf ("new (graphcap-default) x scale: %f\n") + call pargr (g_xndcto_p) + } else + g_xndcto_p = tempr + } + + case GSC_Y_GKITODEV: + + if (IS_INDEF (g_ytask_scale)) { + if (ctod (scale_str, ip, tempr) < 1) { + g_yndcto_p = g_ydefault_scale + call eprintf (warny) + call eprintf ("scale string: %s\n") + call pargstr (scale_str) + call eprintf ("new (graphcap-default) y scale: %f\n") + call pargr (g_yndcto_p) + } else + g_yndcto_p = tempr + } + } +end diff --git a/sys/gio/calcomp/ccpfa.x b/sys/gio/calcomp/ccpfa.x new file mode 100644 index 00000000..cf54861d --- /dev/null +++ b/sys/gio/calcomp/ccpfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# CCP_FILLAREA -- Fill a closed area. + +procedure ccp_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "ccp.com" + +begin + # Not implemented yet. + call ccp_polyline (p, npts) +end diff --git a/sys/gio/calcomp/ccpfaset.x b/sys/gio/calcomp/ccpfaset.x new file mode 100644 index 00000000..228669f9 --- /dev/null +++ b/sys/gio/calcomp/ccpfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_FASET -- Set the fillarea attributes. + +procedure ccp_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "ccp.com" + +begin + fa = CCP_FAAP(g_cc) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/calcomp/ccpfont.x b/sys/gio/calcomp/ccpfont.x new file mode 100644 index 00000000..0e7ad9a4 --- /dev/null +++ b/sys/gio/calcomp/ccpfont.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set CCP_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure ccp_font (font) + +int font # code for font to be set +int pk1, pk2, width +include "ccp.com" + +begin + pk1 = GKI_PACKREAL(1.0) + pk2 = GKI_PACKREAL(2.0) + + width = CCP_WIDTH(g_cc) + + if (font == GT_BOLD) { + if (width != pk2) + width = pk2 + } else { + if (GKI_UNPACKREAL(width) > 1.5) + width = pk1 + } + + CCP_WIDTH(g_cc) = width +end diff --git a/sys/gio/calcomp/ccpinit.x b/sys/gio/calcomp/ccpinit.x new file mode 100644 index 00000000..1ae558c7 --- /dev/null +++ b/sys/gio/calcomp/ccpinit.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +# CCP_INIT -- Initialize the CCP data structures from the graphcap entry +# for the plotter. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine CCP_RESET initializes the attribute +# packets. + +procedure ccp_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size, xres, yres, xwidth, yheight +real mper_punit +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "ccp.com" + +begin + # Allocate the CCP descriptor, string buffer, and x,y segment buffers. + if (g_cc == NULL) { + call calloc (g_cc, LEN_CCP, TY_STRUCT) + call malloc (CCP_SBUF(g_cc), SZ_SBUF, TY_CHAR) + } + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + CCP_SZSBUF(g_cc) = SZ_SBUF + CCP_NEXTCH(g_cc) = CCP_SBUF(g_cc) + 1 + Memc[CCP_SBUF(g_cc)] = EOS + + # Get the device resolution, dimensions in meters, and meter-to-pltr + # unit conversion factor from graphcap; if none are specified, use + # compile-time constants. + + xres = ttygeti (tty, "xr") + if (xres <= 0) + xres = GKI_MAXNDC + yres = ttygeti (tty, "yr") + if (yres <= 0) + yres = GKI_MAXNDC + + xwidth = ttygetr (tty, "xs") + if (xwidth <= 0.0) + xwidth = MAX_PL_XWIDTH + yheight = ttygetr (tty, "ys") + if (yheight <= 0.0) + yheight = MAX_PL_YHEIGHT + + mper_punit = ttygetr (tty, "MP") + if (mper_punit <= 0.0) + mper_punit = DEF_MPER_PUNIT + + # Set up coordinate transformation if not explicitly specified to + # kernel task at run time. Scale determined from graphcap is saved + # in case ccp_escape gets a metacode scale it cannot translate. + # Set up default scale such that a full max_gki_ndc plot will fit in y. + + g_ydefault_scale = yheight / (mper_punit * GKI_MAXNDC) + if (IS_INDEF (g_ytask_scale)) + g_yndcto_p = g_ydefault_scale + + g_xdefault_scale = xwidth / (mper_punit * GKI_MAXNDC) + if (IS_INDEF (g_xtask_scale)) + g_xndcto_p = g_xdefault_scale + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the plotter has a set of discrete character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + CCP_NCHARSIZES(g_cc) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = CCP_NEXTCH(g_cc) + + if (CCP_NCHARSIZES(g_cc) <= 0) { + CCP_NCHARSIZES(g_cc) = 1 + CCP_CHARSIZE(g_cc,1) = 1.0 + CCP_CHARHEIGHT(g_cc,1) = char_height + CCP_CHARWIDTH(g_cc,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= CCP_NCHARSIZES(g_cc); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + CCP_CHARSIZE(g_cc,i) = char_size + CCP_CHARHEIGHT(g_cc,i) = char_height * char_size + CCP_CHARWIDTH(g_cc,i) = char_width * char_size + } + } + + # Get dash length, gap length, and n-tracing separation width: + if (IS_INDEF (g_dashlen)) { + g_dashlen = ttygetr (tty, "DL") + if (g_dashlen <= 0.0) + g_dashlen = DEF_DASHLEN + } + if (IS_INDEF (g_gaplen)) { + g_gaplen = ttygetr (tty, "GL") + if (g_gaplen <= 0.0) + g_gaplen = DEF_GAPLEN + } + if (IS_INDEF (g_plwsep)) { + g_plwsep = ttygetr (tty, "PW") + if (g_plwsep <= 0.0) + g_plwsep = DEF_PLWSEP + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the CCP + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + CCP_POLYLINE(g_cc) = btoi (ttygetb (tty, "pl")) + CCP_POLYMARKER(g_cc) = btoi (ttygetb (tty, "pm")) + CCP_FILLAREA(g_cc) = btoi (ttygetb (tty, "fa")) + CCP_FILLSTYLE(g_cc) = ttygeti (tty, "fs") + CCP_ROAM(g_cc) = btoi (ttygetb (tty, "ro")) + CCP_ZOOM(g_cc) = btoi (ttygetb (tty, "zo")) + CCP_ZRES(g_cc) = ttygeti (tty, "zr") + CCP_SELERASE(g_cc) = btoi (ttygetb (tty, "se")) + CCP_PIXREP(g_cc) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + CCP_CURSOR(g_cc) = 1 + + # Save the device string in the descriptor. + nextch = CCP_NEXTCH(g_cc) + CCP_DEVNAME(g_cc) = nextch + CCP_DEVCHAN(g_cc) = CCP_LDEV + maxch = CCP_SBUF(g_cc) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + CCP_NEXTCH(g_cc) = nextch + + # Initialize maximum-x tracker, used for "newframe" in ccp_clear. + g_max_x = 0.0 +end diff --git a/sys/gio/calcomp/ccpltype.x b/sys/gio/calcomp/ccpltype.x new file mode 100644 index 00000000..e5325ddd --- /dev/null +++ b/sys/gio/calcomp/ccpltype.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_LINETYPE -- Set the line type option in the nspp world. + +procedure ccp_linetype (index) + +int index # index for line type switch statement + +include "ccp.com" + +begin + switch (index) { + case GL_CLEAR: + g_ltype = 0 + case GL_DASHED: + g_ltype = 2 + case GL_DOTTED: + g_ltype = 3 + case GL_DOTDASH: + g_ltype = 4 + default: + g_ltype = 1 # GL_SOLID and default + } +end diff --git a/sys/gio/calcomp/ccplwidth.x b/sys/gio/calcomp/ccplwidth.x new file mode 100644 index 00000000..bda9c33b --- /dev/null +++ b/sys/gio/calcomp/ccplwidth.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# Calcomp pen widths +define SINGLE 1 # ***** site dependence!! [MACHDEP] +define DOUBLE 2 # + +# CCP_LWIDTH set pen width; see ccp_color, which also sets pens. +# We should only be called if task param "lwtype" was explicitly set to +# "p" for pen method; normally bold lines are handled by ntracing. + +procedure ccp_lwidth (index) + +int index # index for width switch statement +include "ccp.com" + +begin + if (g_lwover) # CL param lwover, line width override is on; noop + return + + # ***** site dependence; add other pen numbers here; if pen numbers + # for multiple widths are monotonic, make single call to newpen(index). + + switch (index) { + + case DOUBLE: + call newpen (DOUBLE) + default: + call newpen (SINGLE) + } +end diff --git a/sys/gio/calcomp/ccpopen.x b/sys/gio/calcomp/ccpopen.x new file mode 100644 index 00000000..f900b95b --- /dev/null +++ b/sys/gio/calcomp/ccpopen.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_OPEN -- Install the calcomp kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. The table entry for non-implemented procedures is +# set to zero, causing the interpreter to ignore the instruction. + +procedure ccp_open (devname, dd) + +char devname[ARB] # ignored if only one plotter on system +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern ccp_openws(), ccp_closews(), ccp_clear() +extern ccp_polyline(), ccp_polymarker(), ccp_text() +extern ccp_plset() +extern ccp_pmset(), ccp_txset() +extern ccp_escape() +include "ccp.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_cc = NULL + g_ndraw = 0 #????? may not need; also used in ccp_openws,ccp_clear, + # ccp_polyline, ccp_polymarker, ccp_text; may want for + # debug etc. + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (ccp_openws) + dd[GKI_CLOSEWS] = locpr (ccp_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (ccp_clear) + dd[GKI_CANCEL] = 0 + dd[GKI_FLUSH] = 0 + dd[GKI_POLYLINE] = locpr (ccp_polyline) + dd[GKI_POLYMARKER] = locpr (ccp_polymarker) + dd[GKI_TEXT] = locpr (ccp_text) + dd[GKI_FILLAREA] = 0 + dd[GKI_PUTCELLARRAY] = 0 + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (ccp_plset) + dd[GKI_PMSET] = locpr (ccp_pmset) + dd[GKI_TXSET] = locpr (ccp_txset) + dd[GKI_FASET] = 0 + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (ccp_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call ccp_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/calcomp/ccpopenws.x b/sys/gio/calcomp/ccpopenws.x new file mode 100644 index 00000000..aec063cf --- /dev/null +++ b/sys/gio/calcomp/ccpopenws.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +# CCP_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure ccp_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +bool need_open, same_dev +include "ccp.com" + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # If a particular plotter was named when the kernel was opened then + # output will always go to that plotter (g_device) regardless of the + # plotter named in the OPENWS instruction. If no plotter was named + # (null string) then unpack the plotter name, passed as a short integer + # array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_cc == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_cc != NULL) { # not first time + same_dev = (streq (Memc[CCP_DEVNAME(g_cc)], Memc[buf])) + if (!same_dev) { + # close previous plotter, initialize new one. + call plot (0, 0, 999) + call plots (0, 0, CCP_DEVCHAN(g_cc)) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if ((g_cc != NULL) && !same_dev) + call ttycdes (g_tty) # close prev tty + if (!same_dev) { + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + g_ndraw = 0 + } + } + + # Initialize data structures if we had to open a new device. + if (!same_dev) { + call ccp_init (g_tty, Memc[buf]) + call ccp_reset() + call plots (0, 0, CCP_DEVCHAN(g_cc)) + } + + # Advance a frame if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will advance + # the paper if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call ccp_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/calcomp/ccppl.x b/sys/gio/calcomp/ccppl.x new file mode 100644 index 00000000..2b1712bd --- /dev/null +++ b/sys/gio/calcomp/ccppl.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_POLYLINE -- Set up a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted unless it is the only point, but rather defines the start of +# the polyline. The remaining points define line segments to be drawn. + +procedure ccp_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl, xseg,yseg +int i, curpl_pt, nsegpts +int len_p, segsize, lsize + +include "ccp.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of number of drawing instructions since last frame clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = CCP_PLAP(g_cc) + + if (CCP_LTYPE(g_cc) != PL_LTYPE(pl)) { + call ccp_linetype (PL_LTYPE(pl)) # set g_ltype in ccp.com + CCP_LTYPE(g_cc) = PL_LTYPE(pl) + } + if (CCP_WIDTH(g_cc) != PL_WIDTH(pl)) { + if (GKI_UNPACKREAL(PL_WIDTH(pl)) < 1.5) { + CCP_WIDTH(g_cc) = GKI_PACKREAL(PL_SINGLE) + } else + CCP_WIDTH(g_cc) = PL_WIDTH(pl) + } + if (CCP_COLOR(g_cc) != PL_COLOR(pl)) { + call ccp_color (PL_COLOR(pl)) + CCP_COLOR(g_cc) = PL_COLOR(pl) + } + + # If the overrides are on, or linetype is solid and linewidth is single, + # do simple move and draws: + + if ((g_ltover && g_lwover) || (!g_lwover && g_lwtype == 'p') || + (g_ltype == GL_SOLID && CCP_WIDTH(g_cc) == GKI_PACKREAL(PL_SINGLE)) + || (g_ltover && CCP_WIDTH(g_cc) == GKI_PACKREAL(PL_SINGLE)) || + (g_ltype == GL_SOLID && g_lwover)) { + + if (g_lwtype == 'p') + call newpen (PL_WIDTH(pl)) + + call plot (XTRAN(p[1]), YTRAN(p[2]), CCP_UP) + if (npts == 1) { + call plot (XTRAN(p[1]), YTRAN(p[2]), CCP_DOWN) + } else { # draw normally + do i = 3, len_p, 2 + call plot (XTRAN(p[i]), YTRAN(p[i+1]), CCP_DOWN) + } + + # Store maximum-x point plotted for a "newframe" in ccp_clear. + do i = 1, len_p, 2 + g_max_x = max (XTRAN(p[i]), g_max_x) + + + # Otherwise, must calculate individual segments of dashes and dots, + # keeping their lengths constant along polyline (ccp_calcseg), before + # optionally simulating bold and drawing (ccp_drawseg): + + } else { # vector polyline; simulate linetype, linewidth + + segsize = SEGSIZE + call malloc (xseg, segsize, TY_REAL) + call malloc (yseg, segsize, TY_REAL) + + curpl_pt = 1 + lsize = nint(GKI_UNPACKREAL(CCP_WIDTH(g_cc))) + if (!g_ltover && (g_ltype >= GL_DASHED && g_ltype <= GL_DOTDASH)) { + + while (curpl_pt <= npts) { + call ccp_calcseg (p, npts, g_ltype, curpl_pt, segsize, + xseg,yseg, nsegpts) + call ccp_drawseg (Memr[xseg],Memr[yseg], nsegpts, lsize) + } + + } else { # either (ltype override or solid line), not single wid. + + call ccp_calcseg (p, npts, GL_SOLID, curpl_pt, segsize, xseg, + yseg, nsegpts) + call ccp_drawseg (Memr[xseg],Memr[yseg], nsegpts, lsize) + } + + call mfree (xseg, TY_REAL) + call mfree (yseg, TY_REAL) + } + +end diff --git a/sys/gio/calcomp/ccpplset.x b/sys/gio/calcomp/ccpplset.x new file mode 100644 index 00000000..c118f93e --- /dev/null +++ b/sys/gio/calcomp/ccpplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure ccp_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "ccp.com" + +begin + pl = CCP_PLAP(g_cc) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/calcomp/ccppm.x b/sys/gio/calcomp/ccppm.x new file mode 100644 index 00000000..bb6c783f --- /dev/null +++ b/sys/gio/calcomp/ccppm.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +define DIAGSEP (1.0 * g_plwsep / 0.7071068) # dis at 40 degrees from plwsep + +# CCP_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure ccp_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, j, len_p +real theta, x, y, tx, ty +include "ccp.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = CCP_PMAP(g_cc) + + if (CCP_LTYPE(g_cc) != PM_LTYPE(pm)) { + call ccp_linetype (PM_LTYPE(pm)) + CCP_LTYPE(g_cc) = PM_LTYPE(pm) + } + if (CCP_WIDTH(g_cc) != PM_WIDTH(pm)) + CCP_WIDTH(g_cc) = PM_WIDTH(pm) + + if (CCP_COLOR(g_cc) != PM_COLOR(pm)) { + call ccp_color (PM_COLOR(pm)) + CCP_COLOR(g_cc) = PM_COLOR(pm) + } + + # Draw the polymarker. + do i = 1, len_p, 2 { + # Draw the single point as a box with a diagonal + # through it. + + theta = 0.5 * HALFPI + x = XTRAN(p[i]) + y = YTRAN(p[i+1]) + tx = x + DIAGSEP * cos (theta) + ty = y + DIAGSEP * sin (theta) + call plot (tx, ty, CCP_UP) + g_max_x = max (tx, g_max_x) + + do j = 1, 4 { + theta = theta + HALFPI + tx = x + DIAGSEP * cos (theta) + ty = y + DIAGSEP * sin (theta) + call plot (tx, ty, CCP_DOWN) + } + + # Fill in diagonal. + tx = x + DIAGSEP * cos (theta + PI) + ty = y + DIAGSEP * sin (theta + PI) + call plot (tx, ty, CCP_DOWN) + } +end diff --git a/sys/gio/calcomp/ccppmset.x b/sys/gio/calcomp/ccppmset.x new file mode 100644 index 00000000..2f3f5534 --- /dev/null +++ b/sys/gio/calcomp/ccppmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_PMSET -- Set the polymarker attributes. + +procedure ccp_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "ccp.com" + +begin + pm = CCP_PMAP(g_cc) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/calcomp/ccpreset.x b/sys/gio/calcomp/ccpreset.x new file mode 100644 index 00000000..7d4514f6 --- /dev/null +++ b/sys/gio/calcomp/ccpreset.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure ccp_reset() + +pointer pl, pm, fa, tx +include "ccp.com" + +begin + # Set pointers to attribute substructures. + pl = CCP_PLAP(g_cc) + pm = CCP_PMAP(g_cc) + fa = CCP_FAAP(g_cc) + tx = CCP_TXAP(g_cc) + + # Initialize the attribute packets. + PL_LTYPE(pl) = GL_SOLID + PL_WIDTH(pl) = GKI_PACKREAL(PL_SINGLE) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = GL_SOLID + PM_WIDTH(pm) = GKI_PACKREAL(PL_SINGLE) + PM_COLOR(pm) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + CCP_LTYPE(g_cc) = -1 + CCP_WIDTH(g_cc) = -1 + CCP_COLOR(g_cc) = -1 + CCP_TXSIZE(g_cc) = -1 + CCP_TXFONT(g_cc) = -1 +end diff --git a/sys/gio/calcomp/ccptx.x b/sys/gio/calcomp/ccptx.x new file mode 100644 index 00000000..b93b5223 --- /dev/null +++ b/sys/gio/calcomp/ccptx.x @@ -0,0 +1,463 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# CCP_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure ccp_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +real x, y, dx, dy, tsz, xto_nicesize, yto_nicesize +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen, quality +pointer sp, seg, ip, op, tx, first, pl +int ccx_segment() +include "ccp.com" + +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = CCP_TXAP(g_cc) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by ccp_txset, and is just a scaling factor. + + CCP_TXSIZE(g_cc) = TX_SIZE(tx) + if (TX_COLOR(tx) != CCP_COLOR(g_cc)) { + call ccp_color (TX_COLOR(tx)) + CCP_COLOR(g_cc) = TX_COLOR(tx) + } + + # Set the character-generator quality. Only low (Calcomp "symbol") + # and other (ccp_font; see NSPP doc. on its font) are supported. + if (g_txquality == 0) { + quality = TX_QUALITY(tx) # param was specified "normal" to task + } else + quality = g_txquality # param was explicit to task + + # Set the linetype to a solid line, and invalidate last setting. + call ccp_linetype (GL_SOLID) # for use in ccp_polyline + CCP_LTYPE(g_cc) = -1 # PL_LTYPE still contains current settng + + # Set pointer to polyline attribute structure and set line width + # if necessary. + pl = CCP_PLAP(g_cc) + + if (CCP_WIDTH(g_cc) != PL_WIDTH(pl)) { + if (GKI_UNPACKREAL(PL_WIDTH(pl)) < 1.5) { + CCP_WIDTH(g_cc) = GKI_PACKREAL(PL_SINGLE) + } else + CCP_WIDTH(g_cc) = PL_WIDTH(pl) + } + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = ccx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call ccx_parameters (xc,yc, totlen, x0,y0, gki_dx,gki_dy, polytext, + orien) + + # Scale the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = CCP_CHARHEIGHT(g_cc,1) * tsz + cw = CCP_CHARWIDTH(g_cc,1) * tsz + + # Compute correction factors for absolute physical character sizes. + # This also corrects for distortion of high-qual text if xscale<>yscale. + xto_nicesize = g_xdefault_scale / g_xndcto_p + yto_nicesize = g_ydefault_scale / g_yndcto_p + + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x + x2 = x1 + cw * xto_nicesize + y1 = y + y2 = y1 + ch * yto_nicesize + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x + x2 = x1 + cw * xto_nicesize + y1 = y + y2 = y1 + ch * yto_nicesize + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call ccp_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font, quality) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# CCX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure ccx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# CCX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure ccx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space, xto_nicesize, yto_nicesize +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q, xtmp, ytmp +include "ccp.com" + +begin + tx = CCP_TXAP(g_cc) + + # Compute correction factors for absolute physical character sizes. + # This also removes any warping due to different xscale, yscale. + xto_nicesize = g_xdefault_scale / g_xndcto_p + yto_nicesize = g_ydefault_scale / g_yndcto_p + + # Get character sizes in GKI(plotter) coords; scale y (ch) dimension + # to that of x for absolute scale systems that are different in x,y. + + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = CCP_CHARHEIGHT(g_cc,1) * sz + cw = CCP_CHARWIDTH(g_cc,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated and unscaled). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation, scaling differences, and absolute size. + dx = ( p * cosv + q * sinv) * xto_nicesize + dy = (-p * sinv + q * cosv) * yto_nicesize + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character size in X and Y. + xsize = abs ( cw * cosv + ch * sinv) * xto_nicesize + ysize = abs (-cw * sinv + ch * cosv) * yto_nicesize + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + xtmp = ( p * cosv + q * sinv) * xto_nicesize + ytmp = (-p * sinv + q * cosv) * yto_nicesize + + x0 = x0 + xtmp + y0 = y0 + ytmp + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/calcomp/ccptxset.x b/sys/gio/calcomp/ccptxset.x new file mode 100644 index 00000000..f2f4f040 --- /dev/null +++ b/sys/gio/calcomp/ccptxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_TXSET -- Set the text drawing attributes. + +procedure ccp_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "ccp.com" + +begin + tx = CCP_TXAP(g_cc) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/calcomp/doc/ccpspecs.hlp b/sys/gio/calcomp/doc/ccpspecs.hlp new file mode 100644 index 00000000..fae12e4e --- /dev/null +++ b/sys/gio/calcomp/doc/ccpspecs.hlp @@ -0,0 +1,384 @@ +.help +\fBSpecifications for IRAF Calcomp kernel -- (CCP package)\fR + + +The Calcomp kernel (package prefix "ccp") will implement selected GKI +instructions, using only calls to the Calcomp routines \fBplots\fR, +\fBplot\fR, \fBnewpen\fR and \fBsymbol\fR. + + +There are two sub-components of the CCP package: 1) the kernel driver +task allowing a user to send a specified graphics metafile to the plotter, and +2) the low-level kernel routines which implement specific GKI instructions, +and which make the only calls to the Calcomp library. + + +.nh +\fBCL interface -- task CALCOMP\fR + + +The driver task, \fBcalcomp\fR, allows a user to direct an existing GKI metacode +file to a particular Calcomp plotter under control of a set of CL parameters. +The task is loaded either by being run directly from the CL as a task, or by +being invoked through inter-process control following a write-to-pseudofile +containing the GKI_OPENWS metacode instruction. The task may +optionally control certain kinds of debug output. + +.nf +CL parameters to the kernel driver task \fBcalcomp\fR: + +input,s,a,,,,"input metacode file" +device,s,h,"calcomp",,,"output device" +generic,b,h,no,,,"ignore remaining kernel dependent parameters" +debug,b,h,no,,,"print decoded graphics instructions during processing" +verbose,b,h,no,,,"print elements of polylines, etc. in debug mode" +gkiunits,b,h,no,,,"print coordinates in GKI rather than NDC units" +xscale,r,h,INDEF,0.0,,"plotter x = GKI_NDC_X * xscale" +yscale,r,h,INDEF,0.0,,"plotter y = GKI_NDC_Y * yscale" +txquality,s,h,"normal","normal|low|high",,"character quality; n=from metacode" +lwtype,s,h,"ntracing","ntracing|penchange",,"bold line/text implementation" +ltover,b,h,no,,,"override line type simulation" +lwover,b,h,no,,,"override line width simulation" +lcover,b,h,no,,,"override line color implementation by penchange" +dashlen,r,h,INDEF,0.0,,"dashed line dash length, pltr units; 0.5 reasonable" +gaplen,r,h,INDEF,0.0,,"dashed line gap length, pltr units; 0.1 reasonable" +plwsep,r,hl,INDEF,0.,,"polyline width separation for ntracing; 0.005 reasonable" + +.fi + + +.nh +\fBSuggested GRAPHCAP entry for calcomp plotter\fR + +.nf + + p5|calcomp|calcomp pen plotter:\ + :kf=xcalcomp.e:tn=calcomp:co#132:li#66:xr#32767:yr#5375:\ + :ch#.0294:cw#.0125:xs#1.664564:ys#0.27305:\ + :PU=inches:MP#.0254:DL#.50:GL#.10:PW#.005:\ + :DD=plot!calcomp,/tmp/gcaXXXXXX,\ + !{ cd /tmp; nice /local/bin/plotX -Tcalcomp -W=1 $F |\ + nice /usr/bin/plot -Tcalcomp; rm $F; }&: + + #xs 1.664564 # maximum x in meters; max at .002 inches step size + #ys .27305000 # maximum y in meters; 10.75 inch paper + #xr 32767 # max resolution in x; limited by GKI short int coords + #yr 5375 # max resolution in y; 10.75 inches at .002 inches step + #PU inches # plotter units + #MP 0.0254 # meters per plotter unit + #DL 0.5000 # dash length in plotter units + #GL 0.1000 # gap length in plotter units + #PW 0.0050 # n-tracing (bold line simul.) width sep. in pltr units + #if yscale not set by kernel, g_yndcto_p = GKI_MAXNDC/(MP*yr); 32767/10.75" + #if xscale not set by kernel, g_xndcto_p = g_yndcto_p; square aspect ratio + +.fi + + +.nh +\fBInterface between CALCOMP task and lower-level kernel routines\fR + + +Two kernel routines will normally be called from outside the GKI +instruction-stream decoding facility (as from the driver task): + +.nf + ccp_open (devname, dd) + + devname: device name of desired Calcomp plotter (must have + entry in graphcap file) + + dd: array of entry point addresses to lower-level kernel + routines + + discussion: linking to multiple Calcomp plotters is a + site-dependent function. Ordinarily devname is + ignored; if this kernel is called, output will go + to the device initialized by the Calcomp library. + See ccp_openws. + + + ccp_close () + + discussion: causes a Calcomp "newframe" -- resets origin to + right of last previously-plotted point. + + +.fi +.nh +\fBLow-level kernel routines\fR + + +All remaining kernel routines will normally be called either by ccp_open or +by gki_execute, or by each other. Following are descriptions of the +implementation of GKI instructions: +.nf + + GKI_EOF + + Not implemented; it should be trapped outside the kernel, as in + \fBgki_execute\fR. + + GKI_OPENWS + + ccp_openws (devname, len_devname, mode) + + devname; len_devname: + + name of plotter, name length, if not present in metafile + + mode: + + file access mode for gki metafile; if NEWFILE, a Calcomp + "newframe" (reorigin to right of previous plot) will + occur; if APPEND mode, no newframe. + + discussion: + + There is no output metafile; device connection and any + site-specific spooling is handled below this level. + Note that there must be a graphcap entry for devname. + + GKI_CLOSEWS + + ccp_closews () + + discussion: + + As there is no output metafile, this is a noop. + + GKI_REACTIVATEWS + + Not implemented. + + GKI_DEACTIVATEWS + + Not implemented. + + GKI_MFTITLE + + Not implemented. + + GKI_CLEARWS + + ccp_clear () + + discussion: + + Implemented only by a Calcomp "newframe"; there is no + output metacode file for spooling at this level. + + GKI_CANCEL + + Not implemented, since there is no buffered output. + + GKI_FLUSH + + Not implemented. + + GKI_POLYLINE + + ccp_polyline (p, npts) + + p: array of points (x1, y1, x2, y2, ...) + + npts: number of pairs + + discussion: + + To GKI, ccp_polyline will appear pretty normal; due to + the lack of settable parameters like dashed-line in + Calcomp, such features are implemented in further layers + between ccp_polyline and the actual Calcomp vector-draw + routine. See kernel task parameters lwtype, lwover, and + ltover for line width and type control. + + GKI_POLYMARKER + + ccp_polymarker (p, npts) + + arguments: same as above + + discussion: + + Ccp_polymarker will merely dot the location at the + coordinate passed in; more complicated marker + symbols will be assumed to have been handled above, for + purposes of clipping, and will be drawn with ccp_polyline + at this level. + + GKI_TEXT + + ccp_text (x, y, text, nchar) + + x, y: + + NDC coordinates of text stream; note that the JUSTIFY + parameters in GSET determine where these coordinates are + relative to the text characters. + + text: array of type short characters + + nchar: number of chars in text + + discussion: + + The same levels of text quality will be supported as in + the stdgraph kernel; normal is taken from the metacode + request, medium and high fonts are stroke text, while low + quality is Calcomp hardware text. Depending on the + particular plotter controller at each site, low quality + text may or may not be significantly faster than stroke + text. + + The special Calcomp symbols numbered 0 - 15 in the + Calcomp symbol library are invoked by characters with + ASCII values 0 - 15. When using hardware text generation, + the ASCII symbol requested will be mapped to the Calcomp + set if possible; otherwise, a default "indefinite" character + will appear. + + GKI_FILLAREA + + ccp_fillarea (p, npts) + + p, npts: same as above for ccp_polyline + + discussion: + + With Calcomp, fillarea could only be implemented by + simulating with hatching patterns, a time-consuming + process for a pen plotter. We may or may not choose + to do this, depending upon users' needs. For the + very similar Versaplot kernel which may follow, it + should definitely be implemented, using Versaplot's + \fBtone\fR call. Initially, it will only be implemented + here with a call to ccp_polyline for the border. + + GKI_PUTCELLARRAY + + Not implemented. + + GKI_SETCURSOR + + Not implemented. + + GKI_PLSET + + ccp_plset (gki) + + gki: attribute structure decoded by gki + + discussion: + + Line types documented in the GIO manual will be + implemented in software except for "erase", unless the + CL parameter to the CALCOMP task "ltover" is on, in + which case all lines drawn will be solid. See task + parameters dash and gap. In the future, line types + numbered higher than 4 may be implemented using various + combinations of dashes and dots as in Morse code. Line + width and color may be similarly implemented or overridden; + if not overridden, line width will be done by default using + n-tracing (n = nearest integer value of line width) or by a + penchange, under control of task parameter "lwtype". + + GKI_PMSET + + ccp_pmset (gki) + + gki, discussion: Same as for ccp_plset. + + GKI_TXSET + + ccp_txset (gki) + + gki, discussion: + + Internal flags are set from structure gki controlling + text up vector, path relative to up vector, horizontal + and vertical justification, font, quality, color, + spacing, and size. For high-quality text, all flags are + implemented (color by a pen change, with optional + override); see GKI_TEXT discussion. + + GKI_FASET + + ccp_faset (gki) + + gki, discussion: + + Internal flags are set for fill area style and color. + If we decide to implement fill area in software (the only + way for Calcomp), we will use GKS conventions wherever + possible. + + GKI_GETCURSOR + + Not implemented. The Calcomp \fBwhere\fR routine would only + duplicate GCURPOS in GIO. + + GKI_CURSORVALUE + + Not implemented; not an interactive device. + + GKI_GETCELLARRAY + + Not implemented; not a storage device. + + GKI_CELLARRAY + + Not implemented. + + GKI_ESCAPE + + ccp_escape (fn, instruction, nwords) + + fn: escape function code + + instruction, nwords: + + Nwords-long array of short integers containing the + instruction sequence. + + discussion: + + A high-level task may pass the NDC-to-plotter units + coordinate scaling factor down into the kernel to + permit exact scaling. The scale factors will be + set in common to allow fast access by the ccp_draw + routine. + + GKI_ESCAPE = BOI 25 L FN N DC + + L(i) 5 + N + FN(i) escape function code + N(i) number of escape data words + DC(i) escape data words + + 1) xndc_to_plotter: + + FN = ESC_XNDCTO_P (currently = 1 in ccp.h) + N = number of characters in the scale specification + DC = array of N short integers containing character- + packed scale (must be achtsc'd then ctod'd to + get x scale) + + 2) yndc_to_plotter: + + FN = ESC_YNDCTO_P (currently = 2 in ccp.h) + N = same as in (1) + DC = same as in (1) + + The macros ESC_*NDCTO_P, currently defined in ccp.h, should + probably be defined in a gki-public place like gki.h. + + + GKI_SETWCS + + Not implemented. + + GKI_GETWCS + + Not implemented. +.fi diff --git a/sys/gio/calcomp/font.com b/sys/gio/calcomp/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/calcomp/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/calcomp/font.h b/sys/gio/calcomp/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/sys/gio/calcomp/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/calcomp/mkpkg b/sys/gio/calcomp/mkpkg new file mode 100644 index 00000000..f4b7f8b9 --- /dev/null +++ b/sys/gio/calcomp/mkpkg @@ -0,0 +1,52 @@ +# Make the CALCOMP GIO graphics kernel. Requires the host system library +# LIB_CALCOMP, which must be callable from an IRAF program (which is not the +# same as a Fortran program). + +$checkout libccp.a lib$ +$update libccp.a +$checkin libccp.a lib$ +$call relink +$exit + +update: # update lib$x_calcomp.e + $call relink + $call install + ; + +relink: # make x_calcomp.e in local directory + $omake x_calcomp.x + $link x_calcomp.o -lccp $(LIB_CALCOMP) + ; + +install: # install in system library + $move x_calcomp.e bin$ + ; + +libccp.a: + ccpclear.x ccp.com ccp.h + ccpclose.x ccp.com ccp.h + ccpclws.x ccp.com ccp.h + ccpcolor.x ccp.com ccp.h + ccpcseg.x ccp.com ccp.h + ccpdrawch.x ccp.com ccp.h font.com font.h \ + + ccpdseg.x ccp.com ccp.h + ccpescape.x ccp.com ccp.h + ccpfa.x ccp.com ccp.h + ccpfaset.x ccp.com ccp.h + ccpfont.x ccp.com ccp.h + ccpinit.x ccp.com ccp.h + ccpltype.x ccp.com ccp.h + ccplwidth.x ccp.com ccp.h + ccpopen.x ccp.com ccp.h + ccpopenws.x ccp.com ccp.h + ccppl.x ccp.com ccp.h + ccpplset.x ccp.com ccp.h + ccppm.x ccp.com ccp.h + ccppmset.x ccp.com ccp.h + ccpreset.x ccp.com ccp.h + ccptx.x ccp.com ccp.h + ccptxset.x ccp.com ccp.h + rptheta4.x + t_calcomp.x ccp.com ccp.h + ; diff --git a/sys/gio/calcomp/rptheta4.x b/sys/gio/calcomp/rptheta4.x new file mode 100644 index 00000000..b2ee42b7 --- /dev/null +++ b/sys/gio/calcomp/rptheta4.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define PIOVER4 (0.25 * PI) +define THREEPIOVER4 (0.75 * TWOPI) + +# RPTHETA4 -- Polar angle, Real precision, 4 arguments; from p1(x,y) to p2(x,y): +# angle between line segment p1-p2 and horizontal +x axis centered on p1; +# returned in radians; single precision (see pdtheta4). + +real procedure rptheta4 (p1x, p1y, p2x, p2y) + +real p1x,p1y, p2x,p2y # x,y of each point +real dx, dy, ang + +begin + dx = p2x - p1x + dy = p2y - p1y + + if (dx == 0.0) { + if (dy >= 0.0) { + ang = HALFPI + } else { + ang = THREEPIOVER4 + } + } else { + ang = atan (dy / dx) + if (dx < 0.0) { # 2nd or 3rd quadrant + ang = ang + PI + } else if (dy < 0.0) { # 4th quadrant + ang = ang + TWOPI + } + } + + return (ang) +end diff --git a/sys/gio/calcomp/t_calcomp.x b/sys/gio/calcomp/t_calcomp.x new file mode 100644 index 00000000..0164d043 --- /dev/null +++ b/sys/gio/calcomp/t_calcomp.x @@ -0,0 +1,125 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "ccp.h" + +define SZ_TXQUALITY 1 + +# CALCOMP -- Graphics kernel for Calcomp pen plotter output. The whole +# package is copied as much as possible from the NSPP kernel. + +procedure t_calcomp() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +char txquality[SZ_TXQUALITY] +bool clgetb() +char clgetc() +real clgetr() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +include "ccp.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + g_xtask_scale = INDEF + g_xndcto_p = INDEF + g_ytask_scale = INDEF + g_yndcto_p = INDEF + g_txquality = 0 + g_lwtype = 'n' + g_ltover = false + g_lwover = true + g_lcover = false + g_dashlen = INDEF + g_gaplen = INDEF + g_plwsep = INDEF + + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + + # scale precedence: calcomp.par->metacode->graphcap->compile_time + g_xtask_scale = clgetr ("xscale") + if (!IS_INDEF (g_xtask_scale)) + g_xndcto_p = g_xtask_scale + g_ytask_scale = clgetr ("yscale") + if (!IS_INDEF (g_ytask_scale)) + g_yndcto_p = g_ytask_scale + + # Get the quality parameter for the text generator. + call clgstr ("txquality", txquality, SZ_TXQUALITY) + switch (txquality[1]) { + case 'l': + g_txquality = GT_LOW + case 'm': + g_txquality = GT_MEDIUM + case 'h': + g_txquality = GT_HIGH + default: + g_txquality = 0 # .par default is "normal" + } + + # Method of line width implementation: + g_lwtype = clgetc ("lwtype") + + # The overrides: + g_ltover = clgetb ("ltover") + g_lwover = clgetb ("lwover") + g_lcover = clgetb ("lcover") + + # Plotter line type, width control: + g_dashlen = clgetr ("dashlen") + g_gaplen = clgetr ("gaplen") + g_plwsep = clgetr ("plwsep") + } + + # Open the graphics kernel. + call ccp_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call ccp_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/calcomp/vttest.par b/sys/gio/calcomp/vttest.par new file mode 100644 index 00000000..fcbcb2ad --- /dev/null +++ b/sys/gio/calcomp/vttest.par @@ -0,0 +1,10 @@ +lname,s,hl,"ltest1.dat",,,"input polyline test file name" +tname,s,hl,"ttest3.dat",,,"input text test file name" +ltype,i,hl,1,1,6,"line type" +lwidth,i,hl,1,1,15,"line width" +mtype,i,hl,0,0,1023,"polymarker type code" +dashlen,r,hl,10000.,0.,,"length of dash in plotter units" +gaplen,r,hl,5000.,0.,,"width of gap in plotter units" +plwsep,r,hl,50.,0.,,"polyline width separation for ntracing" +option,s,hl,"l",,,"test option: {l-line; t-text; m-marker}" +device,s,hl,"vt640",,,"output device for test program" diff --git a/sys/gio/calcomp/vttest.x b/sys/gio/calcomp/vttest.x new file mode 100644 index 00000000..ceff7c7a --- /dev/null +++ b/sys/gio/calcomp/vttest.x @@ -0,0 +1,608 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "ccp.h" + +define SZ_BUF 2048 +define PIOVER4 (0.25 * PI) +define THREEPIOVER4 (0.75 * TWOPI) +define MAXCH 15 + +# X_VTTEST -- testing task for simulating calcomp kernel routines on vt640 + +task vttest = t_vttest + +# T_VTTEST -- test low-level Calcomp graphics simulation routines on vt640 + +procedure t_vttest () + +char lname[SZ_FNAME], tname[SZ_FNAME], devname[SZ_FNAME] +int ltype, lwidth, npts, n, mtype, i +char testoption +pointer x, y, gp, sim_gp +short p[ARB] + +pointer sp, nambuf, pl, pm +int clgeti (), strlen () +real clgetr () +char clgetc () +pointer ttygdes (), gopen () + +include "ccp.com" +common /simulate/ sim_gp + +string fdevice "vt640" + +begin + call smark (sp) + call salloc (nambuf, SZ_FNAME, TY_CHAR) + + testoption= clgetc ("option") + if (testoption == 'l') { + call clgstr ("lname", lname, SZ_FNAME) + ltype = clgeti ("ltype") + lwidth = clgeti ("lwidth") # width in rel. units + g_dashlen = clgetr ("dashlen") + g_gaplen = clgetr ("gaplen") + g_plwsep = clgetr ("plwsep") + } else if (testoption == 't') { + call clgstr ("tname", tname, SZ_FNAME) + g_plwsep = clgetr ("plwsep") + } else if (testoption == 'm') { + mtype = clgeti ("mtype") + } + call clgstr ("device", devname, SZ_FNAME) + + n = strlen (devname) + if (g_device[1] == EOS) { + call achtsc (devname, Memc[nambuf], n) + Memc[nambuf+n] = EOS + } + iferr (g_tty = ttygdes (Memc[nambuf])) + call erract (EA_ERROR) + g_cc = NULL + call ccp_init (g_tty, Memc[nambuf]) + call ccp_reset () + + g_xndcto_p = 1.0 # for testing, raw data is NDC-space (0-32767) + g_yndcto_p = 1.0 # (that is, after passing through to_short()) + g_ltover = false + g_lwover = true + + pl = CCP_PLAP(g_cc) + pm = CCP_PMAP(g_cc) + + PL_LTYPE(pl) = ltype + PL_WIDTH(pl) = GKI_PACKREAL(lwidth) + PM_LTYPE(pm) = mtype + + gp = gopen (devname, NEW_FILE, STDGRAPH) + sim_gp = gp + call gsview (gp, 0.0, 0.63, 0.0, 1.0) # square viewport + call gswind (gp, 0.0, 32767.0, 0.0, 32767.0) + + switch (testoption) { + + case 'l': # polyline + + call rddata (lname, x, y, npts) # range 0.0-1.0 + call to_short (Memr[x], Memr[y], npts, p) # range 0-32767 + call ccp_polyline (p, npts) + + case 't': # text + + call testtext (gp, tname) # read, calc, call ccppl + + case 'm': # polymarker + + call rddata (lname, x, y, npts) # x,y array of mrkr pos. + do i = 1, npts { + call calcmarker (32767 * Memr[x+i-1], 32767 * Memr[y+i-1], + mtype, p, npts) + call ccp_polymarker (p, npts) + } + } + + call gclose (gp) + call ccp_close () # free g descriptors + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call sfree (sp) +end + +# TO_SHORT -- convert x, y real arrays to short integers as NDC coords + +procedure to_short (x, y, npts, p) + +real x[ARB], y[ARB] +int npts +short p[ARB] + +int i, j + +begin + do i = 1, npts, 1 { + j = (i - 1) * 2 + 1 + p[j] = x[i] * 32767 + p[j+1] = y[i] * 32767 + } + return +end + +# CALCMARKER -- calculate and return a pattern of points representing a +# polymarker of the specified type, origined at x, y. + +procedure calcmarker (x, y, marktype, p, npts) + +real x,y # GKI_NDC coordinates of marker origin +int marktype # polymarker type, specified in GIO specs +short p[ARB] # output array of points defining marker, in GKI_NDC +int npts # no. of points; x,y pairs (= 1/2 elements in p) + +int i, j, m, fill +real xsize, ysize +pointer tx +int and() + +include "ccp.com" +include "/iraf/sys/gio/markers.dat" + +begin + tx = CCP_TXAP(g_cc) + xsize = CCP_CHARHEIGHT(g_cc,1) * GKI_UNPACKREAL(TX_SIZE(tx)) + ysize = xsize # for now + # The point marker type cannot be combined with the other types and + # is treated as a special case. The remaining markers are drawn + # using GUMARK, which draws marks represented as polygons + + if (marktype == GM_POINT || (xsize == 0 && ysize == 0)) { + p[1] = x + p[2] = y + npts = 1 + + } else { + + # The polylines for the standard marks are stored in MPX and MPY + # at offsets MXO and MYO. + fill = NO + npts = 0 + do i = GM_FIRSTMARK, GM_LASTMARK + if (and (marktype, 2 ** i) != 0) { + m = i - GM_FIRSTMARK + 1 + do j = 1, mnpts[m] { + npts = npts + 1 + p[npts*2-1] = x - 0.5 * xsize + xsize * mpx[moff[m]+j-1] + p[npts*2] = y - 0.5 * ysize + ysize * mpy[moff[m]+j-1] + } + } + } +end + + +procedure rddata (fname, x, y, npts) + +char fname[ARB] +pointer x, y +int npts + +int buflen, n, fd, ncols, lineno, i, status, testint +pointer sp, lbuf, ip +real xval, yval, maxy +int getline(), nscan(), open() +errchk open, sscan, getline, malloc + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + buflen = SZ_BUF + iferr { + call malloc (x, buflen, TY_REAL) + call malloc (y, buflen, TY_REAL) + } then + call erract (EA_FATAL) + + n = 0 + ncols = 0 + lineno = 0 + + status = 0 + while (status != EOF) { + iferr (status = getline (fd, Memc[lbuf])) { + call eprintf ("getline error from rddata: status=%d\n") + call pargi (status) + call erract (EA_FATAL) + } + if (status == EOF) + next + # Skip comment lines and blank lines. + lineno = lineno + 1 + if (Memc[lbuf] == '#') + next + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + # Decode the points to be plotted. + call sscan (Memc[ip]) + call gargr (xval) + call gargr (yval) + + # The first line determines whether we have an x,y list or a + # y-list. It is an error if only one value can be decoded when + # processing a two column list. + + if (ncols == 0 && nscan() > 0) + ncols = nscan() + + switch (nscan()) { + case 0: + call eprintf ("no args; %s, line %d: %s\n") + call pargstr (fname) + call pargi (lineno) + call pargstr (Memc[lbuf]) + next + case 1: + yval = xval + default: # normally, ncols=2 + if (ncols != 2) { + call eprintf ("weird data; file %s, line %d: %s\n") + call pargstr (fname) + call pargi (lineno) + call pargstr (Memc[lbuf]) + next + } + } + + n = n + 1 + if (n > buflen) { + buflen = buflen + SZ_BUF + call realloc (x, buflen, TY_REAL) + call realloc (y, buflen, TY_REAL) + } + + Memr[x+n-1] = xval + Memr[y+n-1] = yval + testint = x+n-1 + } + + if (ncols == 1) { + maxy = 0.0 + do i = 1, n + maxy = max (Memr[y+i-1], maxy) + do i = 1, n + Memr[x+i-1] = maxy * real(i) / real(n) + } + call realloc (x, n, TY_REAL) + call realloc (y, n, TY_REAL) + + call close (fd) + call sfree (sp) + npts = n +end + + +# RPTHETA4 -- Polar angle, Real precision, 4 arguments; from p1(x,y) to p2(x,y): +# angle between line segment p1-p2 and horizontal +x axis centered on p1; +# returned in radians; single precision (see pdtheta4). + +real procedure rptheta4 (p1x, p1y, p2x, p2y) + +real p1x,p1y, p2x,p2y # x,y of each point + +real dx, dy, ang + +begin + dx = p2x - p1x + dy = p2y - p1y + if (dx == 0.0) { + if (dy >= 0.0) { + ang = HALFPI + } else { + ang = THREEPIOVER4 + } + } else { + ang = atan (dy / dx) + if (dx < 0.0) { # 2nd or 3rd quadrant + ang = ang + PI + } else if (dy < 0.0) { # 4th quadrant + ang = ang + TWOPI + } + } + return (ang) +end + +# PLOT -- simulate Calcomp's PLOT routine for testing development version of +# calcomp kernel + +procedure plot (x, y, pencode) + +real x,y # plotter coords (ndc in simulation) +int pencode + +real lastp_x, lastp_y + +pointer gp +common /simulate/ gp + +begin + if (pencode == CCP_DOWN) + call gline (gp, lastp_x, lastp_y, x, y) + if (pencode == CCP_DOWN || pencode == CCP_UP) { + lastp_x = x + lastp_y = y + } +end + +# PLOTS -- simulate calcomp plots routine for testing ccp code on vt640 + +procedure plots (dum1, dum2, ldev) + +int dum1, dum2, ldev + +begin + return +end + + +# NEWPEN -- temporary dummy routine for simulating Calcomp + +procedure newpen (whichpen) + +int whichpen + +begin + return +end + +# SYMBOL -- simulate Calcomp's SYMBOL routine for testing development version of +# calcomp kernel + +procedure symbol (xp, yp, size, ch, orien, nchar) + +real xp,yp # plotter coords (ndc in simulation) +real size # char size in plotter coords +char ch[ARB] # chars to be drawn +real orien # degrees counterclockwise from +x to rightward vector +int nchar # number of chars + +pointer gp +common /simulate/ gp + +string format "" + +begin + ch[nchar+1] = EOS + call gseti (gp, G_TXUP, 90 + int(orien)) + call gsetr (gp, G_TXSIZE, size) + call gtext (gp, xp, yp, ch, format) +end + + +# TESTTEXT -- read sequential lines from designated file and call ccp_text to +# draw text at specified coordinates in specified format. + +procedure testtext (gp, fname) + +pointer gp # graphics device +char fname[SZ_FNAME] # name of file from which to extract table + +int fd, textlen, restlen, ip, op +char lbuf[SZ_LINE], ttext[SZ_LINE], rest[SZ_LINE], tformat[SZ_LINE], quote +short sttext[SZ_LINE] +real x,y +int open (), strlen (), getline (), nscan () + +string errmsg "unable to open table file " +data quote/34/ + +begin + iferr (fd = open (fname, READ_ONLY, TEXT_FILE)) { + call sprintf (errmsg[27], SZ_FNAME, "%s") + call pargstr (fname) + call fatal (EA_FATAL, errmsg) + } + + while (getline (fd, lbuf) != EOF) { + # Skip comment lines and blank lines. + if (lbuf[1] == '#') + next + for (ip=1; IS_WHITE(lbuf[ip]); ip=ip+1) + ; + if (lbuf[ip] == '\n' || lbuf[ip] == EOS) + next + + # Decode. + call sscan (lbuf[ip]) + call gargr (x) + call gargr (y) + call gargstr (rest, SZ_LINE) + + if (nscan() < 3) # insufficient fields; ignore line, not nice. + next + + restlen = strlen (rest) + + # Pull out text buffer: + for (ip=1; rest[ip] != quote && ip < restlen; ip=ip+1) #->1st " + ; + op = 0 + for (ip=ip+1; rest[ip] != quote && ip < restlen; ip=ip+1) { + op = op + 1 + ttext[op] = rest[ip]; + } + textlen = op + ttext[op+1] = EOS + + # Pull out format string: + for (ip=ip+1; IS_WHITE(rest[ip]); ip=ip+1) #-> past whitesp + ; + op = 0 + for (; ip <= restlen && !IS_WHITE(rest[ip]); ip=ip+1) { + op = op + 1 + tformat[op] = rest[ip]; + } + tformat[op+1] = EOS + + # set ccp descriptor text attributes if specified: + if (tformat[1] != EOS) + call testxset (tformat) + call achtcs (ttext, sttext, textlen) # ccp_text expects short text + sttext[textlen+1] = EOS + call ccp_text (nint(x), nint(y), sttext, textlen) + } + call close (fd) +end + + +# TESTXSET -- Parse a text drawing format string and set the values of the text +# attributes in the TX (g_cc) output structure. + +procedure testxset (format) + +char format[ARB] # text attribute format string + +pointer tx +char attribute[MAXCH], value[MAXCH] +real tempsize +int ip, op, tip, temp, ch +int h_v[4], v_v[4], f_v[4], q_v[4], p_v[4] +int ctoi(), ctor(), stridx() + +include "ccp.com" + +define badformat_ 91 + +string h_c "nclr" +data h_v /GT_NORMAL, GT_CENTER, GT_LEFT, GT_RIGHT/ +string v_c "nctb" +data v_v /GT_NORMAL, GT_CENTER, GT_TOP, GT_BOTTOM/ +string f_c "rgib" +data f_v /GT_ROMAN, GT_GREEK, GT_ITALIC, GT_BOLD/ +string q_c "nlmh" +data q_v /GT_NORMAL, GT_LOW, GT_MEDIUM, GT_HIGH/ +string p_c "lrud" +data p_v /GT_LEFT, GT_RIGHT, GT_UP, GT_DOWN/ + +begin + # ccp kernel text descriptor: + tx = CCP_TXAP(g_cc) + + # Parse the format string and set the text attributes. The code is + # more general than need be, i.e., the entire attribute name string + # is extracted but only the first character is used. Whitespace is + # permitted and ignored. + + for (ip=1; format[ip] != EOS; ip=ip+1) { + # Extract the next "attribute=value" construct. + while (IS_WHITE (format[ip])) + ip = ip +1 + + op = 1 + for (ch=format[ip]; ch != EOS && ch != '='; ch=format[ip]) { + if (op <= MAXCH) { + attribute[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + } + attribute[op] = EOS + + if (ch == '=') + ip = ip + 1 + + op = 1 + while (IS_WHITE (format[ip])) + ip = ip +1 + ch = format[ip] + while (ch != EOS && ch != ';' && ch != ',') { + if (op <= MAXCH) { + value[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + ch = format[ip] + } + value[op] = EOS + + if (attribute[1] == EOS || value[1] == EOS) + break + + # Decode the assignment and set the corresponding text attribute + # in the graphics descriptor. + + switch (attribute[1]) { + case 'u': # character up vector + tip = 1 + if (ctoi (value, tip, TX_UP(tx)) <= 0) { + TX_UP(tx) = 90 + goto badformat_ + } + + case 'p': # path + temp = stridx (value[1], p_c) + if (temp <= 0) + goto badformat_ + else + TX_PATH(tx) = p_v[temp] + + case 'c': # color + tip = 1 + if (ctoi (value, tip, TX_COLOR(tx)) <= 0) { + TX_COLOR(tx) = 1 + goto badformat_ + } + + case 's': # character size scale factor + tip = 1 + if (ctor (value, tip, tempsize) <= 0) { + TX_SIZE(tx) = GKI_PACKREAL(1.0) + goto badformat_ + } + TX_SIZE(tx) = GKI_PACKREAL(tempsize) + + case 'h': # horizontal justification + temp = stridx (value[1], h_c) + if (temp <= 0) + goto badformat_ + else + TX_HJUSTIFY(tx) = h_v[temp] + + case 'v': # vertical justification + temp = stridx (value[1], v_c) + if (temp <= 0) + goto badformat_ + else + TX_VJUSTIFY(tx) = v_v[temp] + + case 'f': # font + temp = stridx (value[1], f_c) + if (temp <= 0) + goto badformat_ + else + TX_FONT(tx) = f_v[temp] + + case 'q': # font quality + temp = stridx (value[1], q_c) + if (temp <= 0) + goto badformat_ + else + TX_QUALITY(tx) = q_v[temp] + + default: +badformat_ call eprintf ("Warning (testtxset): bad gtext format '%s'\n") + call pargstr (format) + } + + if (format[ip] == EOS) + break + } +end diff --git a/sys/gio/calcomp/x_calcomp.x b/sys/gio/calcomp/x_calcomp.x new file mode 100644 index 00000000..32c82aa2 --- /dev/null +++ b/sys/gio/calcomp/x_calcomp.x @@ -0,0 +1,3 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task calcomp = t_calcomp diff --git a/sys/gio/cursor/README b/sys/gio/cursor/README new file mode 100644 index 00000000..6534b497 --- /dev/null +++ b/sys/gio/cursor/README @@ -0,0 +1,9 @@ +This directory contains the source for GIOTR and cursor mode, i.e., the code +required to process the graphics output of a graphics task, spooling and/or +applying the workstation transformation and passing the transformed metacode +instructions on to the builtin STDGRAPH kernel or to an external kernel. The +procedure RCURSOR is the main entry point for cursor mode. RCURSOR is called +by the CL to service a query for a cursor type parameter when query mode is +in effect. The workstation transformation is used to zoom and pan on a frame +buffer and consists of a viewport transformation in GKI coordinates with +clipping at the viewport boundary. diff --git a/sys/gio/cursor/doc/cursor.hlp b/sys/gio/cursor/doc/cursor.hlp new file mode 100644 index 00000000..d9912607 --- /dev/null +++ b/sys/gio/cursor/doc/cursor.hlp @@ -0,0 +1,194 @@ +.help GIO Mar85 "Cursor Mode" +.nh 3 +Cursor Mode + + In cursor mode, i.e., after a call to \fBclgcur\fR or after typing "=gcur", +a number of special keystrokes shall be recognized for interactive display +control. All graphics output to stdgraph and stdimage is routed through the +CL on the way to the graphics kernel. The CL will optionally spool in an +internal buffer all graphics instructions output to an interactive device. +This internal buffer is emptied whenever the device screen is cleared. +In cursor mode, special keystrokes may be used to redraw all or any portion +of the spooled graphics, e.g., one may zoom in on a portion of the plot and +then roam about on the plot at high magnification. Since the spooled graphics +vectors typically contain more information than can be displayed at normal +magnification, zooming in on a feature may bring out additional detail +(the maximum resolution is 32768 points in either axis). Increasing the +magnification will increase the precision of the cursor by the same factor. + +Cursor mode is implemented by performing coordinate transformation and +clipping on each GKI instruction in the frame buffer, passing the transformed +and clipped instructions on to the graphics kernel. +The cursor mode operations perform a simple geometric transformation on +the spooled graphics frame, mapping a rectangular window of the spooled +frame onto the device screen. The graphics frame itself is not modified, +hence zoom out or reset and redraw will restore the original display. + +If the graphics frame is a typical vector plot with drawn and labeled +axes, magnifying a portion of the plot may cause the axes to be lost. +If this is not what is desired a keystroke is provided to draw and label +the axes of the displayed window. The axes will be overplotted on the +current display and will not be saved in the frame buffer, hence they +will be lost when the frame is redrawn. In cursor mode the viewport is +the full display area of the output device, hence the tick mark labels +of the drawn axes will be drawn inside the viewport. This form of axes +labeling is used because it is simple and because it is appropriate for +both vector graphics and image display output devices (and cursor mode +must serve both). + +The cursor mode keystrokes are all upper case letters, reserving lower case +for applications programs. The terminal shift lock key may be used to +minimize typing. The recognized cursor mode keystrokes are shown below. + + +.ks +.nf +(*X* means not yet implemented) + + ? print list of keystrokes + *A* draw and label the axes of current viewport + C print the cursor position as it moves + *D* draw a line by marking the endpoints + E expand plot by setting window corners + F set fast cursor (for HJKL) + H step cursor left + J step cursor down + K step cursor up + L step cursor right + M move point under cursor to center of screen + P zoom out (restore previous expansion) + *S* select WCS at current position of cursor + *T* draw a text string + *U* undo (delete) the last instruction in the frame buffer + V set slow cursor (for HJKL) + X zoom in, X only + Y zoom in, Y only + Z zoom in, both X and Y + < set lower limit of plot to the cursor y value + > set upper limit of plot to the cursor y value + *\* escape next character + : set cursor mode options + :! send a command to the host system + 0 reset and redraw + 1-9 roam + +.fi +.ce +Figure 2. Cursor Mode Keystrokes +.ke + + +The numeric keypad of the terminal (if it has one) is used for directional +roaming. The directional significance of the numeric keys for roaming +is obvious if the terminal has a keypad, and is illustrated below. + + +.ks +.nf + 7 8 9 135 090 045 + + 4 5 6 180 000 000 + + 1 2 3 225 -90 -45 +.fi +.ke + + +If the character : is typed while in cursor mode the alpha cursor will appear +at the bottom of the screen, allowing a command line to be entered. If the +command \fIbegins with a period it is interpreted as a cursor mode command\fR, +otherwise the command is passed as a string to the applications program. +Multiple commands may be entered on a line delimited by semicolons. +The command set currently recognized is shown below. Minimum match +abbreviations are permitted. + +.ls 4 +.ls 15 help +Print a list of the cursor mode commands. +.le +.ls case[+-] +Ignore case when interpreting keystrokes. If this option is selected the cursor +mode keystrokes may conflict with those of the applications program. +.le +.ls clear +Clear the alpha screen (but not the graphics screen). This is done by writing +sufficient blank lines to scroll any text off the screen. Does not work if +terminal has only one memory. +.le +.ls markcur[+-] +Draw a small graphics mark at the position of the cursor whenever the cursor +is read, i.e., when cursor mode exits. The default is to not mark. +.le +.ls off [keys] +Disable all cursor mode keystrokes except : (colon). If followed by a list +of keys, e.g., ":.off 0-9IC", only the listed keys are disabled. +.le +.ls on [keys] +Renable all cursor mode keystrokes, or just the listed keystrokes. +.le +.ls page[+-] +Clear the screen when large blocks of text are to be printed, e.g., for '?', +show, and so on. If paging is disabled the text will overwrite the graphics +display. +.le +.ls read +Load the graphics frame from the named metafile. +The current graphics frame is discarded. +.le +.ls reset +Disconnect any connected graphics kernels and free all file descriptors and +memory used by the graphics system. Exit cursor mode. +.le +.ls show +Print the values of all cursor mode parameters, show the status of any +connected graphics kernels, summarize memory utilization, etc. +.le +.ls snap [device] +Dispose of the graphics frame to the standard plotter or to the named device. +A magnified graph will be plotted as it appears on the screen. +.le +.ls txset [size] [up] +Set the text drawing parameters (character size and character up vector). +For example, ".tx 2 180" would set the character size to 2.0 and character +up to 180 degrees for a vertical string drawn upwards. +.le +.ls write +Save the graphics frame in (or append to) the named metafile. +If an exclamation is appended to the command (e.g., "w! file") the output +file, if any, will be overwritten. If a plus sign is appended the entire +frame will be saved regardless of any plot expansion. +.le +.ls xres=N +Set the (soft) device resolution in X. A decrease in resolution will generally +yield an increase in plotting speed. Only plots generated on the graphics +terminal are affected. +.le +.ls yres=N +Set the (soft) device resolution in Y. +.le +.ls zero +Equivalent to the numeric key 0, i.e., restore the unitary workstation +transformation and redraw the screen. +.le +.le + + +For example, to set the X and Y resolutions to 250 and 100, respectively, +one could enter the following command (the computer will type the ':' at +the bottom of the screen when the ':' key is pressed): + + :.xres=250;yres=100 + +Cursor mode may be initialized at login time by supplying a CL environment +variable named "cminit". For example, + + cl> set cminit = off + +would disable cursor mode, and + + cl> set cminit = "mark;case-;xres=100;yres=50" + +would enable marking, turn off case sensitivity, and set the plotting +resolution to 100x50. Initialization is performed only once, when cursor +mode is first entered. +.sh diff --git a/sys/gio/cursor/doc/giotr.notes b/sys/gio/cursor/doc/giotr.notes new file mode 100644 index 00000000..a9221445 --- /dev/null +++ b/sys/gio/cursor/doc/giotr.notes @@ -0,0 +1,330 @@ +.help GIO Feb85 "Graphics I/O" +.nh +Graphics I/O Dataflow + + The GIO procedures are resident in an external applications task which +does graphics. GIO writes a GKI instruction stream which, if not sent directly +to a metafile, is sent to one of the standard graphics streams STDGRAPH, +STDIMAGE, or STDPLOT, much as output is sent to STDOUT or STDERR. +The procedure \fBprfilbuf\fR (directory etc$), which reads the command +stream from a subprocess, is resident in the CL and executes all pseudofile +i/o instructions from a subprocess. Note that \fBprfilbuf\fR is part of the +i/o system of IRAF and operates transparently to the CL. + + +.ks +.nf + GIO(task) ---ipc--> PRFILBUF(CL) --> file (or pipe) + | + v external + GIOTR ---ipc--> graphics + | kernel + v + stdgraph kernel + | + v + (zfioty) + graphics terminal + + + task | cl | task +.fi + +.ce +Graphics Output Dataflow +.ke + + +The \fBprfilbuf\fR procedure passes record read or write requests for the +pseudofiles STDIN, STDOUT or STDERR on to file descriptors assigned by the +CL with the \fBprredir\fR procedure at task execution time. The sole function +of the CL in graphics i/o is to control the redirection of the graphics +i/o streams with \fBprredir\fR. The CL may redirect any of the graphics +streams, i.e., the user may redirect any graphics stream on the command line +when a command is entered, but by default output is directed to a filter +resident in the CL process. This filter is a procedure named \fBgiotr\fR. + + giotr (stream, buffer, nchars) + +The primary function of GIOTR is to pass metacode instructions on to a kernel. +The instruction stream is scanned and special actions are taken for some of +the GKI control instructions. In particular, GIOTR must spawn graphics kernel +subprocesses upon demand. GIOTR is also capabable of performing an +additional transformation upon the drawing instructions before they are passed +to the kernel. This transformation, known as the \fBworkstation +transformation\fR, maps a rectangular portion of the NDC space into the full +device screen, clipping at the boundary of the viewport into NDC space. +The workstation transformation provides a zoom and pan capability and is +controlled interactively by the user in \fBcursor mode\fR (section 3.3). + +As noted earlier, the \fBstdgraph kernel\fR ("fast" kernel) is resident in +the CL process. This is necessary for efficiency reasons and is desirable +in any case because the CL process owns the graphics device, i.e., the +graphics terminal. All devices except the user's graphics terminal are +controlled by external graphics kernel processes. The STDGRAPH kernel is +itself available as an external process and may be called as such to drive +a graphics terminal other than the user terminal (or even to drive the user +terminal if one is willing to shuffle output back through IPC). A graphics +kernel may support an arbitrary number of devices, and may write to more +than one device simultaneously. In addition to being called by GIOTR, +a graphics kernel may be called directly as a CL task to process metacode from +either a file or the standard input, e.g., from a pipe. This offers +additional flexibility as the CL parameter mechanism may then be used to +gain control over metacode translation. + +.nh 2 +Graphics Stream I/O + + The functions performed by GIOTR are summarized in pseudocode below. +GIOTR maintains a separate descriptor for each of the three graphics streams +and is capable of servicing intermixed i/o requests for all streams +simultaneously. The information stored in the descriptor +includes the workstation name, process information, WCS storage for +the SETWCS and GETWCS instructions, the workstation transformation, +and the frame buffer, used to spool GKI instructions for cursor mode. + + +.tp 6 +.nf +procedure giotr (fd, buffer, nchars) + +fd graphics stream (STDGRAPH, etc.) +buffer[] buffer containing GKI metacode instructions +nchars number of chars to be read or written + +begin + # Note that a GKI instruction may span a buffer boundary. + # The code which gets the next instruction from the buffer + # must always return a full instruction, hence some local + # buffering is required therein to reconstruct instructions. + + while (get next instruction != buffer empty) { + + # Handle special instructions. + switch (instruction) { + + case GKI_OPENWS: + if (device not already open) { + read graphcap entry for device + get process name from graphcap entry + if (process not already connected) { + if (some other process is connected) + disconnect current kernel process + connect new kernel process + } + } + output instruction + flush output + clear frame buffer + + case GKI_CLOSEWS, GKI_FLUSH: + output instruction + flush output + + case GKI_CANCEL: + output instruction + flush output + clear frame buffer + + case GKI_SETWCS: + save WCS in descriptor + + case GKI_GETWCS: + write saved WCS to fd + flush (fd) + + default: + append unmodified instruction to frame buffer + perform workstation transformation upon instruction + output transformed instruction + } + } +end +.fi + + +The action implied by "output instruction" above is the following: + + +.ks +.nf + if (kernel is resident in this process) + call gki_execute to execute the instruction + else + call write (process, instruction, nchars) +.fi +.ke + + +The frame buffer (required for cursor mode) will be dynamically allocated and +will be no larger than it has to be, but will have a fixed (user defined) +upper limit, e.g., 128Kb. The median size for a plot is typically 5-10Kb. +Instructions will be silently discarded if the buffer grows too large. +Buffering can be turned off completely if desired, and will always be turned +off for STDPLOT. + +.nh 2 +Cursor Mode Details + + Most of the functionality required to implement cursor mode is provided +by GIOTR. The primary functions of the cursor mode code are to read the +cursor and keystroke, modify the workstation transformation, and redraw the +contents of the frame buffer subject to the new workstation transformation. +Cursor mode does not modify the contents of the frame buffer, except for +possibly appending new graphics instructions to the frame buffer. +A workstation transformation set with cursor mode remains in effect until +the frame buffer is cleared, hence any additional graphics output from the +task which initiated the cursor read (and cursor mode) will undergo the +workstation transformation when drawn. + + +.nf +# PR_FILBUF -- Fill FIO buffer from an IPC channel subject to the CL/IPC +# protocol for multiplexing pseudofile data streams with the command stream. +# Each process has an associated set of pseudofile streams. Each pseudofile +# stream is connected to one, and only one, file or pseudofile of another +# process. I/O requests to XMIT or XFER to an ordinary file are straightforward +# to satisfy. An i/o request from one pseudofile to another is satisfied +# by posting the request (pushing it on a stack) and redirecting our input +# to the process owning the pseudofile being read or written. Pseudofile +# requests are then processed from the second process until a request is +# received which satisfies the posted request from the original process. +# When the original request is satisfied it is popped from the stack and input +# will again be taken from the original process. Note that we cannot write +# directly to the output process since that would violate the IPC protocol +# (the second process may wish to write to its stdout or stderr rather than +# read, etc.: the process must be allowed to complete the original request +# itself). +# +# Request Packet (pushed onto stack for IPC to IPC i/o). +# +# pr process slot number of process placing the request +# iomode request is a read or a write +# count number of chars to be transferred +# ps_server pseudofile number in server process +# ps_receiver pseudofile number in receiver process +# +# The request packet describes a pending pseudofile i/o request. The named +# pseudofile in the server process is either reading from or writing to the +# named pseudofile in the receiver process. + +int procedure pr_filbuf (fd) + +begin + input = fd (the IPC input channel of a process) + + repeat { + get a line from the input file + if (neither XMIT nor XFER directive) + if (request pending) + error: IPC protocol corrupted + else + return command + + if (line is an XMIT directive) { + if (destination is a file) { + # Write from pseudofile to an ordinary file. + get data record from input + write data record to file + + } else { + # Write from pseudofile to another pseudofile. + if (XMIT satisfies XFER request on top of stack) + get data record from input + write record to stacked process + restore input to stacked process + pop request from stack + + } else { + # If writing to local kernel GIOTR will return a null + # length record and we are done. + + get data record from input + if (writing to a graphics stream) + call giotr filter to transform record + if (anything left to output) { + push request on stack + switch input to IPC input of receiver process + } + } + } + + } else if (line is an XFER directive) { + if (source is an ordinary file) { + # Read from a file. + read data record from file + write to active process + + } else if (source is another process) { + # Read from another pseudofile. + if (XFER satisfies XMIT request on top of stack) { + read record from stacked process + write to active process + restore input to stacked process + pop request from stack + } else { + push request on stack + switch input to IPC input channel of receiver process + } + } + } + } +end + + +# GIOTR -- Graphics i/o filter. + +procedure giotr (fd, buffer, nchars) + +fd graphics stream (STDGRAPH, etc.) +buffer[] buffer containing GKI metacode instructions +nchars number of chars to be read or written + +begin + # Note that a GKI instruction may span a buffer boundary. + # The code which gets the next instruction from the buffer + # must always return a full instruction, hence some local + # buffering is required therein to reconstruct instructions. + + while (buffer not empty) { + + # Handle special instructions. + switch (next_instruction) { + + case GKI_OPENWS: + if (device not already open) { + read graphcap entry for device + get process name from graphcap entry + if (process not already connected) { + if (some other process is connected) + disconnect current kernel process + connect new kernel process + } + } + output instruction + flush output + clear frame buffer + + case GKI_CLOSEWS, GKI_FLUSH: + output instruction + flush output + + case GKI_CANCEL: + output instruction + flush output + clear frame buffer + + case GKI_SETWCS: + save WCS in descriptor + + case GKI_GETWCS: + write saved WCS to fd + flush (fd) + + default: + append unmodified instruction to frame buffer + perform workstation transformation upon instruction + output transformed instruction + } + } +end diff --git a/sys/gio/cursor/giotr.x b/sys/gio/cursor/giotr.x new file mode 100644 index 00000000..cfc8f706 --- /dev/null +++ b/sys/gio/cursor/giotr.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" + +# GIOTR -- A graphics filter, called by PR_PSIO (during normal graphics output) +# and RCURSOR (when in cursor mode) to perform the workstation transformation +# on a block of metacode instructions, writing the individual instructions to +# either the inline stdgraph kernel or to an external kernel. Input is taken +# from the frame buffer for the stream. All full instructions starting at the +# input pointer IP and ending at the output pointer OP are processed, leaving +# the input pointer positioned to BOI of the last (and incomplete) instruction +# in the frame buffer. If output is to an inline kernel the kernel is called +# to execute each instruction as it is extracted. If output is to an external +# kernel instructions are written to the named stream, i.e., into the FIO +# buffer associated with the stream, and later transferred to the kernel in the +# external process when the process requests input from the named stream in an +# XFER directive (see PR_PSIO). + +procedure giotr (stream) + +int stream # graphics stream + +pointer tr, gki +int jmpbuf[LEN_JUMPBUF], fn +int mode, xint, status, junk, nwords +common /gtrvex/ jmpbuf + +pointer gtr_init(), coerce() +extern giotr_onint(), gtr_delete() +int gtr_fetch_next_instruction(), locpr() +errchk gtr_init, gtr_fetch_next_instruction, gki_write +data status /OK/, xint /NULL/ +include "gtr.com" + +begin + tr = gtr_init (stream) + + # If an interrupt occurs while GIOTR is executing output is cancelled + # and further processing is disabled until the next frame begins. + + if (xint == NULL) + call xwhen (X_INT, locpr(giotr_onint), xint) + + call zsvjmp (jmpbuf, status) + if (status != OK) { + call gki_cancel (stream) + call gki_deactivatews (stream, 0) + } + + # Fetch, optionally transform, and execute each metacode instruction + # in the frame buffer. + + while (gtr_fetch_next_instruction (tr, gki) != EOF) { + switch (Mems[gki+GKI_HDR_OPCODE-1]) { + + case GKI_OPENWS: + mode = Mems[gki+GKI_OPENWS_M-1] + if (mode != APPEND) + status = OK + + if (status == OK) { + # If the open instruction has already been passed to the + # kernel by gtr_control, do not do so again here. + + if (TR_SKIPOPEN(tr) == YES) + TR_SKIPOPEN(tr) = NO + else + call gki_write (stream, Mems[gki]) + + # gtr_control does not call gki_escape so always do this. + call gki_escape (stream, GKI_OPENWS, 0, 0) + + # Discard frame buffer contents up to and including the + # openws instruction, so that it will only be executed + # once. + + if (Mems[gki+GKI_OPENWS_M-1] == NEW_FILE) + call gtr_frame (tr, TR_IP(tr), stream) + } + + case GKI_CLOSEWS, GKI_DEACTIVATEWS, GKI_REACTIVATEWS: + # These instructions are passed directly to the kernel via + # the PSIOCTRL stream at runtime, but are ignored in metacode + # to avoid unnecessary mode switching of the terminal. + ; + + case GKI_CANCEL: + # Cancel any buffered graphics data. + call gki_write (stream, Mems[gki]) + call gtr_frame (tr, TR_IP(tr), stream) + + case GKI_FLUSH, GKI_GETCURSOR, GKI_GETCELLARRAY: + # Do not buffer these instructions. + call gki_write (stream, Mems[gki]) + call gtr_delete (tr, gki) + + case GKI_CLEAR: + # Clear is special because it initializes things. + if (status != OK) { + call gki_reactivatews (stream, 0) + status = OK + } + # Execute the instruction. + call gki_write (stream, Mems[gki]) + call gki_escape (stream, GKI_CLEAR, 0, 0) + + # Discard frame buffer contents up to and including the clear. + call gtr_frame (tr, TR_IP(tr), stream) + + case GKI_SETWCS: + call gki_write (stream, Mems[gki]) + nwords = Mems[gki+GKI_SETWCS_N-1] + call amovs (Mems[gki+GKI_SETWCS_WCS-1], + Mems[coerce (TR_WCSPTR(tr,1), TY_STRUCT, TY_SHORT)], + min (nwords, LEN_WCS * MAX_WCS * SZ_STRUCT / SZ_SHORT)) + + case GKI_ESCAPE: + if (status == OK) { + fn = Mems[gki+GKI_ESCAPE_FN-1] + + # Execute the escape instruction. + if (wstranset == YES) { + call sge_wstran (fn, Mems[gki+GKI_ESCAPE_DC-1], + vx1,vy1, vx2,vy2) + } else + call gki_write (stream, Mems[gki]) + + # Allow the kernel escape handling code to preserve, + # delete, or edit the instruction. + + call sge_spoolesc (tr, gki, fn, Mems[gki+GKI_ESCAPE_DC-1], + TR_FRAMEBUF(tr), TR_OP(tr), locpr(gtr_delete)) + } + + default: + if (status == OK) + if (wstranset == YES) { + # Perform the workstation transformation and output the + # transformed instruction, if there is anything left. + call gtr_wstran (Mems[gki]) + } else + call gki_write (stream, Mems[gki]) + } + } + + # Clear the frame buffer if spooling is disabled. This is done by + # moving the upper part of the buffer to the beginning of the buffer, + # starting with the word pointed to by the second argument, preserving + # the partial instruction likely to be found at the end of the buffer. + # Truncate the buffer if it grows too large by the same technique of + # shifting data backwards, but in this case without destroying all + # of the data. + + if (TR_SPOOLDATA(tr) == NO) + call gtr_frame (tr, TR_IP(tr), stream) + else if (TR_OP(tr) - TR_FRAMEBUF(tr) > TR_MAXLENFRAMEBUF(tr)) + call gtr_truncate (tr, TR_IP(tr)) + + # Pop the interrupt handler. + if (xint != NULL) { + call xwhen (X_INT, xint, junk) + xint = NULL + } +end + + +# GIOTR_ONINT -- Interrupt handler for GIOTR. + +procedure giotr_onint (vex, next_handler) + +int vex # virtual exception +int next_handler # next exception handler in chain +int jmpbuf[LEN_JUMPBUF] +common /gtrvex/ jmpbuf + +begin + call xer_reset() + call zdojmp (jmpbuf, vex) +end diff --git a/sys/gio/cursor/grc.h b/sys/gio/cursor/grc.h new file mode 100644 index 00000000..35af451f --- /dev/null +++ b/sys/gio/cursor/grc.h @@ -0,0 +1,20 @@ +# GRC.H -- Global definitions and data structures for the RCURSOR (cursor read) +# procedures. + +define KEYSFILE "lib$scr/cursor.key" +define KEYSTROKES "ABCDEFHJKLMPRTUVWXYZ<>0123456789:=" +define MAX_KEYS 128 +define LEN_RCSTRUCT (10+(128/SZ_STRUCT)) + +define RC_CASE Memi[$1] # case sensitive +define RC_MARKCUR Memi[$1+1] # mark cursor +define RC_PHYSOPEN Memi[$1+2] # physical open by rcursor +define RC_AXES Memi[$1+3] # draw axes if screen redrawn + # (open) +define RC_KEYS Memc[P2C($1+10)+$2] # keystroke mappings + +define LEN_CT 2,4 +define CT_TRAN 1 +define CT_SCALE 2 +define CT_WORIGIN 3 +define CT_MORIGIN 4 diff --git a/sys/gio/cursor/grcaxes.x b/sys/gio/cursor/grcaxes.x new file mode 100644 index 00000000..f2f69e4f --- /dev/null +++ b/sys/gio/cursor/grcaxes.x @@ -0,0 +1,402 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" +include "grc.h" + +define LEN_POLYLINE 128 # polyline for axes and ticks +define NTICKS 6 # default rough ticks on an axis +define SZ_TICKFORMAT 6 # "%0.Xg" +define SZ_TICKLABEL 10 # encoded tick label +define TICKLEN 0.03 # tick length, ndc units +define LABELOFFSET 1.5 # offset to tick label in ticklen units + + +# GRC_AXES -- Draw and label the axes of the viewport. This is a simple +# routine not intended to be competitive with GLABAX. We draw a box around +# the edge of the screen, find and label the ticks within the plotting area. + +procedure grc_axes (stream, sx, sy, raster, rx, ry) + +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor + +char tickformat[SZ_TICKFORMAT], ticklabel[SZ_TICKLABEL] +pointer tr, w, ap, save_op +int xt, yt, nwords, nticks, wcs, lt_save +real xb, xe, x1, dx, x, y, lw_save +real yb, ye, y1, dy, aspect_ratio, xticklen, yticklen + +int gt_ndigits() +pointer gtr_init() +real ttygetr() + +errchk gtr_init, ttygetr, realloc, gax_start +include "gtr.com" + +begin + tr = gtr_init (stream) + + # Draw the axes with a solid polyline of width 2.0. + ap = TR_PLAP(tr) + lt_save = PL_LTYPE(ap); PL_LTYPE(ap) = GL_SOLID + lw_save = PL_WIDTH(ap); PL_WIDTH(ap) = 2.0 + + # Select a WCS. + call grc_scrtowcs (stream, sx, sy, raster, rx, ry, x1, y1, wcs) + w = TR_WCSPTR(tr,wcs) + + # Get the coordinates of the axes corners and the tick parameters. + call gax_findticks (w, xb,xe,yb,ye, x1,dx,xt, y1,dy,yt) + + # Mark the position in the frame buffer. The axes drawing instructions + # will be appended to the frame buffer by the drawing routines. When + # we get all done we will move these instructions to the scratch buffer + # and reset the frame buffer pointers, since we do not want the axes + # to be a permanent part of the plot. + + save_op = TR_OP(tr) + + # Compute the X and Y tick lengths in NDC coordinates, corrected for + # the aspect ratio and workstation transformation. + + aspect_ratio = ttygetr (TR_TTY(tr), "ar") + if (aspect_ratio < .001) + aspect_ratio = 1.0 + xticklen = TICKLEN / xscale * aspect_ratio + yticklen = TICKLEN / yscale + + # Construct the polyline to draw the first two axes and ticks. We + # start at the lower left and draw to the lower right then upper right. + + nticks = int ((xe - xb) / dx) # Bottom axis. + call gax_start (xb, yb) + call gax_draw (x1, yb) + call gax_tick (0., yticklen) + + for (x=x1+dx; nticks > 0; nticks=nticks-1) { + call gax_draw (min(x,xe), yb) + call gax_tick (0., yticklen) + x = x + dx + } + + nticks = int ((ye - yb) / dy) # Right axis. + call gax_draw (xe, yb) + call gax_draw (xe, y1) + call gax_tick (-xticklen, 0.) + + for (y=y1+dy; nticks > 0; nticks=nticks-1) { + call gax_draw (xe, min(y,ye)) + call gax_tick (-xticklen, 0.) + y = y + dy + } + + call gax_draw (xe, ye) + call gax_flush (stream) + + # Construct the polyline to draw the second two axes and ticks. We + # start at the lower left and draw to the upper left then upper right. + + nticks = int ((ye - yb) / dy) # Left axis. + call gax_start (xb, yb) + call gax_draw (xb, y1) + call gax_tick (xticklen, 0.) + + for (y=y1+dy; nticks > 0; nticks=nticks-1) { + call gax_draw (xb, min(y,ye)) + call gax_tick (xticklen, 0.) + y = y + dy + } + + nticks = int ((xe - xb) / dx) # Top axis. + call gax_draw (xb, ye) + call gax_draw (x1, ye) + call gax_tick (0., -yticklen) + + for (x=x1+dx; nticks > 0; nticks=nticks-1) { + call gax_draw (min(x,xe), ye) + call gax_tick (0., -yticklen) + x = x + dx + } + + call gax_draw (xe, ye) + call gax_flush (stream) + + # Label the ticks on the bottom axis. The tick labels are centered + # just above each tick. + + nticks = int ((xe - xb) / dx) + 1 + call sprintf (tickformat, SZ_TICKFORMAT, "%%0.%dg") + call pargi (max (1, gt_ndigits (xb, xe, dx)) + 1) + + for (x=x1; nticks > 0; nticks=nticks-1) { + call glb_encode (x, ticklabel, SZ_TICKLABEL, tickformat, dx) + call gax_ndc (x, yb, sx, sy) + call gax_text (stream, sx, sy + (yticklen * LABELOFFSET), + ticklabel, GT_CENTER, GT_BOTTOM) + x = x + dx + } + + # Label the ticks on the left axis. The tick labels are left justified + # just to the right of each tick. + + nticks = int ((ye - yb) / dy) + 1 + call sprintf (tickformat, SZ_TICKFORMAT, "%%0.%dg") + call pargi (max (1, gt_ndigits (yb, ye, dy)) + 1) + + for (y=y1; nticks > 0; nticks=nticks-1) { + call glb_encode (y, ticklabel, SZ_TICKLABEL, tickformat, dy) + call gax_ndc (xb, y, sx, sy) + call gax_text (stream, sx + (xticklen * LABELOFFSET), sy, + ticklabel, GT_LEFT, GT_CENTER) + y = y + dy + } + + # Restore the default polyline attributes. + PL_LTYPE(ap) = lt_save + PL_WIDTH(ap) = lw_save + + # Move the axes drawing and labelling instructions to the scratch + # buffer and fix up the frame buffer pointers. + + nwords = TR_OP(tr) - save_op + if (nwords > TR_LENSCRATCHBUF(tr)) { + call realloc (TR_SCRATCHBUF(tr), nwords, TY_SHORT) + TR_LENSCRATCHBUF(tr) = nwords + } + + call amovs (Mems[save_op], Mems[TR_SCRATCHBUF(tr)], nwords) + TR_OPSB(tr) = TR_SCRATCHBUF(tr) + nwords + TR_OP(tr) = save_op + TR_IP(tr) = save_op + TR_LASTOP(tr) = save_op +end + + +# GAX_FINDTICKS -- Get the coordinates of the endpoints of the axes, the first +# tick on each axis, and the tick spacing on each axis. If log scaling is in +# use on an axis we shall work in log coordinate units, which are linear. + +procedure gax_findticks (w, wx1,wx2,wy1,wy2, x1,dx,xt, y1,dy,yt) + +pointer w # window descriptor +real wx1,wx2,wy1,wy2 # endpoints of axes +real x1,dx # tick start and spacing in X +int xt # type of scaling in X +real y1,dy # tick start and spacing in Y +int yt # type of scaling in Y + +pointer wp +real ct[LEN_CT] +common /ftkgcm/ wp, ct + +real sx1, sx2, sy1, sy2 +real elogr() + +begin + wp = w + + # Set up WCS/NDC coordinate transformations. + call grc_settran (w, ct) + + # Get NDC coords of the corners of the screen. + call grc_scrtondc (0.001, 0.001, sx1, sy1) + call grc_scrtondc (0.999, 0.999, sx2, sy2) + + # Move in a bit if the graphics viewport lies within the screen area. + # This depends upon the workstation transformation, of course. + sx1 = max (WCS_SX1(w), sx1) + sx2 = min (WCS_SX2(w), sx2) + sy1 = max (WCS_SY1(w), sy1) + sy2 = min (WCS_SY2(w), sy2) + + # Compute world coordinates of the viewport (of the axes to be drawn). + call grc_ndctowcs (ct, sx1, sy1, wx1, wy1) + call grc_ndctowcs (ct, sx2, sy2, wx2, wy2) + + # Find the ticks. If log scaling is in use on an axis we shall find + # and draw the ticks in log coordinates. + + switch (WCS_XTRAN(w)) { + case GW_LOG: + wx1 = log10 (wx1) + wx2 = log10 (wx2) + case GW_ELOG: + wx1 = elogr (wx1) + wx2 = elogr (wx2) + } + call gtickr (wx1, wx2, NTICKS, NO, x1, dx) + + switch (WCS_YTRAN(w)) { + case GW_LOG: + wy1 = log10 (wy1) + wy2 = log10 (wy2) + case GW_ELOG: + wy1 = elogr (wy1) + wy2 = elogr (wy2) + } + call gtickr (wy1, wy2, NTICKS, NO, y1, dy) + + xt = WCS_XTRAN(w) + yt = WCS_YTRAN(w) +end + + +# GAX_NDC -- Convert a pair of world or log-world coordinates to NDC +# coordinates. GAX_FINDTICKS must be called first to set up transformation. + +procedure gax_ndc (wx, wy, sx, sy) + +real wx, wy # world coords (input) +real sx, sy # ndc coords (output) + +pointer wp +real ct[LEN_CT] +common /ftkgcm/ wp, ct + +real x, y +real aelogr() + +begin + # Get X in world coordinates. + switch (WCS_XTRAN(wp)) { + case GW_LOG: + x = 10.0 ** wx + case GW_ELOG: + x = aelogr (wx) + default: + x = wx + } + + # Get Y in world coordinates. + switch (WCS_YTRAN(wp)) { + case GW_LOG: + y = 10.0 ** wy + case GW_ELOG: + y = aelogr (wy) + default: + y = wy + } + + # Transform to NDC coordinates and return. + call grc_wcstondc (ct, x, y, sx, sy) +end + + +# GAX_DRAW -- Add a point to the output polyline for an axis. The polyline +# is built up in NDC coordinates for output to GTR_POLYLINE. In addition to +# the draw routine, entry points are provided for start, flush, and tick +# drawing. + +procedure gax_draw (wx, wy) + +real wx, wy # world or log-world coords to draw to +real sx, sy +pointer polyline, op +common /gaxdcm/ polyline, op + +begin + # Transform to NDC coords and add the point to the polyline. + call gax_ndc (wx, wy, sx, sy) + Memr[op] = sx + op = op + 1 + Memr[op] = sy + op = op + 1 +end + + +# GAX_TICK -- Draw a tick at the current position. The offsets to draw the +# tick are given in NDC coordinates. + +procedure gax_tick (dx, dy) + +real dx, dy # tick offset in NDC coords for gax_tick +real x, y +pointer polyline, op +common /gaxdcm/ polyline, op + +begin + x = Memr[op-2] + y = Memr[op-1] + + Memr[op] = x + dx + op = op + 1 + Memr[op] = y + dy + op = op + 1 + + Memr[op] = x + op = op + 1 + Memr[op] = y + op = op + 1 +end + + +# GAX_START -- Start a new polyline at the indicated point in world coords. +# The polyline buffer is of a fixed length with no bounds checking. + +procedure gax_start (wx, wy) + +real wx, wy # world or log-world coords to draw to +pointer polyline, op + +errchk malloc +common /gaxdcm/ polyline, op + +begin + call malloc (polyline, LEN_POLYLINE, TY_REAL) + op = polyline + call gax_draw (wx, wy) +end + + +# GAX_FLUSH -- Flush the buffered polyline and free space on the heap. + +procedure gax_flush (stream) + +int stream # graphics stream +pointer polyline, op +common /gaxdcm/ polyline, op + +begin + call grc_polyline (stream, Memr[polyline], (op - polyline) / 2) + call mfree (polyline, TY_REAL) +end + + +# GAX_TEXT -- Draw a text string (tick label) of size 1.0 with the indicated +# justification. + +procedure gax_text (stream, sx, sy, text, hjustify, vjustify) + +int stream # graphics stream +real sx, sy # text coordinates, NDC +char text[ARB] # text string to be drawn +int hjustify # horizontal justification +int vjustify # vertical justification + +pointer tr, tx +int save_tx[LEN_TX] +errchk gtr_init +pointer gtr_init() + +begin + tr = gtr_init (stream) + tx = TR_TXAP(tr) + call amovi (Memi[tx], save_tx, LEN_TX) + + TX_UP(tx) = 90 + TX_SIZE(tx) = 1.0 + TX_PATH(tx) = GT_RIGHT + TX_SPACING(tx) = 0 + TX_HJUSTIFY(tx) = hjustify + TX_VJUSTIFY(tx) = vjustify + TX_FONT(tx) = GT_BOLD + TX_QUALITY(tx) = GT_NORMAL + TX_COLOR(tx) = 1 + + call grc_text (stream, sx, sy, text) + call amovi (save_tx, Memi[tx], LEN_TX) +end diff --git a/sys/gio/cursor/grcclose.x b/sys/gio/cursor/grcclose.x new file mode 100644 index 00000000..304a0904 --- /dev/null +++ b/sys/gio/cursor/grcclose.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gtr.h" +include "grc.h" + +# GRC_CLOSE -- Close the workstation (kernel). Called by RCURSOR to close the +# kernel after a cursor read. Note that a cursor read may occur while the +# workstation is open, i.e., after gopen but before gclose, or after the +# workstation has been closed, i.e., after a plotting program terminates. +# If the workstation was already open (GKI_OPENWS) by the application when +# the cursor read occurred we must leave things as they were. + +procedure grc_close (fd, rc) + +int fd # graphics stream +pointer rc # rcursor descriptor + +pointer tr +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (fd) + + # Decrement the logical OPENWS count and issue the actual CLOSEWS + # only if the counter goes to zero. If the workstation was open + # but deactivated when grc_open() was called (WS_ACTIVE == NO), + # restore it to its former (deactivated) state. + + TR_WSOPEN(tr) = TR_WSOPEN(tr) - 1 + if (TR_WSOPEN(tr) <= 0) { + call gki_closews (fd, TR_DEVNAME(tr)) + TR_WSOPEN(tr) = 0 + TR_WSACTIVE(tr) = NO + } else if (TR_WSACTSAVE(tr) == NO) { + call gki_deactivatews (fd, 0) + TR_WSACTIVE(tr) = NO + } + + call gki_fflush (fd) +end diff --git a/sys/gio/cursor/grccmd.x b/sys/gio/cursor/grccmd.x new file mode 100644 index 00000000..5aca0f84 --- /dev/null +++ b/sys/gio/cursor/grccmd.x @@ -0,0 +1,533 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "gtr.h" +include "grc.h" + +define MAX_KWLEN 10 + +# Assign opcodes to the recognized keywords. + +define KW_AXES 1 +define KW_CASE 2 +define KW_CLEAR 3 +define KW_CURSOR 4 +define KW_GFLUSH 5 +define KW_HELP 6 +define KW_INIT 7 +define KW_MARKCUR 8 +define KW_OFF 9 +define KW_ON 10 +define KW_PAGE 11 +define KW_READ 12 +define KW_SHOW 13 +define KW_SNAP 14 +define KW_TXQUALITY 15 +define KW_TXSET 16 +define KW_VIEWPORT 17 +define KW_WRITE 18 +define KW_XRES 19 +define KW_YRES 20 +define KW_ZERO 21 + + +# GRC_COMMAND -- Process a ":." cursor mode option string. The RC structure +# contains the current values of the cursor mode options. Some option strings +# are commands that do something, others set options, and still others show +# the status of the program. + +int procedure grc_command (rc, stream, sx, sy, raster, rx, ry, opstr) + +pointer rc #I rcursor descriptor +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor +char opstr[ARB] #I options string excluding the leading ":.". + +pointer tr, p_tr, sp, fname, lbuf, tty +bool clobber, fullframe, auto_gflush +int ip, op, ch, opcode, cursor +int save1, save2, i, xres, yres, quality +char kwname[MAX_KWLEN] + +pointer gtr_init(), grc_open(), ttyodes() +int strdic(), grc_boolval(), ttygeti(), ttystati() +real grc_realval() +string keywords "|axes|case|clear|cursor|gflush|help|init|markcur|off|on|page|\ +read|show|snap|txquality|txset|viewport|write|xres|yres|zero|" +errchk gtr_redraw, gki_flush, gtr_init +define exit_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # The terminal is left in graphics mode when the user types return to + # enter the command. Echo the user command to the terminal without + # the newline to leave the terminal in status line mode, so that any + # output directly to the terminal from the lower level code in the CL + # goes into the status line. + + call strcpy (":.", Memc[lbuf], SZ_LINE) + op = lbuf + 2 + for (ip=1; opstr[ip] != EOS && opstr[ip] != '\n'; ip=ip+1) { + Memc[op] = opstr[ip] + op = op + 1 + } + Memc[op] = EOS + call stg_putline (STDERR, Memc[lbuf]) + + tr = gtr_init (stream) + ip = 1 + + while (ip == 1 || opstr[ip] != EOS) { + while (IS_WHITE(opstr[ip])) + ip = ip + 1 + + # If EOS and not first command, all done. If first command do + # not quit, rather assume ":.help" (see below). + + if (ip > 1 && opstr[ip] == EOS) + break + + # Extract the keyword into the KWNAME buffer. Leave the input + # pointer positioned to the first char following the keyword. + + for (op=1; opstr[ip] != EOS; ip=ip+1) { + ch = opstr[ip] + if (IS_ALNUM(ch)) { + kwname[op] = ch + op = op + 1 + } else + break + } + kwname[op] = EOS + + # Look up the keyword in the dictionary. If not found ring the bell + # but do not return EOF (do not quit cursor mode). + + if (op == 1) + opcode = KW_HELP + else { + opcode = strdic (kwname, kwname, MAX_KWLEN, keywords) + if (opcode <= 0) { + call fprintf (STDERR, "\7") + goto exit_ + } + } + + # Process the command. + + switch (opcode) { + case KW_AXES: + # Set flag to draw axes of viewport when screen readrawn. + RC_AXES(rc) = grc_boolval (opstr, ip) + + case KW_CASE: + # Enable/disable case sensitivity. + RC_CASE(rc) = grc_boolval (opstr, ip) + + case KW_CLEAR: + # Clear the alpha screen. + iferr (tty = ttyodes ("terminal")) + call grc_warn (STDERR) + else { + do i = 1, ttystati (tty, TTY_NLINES) { + call ttygoto (STDOUT, tty, 1, i) + call ttyclearln (STDOUT, tty) + } + call flush (STDOUT) + call ttycdes (tty) + } + + case KW_CURSOR: + # Select the cursor to be referenced in all subsequent reads + # and writes. + + ip = ip + 1 + cursor = max (0, nint (grc_realval (opstr, ip))) + call stg_lockcursor (cursor) + + case KW_GFLUSH: + # Flush any buffered graphics output (dispose of spooled + # plotter output). + + call stg_putline (STDERR, " - ") + call gtr_gflush (STDPLOT) + + case KW_HELP: + # Print help text for cursor mode. + call gtr_page (STDERR, stream) + iferr (call pagefile (KEYSFILE, "cursor mode help")) + call grc_warn (STDERR) + ip = ip + 1 + + case KW_INIT: + # Disconnect all kernels and free memory. Exits cursor mode + # with an EOF. + + call stg_putline (STDERR, " - ") + call gtr_reset (OK) + call sfree (sp) + return (EOF) + + case KW_MARKCUR: + # Enable marking of the cursor position when the cursor is read. + RC_MARKCUR(rc) = grc_boolval (opstr, ip) + + case KW_OFF: + # Disable the listed keys. + call grc_keys (rc, opstr, ip, 0) + + case KW_ON: + # Enable or set the listed keys. + call grc_keys (rc, opstr, ip, 1) + + case KW_PAGE: + # Enable screen clear when ?, show, etc. print text. + TR_PAGE(tr) = grc_boolval (opstr, ip) + + case KW_READ: + # Fill the frame buffer from a metacode spool file. + + call grc_word (opstr, ip, Memc[fname], SZ_FNAME) + call grc_read (tr, stream, Memc[fname]) + + case KW_SHOW: + # Show status of RCURSOR and GIOTR. + + call gtr_page (STDERR, stream) + call fprintf (STDERR, "Cursor Mode Parameters:\n\n") + call grc_status (STDERR, rc) + + call fprintf (STDERR, "\n\nGraphics Kernel Status:\n\n") + call gtr_status (STDERR) + + case KW_SNAP: + # Write a snapshot of the screen to a plotter. Open a subkernel + # on STDPLOT, redraw the screen into the STDPLOT fio buffer, + # flush the buffered metacode to the kernel, then restore + # everything. NOTE: should restore things automatically if an + # interrupt occurs. + + call stg_putline (STDERR, " - ") + call grc_word (opstr, ip, Memc[fname], SZ_FNAME) + iferr (p_tr = grc_open (Memc[fname], NEW_FILE, STDPLOT, rc)) { + call grc_warn (STDERR) + goto exit_ + } + + call gki_redir (stream, STDPLOT, save1, save2) + call fseti (STDPLOT, F_CANCEL, OK) + + iferr { + call gtr_redraw (stream) + call gki_flush (STDPLOT) + } then + call grc_warn (STDERR) + + call gki_redir (stream, 0, save1, save2) + + auto_gflush = (ttygeti (TR_TTY(p_tr), "MF") <= 1) + call grc_close (STDPLOT, rc) + + if (auto_gflush) + call gtr_gflush (STDPLOT) + + call stg_putline (STDERR, " done") + + case KW_VIEWPORT: + # Set the viewport in world coordinates. + call grc_viewport (tr, stream, + sx, sy, raster, rx, ry, opstr, ip) + + case KW_WRITE: + # Save the contents of the frame buffer in a file. + # "w!" clobbers any existing file and "w+" writes the + # full frame. By default the frame is appended to the + # output file. + + if (opstr[ip] == '!') { + clobber = true + ip = ip + 1 + } else + clobber = false + + if (opstr[ip] == '+') { + fullframe = true + ip = ip + 1 + } else + fullframe = false + + # Extract the filename. + call grc_word (opstr, ip, Memc[fname], SZ_FNAME) + + # Write to the spoolfile. + call grc_write (tr, stream, Memc[fname], clobber, fullframe) + + case KW_XRES: + # Set the stdgraph X resolution. + xres = nint (grc_realval (opstr, ip)) + yres = 0 + call stg_resolution (xres, yres) + + case KW_YRES: + # Set the stdgraph Y resolution. + xres = 0 + yres = nint (grc_realval (opstr, ip)) + call stg_resolution (xres, yres) + + case KW_TXQUALITY: + # Set character generator quality. + + while (IS_WHITE(opstr[ip])) + ip = ip + 1 + + switch (opstr[ip]) { + case 'l': + quality = GT_LOW + case 'm': + quality = GT_MEDIUM + case 'h': + quality = GT_HIGH + default: + quality = 0 + } + call stg_txquality (quality) + + case KW_TXSET: + # Set the text drawing attributes. + call gtxset (TR_TXAP(tr), opstr, ip) + + case KW_ZERO: + # Reset and redraw. + call gtr_ptran (stream, 0., 1., 0., 1.) + call gtr_writecursor (stream, .5, .5) + call gtr_redraw (stream) + } + + # Advance to the next statement or the end of string. Any unused + # characters in the statement just processed are discarded. + + while (opstr[ip] != ';' && opstr[ip] != EOS) + ip = ip + 1 + while (opstr[ip] == ';' || opstr[ip] == '.') + ip = ip + 1 + } +exit_ + # Restore the terminal to graphics mode if gtr_page was not called to + # deactivate the ws. (this leaves the waitpage flag set). + + if (TR_WAITPAGE(tr) == NO) + call stg_putline (STDERR, "\n") + + # Leave the graphics descriptor set up as we found it. + tr = gtr_init (stream) + + call flush (STDERR) + call sfree (sp) + return (OK) +end + + +# GRC_WORD -- Extract the next whitespace delimited word from the command line. + +procedure grc_word (opstr, ip, outstr, maxch) + +char opstr[ARB] # input string +int ip # pointer into input string +char outstr[ARB] # output string +int maxch # max chars out +int op + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + op = 1 + while (!IS_WHITE (opstr[ip]) && opstr[ip] != EOS) { + outstr[op] = opstr[ip] + op = op + 1 + ip = ip + 1 + } + + outstr[op] = EOS +end + + +# GRC_BOOL -- Get the boolean value of a parameter. Upon entry, the input +# pointer is positioned to the first character following the parameter name. + +int procedure grc_boolval (opstr, ip) + +char opstr[ARB] # command string +int ip # input pointer +int value +int btoi() + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + if (opstr[ip] == '=') { + ip = ip + 1 + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + value = btoi (opstr[ip] != 'n' && opstr[ip] != 'N') + while (IS_ALPHA (opstr[ip])) + ip = ip + 1 + } else + value = btoi (opstr[ip] != '-') + + return (value) +end + + +# GRC_REALVAL -- Get the real value of a parameter. Upon entry, the input +# pointer is positioned to the first character following the parameter name. +# Zero is returned if no value is given. + +real procedure grc_realval (opstr, ip) + +char opstr[ARB] # command string +int ip # input pointer +real value +int ctor() + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + if (opstr[ip] == '=') + ip = ip + 1 + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + if (ctor (opstr, ip, value) <= 0) + value = 0 + + return (value) +end + + +# GRC_KEYS -- Enable the listed keys or ranges of keys. The operation is +# additive, i.e., only the named keys are affected. + +procedure grc_keys (rc, opstr, ip, onoff) + +pointer rc # rcursor descriptor +char opstr[ARB] # command string +int ip # next char in opstr +int onoff # set keys on (1) or off (0) + +int new_value +int ch, ch1, ch2, ip_start, i +string keys KEYSTROKES + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + ip_start = ip + for (ch=opstr[ip]; ch != EOS; ch=opstr[ip]) { + if (ch == ';' || ch == '\n' || IS_WHITE(ch)) + break + + ch1 = ch + if (opstr[ip+1] == '-' && opstr[ip+2] != EOS) { + # Enable a range of keys. + ip = ip + 2 + ch2 = opstr[ip] + } else if (opstr[ip+1] == '=' && opstr[ip+2] != EOS) { + # Assign the value of a key. + ip = ip + 3 + RC_KEYS(rc,ch) = opstr[ip] + next + } else + ch2 = ch + + for (ch=ch1; ch <= ch2; ch=ch+1) { + if (onoff == 0) + new_value = 0 + else + new_value = ch + RC_KEYS(rc,ch) = new_value + } + + ip = ip + 1 + } + + # If no keys were listed, set all cursor mode keys. + if (ip == ip_start) + for (i=1; keys[i] != EOS; i=i+1) { + ch = keys[i] + if (onoff == 0) + new_value = 0 + else + new_value = ch + RC_KEYS(rc,ch) = new_value + } + + # The ":" key cannot be mapped or disabled. + RC_KEYS(rc,':') = ':' +end + + +# GRC_VIEWPORT -- Set the viewport in world coordinates. Use the current +# cursor position to determine the WCS, then convert the world coordinates +# of the viewport given by the user into NDC coordinates and set the work- +# station transformation. + +procedure grc_viewport (tr, stream, sx, sy, raster, rx, ry, opstr, ip) + +pointer tr #I giotr descriptor +int stream #I graphics stream +real sx, sy #I screen coordinates of cursor +int raster #I raster number +real rx, ry #I raster coordinates of cursor +char opstr[ARB] #I command string +int ip #I input pointer + +pointer w +int i, wcs +real wx, wy, value +real vn[4], vw[4], ct[LEN_CT] +int ctor() + +begin + # Select a WCS. We are not otherwise interested in the cursor value. + call grc_scrtowcs (stream, sx, sy, raster, rx, ry, wx, wy, wcs) + w = TR_WCSPTR(tr,wcs) + call grc_settran (w, ct) + + # Start with the current viewport. + call gtr_gtran (stream, vn[1], vn[2], vn[3], vn[4]) + + # Transform to world coordinates. + call grc_ndctowcs (ct, vn[1], vn[3], vw[1], vw[3]) + call grc_ndctowcs (ct, vn[2], vn[4], vw[2], vw[4]) + + # Get the new viewport (world) coordinates. + do i = 1, 4 + if (ctor (opstr, ip, value) <= 0) + break + else + vw[i] = value + + # Transform to NDC coordinates. + call grc_wcstondc (ct, vw[1], vw[3], vn[1], vn[3]) + call grc_wcstondc (ct, vw[2], vw[4], vn[2], vn[4]) + + # Set the new workstation transformation. + call gtr_ptran (stream, vn[1], vn[2], vn[3], vn[4]) + + # Redraw the screen. + call gtr_redraw (stream) +end diff --git a/sys/gio/cursor/grcinit.x b/sys/gio/cursor/grcinit.x new file mode 100644 index 00000000..3160203c --- /dev/null +++ b/sys/gio/cursor/grcinit.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "grc.h" + +# GRC_INIT -- Initialize the rcursor descriptor. Allocate storage for the +# descriptor and initialize all variables and the keystroke mapping. + +procedure grc_init (rc) + +pointer rc #U grc descriptor (pointer) + +int ip, ch +string keys KEYSTROKES +errchk malloc + +begin + if (rc == NULL) + call malloc (rc, LEN_RCSTRUCT, TY_STRUCT) + call aclri (Memi[rc], LEN_RCSTRUCT) + + # Initialize variables. + RC_CASE(rc) = YES + RC_MARKCUR(rc) = NO + RC_PHYSOPEN(rc) = NO + + # Initialize keystrokes. + for (ip=1; keys[ip] != EOS; ip=ip+1) { + ch = keys[ip] + RC_KEYS(rc,keys[ip]) = ch + } +end diff --git a/sys/gio/cursor/grcopen.x b/sys/gio/cursor/grcopen.x new file mode 100644 index 00000000..8a39d191 --- /dev/null +++ b/sys/gio/cursor/grcopen.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_OPEN -- Open the workstation. Most commonly used to reopen the +# workstation for a cursor read after plotting. + +pointer procedure grc_open (device, mode, stream, rc) + +char device[ARB] # device name (optional) +int mode # desired access mode +int stream # graphics stream +pointer rc # rcursor descriptor + +pointer sp, devname, envvar, tr +int envgets() +bool streq() +pointer gtr_init() + +include "gtr.com" +string stdgraph "stdgraph" +string stdimage "stdimage" +string stdplot "stdplot" +errchk syserrs, gtr_openws, gki_openws, gtr_init + +begin + call smark (sp) + call salloc (envvar, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + tr = gtr_init (stream) + + # If the workstation is already connected and the kernel is open + # issue the openws directive if it has not already been issued. + + if (TR_DEVNAME(tr) != EOS) + if (device[1] == EOS || streq (device, TR_DEVNAME(tr))) { + # Kernel is already physically open on this stream. Activate + # it if necessary; record whether or not is was active when + # we were called, so that we can restore the original state + # when grc_close() is called. + + if (TR_WSOPEN(tr) <= 0) { + call gki_openws (stream, TR_DEVNAME(tr), mode) + TR_WSACTIVE(tr) = YES + TR_WSACTSAVE(tr) = NO + } else { + TR_WSACTSAVE(tr) = TR_WSACTIVE(tr) + call gki_reactivatews (stream, 0) + TR_WSACTIVE(tr) = YES + } + + call gki_fflush (stream) + + TR_WSOPEN(tr) = TR_WSOPEN(tr) + 1 + call sfree (sp) + return (tr) + } + + # If no device name given fetch the device name from the environment. + + if (device[1] == EOS) { + switch (stream) { + case STDGRAPH: + call strcpy (stdgraph, Memc[envvar], SZ_FNAME) + case STDIMAGE: + call strcpy (stdimage, Memc[envvar], SZ_FNAME) + default: + call strcpy (stdplot, Memc[envvar], SZ_FNAME) + } + + # Convert environment variable name into device name. Indirection + # and assumption of the value of "terminal" are allowed. + + repeat { + if (envgets (Memc[envvar], Memc[devname], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, Memc[envvar]) + if (Memc[devname] == '@') { + # Indirection in environment variable name. + call strcpy (Memc[devname+1], Memc[envvar], SZ_FNAME) + } else if (streq (Memc[devname], "terminal")) { + call strcpy (Memc[devname], Memc[envvar], SZ_FNAME) + } else + break + } + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + # Open the workstation (kernel) on stream FD. + call gtr_openws (Memc[devname], mode, stream, NULL) + + TR_WSOPEN(tr) = TR_WSOPEN(tr) + 1 + TR_WSACTSAVE(tr) = NO + TR_WSACTIVE(tr) = YES + + call gki_openws (stream, Memc[devname], mode) + call gki_fflush (stream) + + call sfree (sp) + return (tr) +end diff --git a/sys/gio/cursor/grcpl.x b/sys/gio/cursor/grcpl.x new file mode 100644 index 00000000..7768bf85 --- /dev/null +++ b/sys/gio/cursor/grcpl.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_POLYLINE -- Draw a solid polyline. The instruction is encoded and +# appended to the frame buffer and GIOTR is called to draw the line, +# possibly applying the workstation transformation in the process. + +procedure grc_polyline (stream, v, npts) + +int stream # graphics stream +real v[ARB] # polyline, NDC units +int npts # number of points (coord pairs) in polyline + +pointer tr, sp, p, pl, op, last_op +int nwords, fd, save1, save2, i +int stropen() +pointer gtr_init(), gtr_writep() +errchk gtr_init, gtr_writep, gki_redir + +begin + call smark (sp) + call salloc (p, npts * 2, TY_SHORT) + + tr = gtr_init (stream) + + # Transform the type real, NDC polyline to GKI units, type short. + do i = 1, npts * 2, 2 { + Mems[p+i-1] = v[i ] * GKI_MAXNDC + Mems[p+i ] = v[i+1] * GKI_MAXNDC + } + + # Allocate space in the frame buffer for the polyline set attribute + # and line drawing instructions. Set the last op for undo to undo + # the line. This is also set by writep, hence we must wait to set + # TR_LASTOP until after the call to writep. + + last_op = TR_OP(tr) + nwords = GKI_PLSET_LEN + GKI_POLYLINE_LEN + (npts * 2) + op = gtr_writep (stream, nwords) + TR_LASTOP(tr) = last_op + + # Open the frame buffer as a file and redirect the graphics stream + # output into the buffer. + + fd = stropen (Mems[op], nwords, NEW_FILE) + call gki_redir (stream, fd, save1, save2) + + # Output a polyline set attribute instruction to ensure that a solid + # line is drawn. Output the polyline. + + pl = TR_PLAP(tr) + call gki_plset (stream, pl) + call gki_polyline (stream, Mems[p], npts) + + # Restore the normal output for the stream. + call gki_redir (stream, 0, save1, save2) + call close (fd) + + # Call giotr to send the new instructions off the to the kernel, + # optionally applying the workstation transformation in the process. + + call giotr (stream) + call sfree (sp) +end diff --git a/sys/gio/cursor/grcread.x b/sys/gio/cursor/grcread.x new file mode 100644 index 00000000..ce95fc07 --- /dev/null +++ b/sys/gio/cursor/grcread.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GRC_READ -- Fill the frame buffer from a metacode spool file and redraw +# the screen. The contents of the frame buffer are overwritten. + +procedure grc_read (tr, stream, fname) + +pointer tr # graphics descriptor +int stream # graphics stream +char fname[ARB] # metacode file + +pointer sp, lbuf, op +int fd, nchars, filelen +long fstatl() +pointer gtr_writep() +int open(), read() +errchk read +define err_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + iferr (fd = open (fname, READ_ONLY, BINARY_FILE)) { + call grc_message (stream, " - cannot open file") + call sfree (sp) + return + } + + filelen = fstatl (fd, F_FILESIZE) + call sprintf (Memc[lbuf], SZ_LINE, " - file size %d chars") + call pargi (filelen) + call grc_message (stream, Memc[lbuf]) + + # Discard the current frame. + call gtr_frame (tr, TR_FRAMEBUF(tr), stream) + + # Read new frame buffer. + nchars = filelen + if (nchars <= 0) + goto err_ + op = gtr_writep (stream, nchars) + if (read (fd, Mems[op], nchars) < nchars) + goto err_ + + # Redraw the new frame buffer. + call gtr_redraw (stream) + + call close (fd) + call sfree (sp) + return +err_ + call close (fd) + call grc_message (stream, " [READ ERROR]") + call sfree (sp) +end diff --git a/sys/gio/cursor/grcredraw.x b/sys/gio/cursor/grcredraw.x new file mode 100644 index 00000000..4317db96 --- /dev/null +++ b/sys/gio/cursor/grcredraw.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "grc.h" + +# GRC_REDRAW -- Redraw the screen, and, if the "axes" flag is set, draw the axes +# of the plot. + +procedure grc_redraw (rc, stream, sx, sy, raster, rx, ry) + +pointer rc #I rcursor descriptor +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor + +begin + call gtr_redraw (stream) + if (RC_AXES(rc) == YES) + call grc_axes (stream, sx, sy, raster, rx, ry) +end diff --git a/sys/gio/cursor/grcscr.x b/sys/gio/cursor/grcscr.x new file mode 100644 index 00000000..add322b4 --- /dev/null +++ b/sys/gio/cursor/grcscr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GRC_SCRTONDC -- Coordinate transformation from screen coordinates to NDC +# coordinates. Screen coordinates physically address the device screen and +# range from 0 to 1 in either axis. NDC coordinates also range from 0 to 1 +# in either axis but differ from screen coordinates when the workstation +# transformation is non unitary. The workstation transformation parameters +# are cached in the GTR common. We assume that GTR_INIT has already been +# called to initialize the common for a graphics stream. + +procedure grc_scrtondc (sx, sy, mx, my) + +real sx, sy # screen coordinates (input) +real mx, my # NDC coordinates (output) +include "gtr.com" + +begin + if (wstranset == YES) { + mx = ((sx * GKI_MAXNDC - xorigin) / xscale + mx1) / GKI_MAXNDC + my = ((sy * GKI_MAXNDC - yorigin) / yscale + my1) / GKI_MAXNDC + } else { + mx = sx + my = sy + } +end + + +# GRC_NDCTOSCR -- Coordinate transformation from NDC coordinates to screen +# coordinates. + +procedure grc_ndctoscr (mx, my, sx, sy) + +real mx, my # NDC coordinates (input) +real sx, sy # screen coordinates (output) +include "gtr.com" + +begin + if (wstranset == YES) { + sx = ((mx * GKI_MAXNDC - mx1) * xscale + xorigin) / GKI_MAXNDC + sy = ((my * GKI_MAXNDC - my1) * yscale + yorigin) / GKI_MAXNDC + } else { + sx = mx + sy = my + } +end diff --git a/sys/gio/cursor/grcstatus.x b/sys/gio/cursor/grcstatus.x new file mode 100644 index 00000000..55f44f18 --- /dev/null +++ b/sys/gio/cursor/grcstatus.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gtr.h" +include "grc.h" + +# GRC_STATUS -- Called by ":.show" to print the values of the cursor mode +# parameters. + +procedure grc_status (fd, rc) + +int fd # output file +pointer rc # rcursor descriptor + +int ip, ch +string keys KEYSTROKES +include "gtr.com" + +begin + call fprintf (fd, "\tcase\t= %b\n") + call pargi (RC_CASE(rc)) + call fprintf (fd, "\tmarkcur\t= %b\n") + call pargi (RC_MARKCUR(rc)) + call fprintf (fd, "\taxes\t= %b\n") + call pargi (RC_AXES(rc)) + + if (wstranset == YES) { + call fprintf (fd, "\tview\t= %5.3f %5.3f %5.3f %5.3f\n") + call pargr (vx1) + call pargr (vx2) + call pargr (vy1) + call pargr (vy2) + } else + call fprintf (fd, "\tview\t= full screen\n") + + call fprintf (fd, "\tkeys\t= %s\n") + call pargstr (keys) + call fprintf (fd, "\t\t->") + + for (ip=1; keys[ip] != EOS; ip=ip+1) { + ch = RC_KEYS(rc,keys[ip]) + if (ch != 0) + call putci (fd, ch) + else + call putci (fd, ' ') + } + + call fprintf (fd, "\n") +end diff --git a/sys/gio/cursor/grctext.x b/sys/gio/cursor/grctext.x new file mode 100644 index 00000000..5bee9b34 --- /dev/null +++ b/sys/gio/cursor/grctext.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_TEXT -- Draw a text string. The instruction is encoded and appended to +# the frame buffer and GIOTR is called to draw the new instructions. + +procedure grc_text (stream, x, y, text) + +int stream # graphics stream +real x, y # NDC coordinates of ll corner of first char +char text[ARB] # text string + +pointer tr, op, last_op +int fd, save1, save2, nwords +int stropen(), strlen() +pointer gtr_init(), gtr_writep() +errchk gtr_init, stropen, gki_redir + +begin + tr = gtr_init (stream) + + # Allocate space in the frame buffer for the text set attribute + # and text drawing instructions. Set the last op for undo to undo + # the line. This is also set by writep, hence we must wait to set + # TR_LASTOP until after the call to writep. + + last_op = TR_OP(tr) + nwords = GKI_TXSET_LEN + GKI_TEXT_LEN + strlen(text) + op = gtr_writep (stream, nwords) + TR_LASTOP(tr) = last_op + + # Open the frame buffer as a file and redirect the graphics stream + # output into the buffer. + + fd = stropen (Mems[op], nwords, NEW_FILE) + call gki_redir (stream, fd, save1, save2) + + # Output the set text attribute instruction and the text drawing + # instruction. + + call gki_txset (stream, TR_TXAP(tr)) + call gki_text (stream, nint(x*GKI_MAXNDC), nint(y*GKI_MAXNDC), text) + + # Restore the normal output for the stream. + call gki_redir (stream, 0, save1, save2) + call close (fd) + + # Call giotr to send the new instructions off to the kernel, optionally + # applying the workstation transformation in the process. + + call giotr (stream) +end diff --git a/sys/gio/cursor/grcwarn.x b/sys/gio/cursor/grcwarn.x new file mode 100644 index 00000000..ba9fcb0e --- /dev/null +++ b/sys/gio/cursor/grcwarn.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GRC_WARN -- Called in an error handler to intercept an error message string +# and write it to the workstation in the status line. + +procedure grc_warn (fd) + +int fd # output stream + +int errcode +pointer sp, msg, ip +int errget() + +begin + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + + errcode = errget (Memc[msg], SZ_LINE) + for (ip=msg; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + + call stg_putline (fd, " - ") + call stg_putline (fd, Memc[msg]) + + call sfree (sp) +end diff --git a/sys/gio/cursor/grcwcs.x b/sys/gio/cursor/grcwcs.x new file mode 100644 index 00000000..7c73657a --- /dev/null +++ b/sys/gio/cursor/grcwcs.x @@ -0,0 +1,282 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_SCRTOWCS -- Transform screen coordinates (raw cursor coordinates) to +# world coordinates. This is not terribly efficient, but it does not matter +# for cursor mode applications which do not involve many coordinate +# transformations. + +procedure grc_scrtowcs (stream, sx, sy, raster, rx, ry, wx, wy, wcs) + +int stream #I graphics stream +real sx, sy #I screen coordinates +int raster #I raster number +real rx, ry #I raster coordinates +real wx, wy #O world coordinates +int wcs #O world coordinate system + +pointer w, tr +real mx, my +real ct[LEN_CT] +int grc_selectwcs() +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + # Convert screen (raster 0) to NDC coordinates, undoing the effects + # of the workstation transformation. This is not done for raster + # coordinates since these are already raster-normalized coordinates + # as returned by the server. + + if (raster == 0) + call grc_scrtondc (rx, ry, mx, my) + else { + mx = rx + my = ry + } + + # Select a WCS. The TR_WCS variable is set only if the user + # explicitly fixes the WCS to override automatic selection. The + # best WCS for the raster is used if there is one, otherwise the + # best screen WCS is used. + + if (TR_WCS(tr) == NULL) { + wcs = grc_selectwcs (tr, raster, mx, my) + if (wcs == 0) { + call grc_scrtondc (sx, sy, mx, my) + wcs = grc_selectwcs (tr, 0, mx, my) + } + } else + wcs = TR_WCS(tr) + + # Set up the coordinate transformation. + w = TR_WCSPTR(tr,wcs) + call grc_settran (w, ct) + + # Transform NDC coordinates to WCS coordinates. + call grc_ndctowcs (ct, mx, my, wx, wy) +end + + +# GRC_SETTRAN -- Set up the coordinate transformation parameters for a given +# world coordinate system. + +procedure grc_settran (w, ct) + +pointer w # window descriptor +real ct[LEN_CT] # transformation descriptor + +real worigin, scale +real m1, m2, w1, w2 +int transformation, ax +bool fp_equalr() +real elogr() + +begin + # Compute world -> NDC coordinate transformation. + + do ax = 1, 2 { + if (ax == 1) { + transformation = WCS_XTRAN(w) + w1 = WCS_WX1(w) + w2 = WCS_WX2(w) + m1 = WCS_SX1(w) + m2 = WCS_SX2(w) + } else { + transformation = WCS_YTRAN(w) + w1 = WCS_WY1(w) + w2 = WCS_WY2(w) + m1 = WCS_SY1(w) + m2 = WCS_SY2(w) + } + + if (transformation == LINEAR) { + worigin = w1 + if (fp_equalr (w1, w2)) + scale = 1.0 + else + scale = (m2 - m1) / (w2 - w1) + } else if (transformation == LOG && w1 > 0 && w2 > 0) { + worigin = log10 (w1) + if (fp_equalr (log10(w2), worigin)) + scale = 1.0 + else + scale = (m2 - m1) / (log10(w2) - worigin) + } else { + worigin = elogr (w1) + if (fp_equalr (elogr(w2), worigin)) + scale = 1.0 + else + scale = (m2 - m1) / (elogr(w2) - worigin) + } + + ct[ax,CT_TRAN] = transformation + ct[ax,CT_SCALE] = scale + ct[ax,CT_WORIGIN] = worigin + ct[ax,CT_MORIGIN] = m1 + } +end + + +# GRC_WCSTONDC -- Transform world coordinates to NDC coordinates using the +# computed transformation parameters. + +procedure grc_wcstondc (ct, wx, wy, mx, my) + +real ct[LEN_CT] # coordinate transformation descriptor +real wx, wy # world coordinates of point +real mx, my # ndc coordinates of point + +real v +int transformation, ax +real elogr() + +begin + do ax = 1, 2 { + transformation = nint (ct[ax,CT_TRAN]) + if (ax == 1) + v = wx + else + v = wy + + if (transformation == LINEAR) + ; + else if (transformation == LOG) + v = log10 (v) + else + v = elogr (v) + + v = ((v - ct[ax,CT_WORIGIN]) * ct[ax,CT_SCALE]) + ct[ax,CT_MORIGIN] + if (ax == 1) + mx = v + else + my = v + } +end + + +# GRC_NDCTOWCS -- Transform NDC coordinates to world coordinates using the +# computed transformation parameters. + +procedure grc_ndctowcs (ct, mx, my, wx, wy) + +real ct[LEN_CT] # coordinate transformation descriptor +real mx, my # ndc coordinates of point +real wx, wy # world coordinates of point + +real v +int transformation, ax +real aelogr() + +begin + do ax = 1, 2 { + transformation = nint (ct[ax,CT_TRAN]) + if (ax == 1) + v = mx + else + v = my + + v = ((v - ct[ax,CT_MORIGIN]) / ct[ax,CT_SCALE]) + ct[ax,CT_WORIGIN] + if (transformation == LINEAR) + ; + else if (transformation == LOG) + v = 10.0 ** v + else + v = aelogr (v) + + if (ax == 1) + wx = v + else + wy = v + } +end + + +# GRC_SELECTWCS -- Select the WCS nearest to the given position in NDC +# coordinates. If the point falls within a single WCS then that WCS is +# selected. If the point falls within multiple WCS then the closest WCS +# is selected. If multiple (non unitary) WCS are defined at the same +# distance, e.g., when the WCS share the same viewport, then the highest +# numbered WCS is selected. + +int procedure grc_selectwcs (tr, raster, mx, my) + +pointer tr #I GTR descriptor +int raster #I raster number +real mx, my #I NDC coordinates of point + +pointer w +int wcs, closest_wcs, flags +real tol, sx1, sx2, sy1, sy2 +real distance, old_distance, xcen, ycen +int nin, in[MAX_WCS] + +begin + nin = 0 + closest_wcs = 0 + old_distance = 1.0 + tol = EPSILON * 10.0 + + # Inspect each WCS. All WCS are passed even though only one or two + # WCS will be set to nonunitary values for a given plot. Omitting + # the unitary WCS, determine the closest WCS and make a list of the + # WCS containing the given point. + + do wcs = 1, MAX_WCS { + w = TR_WCSPTR(tr,wcs) + + # Cache WCS params in local storage. + sx1 = WCS_SX1(w) + sx2 = WCS_SX2(w) + sy1 = WCS_SY1(w) + sy2 = WCS_SY2(w) + flags = WCS_FLAGS(w) + xcen = (sx1 + sx2) / 2.0 + ycen = (sy1 + sy2) / 2.0 + + # Skip to next WCS if the raster number doesn't match. + if (WF_RASTER(flags) != raster) + next + + # Skip to next WCS if this one is not defined. + if (and (flags, WF_NEWFORMAT) == 0) { + # Preserve old semantics if passed old format WCS. + if (sx1 == 0 && sx2 == 0 || sy1 == 0 && sy2 == 0) + next + if (abs ((sx2-sx1) - 1.0) < tol && abs ((sy2-sy1) - 1.0) < tol) + next + } else if (and (flags, WF_DEFINED) == 0) + next + + # Determine closest WCS to point (mx,my). + distance = ((mx - xcen) ** 2) + ((my - ycen) ** 2) + if (distance <= old_distance) { + closest_wcs = wcs + old_distance = distance + } + + # Check if point is inside this WCS. + if (mx >= sx1 && mx <= sx2 && my >= sy1 && my <= sy2) { + nin = nin + 1 + in[nin] = wcs + } + } + + # If point is inside exactly one non-unitary WCS then select that WCS. + if (nin == 1) + return (in[1]) + + # If point is inside more than one WCS, or if point is not inside any + # WCS, select the closest WCS. If multiple WCS are at the same + # distance we have already selected the higher numbered WCS due to + # the way the distance test is conducted, above. + + return (closest_wcs) +end diff --git a/sys/gio/cursor/grcwrite.x b/sys/gio/cursor/grcwrite.x new file mode 100644 index 00000000..c0a602a9 --- /dev/null +++ b/sys/gio/cursor/grcwrite.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" +include "grc.h" + +# GRC_WRITE -- Write the contents of the frame buffer to a file, with or +# without applying the workstation transformation, optionally clobbering +# any existing file of the same name. + +procedure grc_write (tr, stream, fname, clobber, fullframe) + +pointer tr # graphics stream descriptor +int stream # graphics stream +char fname[ARB] # file name +bool clobber # clobber existing file +bool fullframe # write full frame (no workstation transform) + +pointer sp, lbuf +long size1, size2 +int save1, save2, fd, nchars +long fstatl() +int open() +errchk write, gtr_redraw + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Delete existing file if clobber requested. + if (clobber) + iferr (call delete (fname)) + ; + + # Open metacode spool file for appending. + iferr (fd = open (fname, APPEND, BINARY_FILE)) { + call grc_message (stream, " - cannot open file for appending") + call sfree (sp) + return + } + + # Write either the full frame or the displayed frame into spool file. + + size1 = fstatl (fd, F_FILESIZE) + if (fullframe) { + nchars = (TR_OP(tr) - TR_FRAMEBUF(tr)) * SZ_SHORT + call write (fd, Mems[TR_FRAMEBUF(tr)], nchars) + } else { + call gki_redir (stream, fd, save1, save2) + call gtr_redraw (stream) + call gki_redir (stream, 0, save1, save2) + } + + size2 = fstatl (fd, F_FILESIZE) + call sprintf (Memc[lbuf], SZ_LINE, " - %d chars %s") + call pargi (size2 - size1) + if (size1 > 0) + call pargstr ("appended") + else + call pargstr ("") + call grc_message (stream, Memc[lbuf]) + + call close (fd) + call sfree (sp) +end diff --git a/sys/gio/cursor/gtr.com b/sys/gio/cursor/gtr.com new file mode 100644 index 00000000..ae5c3ac6 --- /dev/null +++ b/sys/gio/cursor/gtr.com @@ -0,0 +1,25 @@ +# GTR.COM -- Polyline clipping common for the workstation transformation. +# The length of this common in integer units from startcom to endcom inclusive +# is a defined parameter in giotr.h. Values within the save area are saved +# in the TR descriptor for a device and loaded into the common (which serves +# as a cache) when GIOTR or RCURSOR is called for a device. LENGTH=28 + +pointer trdes[MAX_PSEUDOFILES] # pointers to giotr descriptors +int tr_stream # graphics stream currently in the cache +int startcom # dummy entry marking start of common +int pl_op # index of next cell in polyline array +bool last_point_inbounds # last point was inbounds +int pl_type # type of instruction (polyline, polymarker,...) +int wstranset # workstation transformation has been set +real xscale, yscale # scale factor, world to GKI, for transform +real xorigin, yorigin # origins in GKI coords, for transform +long cx, cy # current pen position, GKI coords +long mx1, mx2, my1, my2 # clipping viewport, GKI coords +real vx1, vx2, vy1, vy2 # NDC viewport, may extend beyond boundary +long xs[4], ys[4] # last point plotted (for clipping code) +int endcom # dummy entry marking end of saved area +short pl[LEN_PLBUF+5] # output polyline buffer (plus GKI header) + +common /gtrcom/ trdes, tr_stream, startcom, pl_op, last_point_inbounds, + pl_type, wstranset, xscale, yscale, xorigin, yorigin, cx, cy, + mx1, mx2, my1, my2, vx1, vx2, vy1, vy2, xs, ys, endcom, pl diff --git a/sys/gio/cursor/gtr.h b/sys/gio/cursor/gtr.h new file mode 100644 index 00000000..3fbf93f5 --- /dev/null +++ b/sys/gio/cursor/gtr.h @@ -0,0 +1,51 @@ +# GIOTR.H -- Global definitions for the GIOTR graphics i/o workstation +# transformation and i/o program unit. Note: requires . + +define DEF_MAXLENFRAMEBUF 128000 +define DEF_LENFRAMEBUF 8192 +define INC_LENFRAMEBUF 4096 +define DEF_LENSCRATCHBUF 256 +define INC_LENSCRATCHBUF 256 +define MAX_PSEUDOFILES 10 +define SZ_TRDEVNAME 229 +define SZ_KERNFNAME 259 +define LEN_GTRCOM 28 # see "gtr.com" +define KSHIFT 10000 # encode pr ("etc$prpsio.x") such that + # + # ((pr*KSHIFT)+stream) > LAST_FD + # + # see also + +define LEN_TRSTRUCT (564+204) + +define TR_PID Memi[$1] # process id of kernel +define TR_IN Memi[$1+1] # input from process +define TR_OUT Memi[$1+2] # output to process +define TR_TTY Memi[$1+3] # graphcap descriptor +define TR_SPOOLDATA Memi[$1+4] # spool metacode instructions +define TR_FRAMEBUF Memi[$1+5] # pointer to frame buffer +define TR_LENFRAMEBUF Memi[$1+6] # length of the frame buffer +define TR_MAXLENFRAMEBUF Memi[$1+7] # max length of the frame buffer +define TR_IP Memi[$1+8] # input pointer into frame buf +define TR_OP Memi[$1+9] # output pointer into frame buf +define TR_LASTOP Memi[$1+10] # last OP (for undo) +define TR_SCRATCHBUF Memi[$1+11] # for annotating plots +define TR_LENSCRATCHBUF Memi[$1+12] # length of the scratch buffer +define TR_OPSB Memi[$1+13] # output pointer, scratch buf +define TR_NOPEN Memi[$1+14] # number of opens +define TR_REDIR Memi[$1+15] # redirection information +define TR_WCS Memi[$1+16] # WCS selected, 0 if none +define TR_PAGE Memi[$1+17] # clear screen for text +define TR_WAITPAGE Memi[$1+18] # grc_waitpage flag +define TR_WSOPEN Memi[$1+19] # workstation open count +define TR_SKIPOPEN Memi[$1+20] # skip wsopen in metacode +define TR_WSACTIVE Memi[$1+21] # workstation activated? +define TR_WSACTSAVE Memi[$1+22] # save old wsactive state +define TR_INTERACTIVE Memi[$1+23] # the user graphics terminal? + # (open) +define TR_TXAP ($1+30) # text drawing attributes +define TR_PLAP ($1+40) # text drawing attributes +define TR_DEVNAME Memc[P2C($1+44)] # device name +define TR_KERNFNAME Memc[P2C($1+274)] # name of kernel file (or "cl") +define TR_GTRCOM Memi[$1+534] # storage for the gtr common +define TR_WCSPTR (($1)+564+($2)*LEN_WCS) # WCS storage (0=not used) diff --git a/sys/gio/cursor/gtrbackup.x b/sys/gio/cursor/gtrbackup.x new file mode 100644 index 00000000..9ab13c0b --- /dev/null +++ b/sys/gio/cursor/gtrbackup.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_BACKUP -- Backup one drawing instruction in the frame buffer. Erase +# the graphics if possible. The effects of this function may be undone by +# the UNDO operator. + +procedure gtr_backup (stream) + +int stream # graphics stream + +int opcode +pointer tr, op, bp, sp, ap +pointer gtr_init() +errchk gtr_init +include "gtr.com" + +begin + call smark (sp) + call salloc (ap, LEN_PL, TY_STRUCT) + + tr = gtr_init (stream) + + # Scan backward to the beginning of the last drawing instruction in the + # frame buffer. + + op = TR_OP(tr) + bp = TR_FRAMEBUF(tr) + if (op <= bp) { + call sfree (sp) + return + } + + repeat { + op = op - 1 + while (Mems[op] != BOI) + if (op <= bp) { + TR_OP(tr) = bp + TR_IP(tr) = bp + call sfree (sp) + return + } else + op = op - 1 + opcode = Mems[op+GKI_HDR_OPCODE-1] + } until (opcode >= GKI_POLYLINE && opcode <= GKI_PUTCELLARRAY) + + # Redraw the last instruction to erase it (device permitting). + if (opcode == GKI_POLYLINE) { + PL_LTYPE(ap) = GL_CLEAR + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + call gki_plset (stream, ap) + + if (wstranset == YES) + call gtr_wstran (Mems[op]) + else + call gki_write (stream, Mems[op]) + + PL_LTYPE(ap) = GL_SOLID + call gki_plset (stream, ap) + call gki_fflush (stream) + } + + # Return the space in the buffer. + TR_LASTOP(tr) = TR_OP(tr) + TR_OP(tr) = op + TR_IP(tr) = min (op, TR_IP(tr)) + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrconn.x b/sys/gio/cursor/gtrconn.x new file mode 100644 index 00000000..c2e6fb47 --- /dev/null +++ b/sys/gio/cursor/gtrconn.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_CONNECT -- Connect a subprocess containing a graphics kernel task to a +# graphics stream. The graphics kernel task is a conventional IRAF task +# linked into the kernel process. After spawning the subprocess, we command +# the process to run the named kernel task, then service the parameter +# requests from the task as it begins running. Graphics i/o will be via one +# of the graphics streams, leaving STDIN, STDOUT, and STDERR free to access +# the corresponding streams in the parent (the CL). A kernel may be opened +# either to drive a particular device (if devname is specified) or to drive +# a device selected at runtime. If the kernel is opened to drive a particular +# device the device name in the OPENWS instruction will be ignored. We require +# that the graphics kernel begin processing metacode immediately after +# receiving "yes" for the value of the parameter "generic", signifying that +# the caller wishes a generic kernel, i.e., cannot return the values of any +# kernel dependent parameters. + +int procedure gtr_connect (kernfname, taskname, devname, stream, in, out) + +char kernfname[ARB] # name of executable kernel file +char taskname[ARB] # name of kernel task +char devname[ARB] # device name or null string +int stream # graphics stream to connect process to +int in, out # input and output streams to process + +pointer sp, lbuf +int pid +bool streq() +int propen(), getline() +errchk propen, flush, getline, syserr + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + pid = propen (kernfname, in, out) + call fprintf (out, "%s\n") + call pargstr (taskname) + call flush (out) + + # Pass values of the kernel parameters. For a kernel run as + # part of the graphics system there are only three parameters, + # the input file name (STDGRAPH, etc. for a connected kernel) + # the device name if the kernel is to ignore device names in + # OPENWS instructions, and "generic=yes", signifying that the + # kernel dependent parameters are not to be requested. + + while (getline (in, Memc[lbuf]) != EOF) { + if (streq (Memc[lbuf], "=input\n")) { + call fprintf (out, "%s\n") + switch (stream) { + case STDGRAPH: + call pargstr ("STDGRAPH") + case STDIMAGE: + call pargstr ("STDIMAGE") + case STDPLOT: + call pargstr ("STDPLOT") + } + call flush (out) + } else if (streq (Memc[lbuf], "=device\n")) { + call fprintf (out, "%s\n") + call pargstr (devname) + call flush (out) + } else if (streq (Memc[lbuf], "=generic\n")) { + call putline (out, "yes\n") + call flush (out) + break + } else { + call putline (STDERR, Memc[lbuf]) + call syserr (SYS_GKERNPARAM) + } + } + + call sfree (sp) + return (pid) +end diff --git a/sys/gio/cursor/gtrctrl.x b/sys/gio/cursor/gtrctrl.x new file mode 100644 index 00000000..8de08ccb --- /dev/null +++ b/sys/gio/cursor/gtrctrl.x @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "gtr.h" + +# GTR_CONTROL -- Execute a graphics control instruction, e.g., connect a +# graphics kernel to a graphics stream and set or get the WCS for a frame. +# The control instructions are GKI encoded instructions transmitted to the +# pseudofile GIOCONTROL. The PR_PSIO procedure (which processes the pseudofile +# directives from a subprocess) calls us whenever data is sent to this +# special pseudofile. + +procedure gtr_control (stream, gki, source_pid) + +int stream # graphics stream +short gki[ARB] # encoded graphics control instruction +int source_pid # pid of requesting process + +bool redirected +pointer tr, sp, devname, gki_out +int flags, mode, nwords, fd, p_fd +int prstati(), pr_getredir() +pointer gtr_init(), coerce() +errchk gtr_init, gtr_openws, write, flush, gki_write +include "gtr.com" + +begin + call smark (sp) + call salloc (devname, SZ_TRDEVNAME, TY_CHAR) + + nwords = gki[GKI_HDR_LENGTH] + call salloc (gki_out, nwords, TY_SHORT) + call amovs (gki, Mems[gki_out], nwords) + + tr = gtr_init (stream) + p_fd = abs (pr_getredir (source_pid, stream)) + redirected = (p_fd >= FIRST_FD && p_fd <= LAST_FD) + + switch (gki[GKI_HDR_OPCODE]) { + case GKI_OPENWS: + mode = gki[GKI_OPENWS_M] + nwords = gki[GKI_OPENWS_N] + + # Unpack the device name, passed as a short integer array. + call achtsc (gki[GKI_OPENWS_D], Memc[devname], nwords) + Memc[devname+nwords] = EOS + + # Connect the kernel. + call fseti (stream, F_CANCEL, OK) + call gtr_openws (Memc[devname], mode, stream, source_pid) + + # Count the logical openws. + TR_WSOPEN(tr) = TR_WSOPEN(tr) + 1 + TR_WSACTIVE(tr) = YES + TR_WSACTSAVE(tr) = NO + + # Due to a call to F_CANCEL in prpsio the openws instruction + # spooled by gki_write below is being lost for subkernels, + # so don't set the skipopen flag. This causes giotr to pass + # the openws on to the subkernel. For inline kernels setting + # skipopen prevents the openws from being executed twice. + + if (TR_INTERACTIVE(tr) == YES) + TR_SKIPOPEN(tr) = YES + + # If opening NEW_FILE, discard any previous WCS and clear the + # frame buffer. + + if (mode == NEW_FILE) { + call aclri (Memi[TR_WCSPTR(tr,1)], LEN_WCS * MAX_WCS) + call gtr_frame (tr, TR_FRAMEBUF(tr), stream) + } + + case GKI_CLOSEWS: + # Count the logical closews. + TR_WSOPEN(tr) = TR_WSOPEN(tr) - 1 + TR_WSACTIVE(tr) = NO + + case GKI_DEACTIVATEWS: + TR_WSACTIVE(tr) = NO + if (TR_INTERACTIVE(tr) == YES && TR_PAGE(tr) == NO) { + flags = gki[GKI_REACTIVATEWS_F] + if (and (flags, AW_CLEAR) != 0) + Mems[gki_out+GKI_REACTIVATEWS_F-1] = flags - AW_CLEAR + } + + case GKI_REACTIVATEWS: + TR_WSACTIVE(tr) = YES + if (TR_INTERACTIVE(tr) == YES) { + flags = gki[GKI_REACTIVATEWS_F] + if (and (flags, AW_PAUSE) != 0) + call gtr_waitpage (STDERR, stream) + } + + case GKI_SETWCS: + nwords = gki[GKI_SETWCS_N] + call amovs (gki[GKI_SETWCS_WCS], + Mems[coerce (TR_WCSPTR(tr,1), TY_STRUCT, TY_SHORT)], + min (nwords, LEN_WCS * MAX_WCS * SZ_STRUCT / SZ_SHORT)) + + case GKI_GETWCS: + nwords = gki[GKI_GETWCS_N] + fd = prstati (source_pid, PR_OUTFD) + + call write (fd, Memi[TR_WCSPTR(tr,1)], nwords * SZ_SHORT) + call flush (fd) + } + + # Pass the (possibly modified) instruction on to the kernel. + # We must NOT call gki_flush or gki_fflush here, as this would + # result in a reentrant call to prpsio when writing to a subkernel. + + if (!redirected) + call gki_write (stream, Mems[gki_out]) + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrdelete.x b/sys/gio/cursor/gtrdelete.x new file mode 100644 index 00000000..97f418a0 --- /dev/null +++ b/sys/gio/cursor/gtrdelete.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_DELETE -- Delete an instruction from the frame buffer. This prevents +# the instruction from being executed if the frame is redrawn. + +procedure gtr_delete (tr, gki) + +pointer tr #I giotr descriptor +pointer gki #I instruction to be deleted + +pointer inext +int nwords, shift, ilen + +begin + ilen = Mems[gki+GKI_HDR_LENGTH-1] + inext = gki + ilen + + if (inext >= TR_OP(tr)) { + # Instruction is the last one in the buffer. + TR_OP(tr) = gki + TR_LASTOP(tr) = TR_OP(tr) + if (TR_IP(tr) >= gki) + TR_IP(tr) = gki + + } else { + # If the instruction is small and would be expensive to delete + # just change the opcode to disable it, otherwise shift the + # buffer contents back to overwrite the deleted instruction. + + nwords = TR_OP(tr) - inext + if (ilen < 32 && nwords > 2048) + Mems[gki+GKI_HDR_OPCODE-1] = GKI_UNKNOWN + else { + call amovs (Mems[inext], Mems[gki], nwords) + shift = inext - gki + TR_IP(tr) = TR_IP(tr) - shift + TR_OP(tr) = TR_OP(tr) - shift + TR_LASTOP(tr) = TR_OP(tr) + } + } +end diff --git a/sys/gio/cursor/gtrdiscon.x b/sys/gio/cursor/gtrdiscon.x new file mode 100644 index 00000000..5eba23f4 --- /dev/null +++ b/sys/gio/cursor/gtrdiscon.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_DISCONNECT -- Disconnect from a kernel subprocess. To achieve an orderly +# shutdown we process any outstanding XMIT or XFER requests, then transmit an +# end of file (zero length record) to the kernel task when it reads from the +# graphics stream. The kernel should then shutdown and eventually we will +# receive "bye" from the process. We then call PRCLOSE to shutdown the +# process for good. Note: we do not expect anything but an XFER (read) request +# on the graphics stream, but it seems prudent to do something reasonable if +# some other request is received. + +procedure gtr_disconnect (pid, in, out, stream) + +int pid # process id of subprocess +int in, out # command i/o streams of the subprocess +int stream # graphics stream used by kernel + +pointer sp, sp2, lbuf, buf +int pseudofile, nchars, junk +bool streq() +int getline(), read(), strncmp(), psio_isxmit(), prclose(), pr_findproc() +errchk getline, prclose, read, write + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + while (getline (in, Memc[lbuf]) != EOF) { + if (streq (Memc[lbuf], "bye\n") || + strncmp (Memc[lbuf], "ERROR", 5) == 0) { + + junk = prclose (pid) + break + + } else if (Memc[lbuf] == '!') { + # OS escape. + call proscmd (pr_findproc(pid), Memc[lbuf+1]) + + } else { + call smark (sp2) + + switch (psio_isxmit (Memc[lbuf], pseudofile, nchars)) { + case XMIT: + call salloc (buf, nchars, TY_CHAR) + nchars = read (in, Memc[buf], nchars) + if (nchars > 0) + if (pseudofile == STDOUT || pseudofile == STDERR) + call write (pseudofile, Memc[buf], nchars) + + case XFER: + call salloc (buf, nchars, TY_CHAR) + if (pseudofile == STDIN) + nchars = read (pseudofile, Memc[buf], nchars) + else + nchars = 0 # this is the EOF + call psio_xfer (out, Memc[buf], nchars) + } + + call sfree (sp2) + } + } + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrfetch.x b/sys/gio/cursor/gtrfetch.x new file mode 100644 index 00000000..44ccfe60 --- /dev/null +++ b/sys/gio/cursor/gtrfetch.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_FETCH_NEXT_INSTRUCTION -- Return a pointer to the next GKI metacode +# instruction in the input buffer. Only complete instructions resident in +# a contiguous section of memory are returned. EOF is returned when the +# end of the current buffer is reached, or when the last instruction in the +# frame buffer is not yet complete. EOF does not signify the end of the +# metacode stream. + +int procedure gtr_fetch_next_instruction (tr, gki) + +pointer tr # pointer to giotr descriptor +pointer gki # pointer to next instruction (output) + +int nleft, length +pointer ip, itop + +begin + ip = TR_IP(tr) + itop = TR_OP(tr) + + # Search for the beginning of the next instruction. + while (Mems[ip] != BOI && ip < itop) + ip = ip + 1 + + nleft = itop - ip + if (nleft < 3) { + # The length field of the next instruction is not yet present. + TR_IP(tr) = ip + return (EOF) + } else { + length = Mems[ip+GKI_HDR_LENGTH-1] + if (length > nleft) { + # Entire instruction is not yet present in buffer. + TR_IP(tr) = ip + return (EOF) + } else { + # Entire instruction is present in buffer. + TR_IP(tr) = ip + length + gki = ip + return (length) + } + } +end diff --git a/sys/gio/cursor/gtrframe.x b/sys/gio/cursor/gtrframe.x new file mode 100644 index 00000000..baf68ffb --- /dev/null +++ b/sys/gio/cursor/gtrframe.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_FRAME -- Clear the frame buffer, used to spool the metacode instructions +# required to draw a graphics frame. This is done by moving the metacode data +# at the end of the buffer (beginning with the word pointed to by gki) to the +# beginning of the buffer and adjusting the input and output pointers +# accordingly. The workstation transformation is also reset to the unitary +# transformation when the frame is cleared, i.e., zoom is cancelled. + +procedure gtr_frame (tr, gki, stream) + +pointer tr # giotr descriptor +pointer gki # pointer to first word to be preserved +int stream # graphics stream + +pointer bp +int nwords, shift + +begin + bp = TR_FRAMEBUF(tr) + + if (gki > bp) { + nwords = TR_OP(tr) - gki + call amovs (Mems[gki], Mems[bp], nwords) + shift = gki - bp + TR_IP(tr) = TR_IP(tr) - shift + TR_OP(tr) = TR_OP(tr) - shift + } else { + TR_IP(tr) = bp + TR_OP(tr) = bp + } + + call gtr_ptran (stream, 0., 1., 0., 1.) + TR_OPSB(tr) = TR_SCRATCHBUF(tr) + TR_LASTOP(tr) = TR_OP(tr) + TR_WCS(tr) = NULL +end diff --git a/sys/gio/cursor/gtrgflush.x b/sys/gio/cursor/gtrgflush.x new file mode 100644 index 00000000..5681e234 --- /dev/null +++ b/sys/gio/cursor/gtrgflush.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_GFLUSH -- Dispose of any buffered output on the stream STDPLOT. The last +# plot sent to stdplot cannot be disposed of at CLOSEWS time due to the need +# to permit APPEND mode in the next OPENWS call. We are called to dispose +# of all output to the plotter device. Logging out or doing a reset will have +# the same effect. + +procedure gtr_gflush (stream) + +int stream +pointer tr +bool streq() +include "gtr.com" + +begin + tr = trdes[stream] + if (tr == NULL) + return + + # Disconnect the kernel. + iferr { + if (streq (TR_KERNFNAME(tr), "cl")) + call stg_close() + else if (TR_DEVNAME(tr) != EOS && TR_KERNFNAME(tr) != EOS) { + call gtr_disconnect (TR_PID(tr), TR_IN(tr), TR_OUT(tr), + stream) + TR_PID(tr) = NULL + } + } then + call erract (EA_WARN) + + # Free all storage. + call mfree (TR_FRAMEBUF(tr), TY_SHORT) + call mfree (TR_SCRATCHBUF(tr), TY_SHORT) + call mfree (tr, TY_STRUCT) + + trdes[stream] = NULL + if (tr_stream == stream) + tr_stream = NULL +end diff --git a/sys/gio/cursor/gtrgtran.x b/sys/gio/cursor/gtrgtran.x new file mode 100644 index 00000000..c83c83aa --- /dev/null +++ b/sys/gio/cursor/gtrgtran.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_GTRAN -- Get the workstation transformation. + +procedure gtr_gtran (fd, x1, x2, y1, y2) + +int fd # graphics stream to be set +real x1, x2 # range of workstation viewport in X +real y1, y2 # range of workstation viewport in Y +include "gtr.com" + +begin + if (wstranset == YES) { + x1 = vx1 + x2 = vx2 + y1 = vy1 + y2 = vy2 + } else { + x1 = 0 + x2 = 1.0 + y1 = 0 + y2 = 1.0 + } +end diff --git a/sys/gio/cursor/gtrgtty.x b/sys/gio/cursor/gtrgtty.x new file mode 100644 index 00000000..0e67a1fd --- /dev/null +++ b/sys/gio/cursor/gtrgtty.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_GTTY -- Get the graphcap descriptor for a stream. + +pointer procedure gtr_gtty (stream) + +int stream # graphics stream of interest + +pointer tr +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + return (TR_TTY(tr)) +end diff --git a/sys/gio/cursor/gtrinit.x b/sys/gio/cursor/gtrinit.x new file mode 100644 index 00000000..734d8202 --- /dev/null +++ b/sys/gio/cursor/gtrinit.x @@ -0,0 +1,136 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_INIT -- Initialize the GIOTR data structures for a graphics stream. These +# data structures are initialized only once, when the first i/o occurs on the +# stream. Thereafter our only function is to fault the workstation +# transformation parameters into the cache (the gtr common). + +pointer procedure gtr_init (stream) + +int stream # graphics stream + +int i, len_fb, len_sb +pointer tr, tx, ap, w +bool first_time +int btoi(), envgeti() +data first_time /true/ +errchk calloc, malloc +include "gtr.com" + +begin + if (first_time) { + call amovki (NULL, trdes, MAX_PSEUDOFILES) + tr_stream = NULL + first_time = false + } + + tr = trdes[stream] + + if (tr == NULL) { + # This is the first time the stream has been accessed. + + # Allocate descriptor. + call calloc (tr, LEN_TRSTRUCT, TY_STRUCT) + + # Don't need a frame buffer for STDPLOT, but make a dummy one + # anyhow so that the stream looks like the interactive ones. + + if (stream == STDPLOT) { + len_fb = 1 + len_sb = 1 + } else { + len_fb = DEF_LENFRAMEBUF + len_sb = DEF_LENSCRATCHBUF + } + + call malloc (TR_FRAMEBUF(tr), len_fb, TY_SHORT) + call malloc (TR_SCRATCHBUF(tr), len_sb, TY_SHORT) + + trdes[stream] = tr + TR_IP(tr) = TR_FRAMEBUF(tr) + TR_OP(tr) = TR_FRAMEBUF(tr) + TR_OPSB(tr) = TR_SCRATCHBUF(tr) + TR_LENFRAMEBUF(tr) = len_fb + TR_LENSCRATCHBUF(tr) = len_sb + TR_SPOOLDATA(tr) = btoi (stream != STDPLOT) + TR_WAITPAGE(tr) = NO + TR_PAGE(tr) = YES + + # Set text drawing attributes for annotating plots. + tx = TR_TXAP(tr) + TX_UP(tx) = 90 + TX_SIZE(tx) = 1.0 + TX_PATH(tx) = GT_RIGHT + TX_SPACING(tx) = 0 + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_QUALITY(tx) = GT_NORMAL + TX_COLOR(tx) = 1 + + # Set default polyline attributes for axis drawing. + ap = TR_PLAP(tr) + PL_LTYPE(ap) = GL_SOLID + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + + # The user can override the default maximum frame buffer length + # if they wish, permitting spooling of frames of any size. + + iferr (TR_MAXLENFRAMEBUF(tr) = envgeti ("cmbuflen")) + TR_MAXLENFRAMEBUF(tr) = DEF_MAXLENFRAMEBUF + + if (tr_stream != NULL) { + # Save the workstation transformation parameters for the + # stream currently in the cache, if any. + + call amovi (startcom, TR_GTRCOM(trdes[tr_stream]), LEN_GTRCOM) + call amovi (TR_GTRCOM(tr), startcom, LEN_GTRCOM) + } + + # Initialize the transformation parameters for the new stream. + tr_stream = stream + xscale = 1.0 + yscale = 1.0 + mx2 = GKI_MAXNDC + my2 = GKI_MAXNDC + vx2 = 1.0 + vy2 = 1.0 + + # Initialize the WCS in case someone tries to read the cursor + # before there are any graphics. + + do i = 1, MAX_WCS { + w = TR_WCSPTR(tr,i) + WCS_SX1(w) = 0.0 + WCS_SX2(w) = 1.0 + WCS_SY1(w) = 0.0 + WCS_SY2(w) = 1.0 + + WCS_WX1(w) = 0.0 + WCS_WX2(w) = 1.0 + WCS_WY1(w) = 0.0 + WCS_WY2(w) = 1.0 + } + + } else if (stream != tr_stream) { + # The stream has already been initialized. + + # If the cache is currently validated for some different stream + # move the data for that stream out into its descriptor. + + if (tr_stream != NULL) + call amovi (startcom, TR_GTRCOM(trdes[tr_stream]), LEN_GTRCOM) + + # Load the data for the new stream into the cache. + call amovi (TR_GTRCOM(tr), startcom, LEN_GTRCOM) + tr_stream = stream + } + + return (tr) +end diff --git a/sys/gio/cursor/gtropenws.x b/sys/gio/cursor/gtropenws.x new file mode 100644 index 00000000..27a3072a --- /dev/null +++ b/sys/gio/cursor/gtropenws.x @@ -0,0 +1,206 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include "gtr.h" + +# GTR_OPENWS -- Called by gtr_control(pr_psio) to connect a kernel to a +# graphics stream and to initialize the datapath to the kernel. +# The workstation is not physically opened until the GKI open workstation +# directive has been sent to the kernel. There are two types of kernels, +# the builtin (STDGRAPH) kernel, and all external kernels. The external +# kernels reside in connected subprocesses communicating via the central +# process (the CL process) with the graphics task in another subprocess. + +procedure gtr_openws (devspec, mode, stream, source_pid) + +char devspec[ARB] #I device specification +int mode #I access mode +int stream #I graphics stream +int source_pid #I process which issued the openws directive + +int redir_code, dd[LEN_GKIDD], ip +pointer sp, op, tr, tty, kernfname, taskname, device + +bool streq() +pointer ttygdes() +int pr_getredir(), ttygets(), gtr_connect(), pr_findproc(), locpr() +extern gtr_reset(), prpsio() + +errchk syserr, syserrs, fseti, ttygdes, ttycdes, pr_redir, stg_close, stg_open +errchk gtr_connect, gtr_disconnect +include "gtr.com" + +begin + call smark (sp) + call salloc (kernfname, SZ_FNAME, TY_CHAR) + call salloc (taskname, SZ_FNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + + tr = trdes[stream] + + # Extract the device name field from the device specification. + op = device + for (ip=1; devspec[ip] != EOS; ip=ip+1) + if (devspec[ip] == ',') + break + else { + Memc[op] = devspec[ip] + op = op + 1 + } + Memc[op] = EOS + + # We only connect up the i/o channels, and do not issue the OPENWS + # to the gio kernel, so reset the counter to zero to indicate that + # the workstation has not yet been (logically) opened. + + TR_WSOPEN(tr) = 0 + + # If the stream has been redirected into a file, do not connect a + # kernel. + + redir_code = pr_getredir (source_pid, stream) + if (redir_code >= FIRST_FD && redir_code <= LAST_FD) { + call sfree (sp) + return + } + + # The graphics stream is a spoolfile in this process (the CL process). + # Spoolfiles are files that are fully buffered in memory and never + # get written to disk. Data is written into the spoolfile and then + # read back out by a different part of the program. + + call fseti (stream, F_TYPE, SPOOL_FILE) + call fseti (stream, F_CANCEL, OK) + + # If the device is already connected to the stream (or we are + # appending to a connected device) all we need do is reset the + # redirection code for the graphics stream. This code is reset to + # the default value (the code for the stream itself) by the CL when + # a task is spawned. + + if (TR_DEVNAME(tr) != EOS && mode == APPEND || + streq (devspec, TR_DEVNAME(tr))) { + call pr_redir (source_pid, stream, TR_REDIR(tr)) + call sfree (sp) + return + } + + # Connect the named kernel, i.e., disconnect the old kernel if any + # and connect the new one. Set the redirection information for the + # named stream of the source process. + + iferr { + # Close device graphcap descriptor. + if (TR_TTY(tr) != NULL) + call ttycdes (TR_TTY(tr)) + + # Disconnect old kernel. + if (streq (TR_KERNFNAME(tr), "cl")) + call stg_close() + else if (TR_DEVNAME(tr) != EOS && TR_KERNFNAME(tr) != EOS) { + call gtr_disconnect (TR_PID(tr), TR_IN(tr), TR_OUT(tr), stream) + TR_PID(tr) = NULL + TR_IN(tr) = NULL + TR_OUT(tr) = NULL + } + } then { + TR_DEVNAME(tr) = EOS + call erract (EA_ERROR) + } else + TR_DEVNAME(tr) = EOS + + # Get graphcap entry for the new device. The special device name + # "none" indicates that there is no suitable stdgraph device. + + if (streq (devspec, "none")) { + switch (stream) { + case STDGRAPH: + call syserr (SYS_GGNONE) + case STDIMAGE: + call syserr (SYS_GINONE) + case STDPLOT: + call syserr (SYS_GPNONE) + default: + call syserr (SYS_GGNONE) + } + } else { + tty = ttygdes (Memc[device]) + TR_TTY(tr) = tty + } + + # Get the name of the executable file containing the kernel for the + # device. The special name "cl" signifies the builtin STDGRAPH kernel. + + if (ttygets (tty, "kf", Memc[kernfname], SZ_FNAME) <= 0) { + call ttycdes (tty) + call syserrs (SYS_GNOKF, Memc[device]) + } else if (ttygets (tty, "tn", Memc[taskname], SZ_FNAME) <= 0) + ; + + # Connect the new kernel. + call strcpy (Memc[kernfname], TR_KERNFNAME(tr), SZ_KERNFNAME) + + if (streq (Memc[kernfname], "cl")) { + # Open the stdgraph kernel. Connect the referenced GKI stream to + # the stdgraph kernel. Set a negative redirection code value to + # flag that GIOTR is to be called to filter graphics output from + # the process. + + call stg_open (devspec, dd, STDIN, STDOUT, 0, 0, 0) + call gki_inline_kernel (stream, dd) + if (source_pid != NULL) + call pr_redir (source_pid, stream, -stream) + TR_REDIR(tr) = -stream + TR_INTERACTIVE(tr) = YES + + } else { + # Spawn subprocess and start up kernel task. + TR_PID(tr) = gtr_connect (Memc[kernfname], Memc[taskname], + devspec, stream, TR_IN(tr), TR_OUT(tr)) + + # Encode the process slot number of the kernel process in the + # redirection code for the source process (the process which + # issued the openws). If the stream is STDGRAPH or STDIMAGE + # make the redirection code negative to flag that graphics + # output is to be processed through GIOTR (the workstation + # transformation). + + if (source_pid != NULL) { + redir_code = (pr_findproc(TR_PID(tr)) * KSHIFT) + stream + if (stream == STDGRAPH || stream == STDIMAGE) + redir_code = -redir_code + call pr_redir (source_pid, stream, redir_code) + TR_REDIR(tr) = redir_code + + # Mark the process busy. This flags it it as busy executing + # some subprotocol (in this case processing GKI metacode) and + # prevents commands such as chdir/set from being sent to the + # process and corrupting the IPC protocol. + + call prseti (TR_PID(tr), PR_STATUS, P_BUSY) + } + + call gki_subkernel (stream, TR_PID(tr), locpr(prpsio)) + TR_INTERACTIVE(tr) = NO + } + + # Do not change value of DEVNAME until the new kernel has been + # successfully connected, since this variable is used to test if + # the kernel is already connected. + + call strcpy (devspec, TR_DEVNAME(tr), SZ_TRDEVNAME) + + # Post the gtr_reset procedure to be executed upon process shutdown, + # to close down any connected graphics subkernels in an orderly way. + + call onexit (gtr_reset) + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrpage.x b/sys/gio/cursor/gtrpage.x new file mode 100644 index 00000000..2caa53cb --- /dev/null +++ b/sys/gio/cursor/gtrpage.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_PAGE -- Prepare the workstation for output of one or more pages of text. +# Whether or not the terminal is paged is optional. On terminals where the +# text and graphics are overlaid, it is possible to run the text by beneath +# the plot without affecting the plot. + +procedure gtr_page (fd, stream) + +int fd # output file +int stream # graphics stream + +pointer tr +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + if (TR_PAGE(tr) == YES) + call gki_deactivatews (stream, AW_CLEAR) + else + call gki_deactivatews (stream, 0) + + TR_WAITPAGE(tr) = YES +end diff --git a/sys/gio/cursor/gtrptran.x b/sys/gio/cursor/gtrptran.x new file mode 100644 index 00000000..eba3075e --- /dev/null +++ b/sys/gio/cursor/gtrptran.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_PTRAN -- Set the workstation transformation. The workstation +# transformation is automatically zeroed whenever the screen is cleared +# or when a workstation is opened. + +procedure gtr_ptran (stream, x1, x2, y1, y2) + +int stream # graphics stream to be set +real x1, x2 # range of workstation viewport in X +real y1, y2 # range of workstation viewport in Y + +pointer tr +real tol, min_width, dx, dy +real cx1, cx2, cy1, cy2 +include "gtr.com" + +begin + tr = trdes[stream] + tol = 5.0 * EPSILON + + if (abs(x1) < tol && abs (x2 - 1.0) < tol && + abs(y1) < tol && abs (y2 - 1.0) < tol) { + + wstranset = NO + + } else { + # Save viewport. + vx1 = x1 + vx2 = x2 + vy1 = y1 + vy2 = y2 + + # Clip viewport at NDC boundary. + cx1 = max (0., min (1., x1)) + cx2 = max (0., min (1., x2)) + cy1 = max (0., min (1., y1)) + cy2 = max (0., min (1., y2)) + + # Make sure the viewport does not have a zero extent in either + # axis after clipping. + min_width = 1E-4 + if (cx2 - cx1 < min_width) + cx2 = cx1 + min_width + if (cy2 - cy1 < min_width) + cy2 = cy1 + min_width + + # Set clipping viewport in input GKI space. + mx1 = nint (cx1 * GKI_MAXNDC) + mx2 = nint (cx2 * GKI_MAXNDC) + my1 = nint (cy1 * GKI_MAXNDC) + my2 = nint (cy2 * GKI_MAXNDC) + + # Set transformation upon the clipped GKI coordinates. + dx = max (min_width, (x2 - x1)) + dy = max (min_width, (y2 - y1)) + xorigin = (cx1 - x1) / dx * GKI_MAXNDC + yorigin = (cy1 - y1) / dy * GKI_MAXNDC + xscale = 1. / dx + yscale = 1. / dy + + wstranset = YES + } + + # Clear the scratch buffer whenever the workstation viewport is + # changed. + + TR_OPSB(tr) = TR_SCRATCHBUF(tr) +end diff --git a/sys/gio/cursor/gtrrcur.x b/sys/gio/cursor/gtrrcur.x new file mode 100644 index 00000000..495117a3 --- /dev/null +++ b/sys/gio/cursor/gtrrcur.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_READCURSOR -- Read the graphics cursor position in NDC coordinates. +# By the time we are called the plot has already been drawn and the +# workstation closed, hence we must reopen the workstation to read the +# cursor (the graphics terminal will not be in graphics mode otherwise). + +int procedure gtr_readcursor (fd, key, sx, sy, raster, rx, ry) + +int fd #I graphics stream +int key #O keystroke value +real sx, sy #O NDC screen coords of cursor +int raster #O raster number +real rx, ry #O NDC raster coords of cursor + +int cn +int m_sx, m_sy +int m_rx, m_ry + +begin + call gki_getcursor (fd, 0, + cn, key, m_sx, m_sy, raster, m_rx, m_ry) + + sx = real(m_sx) / GKI_MAXNDC + sy = real(m_sy) / GKI_MAXNDC + rx = real(m_rx) / GKI_MAXNDC + ry = real(m_ry) / GKI_MAXNDC + + return (key) +end diff --git a/sys/gio/cursor/gtrredraw.x b/sys/gio/cursor/gtrredraw.x new file mode 100644 index 00000000..ca2191b3 --- /dev/null +++ b/sys/gio/cursor/gtrredraw.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gtr.h" + +# GTR_REDRAW -- Redraw the screen from the metacode spooled in the frame +# buffer. + +procedure gtr_redraw (stream) + +int stream # graphics stream to be redrawn + +pointer tr, ip_save, op_save +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + if (TR_SPOOLDATA(tr) == YES && TR_OP(tr) > TR_FRAMEBUF(tr)) { + # Rewind the input pointer into the frame buffer. + TR_IP(tr) = TR_FRAMEBUF(tr) + + # Redraw frame buffer. + call gki_clear (stream) + call giotr (stream) + + # Redraw scratch buffer (axes). Set i/o pointers to the scratch + # buffer and draw its contents. Turn off interrupts to prevent + # an interrupt from leaving the pointers pointing to the wrong + # buffer. + + if (TR_OPSB(tr) > TR_SCRATCHBUF(tr)) { + call intr_disable() + ip_save = TR_IP(tr); TR_IP(tr) = TR_SCRATCHBUF(tr) + op_save = TR_OP(tr); TR_OP(tr) = TR_OPSB(tr) + + call giotr (stream) + + TR_IP(tr) = ip_save + TR_OP(tr) = op_save + call intr_enable() + } + + # Flush graphics output. + call gki_flush (stream) + } +end diff --git a/sys/gio/cursor/gtrreset.x b/sys/gio/cursor/gtrreset.x new file mode 100644 index 00000000..36c55a9a --- /dev/null +++ b/sys/gio/cursor/gtrreset.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_RESET -- Reset the graphics system. Disconnect all connected subkernels +# and free all file descriptors and memory. + +procedure gtr_reset (status) + +int status # not used (req. for ONEXIT) + +pointer tr +int stream +bool streq() +include "gtr.com" + +begin + do stream = STDGRAPH, STDPLOT { + tr = trdes[stream] + if (tr == NULL) + next + + iferr { + # Close device graphcap descriptor. + if (TR_TTY(tr) != NULL) + call ttycdes (TR_TTY(tr)) + + # Disconnect old kernel. + if (streq (TR_KERNFNAME(tr), "cl")) + call stg_close() + else if (TR_DEVNAME(tr) != EOS && TR_KERNFNAME(tr) != EOS) { + call gtr_disconnect (TR_PID(tr), + TR_IN(tr), TR_OUT(tr), stream) + TR_PID(tr) = NULL + TR_IN(tr) = NULL + TR_OUT(tr) = NULL + } + } then { + TR_DEVNAME(tr) = EOS + call erract (EA_WARN) + } else + TR_DEVNAME(tr) = EOS + + # Free all storage. + call mfree (TR_FRAMEBUF(tr), TY_SHORT) + call mfree (TR_SCRATCHBUF(tr), TY_SHORT) + call mfree (tr, TY_STRUCT) + + trdes[stream] = NULL + } +end diff --git a/sys/gio/cursor/gtrset.x b/sys/gio/cursor/gtrset.x new file mode 100644 index 00000000..629ef097 --- /dev/null +++ b/sys/gio/cursor/gtrset.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTRSET -- Set the workstation transformation. The workstation transformation +# is automatically zeroed whenever the screen is cleared or when a workstation +# is opened. + +procedure gtrset (fd, x1, x2, y1, y2) + +int fd # graphics stream to be set +real x1, x2 # range of workstation viewport in X +real y1, y2 # range of workstation viewport in Y +include "gtr.com" + +begin + mx1 = x1 * GKI_MAXNDC + mx2 = x2 * GKI_MAXNDC + my1 = y1 * GKI_MAXNDC + my2 = y2 * GKI_MAXNDC + + xscale = GKI_MAXNDC / (mx2 - mx1) + yscale = GKI_MAXNDC / (my2 - my1) + + wstranset = YES +end diff --git a/sys/gio/cursor/gtrstatus.x b/sys/gio/cursor/gtrstatus.x new file mode 100644 index 00000000..45b5731c --- /dev/null +++ b/sys/gio/cursor/gtrstatus.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +define LEN_NAME 10 + + +# GTR_STATUS -- Print information summarizing the utilization of resources +# by each of the three graphics streams. + +procedure gtr_status (fd) + +int fd # output file +int stream, ip +string names "STDGRAPH:,STDIMAGE:,STDPLOT: " +include "gtr.com" + +begin + for (ip=1; names[ip] != EOS; ip=ip+1) + if (names[ip] == ',') + names[ip] = EOS + + do stream = STDGRAPH, STDPLOT { + ip = (stream - STDGRAPH) * LEN_NAME + 1 + if (trdes[stream] == NULL) { + call fprintf (fd, "\t%s disconnected\n") + call pargstr (names[ip]) + } else + call gtr_memusage (fd, stream, names[ip]) + } + + call fprintf (fd, "\n") + call flush (fd) +end + + +# GTR_MEMUSAGE -- Print information summarizing the utilization of memory and +# other resources by a graphics stream. + +procedure gtr_memusage (fd, stream, name) + +int fd # output file +int stream # graphics stream to be described +char name[ARB] # name of graphics stream + +pointer tr, tx +int bufsize +int fstati() +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + call fprintf (fd, "\t%s kernel=%s, device=%s, page %s\n") + call pargstr (name) + call pargstr (TR_KERNFNAME(tr)) + call pargstr (TR_DEVNAME(tr)) + if (TR_PAGE(tr) == YES) + call pargstr ("enabled") + else + call pargstr ("disabled") + + bufsize = fstati (stream, F_BUFSIZE) + call fprintf (fd, + "\t\tmemory=%d (%dfb+%dsb+%dfio), frame=%d+%d words\n") + call pargi (TR_LENFRAMEBUF(tr) + TR_LENSCRATCHBUF(tr) + bufsize) + call pargi (TR_LENFRAMEBUF(tr)) + call pargi (TR_LENSCRATCHBUF(tr)) + call pargi (bufsize) + call pargi (TR_OP(tr) - TR_FRAMEBUF(tr)) + call pargi (TR_OPSB(tr) - TR_SCRATCHBUF(tr)) + + call fprintf (fd, + "\t\tspool=%s, nopen=%d, pid=%d, in=%d, out=%d, redir=%d, wcs=%d\n") + if (TR_SPOOLDATA(tr) == YES) + call pargstr ("yes") + else + call pargstr ("no") + call pargi (TR_NOPEN(tr)) + call pargi (TR_PID(tr)) + call pargi (TR_IN(tr)) + call pargi (TR_OUT(tr)) + call pargi (TR_REDIR(tr)) + call pargi (TR_WCS(tr)) + + tx = TR_TXAP(tr) + call fprintf (fd, + "\t\ttext size=%g, up=%d, path=%s, hj=%s, vj=%s, color=%d\n") + call pargr (TX_SIZE(tx)) + call pargi (TX_UP(tx)) + call gkp_txparg (TX_PATH(tx)) + call gkp_txparg (TX_HJUSTIFY(tx)) + call gkp_txparg (TX_VJUSTIFY(tx)) + call pargi (TX_COLOR(tx)) + + call fprintf (fd, "\n") +end diff --git a/sys/gio/cursor/gtrtrunc.x b/sys/gio/cursor/gtrtrunc.x new file mode 100644 index 00000000..6abda3ba --- /dev/null +++ b/sys/gio/cursor/gtrtrunc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_TRUNCATE -- Truncate the frame buffer, which has grown larger than +# the limit set by the user (or the system default). This is done by moving +# the metacode data at the end of the buffer (beginning with the word pointed +# to by gki) to the maximum upper limit of the buffer and adjusting the input +# and output pointers accordingly. + +procedure gtr_truncate (tr, gki) + +pointer tr # giotr descriptor +pointer gki # pointer to first word to be preserved +pointer top +int nwords + +begin + # Find the first instruction preceding the soft upper limit on the + # size of the buffer. + + top = TR_FRAMEBUF(tr) + TR_MAXLENFRAMEBUF(tr) + while (Mems[top] != BOI && top > TR_FRAMEBUF(tr)) + top = top - 1 + + # Move the partial instruction likely to be at the end of the buffer + # to the new "top". Note that we can only truncate (discard) + # instructions which have already been executed, hence the partial + # instruction at the end of the buffer must be preserved. + + if (gki != top) { + nwords = TR_OP(tr) - gki + call amovs (Mems[gki], Mems[top], nwords) + TR_IP(tr) = top + TR_OP(tr) = top + nwords + } +end diff --git a/sys/gio/cursor/gtrundo.x b/sys/gio/cursor/gtrundo.x new file mode 100644 index 00000000..5b8d3e02 --- /dev/null +++ b/sys/gio/cursor/gtrundo.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_UNDO -- Undo the last frame buffer edit. Successive pairs of undos leave +# the frame buffer unchanged. + +procedure gtr_undo (stream) + +int stream # graphics stream +int opcode +pointer tr, op, new_op, old_op, sp, ap + +pointer gtr_init() +errchk gtr_init +include "gtr.com" + +begin + call smark (sp) + call salloc (ap, LEN_PL, TY_STRUCT) + + tr = gtr_init (stream) + + old_op = TR_OP(tr) + new_op = TR_LASTOP(tr) + if (new_op == old_op || new_op <= TR_FRAMEBUF(tr)) { + call sfree (sp) + return + } + + # Edit the frame buffer. + TR_LASTOP(tr) = old_op + TR_OP(tr) = new_op + TR_IP(tr) = min (new_op, TR_IP(tr)) + + # Redraw the last drawing instruction to erase it (device permitting), + # if we are backing up one instruction. Note that it may be necessary + # to skip one or more control instructions. We assume that the undo + # only has to undo one drawing instruction. + + if (new_op < old_op) { + op = new_op + repeat { + opcode = Mems[op+GKI_HDR_OPCODE-1] + if (opcode == GKI_POLYLINE) + break + else + op = op + Mems[op+GKI_HDR_LENGTH-1] + } until (op >= old_op) + + if (opcode == GKI_POLYLINE && op < old_op) { + PL_LTYPE(ap) = GL_CLEAR + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + call gki_plset (stream, ap) + + if (wstranset == YES) + call gtr_wstran (Mems[op]) + else + call gki_write (stream, Mems[op]) + + PL_LTYPE(ap) = GL_SOLID + call gki_plset (stream, ap) + } + + } else if (new_op > old_op) { + # Call giotr to redraw the recovered instructions. + call giotr (stream) + } + + call gki_flush (stream) + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrwaitp.x b/sys/gio/cursor/gtrwaitp.x new file mode 100644 index 00000000..67f46dd8 --- /dev/null +++ b/sys/gio/cursor/gtrwaitp.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" +include "grc.h" + +# GTR_WAITPAGE -- Print the "hit return to continue" message on the terminal +# screen and wait for the user to respond before returning to graphics mode. +# Redrawing of the graphics frame is optional. + +procedure gtr_waitpage (fd, stream) + +int fd # output file +int stream # graphics stream + +int key, i +pointer tty, tr +int getci(), ttystati() +pointer ttyodes(), gtr_init() +errchk gtr_init, ttyodes + +begin + tr = gtr_init (stream) + tty = ttyodes ("terminal") + + repeat { + # Print prompt in standout mode. + call ttyclearln (fd, tty) + call ttyso (fd, tty, YES) + call fprintf (fd, + "[space=cmhelp,return=quit+redraw,q=quit+noredraw]") + call ttyso (fd, tty, NO) + call flush (fd) + + # Wait for user to hit a key. This is done in text mode via + # a raw getc rather than via a cursor read to avoid switching to + # graphics mode. On some terminals with separate text and + # graphics planes a switch to graphics mode turns off the text + # plane. + + call fseti (STDIN, F_RAW, YES) + if (getci (STDIN, key) == EOF) + key = '\r' + call fseti (STDIN, F_RAW, NO) + + # Take the action commanded by the user. At present the morehelp + # option merely prints cursor mode help; this is appropriate + # because the first waitpage call occurs after printing user help + # in response to ? (or after a :.show). + + switch (key) { + case 'q': + # Quit, do not clear graphics and redraw. + if (TR_PAGE(tr) == NO) { + # If screen paging is disabled (text drawn underneath + # transparent graphics overlay), clear the text frame + # only, using the clear line function. + + do i = 1, ttystati (tty, TTY_NLINES) { + call ttygoto (fd, tty, 1, i) + call ttyclearln (fd, tty) + } + } else + call ttyclearln (fd, tty) + + call flush (fd) + call gki_reactivatews (stream, 0) + break + + case '\r', '\n': + # Quit, clear graphics and redraw. + call ttyclearln (fd, tty) + call flush (fd) + call gki_reactivatews (stream, 0) + call gtr_redraw (stream) + break + + case ' ': + # Print cursor mode help. + iferr (call pagefile (KEYSFILE, "cursor mode help")) + call erract (EA_WARN) + + default: + # Illegal keystroke. + call printf ("\007") + call flush (STDOUT) + } + } + + call ttycdes (tty) +end diff --git a/sys/gio/cursor/gtrwcur.x b/sys/gio/cursor/gtrwcur.x new file mode 100644 index 00000000..9def0a67 --- /dev/null +++ b/sys/gio/cursor/gtrwcur.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_WRITECURSOR -- Write the graphics cursor position in NDC coordinates. + +procedure gtr_writecursor (fd, x, y) + +int fd # graphics stream +real x, y # NDC coords of cursor + +int mx, my + +begin + mx = max(0, min(GKI_MAXNDC, nint (x * GKI_MAXNDC))) + my = max(0, min(GKI_MAXNDC, nint (y * GKI_MAXNDC))) + + call gki_setcursor (fd, mx, my, 0) +end diff --git a/sys/gio/cursor/gtrwritep.x b/sys/gio/cursor/gtrwritep.x new file mode 100644 index 00000000..d1a3fd4a --- /dev/null +++ b/sys/gio/cursor/gtrwritep.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" + +# GTR_WRITEP -- Virtually write (append) to the graphics frame buffer. Return a +# pointer to the start of the area reserved for the data and advance the +# output pointer beyond the new data area. The use of a buffer pointer here +# yields a very efficient graphics i/o dataflow. For the stdgraph kernel, +# XMIT (pr_psio) places a block of metacode directly in the frame buffer at +# the memory location we point to. GIOTR is then called to process the new +# data block. GIOTR calls GTR_FETCH, which "fetches" the next instruction +# by merely returning a pointer into the frame buffer. The stdgraph kernel +# is then called to execute the instruction. Hence in the simple case, there +# are no memory to memory copies and the contents of an instruction are +# touched only by the kernel. + +pointer procedure gtr_writep (fd, nchars) + +int fd # graphics stream +int nchars # nchars to reserve at end of buffer + +pointer tr, bufp, top, segp +int blen, nwords, ip_offset, op_offset +errchk syserr, realloc +include "gtr.com" + +begin + tr = trdes[fd] + if (tr == NULL) + call syserr (SYS_GWRITEP) + + nwords = nchars / SZ_SHORT + bufp = TR_FRAMEBUF(tr) + blen = TR_LENFRAMEBUF(tr) + segp = TR_OP(tr) # pointer to next segment + top = bufp + blen + + # Make space available in the buffer. We must always allocate the + # requested space, even if the result is a buffer larger than the + # (soft) maximum size permitted. Buffer space will be returned + # after GIOTR processes the new instructions if the buffer grows + # too large. + + if (nwords > top - segp) { + # Note that realloc may move the buffer, hence we must adjust any + # pointers into the buffer after the call to realloc. + + ip_offset = TR_IP(tr) - bufp + op_offset = segp - bufp + blen = blen + max (INC_LENFRAMEBUF, nwords) + + call realloc (bufp, blen, TY_SHORT) + + TR_FRAMEBUF(tr) = bufp + TR_LENFRAMEBUF(tr) = blen + TR_IP(tr) = bufp + ip_offset + segp = bufp + op_offset + } + + TR_OP(tr) = segp + nwords + TR_LASTOP(tr) = TR_OP(tr) + + return (segp) +end diff --git a/sys/gio/cursor/gtrwsclip.x b/sys/gio/cursor/gtrwsclip.x new file mode 100644 index 00000000..3a0a384b --- /dev/null +++ b/sys/gio/cursor/gtrwsclip.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GTR_POLYCLIP -- Clip a convex polygon to a box. If the polygon is entirely +# outside the box 0 is returned; if the polygon is entirely within the box 1 +# is returned, otherwise the polygon is clipped and a value other than 0 or 1 +# is returned. This is based on code by Paul Heckbert from Graphics Gems, +# 1985/1989. + +int procedure gtr_polyclip (pv, npts, x1, x2, y1, y2) + +short pv[ARB] #U polygon to be clipped +int npts #U number of points in polygon +int x1,x2,y1,y2 #I clipping box + +pointer sp, p1, p2, pt +int x1out, x2out, y1out, y2out, i +int gtr_cliptoplane() +define nopts_ 91 + +begin + x1out = 0; x2out = 0 + y1out = 0; y2out = 0 + + # Count vertices which are outside with respect to each of the + # four planes. + + do i = 1, npts*2, 2 { + if (pv[i+0] < x1) x1out = x1out + 1 + if (pv[i+0] > x2) x2out = x2out + 1 + if (pv[i+1] < y1) y1out = y1out + 1 + if (pv[i+1] > y2) y2out = y2out + 1 + } + + # Is the polygon entirely inside the clipping box? + if (x1out + x2out + y1out + y2out == 0) + return (1) + + # Is the polygon entirely outside the clipping box? + if (x1out == npts || x2out == npts || y1out == npts || y2out == npts) + return (0) + + # If we get here the polygon partially intersects the clipping box. + # Clip against each of the planes that might cut the polygon, clipping + # the previously clipped polygon in each step. This is done in + # floating point to minimize accumulation of error when interpolating + # to the clipping plane to compute a new polygon vertex when the plane + # is crossed. + + call smark (sp) + call salloc (p1, npts * 4, TY_REAL) + p2 = p1 + npts * 2 + + call achtsr (pv, Memr[p1], npts * 2) + + if (x1out > 0) + if (gtr_cliptoplane (p1, p2, npts, 0, -1.0, real(x1)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + if (x2out > 0) + if (gtr_cliptoplane (p1, p2, npts, 0, 1.0, real(x2)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + if (y1out > 0) + if (gtr_cliptoplane (p1, p2, npts, 1, -1.0, real(y1)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + if (y2out > 0) + if (gtr_cliptoplane (p1, p2, npts, 1, 1.0, real(y2)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + + call achtrs (Memr[p1], pv, npts * 2) + call sfree (sp) + return (npts) + +nopts_ + call sfree (sp) + return (0) +end + + +# GTR_CLIPTOPLANE -- Clip the convex polygon P1 against a plane, copying +# the inbounds portion to the output polygon P2. + +int procedure gtr_cliptoplane (p1, p2, npts, index, s, ref) + +pointer p1 #I pointer to input polygon +pointer p2 #I pointer to output polygon +int npts #U number of polygon points or vertices +int index #I index of coordinate to be tested +real s #I sign for comparison +real ref #I value to compare against + +int nout, i +pointer op, u, v +real tu, tv, t + +begin + nout = 0 + op = p2 + + u = p1 + (npts - 1) * 2 + tu = s * Memr[u+index] - ref + v = p1 + + do i = 1, npts { + # On old polygon P1, U is previous vertex, V is current vertex, + # TV is negative if vertex V is in. + + tv = s * Memr[v+index] - ref + + if (! ((tu <= 0 && tv <= 0) || (tu > 0 && tv > 0))) { + # Edge crosses plane; add intersection point to P2. + t = tu / (tu - tv) + Memr[op+0] = Memr[u+0] + t * (Memr[v+0] - Memr[u+0]) + Memr[op+1] = Memr[u+1] + t * (Memr[v+1] - Memr[u+1]) + nout = nout + 1 + op = op + 2 + } + + if (tv <= 0) { + # Vertex V is in, copy it out. + Memr[op+0] = Memr[v+0] + Memr[op+1] = Memr[v+1] + nout = nout + 1 + op = op + 2 + } + + u = v + tu = tv + v = v + 2 + } + + npts = nout + return (nout) +end diff --git a/sys/gio/cursor/gtrwstran.x b/sys/gio/cursor/gtrwstran.x new file mode 100644 index 00000000..9262e00a --- /dev/null +++ b/sys/gio/cursor/gtrwstran.x @@ -0,0 +1,490 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +define MOVE 0 +define DRAW 1 +define LEFT 0 +define RIGHT 1 +define BELOW 0 +define ABOVE 1 +define INSIDE 2 +define FIRSTPT GKI_POLYLINE_P + + +# GTR_WSTRAN -- Apply the workstation transformation to an instruction and +# write the transformed instruction to the graphics kernel. The transformation +# parameters etc. should have been initialized in the gtr common before we +# are called. + +procedure gtr_wstran (gki) + +short gki[ARB] #I metacode instruction to be spooled + +long x, y +pointer sp, buf +int length, npts, data +int gtr_polyclip() +bool sge_wsenable() +include "gtr.com" + +begin + # Check with the graphics kernel to see if scaling of graphics + # instructions is enabled (it is disabled if the graphics device is + # already doing it for us). + + if (!sge_wsenable()) { + call gki_write (tr_stream, gki) + return + } + + switch (gki[GKI_HDR_OPCODE]) { + case GKI_FILLAREA: + npts = gki[GKI_FILLAREA_N] + data = GKI_FILLAREA_P + length = gki[GKI_HDR_LENGTH] + call amovs (gki, pl, length) + + switch (gtr_polyclip (pl[data], npts, mx1, mx2, my1, my2)) { + case 0: + # Entire instruction out of bounds. + case 1: + # Entire instruction in bounds. + pl_op = GKI_POLYLINE_P + npts * 2 + call gpt_flush() + default: + # Instruction has been clipped. + pl_op = GKI_POLYLINE_P + npts * 2 + call gpt_flush() + } + + case GKI_POLYLINE, GKI_POLYMARKER: + call gtr_polytran (gki) + + case GKI_SETCURSOR: + length = gki[GKI_HDR_LENGTH] + call smark (sp) + call salloc (buf, length, TY_SHORT) + + # Move cursor to edge of screen if point referenced is out of + # bounds. + + call amovs (gki, Mems[buf], length) + x = gki[GKI_SETCURSOR_POS] + y = gki[GKI_SETCURSOR_POS+1] + call gtr_ctran (x, y, x, y) + Mems[buf+GKI_SETCURSOR_POS-1] = x + Mems[buf+GKI_SETCURSOR_POS] = y + call gki_write (tr_stream, Mems[buf]) + + call sfree (sp) + + case GKI_TEXT: + length = gki[GKI_HDR_LENGTH] + call smark (sp) + call salloc (buf, length, TY_SHORT) + + # Discard text drawing instruction if the point referenced is + # out of bounds. If in bounds, transform coordinates and draw + # at the transformed point. + + call amovs (gki, Mems[buf], length) + x = gki[GKI_TEXT_P] + y = gki[GKI_TEXT_P+1] + if (x >= mx1 && x <= mx2 && y >= my1 && y <= my2) { + call gtr_ctran (x, y, x, y) + Mems[buf+GKI_TEXT_P-1] = x + Mems[buf+GKI_TEXT_P] = y + call gki_write (tr_stream, Mems[buf]) + } + + call sfree (sp) + + case GKI_PUTCELLARRAY: + # Just filter these out for now. + + default: + call gki_write (tr_stream, gki) + } +end + + +# GTR_CTRAN -- Apply the workstation transform to a set of GKI coordinates, +# i.e., transform raw GKI coords to screen coords in GKI units. + +procedure gtr_ctran (mx, my, sx, sy) + +int mx, my # raw GKI coordinates +int sx, sy # screen coordinates in GKI units +include "gtr.com" + +begin + sx = max(0, min(GKI_MAXNDC, nint ((mx - mx1) * xscale + xorigin))) + sy = max(0, min(GKI_MAXNDC, nint ((my - my1) * yscale + yorigin))) +end + + +# GTR_POLYTRAN -- Scale a polyline, polymarker, or fill area instruction +# by applying the workstation transformation. The workstation transformation +# scales vectors in a viewport defined in NDC(GKI) space to fit the full +# device screen. Vectors or segments of vectors lying outside the viewport +# are clipped at the screen boundary. + +procedure gtr_polytran (gki) + +short gki[ARB] # gki instruction to be transformed +long mx, my +int last_ip, opcode, i, ip +bool inbounds, otherside, points +int gpt_firstpt() +include "gtr.com" + +begin + last_ip = gki[GKI_HDR_LENGTH] + opcode = gki[GKI_HDR_OPCODE] + points = (opcode == GKI_POLYMARKER) + + # In the process of clipping a polyline may be broken into several + # smaller polylines (or polymarkers or fillareas, all of which are + # very similar at the instruction level). We store the GKI header + # in the first few words of the PL array so that when the transformed + # polyline is broken it is ready for execution. + + do i = 1, GKI_POLYLINE_P - 1 + pl[i] = gki[i] + pl_op = GKI_POLYLINE_P + + # Clip all points until either a point is encountered which is inbounds + # or which is on the other side of the viewport (in either axis). This + # is a fast way of clipping polylines which are mostly out of bounds. + # Return immediately if the entire vector is out of bounds. + + otherside = true + ip = FIRSTPT + if (gpt_firstpt (gki, ip, last_ip) <= 0) + return + + # Set initial position. + cx = gki[ip] + cy = gki[ip+1] + + # Clip the remaining points. Clipping is performed in GKI coordinates. + # The workstation transformation is not applied until the clipped + # vector is output. + + for (ip=ip+2; ip < last_ip; ip=ip+2) { + mx = gki[ip] + my = gki[ip+1] + + # Check to see if this is the first point of a new polyline. + # If so we must set the first physical point in the output + # polyline to the current position, making the current point + # the second physical point of the output polyline. + + if (pl_op <= GKI_POLYLINE_P) { + # Place the current pen position in the polyline as the + # first point if it is inbounds. + + if (cy <= my2 && cy >= my1 && cx <= mx2 && cx >= mx1) { + last_point_inbounds = true + pl[pl_op] = cx + pl_op = pl_op + 1 + pl[pl_op] = cy + pl_op = pl_op + 1 + } else { + last_point_inbounds = false + do i = 1, 4 { + xs[i] = cx + ys[i] = cy + } + } + } + + # Update the current position. + + cx = mx + cy = my + + # Clip at the edge of the device screen. + + inbounds = (my <= my2 && my >= my1 && mx <= mx2 && mx >= mx1) + + if (inbounds && (last_point_inbounds || points)) { + # Add point to polyline (the fast way). + pl[pl_op] = mx + pl_op = pl_op + 1 + pl[pl_op] = my + pl_op = pl_op + 1 + + } else if ((inbounds||last_point_inbounds||otherside) && !points) { + # Clip at viewport boundary. + + if (last_point_inbounds) { + # Update coords of last point drawn (necessary since we did + # not use the clipping code for inbounds points). + do i = 1, 4 { + xs[i] = pl[pl_op-2] + ys[i] = pl[pl_op-1] + } + } + call gpt_clipl (DRAW, mx, my) + otherside = false + + } else { + # Both points are out of bounds. Scan along until a point is + # found which is again in bounds, or which is on the other side + # of the viewport, requiring clipping across the viewport. + + if (gpt_firstpt (gki, ip, last_ip) > 0) { + do i = 1, 4 { + xs[i] = gki[ip] + ys[i] = gki[ip+1] + } + cx = gki[ip] + cy = gki[ip+1] + } + + otherside = true + inbounds = false + } + + last_point_inbounds = inbounds + } + + call gpt_flush() +end + + +# GPT_FIRSTPT -- Scan a vector and return the index of the next good point. +# A good point is a point which is either inbounds or which preceeds a point +# which is either inbounds or on the other side of the viewport, necessitating +# clipping across the viewport. + +int procedure gpt_firstpt (gki, ip, last_ip) + +short gki[ARB] # vector being clipped +int last_ip # last legal value of ip +int ip # starting index + +int mx, my, i +int first_ip, new_ip +include "gtr.com" + +begin + mx = gki[ip] + my = gki[ip+1] + first_ip = ip + new_ip = last_ip + + if (mx < mx1) { + do i=ip+2, last_ip, 2 + if (gki[i] >= mx1) { + new_ip = i + break + } + } else if (mx > mx2) { + do i=ip+2, last_ip, 2 + if (gki[i] <= mx2) { + new_ip = i + break + } + } else if (my < my1) { + do i=ip+3, last_ip, 2 + if (gki[i] >= my1) { + new_ip = i - 1 + break + } + } else if (my > my2) { + do i=ip+3, last_ip, 2 + if (gki[i] <= my2) { + new_ip = i - 1 + break + } + } else + return (ip) + + if (new_ip >= last_ip) + return (0) # entire vector is indefinite + else + ip = max (first_ip, new_ip - 2) + + return (ip) +end + + +# GPT_CLIPL -- Clip at left boundary. + +procedure gpt_clipl (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +long new_my +int newpen +include "gtr.com" + +begin + # Does line cross boundary? + if ((mx >= mx1 && xs[1] < mx1) || (mx <= mx1 && xs[1] > mx1)) { + if (mx >= mx1) + newpen = MOVE + else + newpen = pen + new_my = real(my - ys[1]) * real(mx1 - mx) / real(mx - xs[1]) + + my + 0.5 + call gpt_clipr (newpen, mx1, new_my) + } + + xs[1] = mx + ys[1] = my + + if (mx >= mx1) + call gpt_clipr (pen, mx, my) +end + + +# GPT_CLIPR -- Clip at right boundary. + +procedure gpt_clipr (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +long new_my +int newpen +include "gtr.com" + +begin + # Does line cross boundary? + if ((mx <= mx2 && xs[2] > mx2) || (mx >= mx2 && xs[2] < mx2)) { + if (mx <= mx2) + newpen = MOVE + else + newpen = pen + new_my = real(my - ys[2]) * real(mx2 - mx) / real(mx - xs[2]) + + my + 0.5 + call gpt_clipb (newpen, mx2, new_my) + } + + xs[2] = mx + ys[2] = my + + if (mx <= mx2) + call gpt_clipb (pen, mx, my) +end + + +# GPT_CLIPB -- Clip at bottom boundary. + +procedure gpt_clipb (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +long new_mx +int newpen +include "gtr.com" + +begin + # Does line cross boundary? + if ((my >= my1 && ys[3] < my1) || (my <= my1 && ys[3] > my1)) { + if (my >= my1) + newpen = MOVE + else + newpen = pen + new_mx = real(mx - xs[3]) * real(my1 - my) / real(my - ys[3]) + + mx + 0.5 + call gpt_clipt (newpen, new_mx, my1) + } + + xs[3] = mx + ys[3] = my + + if (my >= my1) + call gpt_clipt (pen, mx, my) +end + + +# GPT_CLIPT -- Clip at top boundary and put the final clipped point(s) in +# the output polyline. Note that a "move" at this level does not affect +# the current position (cx,cy), since the vector endpoints have been clipped +# and the current position vector follows the unclipped vector points input +# by the user. + +procedure gpt_clipt (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +include "gtr.com" + +begin + # Does line cross boundary? + if ((my <= my2 && ys[4] > my2) || (my >= my2 && ys[4] < my2)) { + if (my <= my2 || pen == MOVE) + call gpt_flush() + pl[pl_op] = real(mx - xs[4]) * real(my2 - my) / real(my - ys[4]) + + mx + 0.5 + pl_op = pl_op + 1 + pl[pl_op] = my2 + pl_op = pl_op + 1 + } + + xs[4] = mx + ys[4] = my + + if (my <= my2) { + if (pen == MOVE) + call gpt_flush() + pl[pl_op] = mx + pl_op = pl_op + 1 + pl[pl_op] = my + pl_op = pl_op + 1 + } +end + + +# GPT_FLUSH -- Flush the buffered "polyline", i.e., array of transformed and +# clipped points. For a polyline or fill area polygon there must be at least +# two points (4 cells) or it will be discarded. A single point polymarker is +# permitted. + +procedure gpt_flush() + +int npts, i +long mx, my +include "gtr.com" + +begin + if (pl_op >= GKI_POLYLINE_P + 2) { + npts = (pl_op - GKI_POLYLINE_P) / 2 + + # Apply the workstation transformation. + do i = GKI_POLYLINE_P, pl_op, 2 { + mx = nint ((pl[i] - mx1) * xscale + xorigin) + my = nint ((pl[i+1] - my1) * yscale + yorigin) + pl[i] = max(0, min(GKI_MAXNDC, mx)) + pl[i+1] = max(0, min(GKI_MAXNDC, my)) + } + + switch (pl[GKI_HDR_OPCODE]) { + case GKI_POLYMARKER: + pl[GKI_POLYMARKER_L] = pl_op - 1 + pl[GKI_POLYMARKER_N] = npts + call gki_write (tr_stream, pl) + + case GKI_FILLAREA: + pl[GKI_FILLAREA_L] = pl_op - 1 + pl[GKI_FILLAREA_N] = npts + call gki_write (tr_stream, pl) + + default: + if (npts >= 2) { + pl[GKI_POLYLINE_L] = pl_op - 1 + pl[GKI_POLYLINE_N] = npts + call gki_write (tr_stream, pl) + } + } + + pl_op = GKI_POLYLINE_P + } +end diff --git a/sys/gio/cursor/mkpkg b/sys/gio/cursor/mkpkg new file mode 100644 index 00000000..f6a79332 --- /dev/null +++ b/sys/gio/cursor/mkpkg @@ -0,0 +1,57 @@ +# Make the CURSOR package. + +$checkout libcur.a lib$ +$update libcur.a +$checkin libcur.a lib$ +$exit + +libcur.a: + # $set xflags = "$(xflags) -qfx" + + giotr.x gtr.com gtr.h + grcaxes.x grc.h gtr.com gtr.h + grcclose.x grc.h gtr.h + grccmd.x grc.h gtr.h \ + + grcinit.x grc.h + grcopen.x grc.h gtr.com gtr.h + grcpl.x gtr.h grc.h + grcread.x gtr.h + grcredraw.x grc.h + grcscr.x gtr.com gtr.h + grcstatus.x grc.h gtr.com gtr.h + grctext.x gtr.h grc.h + grcwarn.x + grcwcs.x grc.h gtr.h + grcwrite.x grc.h gtr.h + gtrbackup.x gtr.com gtr.h + gtrconn.x + gtrctrl.x gtr.com gtr.h \ + + gtrdelete.x gtr.h + gtrdiscon.x + gtrfetch.x gtr.h + gtrframe.x gtr.h + gtrgflush.x gtr.com gtr.h + gtrgtran.x gtr.com gtr.h + gtrgtty.x gtr.h + gtrinit.x gtr.com gtr.h + gtropenws.x gtr.com gtr.h \ + + gtrpage.x gtr.h + gtrptran.x gtr.com gtr.h + gtrrcur.x + gtrredraw.x gtr.h + gtrreset.x gtr.com gtr.h + gtrset.x gtr.com gtr.h + gtrstatus.x gtr.com gtr.h + gtrtrunc.x gtr.h + gtrundo.x gtr.com gtr.h + gtrwaitp.x grc.h gtr.h + gtrwcur.x + gtrwritep.x gtr.com gtr.h + gtrwstran.x gtr.com gtr.h + gtrwsclip.x + prpsinit.x + rcursor.x grc.h gtr.com gtr.h + ; diff --git a/sys/gio/cursor/prpsinit.x b/sys/gio/cursor/prpsinit.x new file mode 100644 index 00000000..4959deff --- /dev/null +++ b/sys/gio/cursor/prpsinit.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PRPSINIT -- Load the gio.cursor graphics driver for pseudofile i/o to the +# graphics streams. + +procedure prpsinit() + +extern giotr() +extern gtr_control(), gtr_gflush(), gtr_writep() +extern stg_readtty(), stg_writetty() + +begin + call prpsload (giotr, gtr_control, gtr_gflush, gtr_writep, + stg_readtty, stg_writetty) +end diff --git a/sys/gio/cursor/rcursor.x b/sys/gio/cursor/rcursor.x new file mode 100644 index 00000000..cc7dc739 --- /dev/null +++ b/sys/gio/cursor/rcursor.x @@ -0,0 +1,692 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" +include "grc.h" + +define SZ_CHARCON 5 +define MARKLEN 0.01 + +# Cursor step algorithm parameters. + +define MAX_STEP 0.1 # max cursor step size, cursor motions +define MIN_STEP 0.002 # min cursor step size, cursor motions +define LARGER_STEP 2.0 # factor by which step size is increased +define SMALLER_STEP 0.5 # factor by step size is decreased +define NSTEP 2 # number of steps before larger step +define MANUAL_STEP 5.0 # gear ratio for F/V cursor control +define SLOW 1 # for fast/slow algorithm +define FAST 2 + +# Zoom parameters. + +define X_ZOOMFACTOR 0.5 # zoom factors +define Y_ZOOMFACTOR 0.5 +#define X_ZOOMFACTOR 0.666 # zoom factors +#define Y_ZOOMFACTOR 0.666 + +# Roam factors. + +define X_ROAM 0.333 # fraction of the current window +define Y_ROAM 0.333 # fraction of the current window + + +# RCURSOR -- Read the position of a cursor. This is the main entry point to +# cursor mode/cursor input from the CL; we are called by the QUERY procedure +# of the CL when a cursor type parameter is read. The cursor position is +# returned as a string of the form +# +# x y wcs key stringval +# +# where the "stringval" field may be absent if not appropriate for a given key. +# If EOF is returned the cursor value string is undefined. + +int procedure rcursor (stream, outstr, maxch) + +int stream # graphics stream +char outstr[ARB] # encoded cursor value (output) +int maxch + +bool cminit +int xroam[9], yroam[9] +pointer rc, tr, sp, lbuf, ip +char charcon[SZ_CHARCON], ch +real x1, x2, y1, y2, xt, yt, v[10] +real lx1, lx2, ly1, ly2, aspect_ratio +real x, y, rx, ry, xw, yw, dx, dy, xc, yc +int junk, key, nukey, last_zoom, i, wcs, ppos, ucasein, raster + +bool ttygetb() +pointer grc_open() +int envfind(), ctocc(), oscmd(), gtr_readcursor(), grc_readtty() +int grc_cursor(), grc_command(), grc_selectwcs(), grc_mapkey(), ttstati() +real ttygetr() + +errchk grc_text, grc_readtty, grc_writecursor +errchk grc_init, grc_open, grc_command, grc_cursor, grc_message +errchk grc_readcursor, grc_mapkey, grc_redraw, envfind + +data xroam /1,0,-1,1,0,-1,1,0,-1/ +data yroam /1,1,1,0,0,0,-1,-1,-1/ +data rc /NULL/ +define done_ 91 +define coloncmd_ 92 + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + + # Allocate and initialize the RCURSOR descriptor. + if (rc == NULL) { + call grc_init (rc) + cminit = true + } else + cminit = false + + # Open or reopen the graphics kernel. + tr = grc_open ("", APPEND, stream, rc) + + # Process CMINIT command string, if present in environment. This is + # only done once. + + if (cminit) { + if (envfind ("cminit", Memc[lbuf], SZ_COMMAND) > 0) { + ip = lbuf + while (IS_WHITE(Memc[ip]) || Memc[ip] == '.') + ip = ip + 1 + junk = grc_command (rc, stream, 0.,0.,0,0.,0., Memc[ip]) + } + cminit = false + } + + # If the graphics device does not permit input, i.e., does not have + # a cursor, return EOF. + + if (!ttygetb (TR_TTY(tr), "in")) { + x = 0; y = 0 + key = EOF + goto done_ + } + + # Determine if input keys are to be mapped to lower case by default, + # i.e., ucasein mode has been set for the terminal driver. + + ucasein = ttstati (STDIN, TT_UCASEIN) + + last_zoom = 3 + ppos = NO + + # Enter cursor mode loop. The loop terminates when a non cursor mode + # keystroke is typed. + + while (grc_cursor (rc, stream, key,x,y, raster,rx,ry, ppos) != EOF) { + Memc[lbuf] = EOS + + # As a rule, no processing is performed on escaped keys. The only + # exception is when ucasein mode is set in the terminal driver, + # causing upper case input to be mapped to lower case. This mapping + # is disabled in a raw mode cursor read, hence we must perform the + # mapping explicitly here, returning a lower case key to the + # applications program. Unescaped upper case input keystrokes will + # be intercepted by cursor mode when ucasein mode is in effect. + + if (key == '\\') { + junk = gtr_readcursor (stream, key, x, y, raster, rx, ry) + if (ucasein == YES && IS_UPPER(key)) + key = TO_LOWER (key) + break + } + + # Map keystroke. If the keystroke maps to a null value the key + # is not recognized as a cursor mode keystroke and we exit. + + if (grc_mapkey (rc, key, nukey) == NULL) + break + + switch (nukey) { + case 'M': + # Move the feature under the cursor to the center of the + # screen without changing the scaling. + + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + xw = (x2 - x1) / 2. + yw = (y2 - y1) / 2. + call gtr_ptran (stream, xc-xw, xc+xw, yc-yw, yc+yw) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + + case 'Z': + # Zoom in in both X and Y. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + xw = (x2 - x1) * X_ZOOMFACTOR / 2. + yw = (y2 - y1) * Y_ZOOMFACTOR / 2. + call gtr_ptran (stream, xc-xw, xc+xw, yc-yw, yc+yw) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + last_zoom = 3 + + case 'X': + # Zoom in in X. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + xw = (x2 - x1) * X_ZOOMFACTOR / 2. + call gtr_ptran (stream, xc-xw, xc+xw, y1, y2) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + last_zoom = 1 + + case 'Y': + # Zoom in in Y. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + yw = (y2 - y1) * Y_ZOOMFACTOR / 2. + call gtr_ptran (stream, x1, x2, yc-yw, yc+yw) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + last_zoom = 2 + + case '>': + # Zoom in in Y by setting the upper limit of the viewport + # to the cursor Y position. + + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + call gtr_ptran (stream, lx1, lx2, ly1, yc) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call gtr_writecursor (stream, x, 0.5) + last_zoom = 'E' + + case '<': + # Zoom in in Y by setting the lower limit of the viewport + # to the cursor Y position. + + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + call gtr_ptran (stream, lx1, lx2, yc, ly2) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call gtr_writecursor (stream, x, 0.5) + last_zoom = 'E' + + case 'E': + # Expand by marking corners of new viewport. If the range is + # small in either X or Y only the other axis will be expanded. + + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + call grc_scrtondc (x, y, x1, y1) + call grc_message (stream, "again:") + junk = grc_cursor (rc, stream, key,x2,y2, raster,rx,ry, ppos) + call grc_scrtondc (x2, y2, x2, y2) + + if (x1 > x2) + { xt = x2; x2 = x1; x1 = xt } + if (y1 > y2) + { yt = y2; y2 = y1; y1 = yt } + + if (abs (x1 - x2) < .01) + call gtr_ptran (stream, lx1, lx2, y1, y2) + else if (abs (y1 - y2) < .01) + call gtr_ptran (stream, x1, x2, ly1, ly2) + else + call gtr_ptran (stream, x1, x2, y1, y2) + + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call gtr_writecursor (stream, 0.5, 0.5) + last_zoom = 'E' + + case 'P': + # Zoom out. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + + if (last_zoom == 'E') { + call gtr_ptran (stream, lx1, lx2, ly1, ly2) + lx1 = x1; lx2 = x2; ly1 = y1; ly2 = y2 + } else { + if (last_zoom == 1 || last_zoom == 3) { + xw = (x2 - x1) / X_ZOOMFACTOR / 2. + x1 = xc - xw + x2 = xc + xw + } + if (last_zoom == 2 || last_zoom == 3) { + yw = (y2 - y1) / Y_ZOOMFACTOR / 2. + y1 = yc - yw + y2 = yc + yw + } + call gtr_ptran (stream, x1, x2, y1, y2) + } + + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + + case 'W': + # Select and fix WCS to be used for scr->wcs coordinate + # transformations. + + call grc_scrtondc (x, y, xc, yc) + TR_WCS(tr) = grc_selectwcs (tr, raster, xc, yc) + + case 'C': + # Running tally of cursor position. + #if (ppos == NO) { + # call grc_pcursor (stream, x, y, raster, rx, ry) + # ppos = YES + #} else { + # call grc_message (stream, "\n\n") + # ppos = NO + #} + + call grc_pcursor (stream, x, y, raster, rx, ry) + + case 'D': + # Draw a line by marking the endpoints. + call grc_scrtondc (x, y, v[1], v[2]) + call grc_message (stream, "again:") + junk = grc_cursor (rc, stream, key,x2,y2, raster,rx,ry, ppos) + call grc_scrtondc (x2, y2, v[3], v[4]) + call grc_polyline (stream, v, 2) + + case 'T': + # Draw a text string. + if (grc_readtty (stream, "text: ", Memc[lbuf], SZ_COMMAND) <= 0) + next + call grc_scrtondc (x, y, xc, yc) + call grc_text (stream, xc, yc, Memc[lbuf]) + + case 'A': + # Draw and label the axes of the viewport. + call grc_axes (stream, x, y, raster, rx, ry) + + case 'B': + # Backup one instruction in the frame buffer. + call gtr_backup (stream) + + case 'U': + # Undo the last frame buffer edit. + call gtr_undo (stream) + + case 'R': + # Redraw the screen. + call grc_redraw (rc, stream, x, y, raster, rx, ry) + + case '0': + # Reset and redraw. + call gtr_ptran (stream, 0., 1., 0., 1.) + call gtr_writecursor (stream, .5, .5) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + + case '5': + # Redraw (null roam request). + call grc_redraw (rc, stream, x, y, raster, rx, ry) + + case '1','2','3','4','6','7','8','9': + # Roam. + i = TO_INTEG (key) + if (xroam[i] != 0 || yroam[i] != 0) { + call gtr_gtran (stream, x1, x2, y1, y2) + dx = (x2 - x1) * X_ROAM * xroam[i] + dy = (y2 - y1) * Y_ROAM * yroam[i] + call gtr_ptran (stream, x1+dx, x2+dx, y1+dy, y2+dy) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + } + + case ':': + # Enter a colon command string and terminate cursor mode. + + # Get the string value. + if (grc_readtty (stream, ":", Memc[lbuf], SZ_COMMAND) <= 0) + next + + # All cursor mode commands must begin with a ".". An osescape + # begins with an "!". + + if (Memc[lbuf] == '!') { + call gtr_page (STDERR, stream) + if (oscmd (Memc[lbuf+1], "", "", "") == ERR) + call fprintf (STDERR, "\7") + call gtr_waitpage (STDERR, stream) + + } else if (Memc[lbuf] == '.') { + # Save viewport for 'P'. +coloncmd_ + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + last_zoom = 'E' + + TR_WAITPAGE(tr) = NO + if (grc_command (rc, stream, x, y, raster, rx, ry, + Memc[lbuf+1]) == EOF) { + key = EOF + goto done_ + } + + # The following is a no-op for most colon commands. + if (TR_WAITPAGE(tr) == YES) + call gtr_waitpage (STDERR, stream) + } else + break + + case '=': + # Shorthand for :.snap. The latter must be used once to + # set the plotter device, else the default stdplot device + # will be used. + + call strcpy (".snap", Memc[lbuf], SZ_COMMAND) + goto coloncmd_ + + default: + call fprintf (STDERR, "\007") + } + } + + # Mark the cursor position if markcur enabled. + if (RC_MARKCUR(rc) == YES && key != EOF) { + call grc_scrtondc (x, y, xc, yc) + aspect_ratio = ttygetr (TR_TTY(tr), "ar") + if (aspect_ratio < .001) + aspect_ratio = 1.0 + + v[1] = xc - MARKLEN * aspect_ratio + v[2] = yc + v[3] = xc + MARKLEN * aspect_ratio + v[4] = yc + v[5] = xc + v[6] = yc + v[7] = xc + v[8] = yc - MARKLEN + v[9] = xc + v[10] = yc + MARKLEN + call grc_polyline (stream, v, 5) + } + + # Close the workstation, leave graphics mode, position alpha cursor to + # lower left corner of graphics terminal. + + call grc_close (stream, rc) + + # Encode the cursor value as a string for the CL. +done_ + if (key != EOF) { + if (key == ' ') + call strcpy ("\\40", charcon, SZ_CHARCON) + else { + ch = char (key) + junk = ctocc (ch, charcon, SZ_CHARCON) + } + call grc_scrtowcs (stream, x, y, raster, rx, ry, xc, yc, wcs) + + call sprintf (outstr, maxch, "%g %g %d %s %s\n") + call pargr (xc) + call pargr (yc) + call pargi (wcs) + call pargstr (charcon) + call pargstr (Memc[lbuf]) + } else + outstr[1] = EOS + + call sfree (sp) + return (key) +end + + +# GRC_CURSOR -- Read the position of a cursor in screen coordinates. Recognizes +# the cursor movement keystrokes H, J, K, and L, exiting only when some other +# keystroke is received. The cursor movement algorithm is initialized upon +# entry. Two algorithms are provided for controlling the cursor step size. +# The first algorithm (automatic control) starts with a large initial step +# size. In the vicinity of a feature the cursor will overshoot the feature +# and the user will step back in the opposite direction, causing the step size +# to be decreased, rapidly converging to the desired position. Several steps +# in the same direction cause the large step size to be restored. The second +# algorithm (manual control) uses the F and V keys to directly control the step +# size. + +int procedure grc_cursor (rc, stream, key, x, y, raster, rx, ry, ppos) + +pointer rc #I rcursor descriptor +int stream #I graphics stream +int key #O keystroke typed +real x, y #O cursor screen coordinates +int raster #O raster number +real rx, ry #O cursor raster coordinates +int ppos #I print cursor position flag + +int speed +int xdir, ydir, nukey +real xstep, ystep, newx, newy + +bool ttygetb() +pointer gtr_gtty() +int gtr_readcursor(), grc_mapkey() +errchk gtr_readcursor, gtr_writecursor + +begin + # Reset the cursor step size to the default. + xstep = MAX_STEP + ystep = MAX_STEP + xdir = 0 + ydir = 0 + speed = 0 + + while (gtr_readcursor (stream, key, x, y, raster, rx, ry) != EOF) { + if (grc_mapkey (rc, key, nukey) == NULL) + break + + newx = x + newy = y + + switch (nukey) { + case 'F': + # Faster. + xstep = min (MAX_STEP, xstep * MANUAL_STEP) + ystep = min (MAX_STEP, ystep * MANUAL_STEP) + speed = FAST + + case 'V': + # Slower. + xstep = max (MIN_STEP, xstep / MANUAL_STEP) + ystep = max (MIN_STEP, ystep / MANUAL_STEP) + speed = SLOW + + case 'H': + # Step cursor left. + if (speed == 0) + if (xdir < -NSTEP) { + xstep = MAX_STEP + xdir = -1 + } else if (xdir > 0) { + xstep = max (MIN_STEP, xstep * SMALLER_STEP) + xdir = -1 + } else + xdir = xdir - 1 + newx = newx - xstep + call gtr_writecursor (stream, newx, newy) + + case 'J': + # Step cursor down. + if (speed == 0) + if (ydir < -NSTEP) { + ystep = MAX_STEP + ydir = -1 + } else if (ydir > 0) { + ystep = max (MIN_STEP, ystep * SMALLER_STEP) + ydir = -1 + } else + ydir = ydir - 1 + newy = newy - ystep + call gtr_writecursor (stream, newx, newy) + + case 'K': + # Step cursor up. + if (speed == 0) + if (ydir > NSTEP) { + ystep = MAX_STEP + ydir = 1 + } else if (ydir < 0) { + ystep = max (MIN_STEP, ystep * SMALLER_STEP) + ydir = 1 + } else + ydir = ydir + 1 + newy = newy + ystep + call gtr_writecursor (stream, newx, newy) + + case 'L': + # Step cursor right. + if (speed == 0) + if (xdir > NSTEP) { + xstep = MAX_STEP + xdir = 1 + } else if (xdir < 0) { + xstep = max (MIN_STEP, xstep * SMALLER_STEP) + xdir = 1 + } else + xdir = xdir + 1 + newx = newx + xstep + call gtr_writecursor (stream, newx, newy) + + default: + break + } + + # We assume the cursor may have moved if the WC capability exists + # for this device. + + if (ttygetb (gtr_gtty (stream), "WC")) { + x = newx + y = newy + } + + # Print the cursor position. + if (ppos == YES) + call grc_pcursor (stream, x, y, raster, rx, ry) + } + + return (key) +end + + +# GRC_MAPKEY -- Map keystroke. If the keystroke maps to a null value the key +# is not recognized as a cursor mode keystroke and we exit. Note that if case +# sensitivity is disabled, KEYS comparisions must be made in upper case but +# only lower case is to be returned to the calling program. + +int procedure grc_mapkey (rc, key, nukey) + +pointer rc #I rcursor descriptor +int key #U raw key value +int nukey #O mapped key value + +begin + nukey = max(1, min(MAX_KEYS, key)) + if (RC_CASE(rc) == NO && IS_LOWER(nukey)) + nukey = TO_UPPER(nukey) + + nukey = RC_KEYS(rc,nukey) + if (nukey == NULL) { + # Not a cursor mode key. + if (RC_CASE(rc) == NO && IS_UPPER(nukey)) + key = TO_LOWER(key) + } else if (IS_LOWER(nukey)) + nukey = TO_UPPER(nukey) + + return (nukey) +end + + +# GRC_RESTORECURPOS -- Restore the cursor position in NDC coordinates +# regardless of the current workstation transformation. + +procedure grc_restorecurpos (stream, x, y) + +int stream # graphics stream +real x, y # new cursor position in NDC coords +real sx, sy +include "gtr.com" + +begin + call grc_ndctoscr (x, y, sx, sy) + call gtr_writecursor (stream, sx, sy) +end + + +# GRC_READTTY -- Read from the terminal via the graphics kernel. If the +# kernel already has message data buffered we merely return that data, +# otherwise we issue the prompt given and interactively read the data. + +int procedure grc_readtty (stream, prompt, obuf, maxch) + +int stream #I graphics stream +char prompt[ARB] #I prompt, if read is interactive +char obuf[ARB] #O output buffer +int maxch #I max chars out + +bool issue_prompt +int nchars, index +int stg_msglen(), stg_readtty() +int stridxs(), strlen() + +begin + issue_prompt = (stg_msglen(STDIN) <= 0) + if (issue_prompt) + call stg_putline (STDERR, prompt) + + nchars = stg_readtty (STDIN, obuf, maxch) + index = stridxs ("\n", obuf) + if (index > 0) + obuf[index] = EOS + nchars = strlen (obuf) + + if (issue_prompt && nchars == 0) + call grc_message (stream, "\n\n") + + return (nchars) +end + + +# GRC_MESSAGE -- Write a message on the status line at the bottom of the +# screen. If the string is not newline terminated the terminal is left in +# status line text mode. To clear the status line and force the terminal +# back into graphics mode, output the string "\n\n". + +procedure grc_message (stream, message) + +int stream # graphics stream +char message[ARB] # message to be printed + +begin + call stg_putline (STDERR, message) +end + + +# GRC_PCURSOR -- Convert the cursor position in screen coordinates to world +# coordinates and print on the standard output. + +procedure grc_pcursor (stream, sx, sy, raster, rx, ry) + +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor + +int wcs +real xc, yc +pointer sp, lbuf + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call grc_scrtowcs (stream, sx, sy, raster, rx, ry, xc, yc, wcs) + if (abs(xc) > 1 && abs(xc) < 10000 && abs(yc) > 1 && abs(yc) < 10000) + call sprintf (Memc[lbuf], SZ_LINE, "%10.3f %10.3f \n") + else + call sprintf (Memc[lbuf], SZ_LINE, "%12.7g %12.7g \n") + call pargr (xc) + call pargr (yc) + + call stg_putline (STDERR, Memc[lbuf]) + call sfree (sp) +end diff --git a/sys/gio/doc/gio.hlp b/sys/gio/doc/gio.hlp new file mode 100644 index 00000000..f8749c23 --- /dev/null +++ b/sys/gio/doc/gio.hlp @@ -0,0 +1,3498 @@ +.help gio Dec84 "Graphics I/O" +.ce +\fBGraphics I/O Design\fR +.ce +Doug Tody +.ce +December 1984 +.ce +(revised October 1987) +.sp 3 +.nh +Introduction + + The graphics i/o (GIO) interface is a library of SPP or Fortran callable +procedures for interactive vector graphics. The interface is designed primarily +for scientific applications (graphing 1-dimensional data vectors). Limited +support is also provided for displaying 2-dimensional image data. GIO is fully +integrated into the IRAF system and is not intended for use in systems other +than IRAF. The principal design objectives of GIO are outlined below. + +.ls +.ls o +Simple and efficient interactive graphics. For interactive data analysis +applications speed is typically much more important than the quality of +the plot. +.le +.ls o +Ease of use. The interface must be easy to use for scientific data analysis +applications. Ease of use for interactive graphics in scientific applications +is considered more important than the flexibility required to produce +publication quality graphics. +.le +.ls o +Compact size. That portion of the graphics system required for interactive +graphics must be small enough to be linked into every process which performs +interactive graphics. +.le +.ls o +Device independence. The interface must be device independent without +compromising compactness and speed. True device independence means that +an applications program that normally uses interactive graphics can be run +noninteractively or from a nongraphics workstation. +.le +.le + + +IRAF needs its own graphics interface partly because no existing graphics +interface meets all of the above requirements, and partly because we do not +want our applications to be dependent upon any particular external graphics +package. The existing large graphics interfaces such as GKS and CORE are +likely to make it easier to interface GIO to new graphics devices, but to +be completely and directly dependent on any one such interface is unwise since +implementations are sometimes hard to come by. Furthermore, packages such +as GKS and CORE were designed to serve as the kernel of a graphics system +and are cumbersome to use directly in applications software. GIO will serve +as a front end to the graphics kernel, providing a higher level interface +for applications software and isolating the IRAF applications from the kernel, +making it possible to switch to a different kernel without rewriting the +applications packages. + +.nh +Conceptual Design + + GIO is intended to be used either as a self contained interface to a +graphics device, with GIO writing device instructions directly to the device, +or as an interface to a more general device independent graphics kernel. +For maximum speed in interactive applications GIO will use a special builtin +kernel capable of driving only the interactive graphics devices in use at +a particular site (e.g., tektronix compatible graphics terminals). +Other devices will be driven by a device independent graphics kernel resident +in a separate process. GIO will select the data path to be used for a +particular device transparently to the calling program. Thus, the overhead +of process initiation and IPC will be eliminated in common interactive +applications without sacrificing device independence. The builtin kernel +will be table driven using a \fBtermcap\fR format graphics device database, +allowing maximum flexibility for adapting GIO to new graphics devices. + +The device independent graphics kernel may be GKS, CORE, NSPP, or any other +reasonably capable kernel. GIO will be designed to require only a few simple +graphics primitives at the bottom end, making it straightforward to interface +to different graphics kernels. Any application which requires a more +sophisticated graphics interface than that provided by GIO may bypass GIO +and talk directly to the underlying graphics kernel, but doing so will +render the application usable only with that particular graphics kernel. + +Placing the device independent graphics kernel in a separate process makes +it possible to use a large, sophisticated graphics kernel without linking +enormous libraries of subroutines into applications processes. Bugs can be +fixed and new features and devices added without relinking applications +processes. In principle it is even possible to interface simultaneously +to more than one graphics kernel, e.g., one might drive some devices with +an NSPP kernel and others with a GKS kernel. On a different host CORE might +be the only thing available and GIO would have to be interfaced to CORE on +such a host. + + +.ks +.nf + __________ + / \ + | graphics | + | terminal | + \__________/ + | ^ + | |(device codes) + v | _________ + +--------+ +-----------+ / \ + | CL+ |<----| graphics |<----| | + | fast | | kernel | | gdevice | + | kernel |---->| task |---->| | + +--------+ +-----------+ \_________/ + | ^ | + | |(gki metacode) | (core metacode) + v | +--------> (nspp metacode) + +--------+ (gks vdm) + | user | + | task |-----------------------> (gki metacode) + +--------+ + + + simple plotters + |--- interactive ---|------ metafile ------| + graphics special devices + + +.fi +.ce +Figure 1. Graphics Task Structure +.ke + + +The IRAF command language (CL) is the user interface to IRAF programs and +as such moderates all interaction with the user, including interaction via +graphics devices. GIO is primarily a graphics \fIoutput\fR interface; +graphics input (other than pixel readback) is decoupled from graphics output +and is controlled by the CL. Often the task requesting cursor input will +differ from that which produced the graphics. The CL, under control of the +user, may set the default graphics input and output devices, redirect graphics +input and/or output to devices other than the default, and control whether +a graphics task is used interactively or in batch mode. + +.nh +Specifications + + The GIO graphics output procedures draw various flavors of vectors and +fill or color two dimensional areas. Cursor input is a way of interacting +with the user and is therefore handled by CLIO (the command language +interface). We first define important terms and define the coordinate +systems used by GIO. Next follows an overview of the input and output +procedures. Finally, we describe in detail the individual procedures and +the interface to the graphics kernel. + +.nh 2 +Coordinate Systems + + The full plotting surface of a device defines the domain of definition +of the coordinate systems used by GIO. +GIO supports up to sixteen user defined \fBworld coordinate systems\fR +(WCS) per open device, numbered 1 through 16. +One additional coordinate system (WCS 0) with values ranging from 0 to 1 in +either axis is predefined for every device; this \fBnormalized device +coordinate system\fR (NDC) spans the full plotting surface of the device. + +The mapping of world coordinates to device coordinates is +defined by a \fBwindow\fR into world space and a corresponding \fBviewport\fR +into device space. Each window-viewport pair defines one of the 16 world +coordinate systems. At \fBgopen\fR time GIO is initialized to WCS 1, +which has both window and viewport set to NDC coordinates. A subsequent +call to either \fBgswind\fR or \fBgscale\fR will set the window and a +subsequent call to \fBgsview\fR will set the viewport. The WCS is not fixed +to the device until a plotting operation occurs which requires use of the WCS. +Hence, multiple calls to \fBgscale\fR to determine the range of data values +in X and Y for a family of curves are possible before fixing the WCS to the +device, e.g. in a call to \fBglabax\fR. + +A \fBviewport\fR is any rectangular plotting area lying entirely within the +plotting area of the device. The viewport defines the area in which data +can be plotted, i.e., the boundary at which \fBclipping\fR will occur if +enabled. The viewport is the area framed by \fBglabax\fR; the tick and axis +labels will be plotted in the area just outside the viewport. +A square viewport need not have the same resolution in both X and Y. +Devices with variable resolution, e.g. pen plotters, have a default +resolution in either axis which can be overridden when the plot is drawn. +The aspect ratio of the device is the ratio of the physical size of a +device pixel in Y to that in X. Most devices have an aspect ratio of +unity, but it is common for the resolution to be different in X and Y. +The aspect ratio of the device is available via a \fBgget\fR inquiry, +as is the device resolution in either axis. + +A \fBwindow\fR is the range of world coordinates which GIO will map to the +corresponding viewport. The world coordinates must be cartesian and +either linear or logarithmic (base 10) in either axis. +There are no restrictions on the range of world coordinates other than +those imposed by the single precision floating point hardware of the +host computer, provided that the WCS is not degenerate +(zero range in either axis). + +Most applications will use only a single WCS, hence the WCS number is not +included explicitly in the argument lists of the GIO procedures. +A call to \fBgset\fR is required to change to a different WCS. +Thereafter all graphics output and cursor input will refer to the new WCS. +Multiple WCS are useful when plotting in several distinct (nonoverlapping) +viewports on a device, or when overplotting curves within the same viewport +but with different world coordinate windows. + +.nh 2 +Graphics Output Procedures + + The GIO output procedures range from \fBgplotv\fR and \fBgploto\fR, +which can draw an entire plot with autoscaling and axis labeling in one call, +to the polyline, polymarker, move, draw, and text drawing primitives at +the low end. + + +.ks +.nf + gplotv (v, npts, x1, x2, title) + gploto (gp, v, npts, x1, x2, title) + gpagefile (gp, fname, prompt) + + gp = gopen (device, mode, fd) + gclose (gp) + gdeactivate (gp, flags) + greactivate (gp, flags) + gcancel (gp) + gflush (gp) + gclear (gp) + gframe (gp) + greset (gp, flags) + gmftitle (gp, metafile_title) + + gscan (gp, text) + gset[irs] (gp, param, value) + val = gstat[irs] (gp, param[, outstr, maxch]) + val = gget[birs] (gp, devcap[, outstr, maxch]) + g[sg]view (gp, x1, x2, y1, y2) + g[sg]wind (gp, x1, x2, y1, y2) + g[ar]scale (gp, v, npts, axis) + ggscale (gp, x, y, dx, dy) + gctran (gp, x1, y1, x2, y2, wcs1, wcs2) + gcurpos (gp, x, y) + gescape (gp, fn, instruction, nwords) + + glabax (gp, title, xlabel, ylabel) + gline (gp, x1, y1, x2, y2) + gpline (gp, x, y, npts) + gvline (gp, v, npts, x1, x2) + gmark (gp, x, y, marktype, xsize, ysize) + gpmark (gp, x, y, npts, marktype, xsize, ysize) + gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) + gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) + g[ar]move (gp, x, y) + g[ar]draw (gp, x, y) + gtext (gp, x, y, text, format) + gfill (gp, x, y, npts, style) + g[pg]cell (gp, m, nx, ny, x1, y1, x2, y2) + + gscur (gp, x, y) + stat = ggcur (gp, x, y, key) +.fi +.ke + + +All coordinates are given in world coordinates (user coordinates) +except the viewport coordinates and the marker sizes, which are given in +device coordinates. Low level graphics i/o requires that the graphics +device first be opened with \fBgopen\fR and later closed with \fBgclose\fR. +Several graphics devices may be open simultaneously. + +When a graphics device is opened with \fBgopen\fR all internal parameters +are initialized to their default values, unless the device is opened in +APPEND mode. The default values of these internal parameters may be changed +via explicit \fBgset\fR, \fBgswind\fR, \fBgscale\fR, or \fBgscan\fR calls. +Most powerful is \fBgscan\fR, which interprets graphics commands passed +either as an explicit string or in a text file. + +Much of the flexibility of GIO derives from its parameter defaulting +mechanism. The interface may be expanded indefinitely by adding new +internal parameters accessed via \fBgset\fR calls, without changing the +basic interface. + +.nh 2 +Graphics Input Procedures + + The most commonly used type of graphics input is cursor readback. +Two forms of cursor input are supported: cursor input via the CLIO procedure +\fBclgcur\fR, and cursor input via the GIO procedure \fBggcur\fR. +CLIO based cursor input should be used whenever possible, i.e., when writing +to \fBstdgraph\fR or \fBstdimage\fR. The advantage of cursor input via the +CL is that input may come from a list file or the terminal as well as from +a physical cursor read, allowing programs to be used either interactively +or in batch mode. Furthermore, WCS selection and conversion of NDC cursor +coordinates to WCS and cursor mode interaction are only available with +\fBclgcur\fR. Programs which do not produce any graphics output may read +the cursor via CLIO without using any part of the GIO interface. +The lower level GIO cursor read procedure always reads the physical device +cursor in NDC coordinates and is device dependent (it is what is called by +\fBclgcur\fR). + +Cursors are implemented as abstract datatypes within the CL. A user task +accesses a cursor by reading the value of a CL parameter of type \fBgcur\fR +(stdgraph cursor) or \fBimcur\fR (stdimage cursor). Multiple cursors may +be implemented using multiple cursor type parameters. A cursor parameter +is assumed to have a \fIlist\fR of values; EOF is returned when the end of +the list is reached. Reading the cursor automatically causes any graphics +output to be flushed. + + stat = clgcur (param, wx, wy, wcs, key, strval, maxch) + +The CLIO function \fBclgcur\fR reads the next cursor value from the named +cursor parameter, returning as output arguments the cursor position in world +coordinates, the index of the referenced WCS, the keystroke value (character +typed) of the cursor event, and a string value if the key was ':', the +cursor mode set option escape character. +A cursor read sequence begins with a prompt, i.e., the cursor lights up +or starts blinking. The user is then free to move the cursor about; +the cursor position is not read until a key is typed on the user terminal. +Using a keystroke on the user terminal to terminate both \fBstdgraph\fR +and \fBstdimage\fR cursor reads provides a rich and device independent set of +keystroke values for identifying the action to be performed (imaging devices +are typically very limited in this area). + +GIO always returns the cursor position in world coordinates, along with +the index of the WCS selected. Typically there will be exactly one world +coordinate system (excluding WCS 0) and the WCS value may be ignored. +If no world coordinate systems are defined for the device the cursor +position will be returned in NDC coordinates with WCS=0. + +If multiple world coordinate systems are defined GIO will select the WCS +closest to the position of the cursor, i.e., the cursor may lie outside the +viewport and GIO will still return WCS coordinates. If the cursor lies +within two or more overlapping viewports GIO will select the WCS with the +highest number. The cursor read protocol will allow the user to force +the selection of a particular viewport by first placing the cursor on a +nonoverlapping portion of the viewport and typing a special code, +e.g., W (see next section), and then continuing with the normal cursor read. +If the application wishes to override the automatic WCS selection it may +do so by calling \fBgctran\fR to transform the cursor coordinates returned +by \fBclgcur\fR to a different world coordinate system. + +.nh 3 +Cursor Mode + + In cursor mode, i.e., after a call to \fBclgcur\fR or after typing "=gcur", +a number of special keystrokes shall be recognized for interactive display +control. All graphics output to stdgraph and stdimage is routed through the +CL on the way to the graphics kernel. The CL will optionally spool in an +internal buffer all graphics instructions output to an interactive device. +This internal buffer is emptied whenever the device screen is cleared. +In cursor mode, special keystrokes may be used to redraw all or any portion +of the spooled graphics, e.g., one may zoom in on a portion of the plot and +then roam about on the plot at high magnification. Since the spooled graphics +vectors typically contain more information than can be displayed at normal +magnification, zooming in on a feature may bring out additional detail +(the maximum resolution is 32768 points in either axis). Increasing the +magnification will increase the precision of the cursor by the same factor. + +Cursor mode is implemented by performing coordinate transformation and +clipping on each GKI instruction in the frame buffer, passing the transformed +and clipped instructions on to the graphics kernel. +The cursor mode operations perform a simple geometric transformation on +the spooled graphics frame, mapping a rectangular window of the spooled +frame onto the device screen. The graphics frame itself is not modified, +hence zoom out or reset and redraw will restore the original display. + +If the graphics frame is a typical vector plot with drawn and labeled +axes, magnifying a portion of the plot may cause the axes to be lost. +If this is not what is desired a keystroke is provided to draw and label +the axes of the displayed window. The axes will be overplotted on the +current display and will not be saved in the frame buffer, hence they +will be lost when the frame is redrawn. In cursor mode the viewport is +the full display area of the output device, hence the tick mark labels +of the drawn axes will be drawn inside the viewport. This form of axes +labeling is used because it is simple and because it is appropriate for +both vector graphics and image display output devices (and cursor mode +must serve both). + + +.ks +.nf + A draw and label the axes of current viewport + B backup over last instruction in frame buffer + C print the cursor position as it moves + D draw a line by marking the endpoints + E expand plot by setting window corners + F set fast cursor (for HJKL) + H step cursor left + J step cursor down + K step cursor up + L step cursor right + M move point under cursor to center of screen + P zoom out (restore previous expansion) + R redraw the screen + T draw a text string + U undo last frame buffer edit + V set slow cursor (for HJKL) + W select WCS at current position of cursor + X zoom in, X only + Y zoom in, Y only + Z zoom in, both X and Y + < set lower limit of plot to the cursor y value + > set upper limit of plot to the cursor y value + \ escape next character + : set cursor mode options + :! send a command to the host system + = shorthand for :.snap (make graphics hardcopy) + 0 reset and redraw + 1-9 roam +.fi +.ce +Figure 2. Cursor Mode Keystrokes +.ke + + +By default the cursor mode keystrokes are all upper case letters, reserving +lower case for applications programs. The terminal shift lock key may be +used to simplify typing in lengthy interactive cursor mode sessions. +The cursor motions are decoupled from roam since zoom and roam are often used +merely to increase the precision of a cursor read. Special keystrokes are +provided for stepwise cursor motions to increase the speed of cursor setting +on terminals that do not have fast cursor motions (e.g., the retro-graphics +enhanced VT100). The recognized keystrokes are shown in Figure 2. + +If the character : is typed while in cursor mode the alpha cursor will appear +at the bottom of the screen, allowing a command line to be entered. Commands +which begin with a period, e.g., ":." are interpreted by the graphics system; +any other command will terminate the cursor read, returning the character ':' +as the key value, and the command string as the string value of the cursor +read. The commands recognized by the graphics system are summarized in +figure 3. + + +.ks +.nf + :.axes[+-] draw axes of viewport whenever screen is redrawn + :.case[+-] enable case sensitivity for keystrokes + :.clear clear alpha memory (e.g, this text) + :.cursor n select cursor (0=normal,1=crosshair,2=lightpen) + :.gflush flush plotter output + :.help print help text for cursor mode + :.init initialize the graphics system + :.markcur[+-] mark cursor position after each cursor read + :.off [keys] disable selected cursor mode keys + :.on [keys] enable selected cursor mode keys + :.page[+-] enable screen clear before printing help text + :.read file fill frame buffer from a file + :.show print cursor mode and graphics kernel status + :.snap [device] make hardcopy of graphics display + :.txqual qual set character generator quality (normal,l,m,h) + :.txset format set text drawing parameters (size,up,hj,vj,etc) + :.xres=value set X resolution (stdgraph only) + :.yres=value set Y resolution (stdgraph only) + :.viewport x1 x2 y1 y2 set workstation viewport in world coordinates + :.write[!][+] file save frame buffer in a spool file + :.zero reset viewport and redraw frame +.fi + + +.ce +Figure 3. Cursor Mode Commands +.ke + + +Minimum match abbreviations are permitted for cursor mode command names. +Multiple commands may be given on one line, delimited by semicolons. +If the CL environment variable \fBcminit\fR is defined when cursor mode is +first entered, the string value will be interpreted as a cursor mode command +and used for initialization. For example, to disable the numeric keys and +set the graphics resolution to 200 points in X and 100 points in Y, one +could add the following \fBset\fR declaration to their "login.cl" file: + + set cminit = "xres=200; yres=150; off 0-9" + +The numeric keypad of the terminal (if it has one) is used to roam about +when the zoom factor is greater than one. If the magnification is normal +the numeric keys are not recognized as special keystrokes, i.e., typing +a numeric key will exit cursor mode, returning the character typed to the +applications program. In roam mode a numeric key must be escaped to exit +cursor mode. The directional significance of the numeric keys in roam +mode is obvious if the terminal has a keypad, and is illustrated below. + + +.ks +.nf + 7 8 9 135 090 045 + + 4 5 6 180 000 000 + + 1 2 3 225 -90 -45 +.fi +.ke + + +There is a fixed upper limit on the size of the cursor mode frame buffer. +If the frame data overflows the frame buffer while plotting the plot will +still come out correctly, but only the final plotting instructions will be +retained in the buffer. Redisplay of the frame in cursor mode will thus +result in only a portion of the full frame being drawn. If this is a problem +the user can increase the upper limit on the size of the frame buffer by +setting the value of the environment variable \fBcmbuflen\fR, e.g., + + gflush; set cmbuflen = 512000 + +would initialize the graphics system (freeing the old frame buffer) and set +the upper limit on the size of the frame buffer to 512K words or 1Mb. + +.nh 2 +Example + + At this point a brief example may help to illustrate the use of the GIO +procedures. The following procedure will plot a data vector (pixel array) +and then repeatedly read the cursor, drawing a mark at successive positions +of the cursor. The procedure exits if the user types either the character +'q' or EOF, e.g., or carriage return. + + +.ks +.nf + include + + # MARKPLOT -- Plot a data array and then enter a loop, drawing + # circles at successive cursor positions. + + procedure markplot (data, npts, x1, x2) + + real data[npts] # data vector to be plotted + int npts # length of array + real x1, x2 # world X-coords of vector + + pointer gp + int wcs, key + char str[32] + real wx, wy + pointer gopen() + int clgcur() + + begin + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + + call gploto (gp, data, npts, x1, x2, "data") + + while (clgcur ("points", wx, wy, wcs, key, str, 32) != EOF) + if (key == 'q') + break + else + call gmark (gp, wx, wy, GM_CIRCLE, 1., 1.) + + call gclose (gp) + end +.fi +.ke + +.nh 2 +Graphics Output Devices + + While the graphics output device may be specified explicitly by name, +more often graphics output devices will be specified by one of the logical +device names shown below. Examples of the installation dependent device name +associated with each logical name are also shown. + + +.ks +.nf + stdgraph = "gterm" + stdimage = "deanza" + stdplot = "qms" + stdvdm = "uparm$vdm" +.fi +.ke + + +Interaction (via the CL) is supported only for \fBstdgraph\fR and +\fBstdimage\fR. The standard batch plotter device is \fBstdplot\fR, +and the standard metafile (for spooling graphics output) is \fBstdvdm\fR. + +The user should not normally set the value of \fBstdgraph\fR directly with +\fIset\fR, rather they should set the terminal type with \fIstty\fR and let +the latter specify the value of \fBstdgraph\fR. If the terminal specified +is not a graphics terminal (no ":gd" capability in the termcap entry for the +device) the value of \fBstdgraph\fR will be set to "none", otherwise +\fBstdgraph\fR will be set to the name of the stdgraph device entry for the +graphics terminal. + +The device name associated with a logical graphics output +device must have an associated entry in the \fBgraphcap\fR file, +a text file used to describe the characteristics of each device. +New graphcap entries may easily be added by the user to interface to +special graphics devices. +System privledge is not required to modify graphcap, since the name +of the graphcap file is taken from a CL environment variable of the +same name (which can be redefined by the user to point to a file in a +private directory). The graphcap entries for the most commonly used +devices at a given site may be precompiled by the system manager to +eliminate the overhead of searching the graphcap file at \fBgopen\fR time. + +The graphcap parameters (device \fIcapabilities\fR) are too involved to +be presented here and will be described in a later section. +Examples of device capabilities are the device resolution, whether a frame +advance is required before or after a plot, indication of device capabilities +such as the ability to generate text, and the name of the executable +graphics kernel file associated with the device. Many additional parameters +are defined for interactive devices. The graphcap device capabilities +may be inspected with the \fBgget[birs]\fR procedures, which resolve into +calls to the TTY interface, used to access both graphcap and termcap files. + +The sequence of actions taken by GIO to access the graphcap entry for a +device is summarized below. + + +.ks +.nf + if (standard graphics output device) + get device name from environment + + if (device name is actually a filename) { + load graphics device descriptor using the first device entry + from the named graphcap format file + } else { + get filename of graphcap file from environment + load graphics device descriptor by searching the graphcap file + for the named device + } +.fi +.ke + +.nh 2 +Graphics Input Devices + + The technique used to associate an input source with a graphics cursor +is similar to that used for output devices. A CL environment variable is +associated with each cursor type. The names and default values of the +environment variables are shown below. + + +.ks +.nf + stdgcur = "stdgraph" + stdimcur = "stdimage" +.fi +.ke + + +The default input source for a cursor is the graphics output device associated +with the graphics output stream. If the cursor device is "stdgraph" or +"stdimage" the graphics kernel is called to read the physical device cursor +for \fIstdgraph\fR or \fIstdimage\fR. If the cursor device is "text" +the cursor value is a line of text read from the user terminal. +In this mode the user enters at least two of the fields defining +a cursor value. Missing fields are assigned the value zero (the user +presumably will know that the program does not use the extra fields). + + +.ks +.nf + cl> set stdgcur = "text" + cl> = gcur + gcur: 345.33 23.22 1 c + 345.33 23.22 1 c + cl> +.fi +.ke + + +An example of a cursor read request entered interactively by the user, +taking input from the terminal and sending output to the terminal, +is shown above (the CL typed the "gcur: " query and the user entered the +remainder of that line). If the cursor device were "stdgraph" a real +cursor read would occur and the equivalent interaction might appear as +shown below. The cursor position is returned in world coordinates, +where the world coordinate system was defined by the last plot output to +the device. For an imaging device the world coordinates will typically +be the pixel coordinates of the image section being displayed. + + +.ks +.nf + cl> = gcur + 345.33 23.22 1 c + cl> +.fi +.ke + + +Redirecting cursor input to the terminal is useful when working from a +nongraphics workstation and when debugging programs. ASCII cursor queries +are the only type supported when running an IRAF program outside the CL. +Cursor input may also be taken from a list file by assigning a filename +to a cursor parameter, i.e., by assigning a list file to a list structured +parameter and overriding query mode: + + +.ks +.nf + cl> gcur = filename + cl> = gcur + 345.33 23.22 1 c + cl> +.fi +.ke + + +This last mechanism is a standard technique used with CL list structured +parameters and will not be discussed further here. + +.NH 2 +Mixed Terminal and Graphics I/O + + Interactive graphics programs are normally (but not necessarily) executed +on a graphics terminal or workstation supporting both ordinary terminal i/o +and vector graphics. IRAF is designed to use a single terminal for both text +and graphics; text and graphics on separate devices is also supported but is +not the norm. By text we refer here to ordinary line or screen oriented +terminal i/o (e.g., for \fIhelp\fR or \fIeparam\fR), not the use of text in +the graphics plane to annotate plots. + +.NH 3 +Text and Graphics Mode + + Most modern graphics terminals provide separate memory planes for text +and graphics. Depending upon the device, these planes may be displayed +simultaneously, displayed alternately, or only a single memory plane may be +available for both terminal modes, in which case a mode switch is destructive. +The graphics device model implemented by GIO and the STDGRAPH kernel is +flexible enough to deal with all or nearly all such devices. + +The normal mode for the terminal or workstation is text mode. Activating the +workstation causes a switch to graphics mode; deactivating the workstation +restores the terminal to text mode. Activation is implied whenever a device +is opened with \fBgopen\fR, unless the AW_DEFER mode bit is set to defer the +activate workstation until graphics i/o is actually done to the device. +Closing the workstation automatically deactivates the workstation. The GIO +procedures \fBgreactivate\fR and \fBgdeactivate\fR are provided to simplify +mode switching while a device is open on a graphics stream. + +Occasionally it is necessary to print out a large amount of text in response +to a user command entered in a cursor loop while in graphics mode. If the +text is in a file this is done most easily by calling \fBgpagefile\fR to page +the file in text mode, restoring graphics mode when the operation is completed. +If the application generates the output text dynamically then the workstation +must be explicitly deactivated and later reactivated before resuming graphics +i/o, e.g., + +.ks +.nf + while (clgcur (gp, ...) != EOF) { + switch (key) { + case XXX: + call gdeactivate (gp, AW_CLEAR) + + call greactivate (gp, AW_PAUSE) + case YYY: + ... + } + } +.fi +.ke + +The sequence shown will switch to text mode, clear the screen, output the +text, and pause for the user to read the text before restoring graphics mode +and initiating another cursor read. + +.NH 3 +Status Line I/O + + The deactivate/reactivate workstation technique is fine for outputting +large amounts of text, but is not well suited for small amounts of text, +e.g., single line commands to interactively set internal parameters, +output of single lines of text to prompt the user, print the value of a +calculation or some variable, and so on. The so-called "status line" +interface is provided for this purpose. Status line i/o makes it possible +to interact directly with the user without interfering with the contents of +the graphics frame, and without leaving graphics mode. + +What the status line actually is determined by the graphcap entry for the +device and the characteristics or limitations of the actual device. +On most devices, the status line is a single line at the bottom of the screen. +This only works, however, if the device can dynamically erase the status line; +if this is not possible the status "line" may actually be the entire screen, +with successive output lines being drawn on top of the graph. + +To output text to the status line while in graphics mode one merely writes to +STDOUT or STDERR in the usual way, e.g., in a call to \fBprintf\fR. When +newline is seen a flag is set which causes the status line to be cleared when +the next output character is received. Output lines may be built up in +successive calls to output procedures, outputting a single newline to terminate +the line and start a new one. After a newline delimited line of text has been +output, output of a single newline (blank line) will clear the status line. + +It is also possible to read from the status line. This is most commonly done +after writing a prompt string to the status line. The prompt should be +terminated with a colon (e.g., "enter value: ") rather than a newline, +to signal to the user that input is expected, and to avoid having the +subsequent status line read clear the prompt string. In many cases such +explicit prompting and decoding of the return string can be avoided by using +the standard CLIO parameter prompting mechanism for interactive input. +CL parameter prompts are also permitted in graphics mode, and will interact +with the user on the status line in the expected way, without interfering +with the graphics state of the device. + +When mixing status line i/o and graphics i/o one must be careful to flush any +buffered graphics or textual output before switching modes. In many cases the +system will do this for you automatically, but there are exceptions where +explicitly flushing of buffered output is necessary (e.g., STDOUT and STDERR +are low level facilities with no knowledge of GIO, and output to one of these +streams will not automatically cause any graphics output to be flushed). + +.NH 2 +User Interface Conventions + + While different interactive (cursor driven) graphics programs will differ +in many ways, there are certain operations which are common to all such +programs. In order to present a more consistent interface to the user, +conventions have been defined for these common operations. + +.NH 3 +On Line Help + + All interactive graphics programs should respond to the key '?' with a +description of the keystrokes and colon commands recognized by the program +(or submenu, in the case of a menu structured interface). This is normally +done by calling \fBgpagefile\fR to interactively page the ".key" keystrokes +help file for the program. The keystroke files for system programs are +stored in the directory lib$scr; non-system programs keep their keys files +either in the package directory, or in a global package library. + +.NH 3 +Cursor and Device Names + + In general, applications programs should not read directly from \fBgcur\fR +or \fBimcur\fR (the global cursor parameters), nor should the open the +"stdgraph", "stdimage", or "stdplot" device directly by these explicit string +values. This works, but is inflexible. To make it easy for the user to +run an otherwise interactive program in batch mode, taking input from a cursor +list file, the task should include a cursor type parameter in its parameter +set. Likewise, to make it easy for the user to temporarily redirect the +output of the program to a device other than the current stdgraph, stdplot, +etc., device, the device name should be parameterized as a string type CL +parameter. + +For example, if task \fBplotit\fR has cursor and device parameters named +"cursor" and "device", the command + + cl> plotit cursor=listfile device=qms + +would run the task taking cursor input from the text file "listfile", with +stdgraph graphics output directed to the plotter device "qms". + +.NH 3 +Exiting an Interactive Cursor Loop + + The following standards have been defined for dealing with EOF/quit in +interactive cursor loops. +.ls +.ls EOF +End of file is indicated for a cursor list either by an actual +end of file in the case of a true cursor list, or by typing the EOF character +(e.g., , , or the interrupt character) in an interactive +cursor read. EOF on the cursor list should be taken seriously by the +applications program, and not treated as just another key, hence it should +not be something that the user is expected to type routinely to exit a cursor +loop. If a program gets EOF back as the value of \fBclgcur\fR it should exit +immediately, without any verification queries etc, since it may well have +been run in batch mode with input redirected to a cursor list file. +.le +.ls q +The standard interactive cursor loop exit character is 'q'. +All interactive graphics programs should recognize this character +and take some action to exit the cursor loop, e.g.: + +.ks +.nf + while (clgcur (...) != EOF) + switch (key) { + case 'q': + break + case ... +.fi +.ke + +The 'q' character is intended to be handled directly by the application +program, rather than mapped into EOF by the system (like Q was, and CR and +the gt_gcur 'q' before that in old versions of IRAF), +to distinguish this case from a hard-EOF and to provide maximum +flexibility in how the program treats a request from the user to exit. +If the user would suffer from an accidental program exit then the 'q' key +action should do something before exiting, e.g., ask that the user first +update the database, ask that CR be hit to verify the quit, and so on. +In general, if it would take the user more than a minute to recover after +an accidental program exit, one should consider coding some sort of +verification action to be executed before exiting when 'q' is typed (but not +when EOF is seen on the list). +.le +.le + +The GIO procedure \fBgqverify\fR is provided for programming convenience in +cases where only simple verification is desired. Note that lightweight tasks +or submenus which can easily be reentered should not bother even with this, +but should simply exit. For example: + +.ks +.nf + case 'q': + if (gqverify() == YES) + break +.fi +.ke + +As a more complex example, suppose the program is used to edit or +create a database which could be lost or damaged in an accidental +exit, if not updated first. We do not want to update the database +automatically because this would overwrite the former contents of +the database. The program might be set up as follows. + +.ks +.nf + 'q' program prints error message on status line, e.g., + "No write since last change (:quit! overrides)" + :w[rite] updates the database; q will execute silently + :q[uit]! force a quit w/o an update; discard changes +.fi +.ke + +.nh 2 +Detailed Procedure Specifications + + The graphics output procedures provided by GIO fall into four main +groups. First are the high level "plot at a time" procedures, +used to plot entire data vectors. Second are the control procedures, +used to open and close a device, to flush output and clear the screen, +and to cancel output in the event of an interrupt. +Third are the procedures used to set and stat (inquire) the GIO +internal parameters, e.g. to define a WCS, change pens, select axis labeling +options, or inquire the device resolution. Fourth and last are the output +procedures, used to draw and label the axes of a viewport, set the cursor, +draw lines or marks, plot text, or fill areas. + +.nh 3 +High Level Procedures +.ls 4 +.tp 8 +.ls gplotv (v, npts, x1, x2, title) + +.nf +real v[npts] # data vector +int npts # number of data points +real x1, x2 # WC assigned v[1] and v[npts] +char title[ARB] # plot title +.fi + +Open GIO, clear the screen, autoscale and plot the data vector, then close GIO. +A default viewport is used. The axes are drawn, tick marks are selected, +marked, and labeled, and the plot title is printed. The data is plotted +using solid line segments. The X values of the data points are evenly +distributed from X1 to X2. +.le + +.tp 8 +.ls gploto (gp, v, npts, x1, x2, title) + +.nf +pointer gp # graphics descriptor +real v[npts] # data vector +int npts # number of data points +real x1, x2 # WC assigned v[1] and v[npts] +char title[ARB] # plot title +.fi + +A more flexible version of \fBgplotv\fR. The graphics device must already +have been opened with an explicit call to \fBgopen\fR. The explicit open +call makes it possible to append to an existing plot or to change plotting +options with calls to \fBgset\fR before calling \fBgploto\fR to autoscale, +draw the axes, and plot the data vector. Annotation of the plot via calls +to the low level output primitives is possible before a final call to +\fBgclose\fR to close the device and free the graphics descriptor. +.le + +.tp 8 +.ls gpagefile (gp, fname, prompt) + +.nf +pointer gp # graphics descriptor +char fname[ARB] # file to be paged +char prompt[ARB] # end of page prompt string +.fi + +Interactively page through a file on the terminal in text mode, e.g., to +display help text in response to the '?' standard help query key. +The workstation is deactivated, the screen is cleared and the file is paged, +with the usual file pager prompt being displayed at the bottom of each page +of text. When the pager is exited the workstation is reactivated if it was +active when the pager was called. If the prompt string is null the file +name is used. +.le +.le + +.nh 3 +Control Procedures +.ls +.tp 8 +.ls gopen (device, mode, fd) + +.nf +char device[ARB] # name of device to be opened +int mode # access mode +int fd # graphics stream to be written +.fi + +The named graphics device is opened for graphics i/o. A pointer to the GIO +graphics descriptor assigned to the device is returned as the function value. +The device name may be the name of one of the standard logical graphics +devices, i.e., \fBstdgraph\fR, \fBstdimage\fR, \fBstdplot\fR, or \fBstdvdm\fR, +or the actual name of a physical device. + +The only meaningful device access modes at present are NEW_FILE and APPEND. +In NEW_FILE mode all WCS are initialized to NDC coordinates. +Opening the stdgraph device in NEW_FILE mode causes a screen clear on the next +call to \fIgflush\fR. In APPEND mode the WCS are restored to the values they +had when the device was last accessed. +The GIO internal state variables are initialized to their default values +at \fBgopen\fR time regardless of the access mode for the device. + +Opening the stdgraph device causes an implicit reactivate workstation unless +the AW_DEFER flag () is set in the access mode, e.g., + + gp = gopen (device, NEW_FILE+AW_DEFER, fd) + +Defer mode allows the graphics descriptor to be opened once, e.g., during task +startup, before any graphics output is required. This is sometimes useful in +applications which switch back and forth between text and graphics mode often, +by bracketing each graphics sequence with calls to \fIgreactivate\fR to enter +graphics mode, and \fIgdeactivate\fR to return to text mode. Defer mode may +be combined with any normal access mode code. + +Graphics output will be written to the stream \fIfd\fR, which may be one +of the standard streams STDGRAPH, STDIMAGE, or STDPLOT, or to a binary file +opened explicitly by the user before calling \fBgopen\fR. +.le + +.tp 5 +.ls gclose (gp) + +The graphics device associated with graphics descriptor \fBgp\fR is closed, +freeing all resources allocated to the device. Any buffered graphics output +is automatically flushed before closing the device. +.le + +.tp 4 +.ls gdeactivate (gp, flags) + +.nf +pointer gp # graphics descriptor +int flags # AW_CLEAR, AW_PAUSE (see ) +.fi + +The graphics workstation is deactivated, i.e., restored to the normal terminal +(text drawing) mode, the state the terminal was in prior to \fIgopen\fR, and to +which it will be restored after a \fIgclose\fR. This function is intended for +interactive graphics applications and may be may be ignored by some graphics +kernels. If the AW_PAUSE flag bit is set the user will be asked to type a +key before the terminal is restored to text mode. If the AW_CLEAR flag bit +is set the terminal (text) screen will be cleared after the workstation is +deactivated. + +.le + +.tp 4 +.ls greactivate (gp, flags) + +.nf +pointer gp # graphics descriptor +int flags # AW_CLEAR, AW_PAUSE (see ) +.fi + +The graphics workstation is reactivated, i.e., restored to graphics mode from +the normal terminal (text drawing) mode. This function is intended for +interactive graphics applications and may be may be ignored by some graphics +kernels. If the AW_PAUSE flag bit is set the user will be asked to type a +key before the terminal is restored to graphics mode. If the AW_CLEAR flag +bit is set the graphics frame will be cleared. +.le + +.tp 4 +.ls gcancel (gp) + +Any buffered graphics output is discarded and any output operation currently +in progress is aborted. Used to recover from an interrupt. +.le + +.tp 3 +.ls gflush (gp) + +Any buffered graphics output is flushed to the output device. +.le + +.tp 4 +.ls gclear (gp) + +If the output device is a CRT the screen is erased (including all viewports). +If the output device is a plotter a formfeed is issued, advancing to the next +page of output (whether or not any graphics output has occurred). +All WCS are initialized to NDC coordinates and the internal state of GIO +is initialized, i.e., the state of each drawing instruction attribute packet +is set to UNSET to force retransmission to the graphics kernel as i/o occurs, +and the current settings of the \fIgset\fR options, e.g., line style and width, +\fIglabax\fR options, etc., are all initialized to their default (\fBgopen\fR) +values. +.le + +.tp 4 +.ls gframe (gp) + +Issue a screen clear or frame advance. This call is equivalent to \fBgclear\fR +except that the internal state of GIO is not initialized. An application +might want to call \fBgframe\fR and \fBgreset\fR directly rather than using +\fBgclear\fR, if the full initialization implied by \fBgclear\fR is not what +is desired. +.le + +.tp 4 +.ls greset (gp, flags) + +.nf +pointer gp # graphics descriptor +int flags # bitflags noting what to reset (0 is a no-op) +.fi + +The \fBgreset\fR may be used to reset all or parts of the internal state of +GIO, without actually doing any i/o to the graphics device. The \fIflags\fR +argument is used to specify what is to be reset. The bitflags (defined in +) are enumerated below. + +.nf + GR_RESETALL reset everything + GR_RESETGIO reset only GIO drawing parameters + GR_RESETWCS reset the WCS to wcs=1, all NDC + GR_RESETGLABAX reset the GLABAX parameters +.fi + +A \fBgclear\fR is equivalent to a \fBgframe\fR followed by a +greset(gp,GR_RESETALL). +.le + +.tp 8 +.ls gmftitle (gp, mftitle) + +.nf +pointer gp # graphics descriptor +char mftitle[ARB] # comment (metafile title string) +.fi + +Place a comment describing the graphics being generated in the output +stream. Useful primarily when the output is expected to be saved in a +metafile. No graphics is generated. +.le +.le + +.nh 3 +Set and Stat Procedures +.ls +.tp 8 +.ls gscan (gp, text) [NOT YET IMPLEMENTED] + +.nf +pointer gp # graphics descriptor +char text[ARB] # graphics commands +.fi + +The string \fBtext\fR, consisting of an arbitrary length sequence of +printable ASCII graphics commands delimited by semicolons or newlines, +is interpreted and executed by GIO. Each GIO procedure has a corresponding +command of the same syntax, minus the parenthesis, commas, and the argument +\fBgp\fR. The syntax of a \fBgset\fR command is "param=value". +File inclusion is provided by the operator "@" followed by the filename +of the file to be included. +The include operator may appear anywhere a token is expected and includes +may be nested up to some maximum depth. +The sequence "@STDIN" is especially useful for entering commands or data +interactively. +.le + +.tp 8 +.ls gset[irs] (gp, param, value) + +.nf +pointer gp # graphics descriptor +int param # parameter to be set +[irs] value # new value for parameter +.fi + +Set the value of the indicated parameter. A separate procedure is used for +integer, real, and string valued parameters, i.e., gseti, gsetr, gsets. +GIO parameters may be either internal state variables (e.g. the number of +ticks on an axis) or device parameters (e.g. the number of the pen to be +used to draw lines). +The GIO parameters are defined in the global include file \fB\fR. +.le + +.tp 10 +.sp +.nf +gstati (gp, param) +gstatr (gp, param) +gstats (gp, param, outstr, maxch) +.fi +.ls +.nf +pointer gp # graphics descriptor +int param # parameter to be set +char outstr[maxch] # output string +.fi + +Inquire the value of the indicated GIO internal parameter. +The integer and real functions \fBgstati\fR and \fBgstatr\fR return +the parameter value as the function value, whereas \fBgstats\fR is +a procedure returning the string value of a parameter as an output argument. +The GIO parameters are defined in the global include file \fB\fR. +.le + +.tp 11 +.sp +.nf +ggetb (gp, cap) +ggeti (gp, cap) +ggetr (gp, cap) +ggets (gp, cap, outstr, maxch) +.fi +.ls +.nf +pointer gp # graphics descriptor +char cap[2] # device capability +char outstr[maxch] # output string +.fi + +Inquire the value of the indicated graphics device capability. +The device capability \fIcap\fR is the two character name of the capability +as it appears in the \fIgraphcap\fR file. Aside from the device capabilities +required by GIO, GIO itself knows nothing about the graphcap device +capabilities. New capabilities may be added without modifying GIO. +The \fBgget\fR procedures call the corresponding procedures in the TTY +interface. If more control over device capabilities is required than +that provided by GIO, the TTY interface may be used directly, following a +call to \fBgstati\fR to get the pointer to the TTY descriptor for the device. + +The boolean function \fBggetb\fR tests whether the device has the named +capability. The integer and real functions \fBggeti\fR and \fBggetr\fR return +the capability value as the function value, or zero if the capability is +not defined for the device. String valued capabilities are returned by +\fBggets\fR as an output argument; the null string is returned if the +device does not have the indicated capability. +.le + +.tp 8 +.ls g[sg]view (gp, x1, x2, y1, y2) + +.nf +pointer gp # graphics descriptor +real x1, x2 # range of NDC coordinates in X +real y1, y2 # range of NDC coordinates in Y +.fi + +Set or get the NDC coordinates of the viewport associated with the current WCS. +The default viewport is the full display area of the device. +.le + +.tp 8 +.ls g[sg]wind (gp, x1, x2, y1, y2) + +.nf +pointer gp # graphics descriptor +real x1, x2 # range of world coordinates in X +real y1, y2 # range of world coordinates in Y +.fi + +Set or get the world coordinates of the window associated with the current WCS. +The default window ranges from 0 to 1 in both X and Y, i.e., the default +window associates a normalized coordinate system with the associated viewport. +Any window limits passed as INDEF will be ignored, i.e., those window +parameters will not be modified. +.le + +.tp 9 +.ls g[ar]scale (gp, v, npts, axis) + +.nf +pointer gp # graphics descriptor +real v[npts] # data vector window is to be scaled to +int npts # length of data vector +int axis # axis to be scaled (1=X, 2=Y). +.fi + +Set absolute (\fIgascale\fR) or rescale (\fBgrscale\fR) the minimum and +maximum world coordinates of the indicated axis of the current window, +i.e., scale the window to fit a data vector. +May be called repeatedly if overplotting several curves. The current minimum +and maximum values for either axis may be obtained at any time by calling +\fBggwind\fR. To scale the window to fit a family of curves, +call \fBgascale\fR for the first curve and \fBgrscale\fR for the remaining +curves, thereby computing the range in X and or Y of all curves. +.le + +.tp 9 +.ls ggscale (gp, x, y, dx, dy) + +.nf +pointer gp # graphics descriptor +real x, y # point at which scale is desired (wc) +real dx, dy # scale, wcs units per ndc unit +.fi + +Determine the scale in world coordinate units at the point (x,y). Useful +for computing the size of an object in world coordinates given its size +in ndc coordinates, or vice versa. An approximation is used to determine +the scale if log scaling is in use. Note that the scale is a function of +position for the nonlinear coordinate systems. +.le + +.tp 9 +.ls gctran (gp, x1, y1, x2, y2, wcs1, wcs2) + +.nf +pointer gp # graphics descriptor +real x1, y1 # input point in WCS1 coords +real x2, y2 # output point in WCS2 coords +int wcs1, wcs2 # input, output world coordinate systems +.fi + +Transform a point in world coordinate system \fIwcs1\fR to world coordinate +system \fIwcs2\fR. If \fIwcs1\fR is zero the transformation is from NDC +coordinates to WCS coordinates. If \fIwcs2\fR is zero the transformation is +from WCS coordinates to NDC coordinates. Otherwise the transformation is +between two user defined world coordinate systems. The point need not fall +within the viewports of the two world coordinate systems. World coordinate +systems which were never set are equivalent to WCS=0. +.le + +.tp 9 +.ls gcurpos (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # current pen position in world coordinates +.fi + +Return the "current pen position" in the current world coordinate system. +The current pen position is the position set by the last move or draw +command. +.le + +.tp 10 +.ls gescape (gp, fn, instruction, nwords) + +.nf +pointer gp # graphics descriptor +int fn # function code +short instruction[nwords] # instruction sequence to be passed +int nwords # length of instruction sequence +.fi + +Send a device dependent instruction sequence to the graphics kernel. +Escape functions are ignored by GIO and by graphics kernels that do +not recognize the function code. +.le +.le + +.nh 3 +Output Procedures + + Data passed to the polyline or polymarker output procedures may contain +embedded INDEF (indefinite) values in the X, Y, or V arrays. Indefinite valued +points appear as gaps in the plot and are ignored when autoscaling. +Indefinite valued pixels are not permitted in a cell array since GIO does +not look at the values of the pixels. + +.ls +.tp 9 +.ls glabax (gp, title, xlabel, ylabel) + +.nf +pointer gp # graphics descriptor +char title[ARB] # plot title +char xlabel[ARB] # X axis label +char ylabel[ARB] # Y axis label +.fi + +Draw and label the axes of the viewport. +If the WCS has not yet been fixed it will be fixed by this call. +If desired, \fBglabax\fR may modify the window slightly to place +simple values on the tick marks. Numerous \fBgset\fR options are +available for controlling the number and sizes of the tick marks, +the format of tick labels, the axes on which tick labels appear, +and so on. If the device viewport has not yet been set and axis labeling +is enabled, \fBglabax\fR will set a default size viewport which allows room +for the label text outside the viewport. +.le + +.tp 8 +.ls gline (gp, x1, y1, x2, y2) + +.nf +pointer gp # graphics descriptor +real x1, y1 # start of line +real x2, y2 # end of line +.fi + +Draw a line connecting the point (x1,y1) to the point (x2,y2) (WCS coordinates). +The linetype, linewidth, and color may be changed beforehand with a call +to \fBgset\fR. The relevant parameters and their possible values are shown +below. Linetype zero (clear) may be used to erase lines drawn with any of the +other linetypes (device permitting). + +.ks +.nf + G_PLTYPE 0=clear, 1=solid, 2=dashed, 3=dotted, + 4=dotdash, >4=device dependent + G_PLWIDTH relative line width (default 1.0) + G_PLCOLOR color index +.fi +.ke +.le + +.tp 8 +.ls gpline (gp, x, y, npts) + +.nf +pointer gp # graphics descriptor +real x[npts] # X coordinates of the line endpoints +real y[npts] # Y coordinates of the line endpoints +int npts # number of line endpoints +.fi + +Polyline. Draw a line connecting the points (WCS coordinates). +The linetype, linewidth, and color may be changed beforehand with a call +to \fBgset\fR. +.le + +.tp 8 +.ls gvline (gp, v, npts, x1, x2) + +.nf +pointer gp # graphics descriptor +real v[npts] # vector to be plotted (Y values) +int npts # number of line endpoints +real x1, x2 # range of vector in X +.fi + +Vector polyline. Draw a polyline wherein the Y values of the polyline are +taken from V and the X values are evenly distributed along the X-axis, +ranging from X1 at point V[1] to X2 at point V[npts] (WCS coordinates). +.le + +.tp 9 +.ls gmark (gp, x, y, marktype, xsize, ysize) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates of marker +int marktype # marker type +real xsize, ysize # marker sizes +.fi + +Mark drawing primitive. Draw a mark of type \fImarktype\fR and size +\fImarksize\fR at the given position in WCS coordinates. +The marker type codes recognized are shown below and are defined in . +Marktype codes may be summed to make composite marks, e.g., + + call gmark (gp, x, y, GM_PLUS+GM_CROSS, 1.) + +is an asterisk. The pseudo-mark GM_FILL may be combined with GM_CIRCLE, +GM_BOX, or GM_DIAMOND to output the mark as a filled area, using the current +fill area attributes. A positive \fImarksize\fR specifies the mark size in NDC +coordinates, whereas negative signifies WCS coordinates. +The positive marksizes 1., 2., 3., and 4. signify default size marks of +increasing size. + +.ks +.nf + typecode name symbol + + 0 GM_POINT smallest plottable point + 1 GM_FILL fill interior of mark + 2 GM_BOX square box + 4 GM_PLUS plus + 8 GM_CROSS cross + 16 GM_DIAMOND diamond + 32 GM_HLINE horizontal line + 64 GM_VLINE vertical line + 128 GM_HEBAR horizontal error bar + 256 GM_VEBAR vertical error bar + 512 GM_CIRCLE circle +.fi +.ke + +The linetype for a mark is set by the parameter G_PMLTYPE. A mark may +be erased (device permitting) by setting the marker linetype to clear and +redrawing the mark. The color index used for marks is controlled by the +\fBgset\fR parameter G_PMCOLOR. +.le + +.tp 9 +.ls gpmark (gp, x, y, npts, marktype, xsize, ysize) + +.nf +pointer gp # graphics descriptor +real x[npts] # WCS X coordinates of markers +real y[npts] # WCS Y coordinates of markers +int npts # number of markers +int marktype # marker type +real xsize, ysize # marker sizes +.fi + +Polymarker. Plot a sequence of \fInpts\fR markers at the positions given +by successive WCS coordinate pairs (x[i],y[i]). All markers will be of +the same type and size. The significance of the marker type and size codes +is the same as for \fBgmark\fR. +.le + +.tp 9 +.ls gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) + +.nf +pointer gp # graphics descriptor +real v[npts] # WCS Y coordinates of markers +int npts # number of markers +real x1, x2 # range of WCS X coordinates +int marktype # marker type +real xsize, ysize # marker sizes +.fi + +Vector polymarker. Plot a sequence of \fInpts\fR markers at the positions given +by successive WCS coordinate pairs (x[i],y[i]), where the x[i] are evenly +distributed from X1 at V[1] to X2 at V[npts]. All markers will be of the same +type and size. The significance of the marker type and size codes is the same +as for \fBgmark\fR. +.le + +.tp 11 +.ls gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) + +.nf +pointer gp # graphics descriptor +real x[npts],y[npts] # normalized polyline defining marker +int npts # number of points in polyline +real xcen, xcen # world coordinates of center of marker +real xsize, ysize # marker size in X and Y +int fill # draw mark using area fill +.fi + +Draw a user defined marker. The marker is defined by the polyline (X[i],Y[i]), +normalized to the unit square. The marker polyline is scaled to fit the +window defined by \fIxcen\fR, \fIycen\fR, \fIxsize\fR, and \fIysize\fR, +where the center is always defined in world coordinates but the marker sizes +may be defined in any of a number of ways (see \fBgmark\fR). If \fIfill\fR +is YES the marker will be drawn using area fill rather than as a polyline. +.le + +.tp 8 +.ls g[ar]move (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates to move or shift +.fi + +Move absolute (\fBgamove\fR) or move relative (\fBgrmove\fR), +with the "pen up". A move relative should be preceded by a move absolute +to unambiguously define the "current pen position" in WCS coordinates. +Only the move, draw, and mark primitives leave the pen in a defined position. +Calls to \fBgset\fR may be intermixed with move and draw commands without +affecting the current pen position. +.le + +.tp 8 +.ls g[ar]draw (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates to move or shift +.fi + +Move absolute (\fBgadraw\fR) or move relative (\fBgrdraw\fR), +with the "pen down". Draws a line segment. +The type of line drawn (linetype or "pen number") defaults to solid but +may be changed beforehand with a call to \fBgset\fR. +Calls to \fBgset\fR may be intermixed with move and draw commands without +affecting the current pen position. +.le + +.tp 9 +.ls gtext (gp, x, y, text, format) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates of text string +char text[ARB] # text to be plotted +char format[ARB] # text characteristics +.fi + +Plot the string \fItext\fR at the position (x,y) in WCS coordinates. +The default size, orientation, and justification of the generated string +may be set by a prior call to \fBgset\fR or overridden for the duration +of the current call by the \fIformat\fR string. A null format string +is permtted. + + +.ks +.nf + keyword values default + + up degrees ccw, zero = +x 90 + size character size scale factor 1.0 + path left,right,up,down r + hjustify normal,center,left,right l + vjustify normal,center,top,bottom b + font roman,greek,italic,bold r + quality normal,low,medium,high n + color integers greater than one 1 +.fi +.ke + + +The attributes controlling how text is generated are shown above. +The character up vector (attribute \fIup\fR) defines the horizontal and +vertical axes (the horizontal axis is perpendicular to the character up +vector). Directions left and right, up and down are relative to these axes. +The attribute \fIpath\fR defines the direction in which characters are +to be plotted. The attribute \fBquality\fR makes it possible to choose +between low or medium quality (fast) and high quality (expensive) character +generation techniques, e.g., hardware versus software character generation. +This attribute is normally best set to "normal" and then overridden at +metafile translation time. + +The attributes are set in the format string by a semicolon delimited list of +keyword=value constructs. Only the first character of keyword and value +strings is significant, i.e., keywords and values may be abbreviated to as +little as one character if desired. For example, the format "p=d;v=c" +would plot characters downward in a vertical string centered at the position +given. + +The default font is set by the font attribute at the beginning of each call. +Font changes may also be signaled by placing the sequence "\fF" in the text, +where F is one of the characters RGIB, denoting the fonts roman, greek, +italic, and bold. In this manner the font may change from character +to character within a single line of text. Additional escape sequences may +be added to represent special symbols. +.le + +.tp 10 +.ls gfill (gp, x, y, npts, style) + +.nf +pointer gp # graphics descriptor +real x[npts] # X coordinates of polygon +real y[npts] # Y coordinates of polygon +int npts # number of vertices of polygon +int style # type of fill +.fi + +Area fill. The points (x[i],y[i]) define a closed area which will be filled +in the indicated \fIstyle\fR. The recognized style codes, defined in , +are: + +.ks +.nf + 0 GF_CLEAR clear area + 1 GF_HOLLOW draw only outline of area + 2 GF_SOLID fill area with a color + 3-6 GF_HATCH[1234] fill area with a pattern + 7-N device dependent +.fi +.ke + +If the device can support multiple colors the color index for area fill may +be set beforehand with a call to \fBgset\fR to set the parameter G_FILLCOLOR. +.le + +.tp 10 +.ls gpcell (gp, m, nx, ny, x1, y1, x2, y2) + +.nf +pointer gp # graphics descriptor +short m[nx,ny] # greylevels or colors (pixels) +int nx, ny # number of pixels in X and Y +real x1, y1 # lower left corner of output area +real x2, y2 # upper right corner of output area +.fi + +Output a cell array. +Map each pixel in the input array into the corresponding area +of the output device. For maximum efficiency the resolution of M should +match that of the area of the output device defined by the window (x1,y1) +and (x2,y2), otherwise M is subsampled or replicated to best fill the output +area. The aspect ratio of a pixel need not be preserved in the mapping. +The pixel values (greylevels or color indices) are passed on to the kernel +without modification. +.le + +.tp 7 +.ls gscur (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # new cursor position +.fi + +Move the device cursor to the indicated position (WCS coordinates). +.le +.le + +.nh 3 +Input Procedures + + Input procedures are available for cursor and pixel input. Inquiry of GIO +parameters and device capabilities is handled by the \fBgstat\fR and \fBgget\fR +procedures and is not considered graphics input. + +.ls +.tp 8 +.ls clgcur (param, wx, wy, wcs, key, strval, maxch) + +.nf +char param[ARB] # CL parameter to be input +real wx, wy # world coordinates of cursor event +int wcs # index of WCS selected +int key # keystroke value of cursor event +char strval[maxch] # string value if set option (key = ':') +int maxch # max chars to be returned in strval +.fi + +The next value of the list structured CL cursor type parameter \fIparam\fR +is read and the cursor coordinates in WCS units are decoded and returned +as output arguments, along with the WCS number and the keystroke value, +i.e., the character typed by the user causing the cursor to be read. +The range of keystroke values is the full ASCII character set, minus a system +dependent subset of control codes (if a physical cursor is read, the read is +always terminated by the user typing a key on the user terminal). +No GIO device need be open to read the cursor. EOF is returned as the +function value when the end of the cursor list is reached. +The number of output arguments successfully decoded is returned as the +function value for a normal read. Values not converted are set to zero. +.le + +.tp 8 +.ls ggcur (gp, sx, sy, key) + +.nf +pointer gp # graphics descriptor +real sx, sy # NDC coordinates of cursor event +int key # keystroke value of cursor event +.fi + +The physical cursor of the graphics device associated with graphics +descriptor \fIgp\fR is read and the cursor coordinates in NDC units are +returned as output arguments, along with the keystroke value, i.e., +the character typed or button pushed causing the cursor to be read. +On many devices the cursor read will be instantaneous (the cursor position +will be sampled), and the keystroke value will always be zero. The range +of possible keystroke values is device dependent. EOF is returned as the +function value when the end of the cursor list is reached. An error action +is taken if the device is not readable. The GIO device must have previously +been opened with \fBgopen\fR. + +Use of this low level procedure is not recommended since it forces a program +to be used interactively, operation is device dependent, and cursor mode +interaction is not supported. The main uses for \fBggcur\fR are cursor input +from special graphics devices, i.e., devices other than \fBstdgraph\fR or +\fBstdimage\fR, and continuous sampling of the cursor position on devices +which support it. The characteristics of the device cursors are described +in the graphcap entry for the device. +.le + +.tp 10 +.ls ggcell (gp, m, nx, ny, x1, y1, x2, y2) + +.nf +pointer gp # graphics descriptor +short m[nx,ny] # output pixel array +int nx, ny # number of pixels out in X and Y +real x1, y1 # lower left corner of input area +real x2, y2 # upper right corner of input area +.fi + +Input a cell array. The cell array defined by the rectangular window +from point (x1,y1) to (x2,y2) is read into the output array M of size +NX columns by NY lines. +For maximum efficiency the resolution of the output array should match +that of the device area defined by the input window. +If the resolution of the output array does not match that of the device +output lines will be subsampled or replicated to best fit the output array. +Unaddressable pixels are returned as negative values. An error action is +taken if the device is not readable. +.le +.le + +.nh 2 +GIO Internal Parameters + + The GIO internal parameters may be set with either a \fBgset\fR or +\fBgscan\fR call, and inspected with a \fBgstat\fR function call. +Parameters are identified to \fBgset\fR and \fBgscan\fR by an integer +code. Each integer code is assigned a symbolic name of the form G_PARAM +in the include file . In input to \fBgscan\fR, parameters are +referred to by name in lower case, without the "g_" prefix. The parameters +and their default values are shown below. + + +.tp 5 +.nf + \fBparameter default description\fR + + wcs 1 index of current WCS + xtran linear linear, log, or nlog (WCS attribute) + ytran linear linear, log, or nlog (WCS attribute) + clip yes clip at viewport boundary (WCS attribute) + cursor 1 current cursor number + pltype 1 polyline linetype + plwidth 1.0 polyline relative line width + plcolor 1 polyline color index + pmltype 1 polymarker linetype + pmcolor 1 polymarker color index + szmarker[1-4] (.5:2)*ch standard marker sizes, NDC coordinates + fastyle 1 fill area interior style + facolor 1 fill area color index + txsize 1.0 relative character size + txup 90 character up vector + txpath right direction in which characters are drawn + txspacing 0.0 character spacing relative to height + txhjustify left horizontal justification (n,c,l,r) + txvjustify bottom vertical justification (n,c,t,b) + txfont roman text font (roman,greek,italic,bold) + txquality normal text generator precision (n,l,m,h) + txcolor 1 text color index +.fi + +.tp 9 +.nf + (axis labeling parameters) + + drawtitle yes draw plot title if given + titlesize 1.0 character size for plot title + titlejust center horizontal justification of title + ntitlelines 1 number of lines in title block + aspect 0.0 aspect ratio of viewport (0=dontcare) + + (the following are duplicated for the Y axis) + + xdrawaxes 3 draw X axis 1, 2, both (3), none (0) + xsetaxispos no set world coords of X axes + xaxispos1 0.0 world coord of X axis 1 (default wx1) + xaxispos2 0.0 world coord of X axis 2 (default wx2) + xdrawgrid yes draw grid marks connecting X ticks + xround no extend WCS to end at a tick mark + xlabelaxis yes draw axis label string if given + xaxislabelsize 1.0 character size for X axis label + xdrawticks yes draw and label X ticks + xlabelticks yes label X ticks + xnmajor 6 number of major ticks in X + xnminor 4 number of minor ticks in X + xmajorlength 0.8ch length of a major tick, X + xminorlength 0.4ch length of a minor tick, X + xmajorwidth 1.0 linewidth of a major tick, X + xminorwidth 1.0 linewidth of a minor tick, X + xaxiswidth 1.0 linewidth of the axis + xticklabelsize 1.0 character size for X tick labels + xtickformat "" override format for X tick labels +.fi + +.tp 4 +.nf + (read only variables) + + tty - pointer to TTY graphcap descriptor + fd - file descriptor of output stream + devname - device name as passed to gopen +.fi + + +The Y axis parameters have names equivalent to those shown with the +X prefix replaced by a Y. If the prefix is omitted entirely then the +parameters for both axes will be set or queried. +The \fBglabax\fR code and parameters are built upon the GIO graphics +primitives and may be replaced by a more sophisticated user program +if desired. + +Drawing and labeling of the X and Y axes is parameterized independently +in X and Y. If drawing and labeling of an axis is disabled, tick drawing +and labeling is automatically disabled. Drawing and labeling of an axis +may be disabled on only one side of the viewport (useful when a single viewport +is used simultaneously for two different world coordinate systems). +If tick drawing is disabled tick labeling is automatically disabled. +The tick marks, if drawn, may be connected by dotted lines within the +interior of the plot. + +Given the approximate number of major ticks, GIO will compute the nearest +number of tick marks resulting in round numbers for the tick mark labels. +If rounding is enabled the window will be enlarged to the nearest tick +outward on either end of an axis, otherwise an axis will end at the window +boundary, which need not fall on a tick mark. +If linear scaling is indicated \fInminor\fR minor ticks will be drawn +between each pair of major ticks. If log scaling is indicated the +\fInmajor\fR and \fInminor\fR parameters are ignored and +major ticks will be placed at powers of ten with eight minor ticks +(e.g., 2,3,4,5,6,7,8,9) between each pair of major ticks. +Tick lengths are given in NDC coordinates. The default tick lengths +are parameterized in terms of the character height for the device. + + +.nh 2 +Graphcap Parameters + + Each logical graphics device accessible to GIO must have an entry +in the \fBgraphcap\fR (graphics capabilities) file. The name of the +device entry in the graphcap file must agree with that specified in the +\fBgopen\fR call when the device is opened. Multiple logical device +entries may be given for a single physical device, each with slightly +different parameters. The name of the graphcap file is parameterized +by the CL environment variable "graphcap", making it easy for the user +to customize or extend the graphcap file. The graphcap entries for +common devices may be precompiled by the system manager to eliminate +the overhead of searching the graphcap file at run time. + +The format of the graphcap file is identical to that of a UNIX \fBtermcap\fR +file, and indeed the same interface (TTY) is used to access both types of files. +The set of capabilities defined for a graphics device is however quite +different than that defined for a terminal. Capabilities are typed +parameters referred to by a two character internal name. The restriction to +two characters is perhaps unfortunate but is desirable for efficiency reasons +(as well as for compatablity with the original termcap) and may be alleviated +at some point in the future by the use of macro defines. + +Graphcap parameters fall into two classes, those parameters which are +common to all devices, and those parameters which are required only for +devices accessed with a particular graphics kernel. GIO is capable +of supporting any number of quite different kernels, each of which may +support any number of devices. These kernels are free to add parameters +to their graphcap entries provided they do not conflict with the standard +parameters. An example is the "fast" or \fBstdgraph\fR kernel, discussed +in detail in a later section. If a device is to be accessed by more than +one kernel each kernel must typically have its own graphcap entry for the +device, with selection of the graphcap entry (logical device name) +specifying the kernel to be used. + +In the discussion which follows the reader is assumed to already be familiar +with the syntax and usage of \fBtermcap\fR format files. This is documented, +for example, in section 5 of the UNIX manuals. A sample termcap entry for +the devices "vt100-nam" and "vt100-am" is included below as an example of +a typical termcap entry. + + +.tp 5 +.nf +d1|vt100|vt100-nam|vt100 w/no am:\ + :am@:xn@:tc=vt100-am: +d0|vt100|vt100-am|vt100|dec vt100:\ + :cr=^M:do=^J:nl=^J:bl=^G:co#80:li#24:cl=50\E[;H\E[2J:\ + :le=^H:bs:am:cm=5\E[%i%d;%dH:nd=2\E[C:up=2\E[A:\ + :ce=3\E[K:cd=50\E[J:so=2\E[7m:se=2\E[m:us=2\E[4m:ue=2\E[m:\ + :md=2\E[1m:mr=2\E[7m:mb=2\E[5m:me=2\E[m:is=\E[1;24r\E[24;1H:\ + :rs=\E>\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h:\ + :if=/usr/lib/tabset/vt100:ku=\EOA:kd=\EOB:kr=\EOC:kl=\EOD:kb=^H:\ + :ho=\E[H:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:ta=^I:pt:sr=5\EM:vt#3:xn:\ + :k5=\EOp:k6=\EOx:k7=\EOr:k8=\EOm:k9=\EOl:k0=\EOq:\ + :sc=\E7:rc=\E8:cs=\E[%i%d;%dr:ks=\E[?1h\E=:ke=\E[?1l\E>: +.fi + + +Note that each device may be known by several names. The device capabilities +are delimited by colons, e.g., ":xx=...:yy=...:". The special capability "tc" +allows an entry to include another entry recursively. Escape is represented +as either "\E" or "^[", is "^H". If a delay of so many milliseconds +is required after transmission of a string, the number of milliseconds +appears as the first few chars in an entry, e.g., "cl=50..." causes a +delay of 50 milliseconds following a screen clear. Numeric capabilities are +prefaced by a sharp, e.g., ":co#80:" (screen has 80 columns). + + +.nh 3 +Generic GRAPHCAP Parameters + + To make the distinction between the generic and kernel graphcap parameters +clear and to eliminate the possibility of redefinitions, the generic +parameters have lower case names and the kernel parameters have upper case +names. Only the standard graphcap parameters should be accessed from within +applications programs. The standard parameters are listed and defined below. +These parameters should be included in the graphcap entry for every device. + +.ls 4 +.ls 15 ar real +Aspect ratio dY/dX, i.e., the ratio of the size of the device screen in Y to +that in X (equivalent to ys/xs). +.le +.ls ca bool +Device implements cellarray plotting in hardware, i.e, the \fIzr\fR greylevels +are displayed by the hardware rather than emulated by software in the kernel. +.le +.ls ch real +Height in NDC units of a character of size 1.0. +.le +.ls co int +Number of columns of text displayable on the device screen at character +size 1.0. +.le +.ls cw real +Width in NDC units of a character of size 1.0. +.le +.ls fa bool +Device implements fill area in hardware. +.le +.ls fs int +Number of fill area styles supported by the device. +.le +.ls in bool +Device supports at least one input function, i.e., cursor readback or cell +array input. +.le +.ls k1 int +Minimum possible key value in a cursor read. +.le +.ls k2 int +Maximum possible key value in a cursor read. +.le +.ls kf str +Filename of the executable graphics kernel file for the device. +If this is given as "cl", the kernel is assumed to be resident in the +CL process. Should be a virtual filename, e.g., "dev$x_device.e". +See also parameter \fItn\fR. +.le +.ls li int +Number of lines of text displayable on the device screen at character +size 1.0. +.le +.ls lt int +Number of linetypes supported by the device. +.le +.ls lw int +Number of linewidths supported by the device. +.le +.ls nc int +Number of cursors supported by the device. +.le +.ls nk int +Number of possible key values in a cursor read. +.le +.ls pl bool +Device implements polyline drawing in hardware. +.le +.ls pm bool +Device implements polymarker drawing in hardware. +.le +.ls ro bool +Device supports roam at the hardware level (used in cursor mode). +.le +.ls se bool +Device supports selective erase of portions of the screen. +.le +.ls tf int +Number of text fonts supported by the device. +.le +.ls th int +Number of text heights or sizes supported by the device. If absent or zero +it is assumed that characters may be freely scaled in size. If only a number +of discreet character sizes are available the sizes are given by the +parameters \fItN\fR. +.le +.ls tn str +Taskname, i.e., name of the logical task within the kernel file \fIkf\fR +to be run to exercise a kernel. +.le +.ls tq int +Number of text quality or precision levels supported by the device. +.le +.ls tN real +Sizes of the \fIth\fR possible character sizes, relative to a character +of size 1.0 (expands to the set of parameters t1,t2,...,tN). +.le +.ls tx bool +Device implements text generation in hardware. +.le +.ls wc bool +Reading the cursor implies a wait, i.e., a cursor read is triggered by +the user. +.le +.ls xr int +Device resolution in X. +.le +.ls xs real +Device scale in X, i.e., the width of the display area in meters. +.le +.ls yr int +Device resolution in Y. +.le +.ls ys real +Device scale in Y, i.e., the height of the display area in meters. +.le +.ls zo bool +Device supports zoom at the hardware level (used in cursor mode). +.le +.ls zr int +Device resolution in Z, i.e., the number of greylevels or colors displayable +at each point using the cell array primitive. +.le +.le + + +The graphcap parameters are accessed by name via \fBgget\fR calls. +For example, + + xr = ggetr (gp, "xr") + +would assign the value of the parameter "xr" into the local variable of +the same name. + +.nh 3 +STDGRAPH Graphcap Parameters + + The \fBstdgraph\fR kernel is the "fast" kernel, i.e., the graphics kernel +resident in the CL process. This kernel is capable of driving almost any +modern graphics terminals given only a graphcap entry for the device, +providing the graphics terminal is data driven and provides both character +and vector generation in hardware. + +.nh 4 +Classes of Parameters + + The stdgraph parameters fall into a number of classes which we shall +describe separately. An alphabetical summary of all parameters is given in +a later section. + +The open and close workstation sequences are sent to the device whenever the +workstation is activated (OW) or deactivated (CW), e.g., when the STDGRAPH +kernel receives the open workstation or close workstation directive, or when +the open workstation is explicitly deactivated and later reactivated by the +applications program. + +The primary function of the open and close workstation sequences is to +effect a mode switch from text mode to graphics mode and back again, +but the sequences may also contain instructions used only for initialization +or mode setting. For example, OW might initialize user defined line types +or enable the graphics board. The close string CW might disable the graphics +board and set the alpha cursor to a standard place on the screen. + +The graphics enable and disable strings (GE,GD) are sent to the terminal +by the STDGRAPH kernel when status line i/o occurs. The GD sequence should +clear the status line, leaving the terminal in status line mode, with the +text cursor positioned to the start of the status line. The GE sequence +restores the terminal to graphics mode, and is often the same as the OW +sequence. Note that GD should not cause the graphics frame to disappear, +as the status line is supposed to be visible at the same time as the plot. + +The status line is normally the line at the bottom of the screen. On terminals +with separate text and graphics memories which can both be displayed at the +same time, the status line is normally written into the text memory. If the +terminal has both text and graphics memories but can only display one at a time +the graphics memory should be used, provided the status line can be erased in +the graphics memory. If the graphics plane must be used but erase is not +possible, the best approach is probably to write successive lines of status +line text on top of the plot, starting at the upper left corner and advancing +downward for each line of output text (see the 4012 entry in dev$graphcap). + +The parameters X1, X2, Y1, and Y2 define the range of device coordinates +to be output. Normally these will span the full screen of the device, +but in general they may define any rectangular window on the device screen. +The fill area and font tables are array valued parameters mapping the GKI +fill area and font indices into device codes (if the device should happen +to support such niceties). + + +.ks +.nf + OW open (reactivate) workstation + IF initialization file, if OW string is large + CW close (deactivate) workstation + GE graphics enable (exit status line mode) + GD graphics disable (enter status line mode) + CL screen clear + LR load registers (see "binary encoding") + + X1,X2 range of device X coordinates + Y1,Y2 range of device Y coordinates +.fi +.ke + + +The set attribute parameters are format strings used to encode set attribute +commands, each of which has a single integer argument. The format string is +similar to a \fBprintf\fR format string with the addition of a notation for +binary encoding (described below). + + +.ks +.nf + TH(i) set text height + TC(i) set text color + TF(i) set text font + LT(i) set line type + LC(i) set line color + LW(i) set line width + MC(i) set marker color + FT(i) set fill area type + FC(i) set fill area color +.fi +.ke + + +Polyline generation, i.e., vector drawing, is more difficult to parameterize. +We assume that polylines, polymarkers, fill areas, etc. are all similar enough +to be described by the same coordinate encoding format, but we allow each +such instruction to have different head and tail strings. + +.ks +.nf + PL polyline flag + VS move start + VE move end + DS draw start + DE draw end + MS marker start + ME marker end + FS fillarea start + FE fillarea end + XY(i,j) coord format +.fi +.ke + + +A polyline command consists of a number of subcommands, as outlined in the +drawing below. The polyline is a move followed by one or more draws. +The polyline flag PL is set to indicate that multiple coordinate pairs +can be output between the DS and DE commands. If PL is false (or omitted) +each coordinate pair in the GKI polyline will be output surrounded by DS +and DE commands. The encoding of each coordinate pair is defined by the +parameter XY. + + +.ks +.nf + set attributes if necessary + move start + x, y + move end + draw start + x, y + ... + x, y + draw end +.fi +.ke + + +The polymarker and fillarea parameters are optional. The kernel will +emulate markers and fill area if not supported by the hardware. +Recall that GIO handles all mark drawing except GM_POINT (point mode), +hence sophisticated mark drawing facilities are not required. + +Text generation is handled by the kernel a character at a time. +If character up is 90 degrees and the path is to the right, the kernel +will assume that it can output a number of characters between a TS +and a TE. Otherwise each character will be output preceded by a TS +and followed by a TE. The TS parameter is a format string with two +arguments, the device coordinates of the lower left corner of the +character to be drawn. The encoding of these coordinates is defined +by the TS format string. It is possible to perform a coordinate +transformation using the binary encoding facilities, if such is necessary. +If characters are not addressed at the lower left corner an offset +may be applied to the given coordinates using the binary encoding +facilities. + + +.ks +.nf + TS(i,j) text start + TE text end +.fi +.ke + + +Cursor output is controlled by the parameter WC. +Cursor input is initiated by output of the sequence defined by the format RC. +RC has one integer argument, the number of the cursor to be read. +The UC capability, if defined, will cause the cursor position to be updated +(with WC) to the position at the last cursor read. This is desirable if the +device cannot maintain the cursor position, i.e., if unrelated graphics +output commands affect the cursor position as an unwanted side effect. + + +.ks +.nf + UC update cursor pos before read + WC(x,y,i) write cursor + RC(i) read cursor start + RE read cursor end + CN cursor value length + CD cursor value delimiter + SC scan cursor (-> x,y,key) +.fi +.ke + + +Following transmission of the RC sequence the kernel will read the +response as defined by the parameters CN and CD. At least one of CN or CD +must be given. If CN is given but not CD exactly CN characters will be +read. If CD is given then characters will be read until the delimiter string +is matched (and until at least CN characters have been read). If possible +a delimiter string should be specified to permit recovery from bad cursor +reads, e.g., when the user types something before the cursor is displayed. +When a satisfactory cursor response string has been obtained the format SC +will be used to decode the string into the output values X, Y, and KEY. +The RE sequence is transmitted once the cursor read has successfully +completed. + +.nh 4 +Binary Encoding + + Graphics devices vary widely in the techniques used to encode numeric +data such as a line type or color index, or the coordinate pairs of a +polyline. Our approach to the encoding problem is a generalization of the +\fBprintf\fR format string. The encoder is driven by a format string +taken from the graphcap entry for the device. A number of standard formats +are recognized with encoding provided internally for these standard formats +by the encoder. To permit encoding of special formats the encoder provides +a very general yet efficient RPN virtual machine capable of computing bit +patterns according to a user supplied program embedded in the format string. + +A format string is a sequence of ASCII characters. Any ASCII character, +including all control characters, is permitted in the string. +The significance of a character depends on the context in which it appears. +Initially characters are simply copied to the output. Three special +characters are recognized in \fBcopy mode\fR (excluding the characters +already counted as special by termcap): + + +.ks +.nf + ' escape next character (literal) + % begin a formatted output string + ( begin an executable expression +.fi +.ke + + +The encoder is a table driven interpreter which is programmed by the format +given in the graphcap file. Programming the encoder is rather +like programming in assembler or microcode (its fun but easy to screw up). +The encoder provides a set of 12 integer registers, an integer stack with a +capacity of 50 values, and a dozen or so instructions. It is fundamentally +assumed that the character set is ASCII (this is guaranteed by the IRAF +programming environment). + +Upon entry one or more of the registers 1 through 3 are initialized to the +values of the input arguments, leaving the remaining registers, i.e., R4-R9 +and R0 (R10) available for general use. Registers R11 and R12 are reserved +for internal use. +The interpreter is activated when an unescaped ( is encountered in the input. +In \fBexecute mode\fR the following characters have special meanings +(excluding :, ^, and \, which are special characters to termcap/TTY): + +.ks +.nf + ' escape next character (recognized everywhere) + % conventional formatted output + ) revert to copy mode + #nnn push signed decimal integer number nnn + $ switch case construct + . pop number from stack and place in output string + , get next character from input string and push on stack + & modulus (similar to AND of low bits) + + add (similar to OR) + - subtract (similar to AND) + * multiply (shift left if pwr of 2) + / divide (shift right if pwr of 2) + < less than (0=false, 1=true) + > greater than (0=false, 1=true) + = equals (0=false, 1=true) + ; branch if: ;. The ; is at offset=0. + 0-9 push contents of register 0 through 9 + !N pop stack into register N + !! generate a N millisecond delay, where N is on the stack +.fi +.ke + + +Any other character encountered in execute mode is interpreted as an integer +number and pushed on the stack. Hence, the character "@" is equivalent to +"#64", i.e., octal 100. A blank is the integer constant 40B. + +The output format directive % will format and output the number on the top +of the stack, popping the stack in the process. The format specification +may be any legal \fBprintf\fR format. The case construct is used to process +set attribute commands, e.g., set linetype 0, 1, 2, text size 1, 2, 3, etc, +and also provides a rudimentary conditional processing capability. The branch +if operator ; provides a rudimentary branching and looping capability. +Beware that sequences like "^N" and "\E" compile as a single character in +the format string. + +.nh 4 +Examples + + As a simple example consider the encoding of the ANSI command to set +the cursor of a nongraphics terminal. The required sequence is the +following: + + ESC [ line ; col H + +Assuming that the column number is designated as X and the line number as +Y, in registers 1 and 2 respectively, the format would be as follows +(the quotes are not part of the format): + + "\E[(2)%d;(1)%dH" + +Now assume that the output sequence is the same but the line and column +numbers are one-indexed while the terminal requires zero-indexed +coordinates: + + "\E[(2#1-)%d;(1#1-)%dH" + +Thus far the examples have been pretty trivial and do not warrant the +complexity of the RPN interpreter proposed here. For our next example +consider the encoding of a polyline coordinate pair for a Tektronix +compatible graphics terminal and for an AED512, two quite different +graphics terminals. The Tektronix format for encoding an (X,Y) coordinate +pair is as follows: + + +.ks +.nf + 0 1 YA Y9 Y8 Y7 Y6 + 1 1 Y5 Y4 Y3 Y2 Y1 + 0 1 XA X9 X8 X7 X6 + 1 0 X5 X4 X3 X2 X1 +.fi +.ke + + +Since the Tektronix device is so common the special format %t is provided +for encoding register 1 and 2 (X and Y) in this format, and writing out +the result. The format string + + "%t" + +is all that is required. The more general solution is provided by the +following format. + + "(2 / +.2 &`+.1 / +.1 &@+." + +To understand this last example one must look up the octal values of +the characters " " (40B), "`" (140B), and "@" (100B). The notation is +admittedly rather cryptic but it is also concise and efficient, and works +for a wide range of devices. + +Now consider the AED512 in binary mode (this is courtesy of NCAR; I do not +have access to such a terminal). The output encoding of a coordinate pair +is as follows: + + +.ks +.nf + XA X9 X8 YB YA Y9 Y8 + X7 X6 X5 X4 X3 X2 X1 + Y7 Y6 Y5 Y4 Y3 Y2 Y1 +.fi +.ke + + +The format required to generate this is shown below. Note the use of +register 9 to store the constant 200B. The "^N" signifies , +i.e., 16B, used to effect a left shift of four bits. + + "(#128!919/^N*29/+.19&.29&." + +This format could be further optimized by preloading register 9 at +\fBopenws\fR time by moving the "(#128!9" to parameter LR. The encoder +registers maintain their values indefinitely. Using LR the two parameters +might appear in the graphcap entry as follows. + + ":LR=(#128!9:XY=(19/^N*29/+.19&.29&.:" + +The case construct makes it possible to generate output conditionally based +on the value of an integer switch. The syntax of a case statement is as +follows: + + $1 ... $2-5 ... $6 ... $D ... $$ + +When the first $ is encountered the switch value is popped off the stack +and converted into a character by addition of the constant '0' (60B). +The interpreter will then scan forward until it finds the indicated case, +at which point it resumes execution in case mode. If the indicated case +is not found scanning will stop at $D (the default case) or $$, whichever +comes first. When the next $ is seen the interpreter skips forward until +it finds $$, which marks the end of the case. Case constructs are not +nestable. + +The case construct is used primarily for set attribute formats. +For example, the GKI linetype codes are integers greater than or equal to zero, +with case zero being the line clear and the other cases actual linetypes. +For the VT640 there are nine possible linetypes, i.e., line clear, +five builtin linetypes, and 3 user defined linetypes. The strings to be +output for the cases 0 through 5 are the following: + + +.ks +.nf + linetype string + + 0 ESC / 1 d ESC ` + 1 ESC / 0 d ESC ` + 2 ESC / 0 d ESC a + 3 ESC / 0 d ESC b + (etc) (etc) +.fi +.ke + + +We could encode linetypes 0, 1 through 5, and everything else with the +following format (linetype code in register 1): + + "\E/(1$0)0d\E`($1-5)1d\E(1_+.$D)0d\E`($$" + +Note that case searching is a simple string matching operation that ignores +operators such as ( and ). Only $, ' (escape), and EOS are recognized when +searching for a case. + +.nh 4 +Efficiency + + The interpreter approach to solving the general encoding problem +presented here is not the only solution to the problem. Before adopting +this approach several alternatives were considered. One such alternative +was the bitfield packing and unpacking scheme used by NCAR to solve the +same problem. The third alternative considered was to hand code a +subroutine for each encoding required for each device. Benchmarks run +to compare the three alternatives yielded the following times in +cpu seconds required to plot a 1000 point array with Tektronix encoding: + + +.ks +.nf + bitfields approximately 30 seconds + interpreter 0.82 - 2.0 seconds + hand coded 0.78 seconds (mostly i/o) +.fi +.ke + + +The time required for character output is included in the figures shown. +The bitfields benchmark is an extrapolation from an actual timing of the +prototype NCAR software as ported to the UNIX VAX by Cliff Stoll. +The GBYTE and SBYTE primitives used to implement bitfields in the NCAR +software were written in portable C by Cliff and did not use the VAX bitfield +instructions, which would have helped significantly (but which would not +have yielded a fair test: all IRAF target machines may not have bitfield +instructions). The two timings shown for the interpreter are for the "%t" +format and the general format. The clock time required by the hardware +(VT100 with VT640 retrographics board) to draw the vectors was about 7 seconds. + +We conclude that the execution time overhead of the interpreter for encoding +polyline points is acceptable and the use of hand coded, device dependent +procedures is neither warranted nor desirable. The bitfields technique +is too inefficient to use in a production interface. + +.nh 4 +Decoding Cursor Input + + Decoding of the cursor value string returned by the device into +X, Y, and KEY (keystroke) values is carried out using the table driven +interpreter for decoding rather than for encoding. In this mode characters +are input with "," and the decoded output values X, Y, and KEY are returned +in registers 1 through 3. The % format encoding operator is not used. +If the cursor value is returned in ASCII X and Y must be converted to +binary the hard way (e.g., "ch1 '0' - 100 * ch2 '0' - 10 * +", etc.). + +To verify that this scheme will work consider the cursor value returned +by a Tektronix compatible terminal. The return value is 6 characters, +consisting of the character typed followed by the encoded X and Y in +the next four characters, and lastly a CR terminator: + + +.ks +.nf + C7 C6 C5 C4 C3 C2 C1 + 0 1 XA X9 X8 X7 X6 + 0 1 X5 X4 X3 X2 X1 + 0 1 YA Y9 Y8 Y7 Y6 + 0 1 Y5 Y4 Y3 Y2 Y1 + 0 0 0 1 1 0 1 +.fi +.ke + + +The required decoding format is shown below. + + ",!3, & *, &+!1, & *, &+!2" + +.nh 4 +Summary of STDGRAPH Graphcap Parameters + + An alphabetical summary of the graphcap parameters used by the STDGRAPH +kernel is given below. + + +.tp 3 +.nf + CD cursor value delimiter + CL screen clear + CN cursor response length + CW close (deactivate) workstation + DE draw end + DS draw start + FC(i) set fill area color + FE fillarea end + FS fillarea start + FT(i) set fill area type + GD graphics disable (exit status line mode) + GE graphics enable (enter status line mode) + IF initialization file, if OP string is large + LC(i) set line color + LR load registers + LT(i) set line type + LW(i) set line width + MC(i) set marker color + ME marker end + MS marker start + OW open (reactivate) workstation + PL polyline flag + RC(i) read cursor start + RE read cursor end + SC scan cursor (-> x,y,key) + TC(i) set text color + TE text end + TF(i) set text font + TH(i) set text height + TS(i,j) text start + VE move end + VS move start + WC(x,y,i) write cursor + X1 first device X coordinate + X2 last device X coordinate + XY(i,j) coordinate format + Y1 first device Y coordinate + Y2 last device Y coordinate +.fi + + +As a final example, the actual graphcap entry for the vt640 terminal +(DEC VT100 with retrographics) is reproduced below. + + +.ks +.nf +vt640|vt640g|vt100 with Retrographics:\ + :RC=(1$2)^X\E[24;65H\E[7mLIGHT PEN READY\E[0m($$)^]\E"(1$2)5($D)4($$)g:\ + :WC=^]%t\E/f:OW=150^]^_:CW=^X\E[24;0H\E[K:GE=150^]^_:GD=^X\E[24;0H\E[K:\ + :lt#5:nc#2:se:CL=50^]\E^L:xr#640:yr#480:ar#.57:xs#.23:ys#.13:tc=4012: + +4012|tek4012|tektronix 4012:\ + :ar#.70:ch#.0294:co#80:cw#.0125:in:k1#1:k2#127:kf=cl:li#35:\ + :lt#5:nc#1:nk#127:pl:pm:th#4:t1#1:t2#2:t3#3:t4#4:tx:\ + :wc:xr#1024:yr#780:xs#.20:ys#.14:\ + :CD=^M:CN#6:LT=^]\E/(1$0)1d\E`($1-5)0d\E(1_+.$D)0d\E`($$:\ + :MS=\034:PL:RC=\E^Z:SC=(,!3, & *, &+!1, & *, &+!2:\ + :TH=\E(1#47+.:TS=^]%t^_:VS=^]:X1#0:X2#1023:XY=%t:Y1#0:Y2#779:\ + :OW=^]^_:CW=(#682!2#0!1)^]%t^_:GE=^]^_:\ + :CL=1000(#32!9)\E^L:\ + :LR=(#32!9:GD=(9#1-!99$0#31!9$$9#22*!2#0!1)^]%t^_: +.fi +.ke + +.NH 3 +TERMCAP and GRAPHCAP + + Every graphics terminal entry in the graphcap file should have a +corresponding terminal capability entry in the termcap file. When the user +sets the terminal type with the \fBstty\fR task in the CL, the termcap entry +tells whether or not the terminal supports vector graphics, and the value +of the \fBstdgraph\fR environment variable is set to "none" for a non-graphics +terminal, or to the graphcap name of the device for a graphics terminal. +For a terminal to be recognized by the system as a graphics terminal the +termcap entry must include the ":gd" capability. If the graphcap name for +the device is different than the termcap name then the form ":gd=gcname:" +should be used. + +For example, the minimal termcap entry for the vt640 graphics terminal would +be as follows. Note that it makes no sense to set the terminal type to +"vt100", since a standard vt100 does not support vector graphics. + +.ks +.nf + vt640|Retrographics enhanced VT100:\ + :gd:tc=vt100: +.fi +.ke + +The "gd" capability is not standard termcap, but will be ignored by non-IRAF +programs which do not recognize the capability. + +.nh 2 +Graphics Kernel Interface + + The graphics kernel interface (GKI) is the interface between GIO and the +underlying graphics kernel or kernels. The GKI is a data driven interface, +i.e., GIO communicates with the graphics kernel via bidirectional streams +of control instructions and data. The functionality assumed by the GKI is +simple enough to permit use of a variety of graphics kernels, e.g., the builtin +GIO kernel for interactive graphics terminals, GKS, CORE, NSPP, and so on. +To understand the level of functionality expected from the kernel we first +summarize the functions the kernel is \fInot\fR expected to perform, i.e., +the functions performed by GIO before output to the kernel: + +.ls 4 +.ls o +All WCS coordinate transformations and clipping at the viewport boundary. +The kernel sees only NDC coordinates. +.le +.ls o +Axis drawing and labeling. GIO processes a \fBglabax\fR call into a +sequence of polylines in NDC coordinates. +.le +.ls o +Mark drawing. GIO processes all mark drawing commands into polyline +instructions. +.le +.ls o +Move and draw commands. GIO processes all absolute and relative move and draw +commands into sequences of polyline instructions. +.le +.le + + +The main functions of the kernel are the control and attribute set functions, +set cursor, polyline, polymarker (GM_POINT only), text generation, fill area, +cell array, and cursor read. A kernel need not implement all such functions, +but it must at least recognize and ignore the corresponding GKI instructions. +The GKI kernel instructions are easily implemented for modern intelligent +graphics terminals. The fast kernel will let the terminal handle polyline +drawing, point mode polymarker drawing, dashed lines, and character generation. + +The GKI format is a sequence of variable length binary control and +output instructions. Each instruction consists of the beginning of instruction +sentinel (BOI), an integer binary opcode identifying the instruction, +an integer giving the length of the instruction in metacode words, +and an arbitrary number of parameter and data words. +The BOI word aids in the detection of and recovery from botched instructions, +e.g., if an interrupt occurs while writing an instruction. + + +.ks +.nf + \fBfield\fR \fBdescription\fR + + BOI beginning of instruction (magic value = 100000B) + opcode unique instruction identification code (1-27) + length length of entire of instruction in metacode + words (includes all four fields) + data variable length part of instruction +.fi + +.ce +Figure 3. GKI Instruction Format +.ke + + +The instruction format chosen for GKI is basically a direct mapping of the +required low level functions into binary opcodes. +Various standard formats were considered and rejected, +in particular the GKS VDM (virtual device metafile) format. +GKS VDM turned out to be far to complex to be worth using at this level +in the system. The GKS VDI format might have been better suited, +but I could not find any information describing this format +(my understanding was that, although there are numerous implementations of VDI, +there is no formal standard as yet). + +The GKI format may be extended at some point in the future to provide +a binary instruction for each procedure in the GKS Fortran binding. +This will make it possible for applications to use either GIO or GKS, +provided a GKS kernel is available. This will make it easier to +import applications which are already written to use GKS (alternatively a +mini-GKS might be built upon GIO, since the primitive functions are almost +identical). Since IRAF itself is transportable and it is desirable for IRAF +applications to have full access to the IRAF i/o facilities, new IRAF +applications are not being written with transport to another data reduction +system in mind. New IRAF applications will use only GIO whenever the +facilities provided by GIO are adequate. Applications which use only GIO +will continue to be usable with any graphics kernel. + +.nh 3 +GKI Instructions + + The GKI instruction stream transmitted between processes on the same or +compatible machines will be a sequence of SPP short integer metacode words. +The machine independent GKI metafile format will be the equivalent stream +encoded as 16 bit twos complement signed integer metacode words, blocked +1440 words per block, with conversion between the internal and external +metacode formats being provided by the IRAF MII (machine independent integer) +interface (MII takes care of byte swapping, etc.). GKI metafiles in MII +format will be easily read and written by different machines, offloading most +of the work to the graphics kernel on the reader machine. The GKI instruction +format is designed for maximum efficiency on modern minicomputers, i.e., +the internal format (SPP short integer) is an atomic datatype and no bit +operations are required to generate or interpret metacode. + +NDC coordinates (0.0 to 1.0) will be represented in GKI as integers in the +range 0-32767. Character data will be packed one 7 bit ASCII character per +metacode word. Floating point is required only for certain output attributes, +e.g., the linewidth and character height (size) scale factors. +To avoid the problems of machine dependent floating point formats we shall +represent the low precision real numbers by converting them to integer +metacode words scaled according to the following relation: + + I = int (R * 1E2) + +Specifications for the GKI metafile instructions follow. The datatype and +size of each field of the instruction is given in parenthesis. +The datatype "p" denotes a coordinate pair (x,y) of type (m,m), +where "m" denotes an NDC coordinate. + +The OPENWS instruction marks the start of an instruction stream or +\fBmetafile\fR for a particular device. +A subsequent CLOSEWS (or physical end of file) marks the end of a metafile. +An OPENWS in APPEND mode requires that GIO recall the WCS defined when the +device was last accessed. +A physical file may consist of any number of independent metafiles. +Although there is no explicit connection between OPENWS and screen clear +(CLEARWS), a screen clear is implied for some devices when opened in +new file mode. +The MFTITLE instruction is optional and is provided only for documenting +the contents of a metafile. + + +.ks +.nf + GKI_EOF = BOI 0 L + GKI_OPENWS = BOI 1 L M N D + GKI_CLOSEWS = BOI 2 L N D + GKI_REACTIVATEWS = BOI 3 L + GKI_DEACTIVATEWS = BOI 4 L + GKI_MFTITLE = BOI 5 L N T + GKI_CLEARWS = BOI 6 L + GKI_CANCEL = BOI 7 L + GKI_FLUSH = BOI 8 L + GKI_POLYLINE = BOI 9 L N P + GKI_POLYMARKER = BOI 10 L N P + GKI_TEXT = BOI 11 L P N T + GKI_FILLAREA = BOI 12 L N P + GKI_PUTCELLARRAY = BOI 13 L LL UR NC NL P + GKI_SETCURSOR = BOI 14 L CN POS + GKI_PLSET = BOI 15 L LT LW CI + GKI_PMSET = BOI 16 L MT MW CI + GKI_TXSET = BOI 17 L UP SZ SP P HJ VJ F Q CI + GKI_FASET = BOI 18 L FS CI + GKI_GETCURSOR = BOI 19 L CN + GKI_CURSORVALUE = BOI 19 L CN POS KEY + GKI_GETCELLARRAY = BOI 20 L LL UR NC NL + GKI_CELLARRAY = BOI 20 L NP P + GKI_ESCAPE = BOI 25 L FN N DC + GKI_SETWCS = BOI 26 L N WCS + GKI_GETWCS = BOI 27 L N +.fi + +.ce +The GKI Instruction Set +.ke + +.nh 4 +Control Instructions + + The NULL instruction is unique in that it consists of a single metacode +word with value zero. The BOI and length fields are omitted. Any number +of null words may be inserted between regular metacode instructions, e.g., +to pad a block of metacode to be written to an MII format metafile. +The EOF instruction is used internally by GIO to stop metacode translation +on a pseudofile stream, as if end of file had been encountered. + +The open workstation instruction should start a new frame unless the access +mode is APPEND, in which case graphics is to be added to the last frame. +An OPENWS implies an REACTIVATEWS. CLOSEWS does little more than deactivate +the workstation, since the last frame must in some sense remain open for +APPEND mode to be possible. Normal termination of the kernel process +will or an open workstation in a mode other than append will cause the last +frame to be terminated. + + +.ls +.tp 4 +GKI_EOF = BOI 0 L +.ls +.nf +L(i) 3 +.fi +.le + + +.tp 6 +GKI_OPENWS = BOI 1 L M N D +.ls +.nf +L(i) 5 + N +M(i) access mode (APPEND=4, NEW_FILE=5, TEE=6) +N(i) number of characters in field D +D(Nc) device name as in \fBgraphcap\fR file +.fi +.le + + +.tp 5 +GKI_CLOSEWS = BOI 2 L N D +.ls +.nf +L(i) 4 + N +N(i) number of characters in field D +D(Nc) device name as in \fBgraphcap\fR file +.fi +.le + + +.tp 5 +GKI_REACTIVATEWS = BOI 3 L +.ls +.nf +L(i) 3 +.fi +.le + + +.tp 5 +GKI_DEACTIVATEWS = BOI 4 L +.ls +.nf +L(i) 3 +.fi +.le + + +.tp 5 +.rj (optional) +GKI_MFTITLE = BOI 5 L N T +.ls +.nf +L(i) 4 + N +N(i) number of characters in field T +T(Nc) title string identifying metafile +.fi +.le + + +.tp 3 +GKI_CLEARWS = BOI 6 L +.ls +.nf +L(i) set to the constant 3 (no data fields) +.fi +.le + + +.tp 3 +GKI_CANCEL = BOI 7 L +.ls +.nf +L(i) set to the constant 3 (no data fields) +.fi +.le + + +.tp 3 +GKI_FLUSH = BOI 8 L +.ls +.nf +L(i) set to the constant 3 (no data fields) +.fi +.le +.le + +.nh 4 +Output Instructions + + All data points in the GKI output instructions have been transformed into +NDC coordinates and clipped at the viewport boundary (if clipping is enabled). +In the process GIO will translate any INDEF valued points by breaking large +polylines into smaller polylines, hence the semantics of plotting polylines and +polymarkers is quite simple at the graphics kernel level. + +CELLARRAY is processed into a series of one dimensional cell array instructions, +one for each line in the two dimensional array supplied by the user. Fewer or +shorter lines will be output if clipping is necessary. Arrays larger than 32767 +pixels may be output since each line is passed as a separate instruction. +The maximum number of lines and columns in a cell array is 32767 and 32761, +respectively (more lines can be input but they will not be resolved). +The kernel is expected to scale cell arrays to fit the output device via some +combination of pixel replication or subsampling, if there is not a one to one +correspondence between cell array pixels and device pixels. + +.ls +.tp 5 +GKI_POLYLINE = BOI 9 L N P +.ls +.nf +L(i) 4 + N * 2 +N(i) number of points in the polyline +P(Np) list of points (x,y pairs) +.fi +.le + + +.tp 5 +GKI_POLYMARKER = BOI 10 L N P +.ls +.nf +L(i) 4 + N * 2 +N(i) number of points in the polymarker +P(Np) list of points (x,y pairs) +.fi +.le + + +.tp 6 +GKI_TEXT = BOI 11 L P N T +.ls +.nf +L(i) 6 + N +P(p) starting point of character string +N(i) number of characters in string T +T(Nc) string of N ASCII characters +.fi +.le + + +.tp 5 +GKI_FILLAREA = BOI 12 L N P +.ls +.nf +L(i) 4 + (N * 2) +N(i) number of points defining the polygon to be filled +P(Np) list of points (x,y pairs) +.fi +.le + + +.tp 8 +GKI_PUTCELLARRAY = BOI 13 L LL UR NC NL P +.ls +.nf +L(i) 9 + (N * M) +LL(p) coordinates of lower left corner of output area +UR(p) coordinates of upper right corner of output area +NC(i) number of columns in array +NL(i) number of lines in array +P(NCNLi) array of color indices (pixels) stored by row +.fi +.le + + +.tp 5 +GKI_SETCURSOR = BOI 14 L CN POS +.ls +.nf +L(i) 6 +CN(i) cursor number +POS(p) new cursor position +.fi +.le +.le + +.nh 4 +Set Attribute Instructions + + The set polyline, polymarker, text, and fillarea instructions change +the attributes used to generate graphics output. These instructions need be +issued only when one of the attributes in an instruction packet changes, i.e., +the kernel is assumed to remember the attributes while a device is open. + +.ls +.tp 6 +GKI_PLSET = BOI 15 L LT LW CI +.ls +.nf +L(i) 6 +LT(i) linetype number +LW(r) linewidth scale factor +CI(i) polyline color index +.fi +.le + + +.tp 6 +GKI_PMSET = BOI 16 L MT MW CI +.ls +.nf +L(i) 6 +MT(i) marktype (not used at present) +MW(i) marksize, NDC coords (not used at present) +CI(i) marker color index +.fi +.le + + +.tp 9 +GKI_TXSET = BOI 17 L UP SZ SP P HJ VJ F Q CI +.ls +.nf +L(i) 12 +UP(i) character up vector (degrees) +SZ(r) character size scale factor +SP(r) character spacing +P(i) path (0,2=left,3=right,4=up,5=down) +HJ(i) horizontal justification + (0=normal,1=center,2=left,3=right) +VJ(i) vertical justification + (0=normal,1=center,6=top,7=bottom) +F(i) font (8=roman,9=greek,10=italic,11=bold) +Q(i) quality (0=normal,12=low,13=medium,14=high) +CI(i) text color index +.fi +.le + + +.tp 5 +GKI_FASET = BOI 18 L FS CI +.ls +.nf +L(i) 5 +FS(i) fill style (0=clear,1=hollow,2=solid,3-6=hatch) +CI(i) fill area color index +.fi +.le +.le + + +The attributes for the output primitives are assumed to be set to their +default values when OPENWS is issued. + +.nh 4 +Input Instructions + + The primary input instruction is the cursor read instruction, used to read +the cursor position in NDC coordinates. The device cursor read may be either +event driven or instantaneous. If the cursor read is event driven a nonzero +keystroke value may be returned, the range of possible keystroke values being +device dependent. The instantaneous type of cursor read is preferred at the +GKI level since it offers the maximum flexibility (\fBclgcur\fR may then be +used to provide an optional device independent keystroke driven cursor read). +Devices which support both forms of cursor read may provide both as separate +logical cursors. The graphics kernel should return a null cursor value if +the output device does not have a cursor. + +.ls +.tp 6 +GKI_GETCURSOR = BOI 19 L CN +.ls +.nf +L(i) 4 +CN(i) cursor number +.fi + +The kernel reads graphics cursor number CN and returns the keystroke value +(if any) and the cursor position in NDC coordinates. The cursor attributes +are returned in the following format: + + GKI_CURSORVALUE = BOI 19 L CN POS KEY + +where + +.nf + L(i) 7 + CN(i) cursor number + POS(r) NDC coordinates of cursor + KEY(i) keystroke value (>= 0 or EOF) +.fi +.le + + +.tp 8 +GKI_GETCELLARRAY = BOI 20 L LL UR NC NL +.ls +.nf +L(i) 9 +LL(p) coordinates of lower left corner of input area +UR(p) coordinates of upper right corner of input area +NC(i) number of columns in output array +NL(i) number of lines in output array +.fi + +The GETCELLARRAY instruction is the converse of the PUTCELLARRAY instruction. +The cell array is returned in the following format: + + GKI_CELLARRAY = BOI 20 L NP P + +where + +.nf + L(i) 4 + NP + NP(i) number of pixels (0 if noread) + P(NPi) array of pixels +.fi +.le + + +(instruction codes 19-24 are reserved for future use) +.le + +.nh 4 +Escape Instruction + + The escape instruction is used to pass device dependent information or +commands to the graphics kernel via GKI. The graphics kernel will ignore +unrecognized escape functions. Function codes 1 through 100 are reserved +for use by GIO. + +.ls +.tp 5 +GKI_ESCAPE = BOI 25 L FN N DC +.ls +.nf +L(i) 5 + N +FN(i) escape function code +N(i) number of escape data words +DC(i) escape data words +.fi +.le +.le + +.nh 4 +Pseudo-GKI Instructions + + Since the CL must be able to read the device cursor and convert NDC +coordinates to WCS coordinates, the WCS must be passed to the CL when they +are "fixed" to the device. The most natural and efficient way to do this +is via the GKI instruction stream, hence several additional instructions +are used internally in GIO to communicate with the portion of GIO resident +in the CL process. These instructions are filtered out and executed by the +CL process and their existence may therefore be ignored by the graphics kernels. + +The SETWCS instruction is used to pass WCS information to the CL process. +The GETWCS instruction is used to recall the WCS for a device opened in APPEND +mode (the WCS are returned in SETWCS format). Since these instructions +are passed only between two closely coupled processes on a single cpu, +floating point numbers are passed in machine dependent format. +The length of this instruction is machine dependent. +Only the fields L and WCS are truely part of the instruction; the remaining +fields are a binary copy of the GIO internal WCS structure. + +.ls +.tp 6 +GKI_SETWCS = BOI 26 L N WCS +.ls +.nf +L(i) 4 + 17 * sizeof (struct wcs) +N(i) length of WCS structure, words +WCS binary copy of the 17 WCS structures, transmitted + in a single call to WRITE +.fi +.le + + +.tp 5 +GKI_GETWCS = BOI 27 L N +.ls +.nf +L(i) 4 +N(i) maximum number of words to read +.fi +.le +.le + +.nh 3 +Encoding GKI Instructions + + The GKI instruction opcodes and fields are defined in the global include +file lib$gki.h. To avoid direct knowledge of the binary format of the GKI +instructions, GIO uses a subpackage called GKI to encode the GKI instructions. +The GKI procedures each encode and transmit a single GKI instruction on the +output stream. Although the GIO and GKI procedures have similar names, they +should not be confused. The GIO \fBgpline\fR, for example, performs conversion +from a WCS to GKI coordinates with clipping at the viewport boundary, checking +that the polyline attributes are up to date before transmitting the polyline +instruction. In contrast the GKI \fBgki_polyline\fR merely encodes and +transmits the GKI_POLYLINE metacode instruction. + +The GKI procedures are self contained with the exception of the set attribute +instructions, which reference attribute packet structures (argument \fIap\fR) +defined in the include file gio.h. +The GKI instruction encoding procedures are shown below. + +.ks +.nf + gki_openws (fd, device, mode) + gki_closews (fd, device) + gki_reactivatews (fd, flags) + gki_deactivatews (fd, flags) + gki_mftitle (fd, title) + gki_clearws (fd) + gki_cancel (fd) + gki_flush (fd) + gki_polyline (fd, points, npts) + gki_polymarker (fd, points, npts) + gki_text (fd, x, y, text) + gki_fillarea (fd, points, npts) + gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_plset (fd, ap) + gki_pmset (fd, ap) + gki_txset (fd, ap) + gki_faset (fd, ap) + gki_setcursor (fd, x, y, cursor) + gki_getcursor (fd, x, y, key, cursor) + gki_escape (fd, fn, instruction, nwords) + gki_setwcs (fd, wcsdata, len_wcsdata) + gki_getwcs (fd, wcsdata, len_wcsdata) + + gki_fflush (fd) # not GKI instruction; flushes GKI stream +.fi +.ke + + +.nh 3 +Decoding GKI Instructions + + The following additional procedures are provided for decoding and executing +GKI metacode, e.g., in a graphics kernel. In what follows, \fIinstruction\fR +is a short integer array containing the encoded GKI instruction, and \fIdd\fR +is the device driver table, i.e., array of \fBzlocpr\fR entry point addresses +of the standard kernel procedures. + + +.ks +.nf + stat = gki_fetch_next_instruction (fd, instruction_ptr) + gki_execute (instruction, dd) + gkp_install (dd, out_fd, verbose_output) +.fi +.ke + + +The \fBfetch\fR procedure extracts the next instruction from the input metacode +stream, returning a short integer pointer to the instruction as an output +argument. EOF is returned as the function value when end of file is detected. +The \fBexecute\fR procedure decodes an instruction and calls a graphics device +driver procedure to execute the instruction. If the entry point address +of the driver procedure is NULL \fBgki_execute\fR will ignore the corresponding +GKI instruction. The fields of the metacode instruction are passed to the +driver procedure as distinct arguments, hence the device driver need not +understand the GKI format. + +A standard kernel is provided for decoding GKI instructions, printing the +decoded instructions in text form on the output stream. The driver for this +kernel is installed with \fBgkp_install\fR, setting the output file and +verbose output flag in the process. + +.nh 3 +Example + + To illustrate the use of GKI as well as the output of the GKI decoding +kernel, consider the simple \fBgplotv\fR style plot of the following function: + + y = x ** 2 + +over the range + + x = 1 to 5, y = 1 to 25 + +The decoded GKI metacode produced by GIO to graph this function is +shown below. The "verbose" mode of output (shown) lists the values +of the data points in the polyline, etc. output functions. If verbose +output is disabled only the statistics of the output polylines +(computed by the decoder) will be printed. All coordinates are printed +in NDC units. The redundant points appearing in the output metacode +are expected to be filtered out by the kernel, which should not plot +points separated by less than the device resolution in NDC units. + + +.tp 4 +.nf +open_workstation 'vt640', mode=new_file +set_wcs nwords=352 + 1 1. 5. 1. 25. 0.19 0.81 0.33 0.96 0 0 1 +set_polyline ltype=1, lwidth=2.00, color=1 +polyline np=3, xmin=0.19,xmax=0.19,xavg=0.19, ymin=0.33,ymax=0.37,yavg=0.34 + 0.188 0.334 0.188 0.334 0.188 0.367 +set_text up=90, path=right, hjustify=center, vjustify=top, font=roman, + size=1.00, spacing=0.00, color=1, quality=normal +text 0.19, 0.31, '1' +polyline np=15, xmin=0.19,xmax=0.34,xavg=0.27, ymin=0.33,ymax=0.37,yavg=0.34 + 0.188 0.334 0.219 0.334 0.219 0.350 0.219 0.334 0.250 0.334 + 0.250 0.350 0.250 0.334 0.281 0.334 0.281 0.350 0.281 0.334 + 0.313 0.334 0.313 0.350 0.313 0.334 0.344 0.334 0.344 0.367 +text 0.34, 0.31, '2' +polyline np=15, xmin=0.34,xmax=0.50,xavg=0.43, ymin=0.33,ymax=0.37,yavg=0.34 + 0.344 0.334 0.375 0.334 0.375 0.350 0.375 0.334 0.406 0.334 + 0.406 0.350 0.406 0.334 0.437 0.334 0.437 0.350 0.437 0.334 + 0.469 0.334 0.469 0.350 0.469 0.334 0.500 0.334 0.500 0.367 +text 0.50, 0.31, '3' +polyline np=15, xmin=0.50,xmax=0.66,xavg=0.58, ymin=0.33,ymax=0.37,yavg=0.34 + 0.500 0.334 0.531 0.334 0.531 0.350 0.531 0.334 0.562 0.334 + 0.562 0.350 0.562 0.334 0.593 0.334 0.593 0.350 0.593 0.334 + 0.625 0.334 0.625 0.350 0.625 0.334 0.656 0.334 0.656 0.367 +text 0.66, 0.31, '4' +polyline np=15, xmin=0.66,xmax=0.81,xavg=0.74, ymin=0.33,ymax=0.37,yavg=0.34 + 0.656 0.334 0.687 0.334 0.687 0.350 0.687 0.334 0.718 0.334 + 0.718 0.350 0.718 0.334 0.750 0.334 0.750 0.350 0.750 0.334 + 0.781 0.334 0.781 0.350 0.781 0.334 0.812 0.334 0.812 0.367 +text 0.81, 0.31, '5' +polyline np=2, xmin=0.81,xmax=0.81,xavg=0.81, ymin=0.33,ymax=0.33,yavg=0.33 + 0.812 0.334 0.812 0.334 +polyline np=77, xmin=0.78,xmax=0.81,xavg=0.81, ymin=0.33,ymax=0.96,yavg=0.65 + 0.812 0.334 0.812 0.334 0.796 0.334 0.812 0.334 0.812 0.360 + 0.796 0.360 0.812 0.360 0.812 0.386 0.796 0.386 0.812 0.386 + 0.812 0.412 0.796 0.412 0.812 0.412 0.812 0.438 0.779 0.438 + 0.812 0.438 0.812 0.464 0.795 0.464 0.812 0.464 0.812 0.490 + 0.795 0.490 0.812 0.490 0.812 0.516 0.795 0.516 0.812 0.516 + 0.812 0.542 0.795 0.542 0.812 0.542 0.812 0.568 0.779 0.568 + 0.812 0.568 0.812 0.594 0.795 0.594 0.812 0.594 0.812 0.620 + 0.795 0.620 0.812 0.620 0.812 0.646 0.795 0.646 0.812 0.646 + 0.812 0.672 0.795 0.672 0.812 0.672 0.812 0.698 0.779 0.698 + 0.812 0.698 0.812 0.724 0.795 0.724 0.812 0.724 0.812 0.750 + 0.795 0.750 0.812 0.750 0.812 0.776 0.795 0.776 0.812 0.776 + 0.812 0.802 0.795 0.802 0.812 0.802 0.812 0.828 0.778 0.828 + 0.812 0.828 0.812 0.854 0.795 0.854 0.812 0.854 0.812 0.880 + 0.795 0.880 0.812 0.880 0.812 0.906 0.795 0.906 0.812 0.906 + 0.812 0.932 0.795 0.932 0.812 0.932 0.812 0.958 0.778 0.958 + 0.812 0.958 0.812 0.958 +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.33,ymax=0.44,yavg=0.38 + 0.188 0.334 0.188 0.334 0.204 0.334 0.188 0.334 0.188 0.360 + 0.204 0.360 0.188 0.360 0.188 0.386 0.204 0.386 0.188 0.386 + 0.188 0.412 0.204 0.412 0.188 0.412 0.188 0.438 0.221 0.438 +set_text up=90, path=right, hjustify=right, vjustify=center, font=roman, + size=1.00, spacing=0.00, color=1, quality=normal +text 0.19, 0.44, '5' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.44,ymax=0.57,yavg=0.51 + 0.188 0.438 0.188 0.464 0.204 0.464 0.188 0.464 0.188 0.490 + 0.204 0.490 0.188 0.490 0.188 0.516 0.204 0.516 0.188 0.516 + 0.188 0.542 0.204 0.542 0.188 0.542 0.188 0.568 0.221 0.568 +text 0.19, 0.57, '10' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.57,ymax=0.70,yavg=0.64 + 0.188 0.568 0.188 0.594 0.204 0.594 0.188 0.594 0.188 0.620 + 0.204 0.620 0.188 0.620 0.188 0.646 0.204 0.646 0.188 0.646 + 0.188 0.672 0.204 0.672 0.188 0.672 0.188 0.698 0.221 0.698 +text 0.19, 0.70, '15' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.70,ymax=0.83,yavg=0.77 + 0.188 0.698 0.188 0.724 0.204 0.724 0.188 0.724 0.188 0.750 + 0.204 0.750 0.188 0.750 0.188 0.776 0.204 0.776 0.188 0.776 + 0.188 0.802 0.204 0.802 0.188 0.802 0.188 0.828 0.221 0.828 +text 0.19, 0.83, '20' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.83,ymax=0.96,yavg=0.90 + 0.188 0.828 0.188 0.854 0.204 0.854 0.188 0.854 0.188 0.880 + 0.204 0.880 0.188 0.880 0.188 0.906 0.204 0.906 0.188 0.906 + 0.188 0.932 0.204 0.932 0.188 0.932 0.188 0.958 0.221 0.958 +text 0.19, 0.96, '25' +polyline np=2, xmin=0.19,xmax=0.19,xavg=0.19, ymin=0.96,ymax=0.96,yavg=0.96 + 0.188 0.958 0.188 0.958 +polyline np=65, xmin=0.19,xmax=0.81,xavg=0.50, ymin=0.92,ymax=0.96,yavg=0.95 + 0.188 0.958 0.188 0.958 0.188 0.925 0.188 0.958 0.219 0.958 + 0.219 0.942 0.219 0.958 0.250 0.958 0.250 0.942 0.250 0.958 + 0.281 0.958 0.281 0.941 0.281 0.958 0.313 0.958 0.313 0.941 + 0.313 0.958 0.344 0.958 0.344 0.925 0.344 0.958 0.375 0.958 + 0.375 0.941 0.375 0.958 0.406 0.958 0.406 0.941 0.406 0.958 + 0.437 0.958 0.437 0.941 0.437 0.958 0.469 0.958 0.469 0.941 + 0.469 0.958 0.500 0.958 0.500 0.925 0.500 0.958 0.531 0.958 + 0.531 0.941 0.531 0.958 0.562 0.958 0.562 0.941 0.562 0.958 + 0.593 0.958 0.593 0.941 0.593 0.958 0.625 0.958 0.625 0.941 + 0.625 0.958 0.656 0.958 0.656 0.924 0.656 0.958 0.687 0.958 + 0.687 0.941 0.687 0.958 0.718 0.958 0.718 0.941 0.718 0.958 + 0.750 0.958 0.750 0.941 0.750 0.958 0.781 0.958 0.781 0.941 + 0.781 0.958 0.812 0.958 0.812 0.924 0.812 0.958 0.812 0.958 +set_text up=90, path=right, hjustify=center, vjustify=bottom, font=roman, + size=1.00, spacing=0.00, color=1, quality=normal +text 0.50, 0.96, 'title' +set_polyline ltype=1, lwidth=1.00, color=1 +polyline np=5, xmin=0.19,xmax=0.69,xavg=0.44, ymin=0.33,ymax=0.96,yavg=0.59 + 0.188 0.334 0.313 0.412 0.438 0.542 0.562 0.724 0.687 0.958 +flush +close_workstation 'vt640' +.fi + + +.nh 2 +Graphics Kernel Parameters + + The translation from GKI codes to device codes should ideally be +parameterized to permit variable device resolution, font substitution, +and so on at translation time. In general this is best handled by +spooling the metacode and later processing it via an explicit call to +a metacode translator program, using CL parameters to control the translation. +Some control over translation may also be achieved by modifying the +\fBgraphcap\fR entry for a device, provided the graphics kernel uses +the graphics capability database. + +One of the most useful translation time parameters is the device resolution. +On some devices, e.g. pen plotters, it is necessary to be able to change +the device resolution at translation time to permit plotting of large vectors +without loss of resolution. Changing the device resolution is also a valuable +technique for speeding up graphics when working remotely via a modem. + +.nh +GKS Emulation + + The basic graphics primitives provided by GIO (polyline, polymarker, etc.) +are functionally identical to those provided by GKS (the Graphics Kernel +System). The basic drawing primitives of GKS are therefore easily emulated +using GIO. A subset of the Fortran binding of GKS has already been emulated, +sufficient to run the NCAR utilities recently converted by NCAR for use with +GKS. In principle it should be possible to expand the GKS emulation to a +full level 0b or 1b interface, although we have no plans to do so at present. diff --git a/sys/gio/elogd.x b/sys/gio/elogd.x new file mode 100644 index 00000000..b910a80c --- /dev/null +++ b/sys/gio/elogd.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ELOGD -- Extended range log function. Logarithmic scaling function for +# negative or partially negative data. The function is piecewise, continuous, +# monotonic, reasonably smooth, and most importantly, is defined for all x. +# +# 10.0 < X y = log(x) +# -10.0 <= X <= 10.0 y = x / 10.0 +# X < -10.0 y = -log(-x) +# +# Axes scaled with this function should have ticks labelled, e.g., 10**3, +# 10**2, 10**1, 0, -10**1, -10**2, -10**3. The corresponding ticks for +# the normal log function would have values like 10**-2 rather than -10**2, +# hence it is not difficult to distinguish between the two functions. + +double procedure elogd (x) + +double x + +begin + if (x > 10.0D0) + return (log10 (x)) + else if (x >= -10.0D0) + return (x / 10.0D0) + else + return (-log10 (-x)) +end diff --git a/sys/gio/elogr.x b/sys/gio/elogr.x new file mode 100644 index 00000000..3dfb26ee --- /dev/null +++ b/sys/gio/elogr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ELOGR -- Extended range log function. Logarithmic scaling function for +# negative or partially negative data. The function is piecewise, continuous, +# monotonic, reasonably smooth, and most importantly, is defined for all x. +# +# 10.0 < X y = log(x) +# -10.0 <= X <= 10.0 y = x / 10.0 +# X < -10.0 y = -log(-x) +# +# Axes scaled with this function should have ticks labelled, e.g., 10**3, +# 10**2, 10**1, 0, -10**1, -10**2, -10**3. The corresponding ticks for +# the normal log function would have values like 10**-2 rather than -10**2, +# hence it is not difficult to distinguish between the two functions. + +real procedure elogr (x) + +real x + +begin + if (x > 10.0) + return (log10 (x)) + else if (x >= -10.0) + return (x / 10.0) + else + return (-log10 (-x)) +end diff --git a/sys/gio/fonts/README b/sys/gio/fonts/README new file mode 100644 index 00000000..8b657b76 --- /dev/null +++ b/sys/gio/fonts/README @@ -0,0 +1,42 @@ + +FONT Generation Utilities (August 1997) +---------------------------------------- + +This directory contains utilities for building font tables for the GIO +system executables. For reference we include here the font tables for +the standard and greek fonts currently installed in the system: + + font.com standard text font (Roman) + greek.com greek character font + +These table were built from the Hershey stroke data using the following +files: + + mkfont.c task to build font table + hershey.dat Hershey stroke data table + +Once compiled the MKFONT task can be used to build the table with a command +such as + + % mkfont < romant.txt > font.com + +Note that by default the tables are created with a "chr" prefix for the +index, width, and character tables in the .com file. When building a new +Greek or other symbolic font these should be changed appropriately. + + +Addition input files for fonts supplied here include: + + futural.txt Futura (light) + futuram.txt Futura (medium) + gotheng.txt Gothic (english) + gothger.txt Gothic (german) + gothita.txt Gothic (italian) + greekc.txt Greek (complex) (current greek.com) + greeks.txt Greek (simple) + math.txt Math symbols + meteor.txt Meteorological symbols + romans.txt Roman (simple) + romant.txt Roman (Times) (current font.com) + scripts.txt Script text font + timesr.txt Times-Roman diff --git a/sys/gio/fonts/font.com b/sys/gio/fonts/font.com new file mode 100644 index 00000000..c26af8d6 --- /dev/null +++ b/sys/gio/fonts/font.com @@ -0,0 +1,746 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short chridx[97] # character index in chrtab +short chrwid[97] # character width table +short chrtab[3363] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (chridx(i), i=001,005) / 1, 3, 32, 49, 58/ +data (chridx(i), i=006,010) / 110, 140, 207, 228, 253/ +data (chridx(i), i=011,015) / 278, 309, 322, 343, 350/ +data (chridx(i), i=016,020) / 365, 372, 418, 438, 494/ +data (chridx(i), i=021,025) / 563, 583, 632, 696, 733/ +data (chridx(i), i=026,030) / 803, 867, 896, 931, 935/ +data (chridx(i), i=031,035) / 948, 952, 999, 1052, 1077/ +data (chridx(i), i=036,040) / 1139, 1174, 1223, 1281, 1330/ +data (chridx(i), i=041,045) / 1381, 1436, 1463, 1500, 1547/ +data (chridx(i), i=046,050) / 1583, 1626, 1653, 1703, 1748/ +data (chridx(i), i=051,055) / 1818, 1881, 1923, 1962, 1997/ +data (chridx(i), i=056,060) / 2021, 2060, 2097, 2131, 2160/ +data (chridx(i), i=061,065) / 2169, 2172, 2181, 2190, 2193/ +data (chridx(i), i=066,070) / 2214, 2263, 2303, 2335, 2378/ +data (chridx(i), i=071,075) / 2415, 2447, 2527, 2575, 2606/ +data (chridx(i), i=076,080) / 2640, 2682, 2704, 2778, 2826/ +data (chridx(i), i=081,085) / 2868, 2916, 2961, 2994, 3033/ +data (chridx(i), i=086,090) / 3052, 3086, 3108, 3140, 3173/ +data (chridx(i), i=091,095) / 3204, 3233, 3271, 3274, 3312/ +data (chridx(i), i=096,096) / 3335/ + + +# Width data. + +data (chrwid(i), i=001,005) / 21, 16, 23, 26, 25/ +data (chrwid(i), i=006,010) / 29, 31, 16, 19, 19/ +data (chrwid(i), i=011,015) / 21, 30, 16, 30, 16/ +data (chrwid(i), i=016,020) / 28, 25, 25, 25, 25/ +data (chrwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (chrwid(i), i=026,030) / 25, 16, 16, 29, 30/ +data (chrwid(i), i=031,035) / 29, 24, 32, 25, 27/ +data (chrwid(i), i=036,040) / 26, 27, 26, 25, 28/ +data (chrwid(i), i=041,045) / 29, 17, 21, 27, 23/ +data (chrwid(i), i=046,050) / 31, 29, 27, 27, 27/ +data (chrwid(i), i=051,055) / 27, 25, 25, 29, 25/ +data (chrwid(i), i=056,060) / 29, 25, 27, 25, 19/ +data (chrwid(i), i=061,065) / 19, 19, 21, 21, 16/ +data (chrwid(i), i=066,070) / 25, 26, 24, 26, 24/ +data (chrwid(i), i=071,075) / 19, 24, 28, 17, 18/ +data (chrwid(i), i=076,080) / 27, 17, 32, 28, 25/ +data (chrwid(i), i=081,085) / 26, 25, 22, 22, 20/ +data (chrwid(i), i=086,090) / 28, 23, 29, 25, 24/ +data (chrwid(i), i=091,095) / 23, 19, 13, 19, 29/ +data (chrwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (chrtab(i), i=0001,0005) / 35, 0, 220, 4251, 4249/ +data (chrtab(i), i=0006,0010) / 4305, 220, 4302, 4366, 220/ +data (chrtab(i), i=0011,0015) / 4380, 4366, 284, 4443, 4441/ +data (chrtab(i), i=0016,0020) / 4369, 202, 4233, 4232, 4295/ +data (chrtab(i), i=0021,0025) / 4359, 4424, 4425, 4362, 4298/ +data (chrtab(i), i=0026,0030) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0031,0035) / 0, 220, 4251, 4245, 219/ +data (chrtab(i), i=0036,0040) / 4245, 220, 4379, 4245, 796/ +data (chrtab(i), i=0041,0045) / 4827, 4821, 795, 4821, 796/ +data (chrtab(i), i=0046,0050) / 4955, 4821, 0, 604, 4224/ +data (chrtab(i), i=0051,0055) / 988, 4608, 145, 5137, 75/ +data (chrtab(i), i=0056,0060) / 5067, 0, 416, 4483, 672/ +data (chrtab(i), i=0061,0065) / 4739, 919, 5016, 4952, 4950/ +data (chrtab(i), i=0066,0070) / 5078, 5080, 5018, 4955, 4764/ +data (chrtab(i), i=0071,0075) / 4508, 4315, 4185, 4182, 4244/ +data (chrtab(i), i=0076,0080) / 4434, 4816, 4943, 5005, 5002/ +data (chrtab(i), i=0081,0085) / 4936, 150, 4308, 4435, 4817/ +data (chrtab(i), i=0086,0090) / 4944, 5006, 219, 4249, 4247/ +data (chrtab(i), i=0091,0095) / 4309, 4436, 4818, 5008, 5070/ +data (chrtab(i), i=0096,0100) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0101,0105) / 4296, 4233, 4171, 4173, 4301/ +data (chrtab(i), i=0106,0110) / 4299, 4235, 4236, 0, 1244/ +data (chrtab(i), i=0111,0115) / 4167, 412, 4634, 4632, 4566/ +data (chrtab(i), i=0116,0120) / 4437, 4309, 4183, 4185, 4251/ +data (chrtab(i), i=0121,0125) / 4380, 4508, 4635, 4826, 5018/ +data (chrtab(i), i=0126,0130) / 5211, 5340, 974, 4941, 4875/ +data (chrtab(i), i=0131,0135) / 4873, 4999, 5127, 5256, 5322/ +data (chrtab(i), i=0136,0140) / 5324, 5198, 5070, 0, 1299/ +data (chrtab(i), i=0141,0145) / 5396, 5332, 5330, 5458, 5460/ +data (chrtab(i), i=0146,0150) / 5397, 5333, 5268, 5202, 5069/ +data (chrtab(i), i=0151,0155) / 4938, 4808, 4679, 4423, 4296/ +data (chrtab(i), i=0156,0160) / 4234, 4237, 4303, 4691, 4821/ +data (chrtab(i), i=0161,0165) / 4887, 4889, 4827, 4700, 4571/ +data (chrtab(i), i=0166,0170) / 4505, 4502, 4563, 4688, 4939/ +data (chrtab(i), i=0171,0175) / 5128, 5255, 5383, 5449, 5450/ +data (chrtab(i), i=0176,0180) / 264, 4298, 4301, 4367, 4432/ +data (chrtab(i), i=0181,0185) / 725, 4889, 791, 4827, 475/ +data (chrtab(i), i=0186,0190) / 4503, 468, 4689, 4940, 5129/ +data (chrtab(i), i=0191,0195) / 5256, 455, 4424, 4362, 4365/ +data (chrtab(i), i=0196,0200) / 4431, 4691, 409, 4565, 4753/ +data (chrtab(i), i=0201,0205) / 5004, 5193, 5320, 5384, 5449/ +data (chrtab(i), i=0206,0210) / 0, 346, 4377, 4313, 4250/ +data (chrtab(i), i=0211,0215) / 4251, 4316, 4380, 4443, 4440/ +data (chrtab(i), i=0216,0220) / 4374, 4245, 219, 4314, 4378/ +data (chrtab(i), i=0221,0225) / 4379, 4315, 281, 4440, 346/ +data (chrtab(i), i=0226,0230) / 4374, 0, 544, 4510, 4379/ +data (chrtab(i), i=0231,0235) / 4247, 4178, 4174, 4233, 4357/ +data (chrtab(i), i=0236,0240) / 4482, 4608, 282, 4311, 4243/ +data (chrtab(i), i=0241,0245) / 4237, 4297, 4358, 414, 4444/ +data (chrtab(i), i=0246,0250) / 4377, 4307, 4301, 4359, 4420/ +data (chrtab(i), i=0251,0255) / 4482, 0, 160, 4382, 4507/ +data (chrtab(i), i=0256,0260) / 4631, 4690, 4686, 4617, 4485/ +data (chrtab(i), i=0261,0265) / 4354, 4224, 410, 4567, 4627/ +data (chrtab(i), i=0266,0270) / 4621, 4553, 4486, 286, 4444/ +data (chrtab(i), i=0271,0275) / 4505, 4563, 4557, 4487, 4420/ +data (chrtab(i), i=0276,0280) / 4354, 0, 412, 4443, 4561/ +data (chrtab(i), i=0281,0285) / 4496, 412, 4496, 412, 4571/ +data (chrtab(i), i=0286,0290) / 4433, 4496, 89, 4249, 4755/ +data (chrtab(i), i=0291,0295) / 4819, 89, 4819, 89, 4184/ +data (chrtab(i), i=0296,0300) / 4820, 4819, 729, 4761, 4243/ +data (chrtab(i), i=0301,0305) / 4179, 729, 4179, 729, 4824/ +data (chrtab(i), i=0306,0310) / 4180, 4179, 0, 665, 4744/ +data (chrtab(i), i=0311,0315) / 4808, 665, 4825, 4808, 145/ +data (chrtab(i), i=0316,0320) / 5329, 5328, 145, 4240, 5328/ +data (chrtab(i), i=0321,0325) / 0, 328, 4359, 4295, 4232/ +data (chrtab(i), i=0326,0330) / 4233, 4298, 4362, 4425, 4422/ +data (chrtab(i), i=0331,0335) / 4356, 4227, 201, 4296, 4360/ +data (chrtab(i), i=0336,0340) / 4361, 4297, 263, 4422, 328/ +data (chrtab(i), i=0341,0345) / 4356, 0, 145, 5329, 5328/ +data (chrtab(i), i=0346,0350) / 145, 4240, 5328, 0, 202/ +data (chrtab(i), i=0351,0355) / 4233, 4232, 4295, 4359, 4424/ +data (chrtab(i), i=0356,0360) / 4425, 4362, 4298, 201, 4296/ +data (chrtab(i), i=0361,0365) / 4360, 4361, 4297, 0, 1184/ +data (chrtab(i), i=0366,0370) / 4096, 4160, 1184, 5344, 4160/ +data (chrtab(i), i=0371,0375) / 0, 476, 4379, 4248, 4179/ +data (chrtab(i), i=0376,0380) / 4176, 4235, 4360, 4551, 4679/ +data (chrtab(i), i=0381,0385) / 4872, 5003, 5072, 5075, 5016/ +data (chrtab(i), i=0386,0390) / 4891, 4700, 4572, 282, 4312/ +data (chrtab(i), i=0391,0395) / 4244, 4239, 4299, 4361, 777/ +data (chrtab(i), i=0396,0400) / 4939, 5007, 5012, 4952, 4890/ +data (chrtab(i), i=0401,0405) / 476, 4443, 4377, 4308, 4303/ +data (chrtab(i), i=0406,0410) / 4362, 4424, 4551, 583, 4808/ +data (chrtab(i), i=0411,0415) / 4874, 4943, 4948, 4889, 4827/ +data (chrtab(i), i=0416,0420) / 4700, 0, 474, 4551, 538/ +data (chrtab(i), i=0421,0425) / 4616, 604, 4679, 604, 4505/ +data (chrtab(i), i=0426,0430) / 4376, 199, 4935, 456, 4423/ +data (chrtab(i), i=0431,0435) / 457, 4487, 585, 4743, 584/ +data (chrtab(i), i=0436,0440) / 4807, 0, 152, 4247, 4311/ +data (chrtab(i), i=0441,0445) / 4312, 4248, 153, 4313, 4376/ +data (chrtab(i), i=0446,0450) / 4375, 4310, 4246, 4183, 4184/ +data (chrtab(i), i=0451,0455) / 4250, 4315, 4508, 4764, 4955/ +data (chrtab(i), i=0456,0460) / 5018, 5080, 5078, 5012, 4818/ +data (chrtab(i), i=0461,0465) / 4496, 4367, 4237, 4170, 4167/ +data (chrtab(i), i=0466,0470) / 858, 5016, 5014, 4948, 668/ +data (chrtab(i), i=0471,0475) / 4891, 4952, 4950, 4884, 4754/ +data (chrtab(i), i=0476,0480) / 4496, 73, 4234, 4362, 4681/ +data (chrtab(i), i=0481,0485) / 4937, 5066, 266, 4680, 4936/ +data (chrtab(i), i=0486,0490) / 5001, 266, 4679, 4935, 5000/ +data (chrtab(i), i=0491,0495) / 5066, 5068, 0, 152, 4247/ +data (chrtab(i), i=0496,0500) / 4311, 4312, 4248, 153, 4313/ +data (chrtab(i), i=0501,0505) / 4376, 4375, 4310, 4246, 4183/ +data (chrtab(i), i=0506,0510) / 4184, 4250, 4315, 4508, 4764/ +data (chrtab(i), i=0511,0515) / 4955, 5017, 5014, 4948, 4755/ +data (chrtab(i), i=0516,0520) / 795, 4953, 4950, 4884, 604/ +data (chrtab(i), i=0521,0525) / 4827, 4889, 4886, 4820, 4691/ +data (chrtab(i), i=0526,0530) / 467, 4755, 4882, 5008, 5070/ +data (chrtab(i), i=0531,0535) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0536,0540) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0541,0545) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0546,0550) / 848, 5006, 5003, 4937, 595/ +data (chrtab(i), i=0551,0555) / 4818, 4881, 4942, 4939, 4872/ +data (chrtab(i), i=0556,0560) / 4743, 140, 4235, 4299, 4300/ +data (chrtab(i), i=0561,0565) / 4236, 0, 601, 4679, 666/ +data (chrtab(i), i=0566,0570) / 4744, 732, 4807, 732, 4109/ +data (chrtab(i), i=0571,0575) / 5133, 391, 4999, 584, 4551/ +data (chrtab(i), i=0576,0580) / 585, 4615, 713, 4871, 712/ +data (chrtab(i), i=0581,0585) / 4935, 0, 220, 4178, 4308/ +data (chrtab(i), i=0586,0590) / 4501, 4693, 4884, 5010, 5071/ +data (chrtab(i), i=0591,0595) / 5069, 5002, 4872, 4679, 4487/ +data (chrtab(i), i=0596,0600) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0601,0605) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0606,0610) / 850, 5008, 5004, 4938, 597/ +data (chrtab(i), i=0611,0615) / 4820, 4883, 4944, 4940, 4873/ +data (chrtab(i), i=0616,0620) / 4808, 4679, 140, 4235, 4299/ +data (chrtab(i), i=0621,0625) / 4300, 4236, 220, 4956, 219/ +data (chrtab(i), i=0626,0630) / 4827, 218, 4570, 4827, 4956/ +data (chrtab(i), i=0631,0635) / 0, 793, 4888, 4952, 4953/ +data (chrtab(i), i=0636,0640) / 4889, 858, 4890, 4825, 4824/ +data (chrtab(i), i=0641,0645) / 4887, 4951, 5016, 5017, 4955/ +data (chrtab(i), i=0646,0650) / 4828, 4636, 4443, 4313, 4247/ +data (chrtab(i), i=0651,0655) / 4179, 4173, 4234, 4360, 4551/ +data (chrtab(i), i=0656,0660) / 4679, 4872, 5002, 5069, 5070/ +data (chrtab(i), i=0661,0665) / 5009, 4883, 4692, 4564, 4435/ +data (chrtab(i), i=0666,0670) / 4370, 4304, 281, 4311, 4243/ +data (chrtab(i), i=0671,0675) / 4237, 4298, 4361, 842, 5004/ +data (chrtab(i), i=0676,0680) / 5007, 4945, 540, 4507, 4442/ +data (chrtab(i), i=0681,0685) / 4376, 4308, 4301, 4362, 4424/ +data (chrtab(i), i=0686,0690) / 4551, 583, 4808, 4873, 4940/ +data (chrtab(i), i=0691,0695) / 4943, 4882, 4819, 4692, 0/ +data (chrtab(i), i=0696,0700) / 92, 4182, 988, 5081, 5014/ +data (chrtab(i), i=0701,0705) / 4753, 4687, 4619, 4615, 592/ +data (chrtab(i), i=0706,0710) / 4622, 4555, 4551, 918, 4689/ +data (chrtab(i), i=0711,0715) / 4558, 4491, 4487, 4615, 88/ +data (chrtab(i), i=0716,0720) / 4250, 4380, 4508, 4825, 4953/ +data (chrtab(i), i=0721,0725) / 5018, 5084, 218, 4379, 4507/ +data (chrtab(i), i=0726,0730) / 4634, 88, 4249, 4378, 4506/ +data (chrtab(i), i=0731,0735) / 4825, 0, 412, 4315, 4249/ +data (chrtab(i), i=0736,0740) / 4246, 4308, 4499, 4755, 4948/ +data (chrtab(i), i=0741,0745) / 5014, 5017, 4955, 4764, 4508/ +data (chrtab(i), i=0746,0750) / 283, 4313, 4310, 4372, 788/ +data (chrtab(i), i=0751,0755) / 4950, 4953, 4891, 412, 4443/ +data (chrtab(i), i=0756,0760) / 4377, 4374, 4436, 4499, 659/ +data (chrtab(i), i=0761,0765) / 4820, 4886, 4889, 4827, 4764/ +data (chrtab(i), i=0766,0770) / 403, 4306, 4241, 4175, 4171/ +data (chrtab(i), i=0771,0775) / 4233, 4296, 4487, 4743, 4936/ +data (chrtab(i), i=0776,0780) / 5001, 5067, 5071, 5009, 4946/ +data (chrtab(i), i=0781,0785) / 4755, 209, 4239, 4235, 4297/ +data (chrtab(i), i=0786,0790) / 841, 5003, 5007, 4945, 403/ +data (chrtab(i), i=0791,0795) / 4370, 4303, 4299, 4360, 4487/ +data (chrtab(i), i=0796,0800) / 647, 4872, 4939, 4943, 4882/ +data (chrtab(i), i=0801,0805) / 4755, 0, 203, 4298, 4362/ +data (chrtab(i), i=0806,0810) / 4363, 4299, 851, 4881, 4816/ +data (chrtab(i), i=0811,0815) / 4687, 4559, 4368, 4242, 4181/ +data (chrtab(i), i=0816,0820) / 4182, 4249, 4379, 4572, 4700/ +data (chrtab(i), i=0821,0825) / 4891, 5017, 5078, 5072, 5004/ +data (chrtab(i), i=0826,0830) / 4938, 4808, 4615, 4423, 4296/ +data (chrtab(i), i=0831,0835) / 4234, 4235, 4300, 4364, 4427/ +data (chrtab(i), i=0836,0840) / 4426, 4361, 4297, 210, 4244/ +data (chrtab(i), i=0841,0845) / 4247, 4313, 794, 4953, 5014/ +data (chrtab(i), i=0846,0850) / 5008, 4940, 4874, 463, 4432/ +data (chrtab(i), i=0851,0855) / 4369, 4308, 4311, 4378, 4443/ +data (chrtab(i), i=0856,0860) / 4572, 604, 4827, 4889, 4950/ +data (chrtab(i), i=0861,0865) / 4943, 4875, 4809, 4744, 4615/ +data (chrtab(i), i=0866,0870) / 0, 213, 4244, 4243, 4306/ +data (chrtab(i), i=0871,0875) / 4370, 4435, 4436, 4373, 4309/ +data (chrtab(i), i=0876,0880) / 212, 4307, 4371, 4372, 4308/ +data (chrtab(i), i=0881,0885) / 202, 4233, 4232, 4295, 4359/ +data (chrtab(i), i=0886,0890) / 4424, 4425, 4362, 4298, 201/ +data (chrtab(i), i=0891,0895) / 4296, 4360, 4361, 4297, 0/ +data (chrtab(i), i=0896,0900) / 213, 4244, 4243, 4306, 4370/ +data (chrtab(i), i=0901,0905) / 4435, 4436, 4373, 4309, 212/ +data (chrtab(i), i=0906,0910) / 4307, 4371, 4372, 4308, 328/ +data (chrtab(i), i=0911,0915) / 4359, 4295, 4232, 4233, 4298/ +data (chrtab(i), i=0916,0920) / 4362, 4425, 4422, 4356, 4227/ +data (chrtab(i), i=0921,0925) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0926,0930) / 263, 4422, 328, 4356, 0/ +data (chrtab(i), i=0931,0935) / 1177, 4240, 5255, 0, 149/ +data (chrtab(i), i=0936,0940) / 5333, 5332, 149, 4244, 5332/ +data (chrtab(i), i=0941,0945) / 141, 5325, 5324, 141, 4236/ +data (chrtab(i), i=0946,0950) / 5324, 0, 153, 5264, 4231/ +data (chrtab(i), i=0951,0955) / 0, 151, 4248, 4312, 4310/ +data (chrtab(i), i=0956,0960) / 4182, 4184, 4250, 4315, 4444/ +data (chrtab(i), i=0961,0965) / 4700, 4891, 4954, 5016, 5014/ +data (chrtab(i), i=0966,0970) / 4948, 4883, 4625, 794, 4953/ +data (chrtab(i), i=0971,0975) / 4949, 4884, 604, 4827, 4889/ +data (chrtab(i), i=0976,0980) / 4885, 4819, 4754, 465, 4558/ +data (chrtab(i), i=0981,0985) / 4622, 4625, 4561, 458, 4489/ +data (chrtab(i), i=0986,0990) / 4488, 4551, 4615, 4680, 4681/ +data (chrtab(i), i=0991,0995) / 4618, 4554, 457, 4552, 4616/ +data (chrtab(i), i=0996,1000) / 4617, 4553, 0, 1044, 5078/ +data (chrtab(i), i=1001,1005) / 4951, 4759, 4630, 4565, 4498/ +data (chrtab(i), i=1006,1010) / 4495, 4557, 4684, 4876, 5005/ +data (chrtab(i), i=1011,1015) / 5071, 663, 4629, 4562, 4559/ +data (chrtab(i), i=1016,1020) / 4621, 4684, 1047, 5071, 5069/ +data (chrtab(i), i=1021,1025) / 5196, 5324, 5454, 5521, 5523/ +data (chrtab(i), i=1026,1030) / 5462, 5400, 5274, 5147, 4956/ +data (chrtab(i), i=1031,1035) / 4764, 4571, 4442, 4312, 4246/ +data (chrtab(i), i=1036,1040) / 4179, 4176, 4237, 4299, 4425/ +data (chrtab(i), i=1041,1045) / 4552, 4743, 4935, 5128, 5257/ +data (chrtab(i), i=1046,1050) / 5322, 1111, 5135, 5133, 5196/ +data (chrtab(i), i=1051,1055) / 0, 540, 4168, 473, 4935/ +data (chrtab(i), i=1056,1060) / 537, 4999, 540, 5063, 205/ +data (chrtab(i), i=1061,1065) / 4877, 7, 4423, 647, 5191/ +data (chrtab(i), i=1066,1070) / 72, 4103, 72, 4295, 840/ +data (chrtab(i), i=1071,1075) / 4807, 841, 4871, 905, 5127/ +data (chrtab(i), i=1076,1080) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1081,1085) / 348, 4423, 28, 4892, 5083/ +data (chrtab(i), i=1086,1090) / 5146, 5208, 5206, 5140, 5075/ +data (chrtab(i), i=1091,1095) / 4882, 986, 5144, 5142, 5076/ +data (chrtab(i), i=1096,1100) / 796, 5019, 5081, 5077, 5011/ +data (chrtab(i), i=1101,1105) / 4882, 338, 4882, 5073, 5136/ +data (chrtab(i), i=1106,1110) / 5198, 5195, 5129, 5064, 4871/ +data (chrtab(i), i=1111,1115) / 4103, 976, 5134, 5131, 5065/ +data (chrtab(i), i=1116,1120) / 786, 5009, 5071, 5066, 5000/ +data (chrtab(i), i=1121,1125) / 4871, 92, 4315, 156, 4314/ +data (chrtab(i), i=1126,1130) / 412, 4442, 476, 4443, 200/ +data (chrtab(i), i=1131,1135) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=1136,1140) / 328, 4551, 0, 985, 5148/ +data (chrtab(i), i=1141,1145) / 5142, 5081, 4955, 4828, 4636/ +data (chrtab(i), i=1146,1150) / 4443, 4313, 4247, 4180, 4175/ +data (chrtab(i), i=1151,1155) / 4236, 4298, 4424, 4615, 4807/ +data (chrtab(i), i=1156,1160) / 4936, 5066, 5132, 281, 4311/ +data (chrtab(i), i=1161,1165) / 4244, 4239, 4300, 4362, 540/ +data (chrtab(i), i=1166,1170) / 4507, 4376, 4308, 4303, 4363/ +data (chrtab(i), i=1171,1175) / 4488, 4615, 0, 220, 4295/ +data (chrtab(i), i=1176,1180) / 283, 4360, 348, 4423, 28/ +data (chrtab(i), i=1181,1185) / 4764, 4955, 5081, 5143, 5204/ +data (chrtab(i), i=1186,1190) / 5199, 5132, 5066, 4936, 4743/ +data (chrtab(i), i=1191,1195) / 4103, 921, 5079, 5140, 5135/ +data (chrtab(i), i=1196,1200) / 5068, 5002, 668, 4891, 5016/ +data (chrtab(i), i=1201,1205) / 5076, 5071, 5003, 4872, 4743/ +data (chrtab(i), i=1206,1210) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1211,1215) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1216,1220) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1221,1225) / 4551, 0, 220, 4295, 283/ +data (chrtab(i), i=1226,1230) / 4360, 348, 4423, 28, 5148/ +data (chrtab(i), i=1231,1235) / 5142, 338, 4818, 726, 4814/ +data (chrtab(i), i=1236,1240) / 7, 5127, 5133, 92, 4315/ +data (chrtab(i), i=1241,1245) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1246,1250) / 4443, 732, 5147, 860, 5146/ +data (chrtab(i), i=1251,1255) / 924, 5145, 988, 5142, 726/ +data (chrtab(i), i=1256,1260) / 4754, 4814, 724, 4690, 4816/ +data (chrtab(i), i=1261,1265) / 723, 4562, 4817, 200, 4167/ +data (chrtab(i), i=1266,1270) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1271,1275) / 4551, 711, 5128, 839, 5129/ +data (chrtab(i), i=1276,1280) / 903, 5130, 967, 5133, 0/ +data (chrtab(i), i=1281,1285) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1286,1290) / 4423, 28, 5148, 5142, 338/ +data (chrtab(i), i=1291,1295) / 4818, 726, 4814, 7, 4615/ +data (chrtab(i), i=1296,1300) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1301,1305) / 4442, 476, 4443, 732, 5147/ +data (chrtab(i), i=1306,1310) / 860, 5146, 924, 5145, 988/ +data (chrtab(i), i=1311,1315) / 5142, 726, 4754, 4814, 724/ +data (chrtab(i), i=1316,1320) / 4690, 4816, 723, 4562, 4817/ +data (chrtab(i), i=1321,1325) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1326,1330) / 4487, 328, 4551, 0, 985/ +data (chrtab(i), i=1331,1335) / 5148, 5142, 5081, 4955, 4828/ +data (chrtab(i), i=1336,1340) / 4636, 4443, 4313, 4247, 4180/ +data (chrtab(i), i=1341,1345) / 4175, 4236, 4298, 4424, 4615/ +data (chrtab(i), i=1346,1350) / 4807, 4936, 5064, 5127, 5135/ +data (chrtab(i), i=1351,1355) / 281, 4311, 4244, 4239, 4300/ +data (chrtab(i), i=1356,1360) / 4362, 540, 4507, 4376, 4308/ +data (chrtab(i), i=1361,1365) / 4303, 4363, 4488, 4615, 974/ +data (chrtab(i), i=1366,1370) / 5065, 911, 5001, 4936, 719/ +data (chrtab(i), i=1371,1375) / 5327, 783, 5006, 847, 5005/ +data (chrtab(i), i=1376,1380) / 1103, 5133, 1167, 5134, 0/ +data (chrtab(i), i=1381,1385) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1386,1390) / 4423, 988, 5063, 1051, 5128/ +data (chrtab(i), i=1391,1395) / 1116, 5191, 28, 4636, 796/ +data (chrtab(i), i=1396,1400) / 5404, 338, 5074, 7, 4615/ +data (chrtab(i), i=1401,1405) / 775, 5383, 92, 4315, 156/ +data (chrtab(i), i=1406,1410) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1411,1415) / 860, 5083, 924, 5082, 1180/ +data (chrtab(i), i=1416,1420) / 5210, 1244, 5211, 200, 4167/ +data (chrtab(i), i=1421,1425) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1426,1430) / 4551, 968, 4935, 969, 4999/ +data (chrtab(i), i=1431,1435) / 1097, 5255, 1096, 5319, 0/ +data (chrtab(i), i=1436,1440) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1441,1445) / 4423, 28, 4636, 7, 4615/ +data (chrtab(i), i=1446,1450) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1451,1455) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1456,1460) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1461,1465) / 4551, 0, 476, 4555, 4488/ +data (chrtab(i), i=1466,1470) / 4423, 539, 4619, 4552, 604/ +data (chrtab(i), i=1471,1475) / 4683, 4616, 4423, 4295, 4168/ +data (chrtab(i), i=1476,1480) / 4106, 4108, 4173, 4237, 4300/ +data (chrtab(i), i=1481,1485) / 4299, 4234, 4170, 76, 4171/ +data (chrtab(i), i=1486,1490) / 4235, 4236, 4172, 284, 4892/ +data (chrtab(i), i=1491,1495) / 348, 4571, 412, 4570, 668/ +data (chrtab(i), i=1496,1500) / 4698, 732, 4699, 0, 220/ +data (chrtab(i), i=1501,1505) / 4295, 283, 4360, 348, 4423/ +data (chrtab(i), i=1506,1510) / 1051, 4432, 530, 5063, 594/ +data (chrtab(i), i=1511,1515) / 5127, 596, 5191, 28, 4636/ +data (chrtab(i), i=1516,1520) / 860, 5340, 7, 4615, 775/ +data (chrtab(i), i=1521,1525) / 5319, 92, 4315, 156, 4314/ +data (chrtab(i), i=1526,1530) / 412, 4442, 476, 4443, 988/ +data (chrtab(i), i=1531,1535) / 5147, 1180, 5147, 200, 4167/ +data (chrtab(i), i=1536,1540) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1541,1545) / 4551, 969, 4935, 969, 5255/ +data (chrtab(i), i=1546,1550) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1551,1555) / 348, 4423, 28, 4636, 7/ +data (chrtab(i), i=1556,1560) / 5063, 5069, 92, 4315, 156/ +data (chrtab(i), i=1561,1565) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1566,1570) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1571,1575) / 4487, 328, 4551, 647, 5064/ +data (chrtab(i), i=1576,1580) / 775, 5065, 839, 5066, 903/ +data (chrtab(i), i=1581,1585) / 5069, 0, 220, 4296, 220/ +data (chrtab(i), i=1586,1590) / 4743, 284, 4746, 348, 4810/ +data (chrtab(i), i=1591,1595) / 1116, 4743, 1116, 5191, 1179/ +data (chrtab(i), i=1596,1600) / 5256, 1244, 5319, 28, 4444/ +data (chrtab(i), i=1601,1605) / 1116, 5532, 7, 4487, 903/ +data (chrtab(i), i=1606,1610) / 5511, 92, 4315, 1308, 5338/ +data (chrtab(i), i=1611,1615) / 1372, 5339, 200, 4167, 200/ +data (chrtab(i), i=1616,1620) / 4423, 1096, 5063, 1097, 5127/ +data (chrtab(i), i=1621,1625) / 1225, 5383, 1224, 5447, 0/ +data (chrtab(i), i=1626,1630) / 220, 4296, 220, 5191, 284/ +data (chrtab(i), i=1631,1635) / 5130, 348, 5194, 1115, 5191/ +data (chrtab(i), i=1636,1640) / 28, 4444, 924, 5404, 7/ +data (chrtab(i), i=1641,1645) / 4487, 92, 4315, 988, 5211/ +data (chrtab(i), i=1646,1650) / 1244, 5211, 200, 4167, 200/ +data (chrtab(i), i=1651,1655) / 4423, 0, 540, 4443, 4313/ +data (chrtab(i), i=1656,1660) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1661,1665) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1666,1670) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1671,1675) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1676,1680) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1681,1685) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1686,1690) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1691,1695) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1696,1700) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1701,1705) / 4764, 0, 220, 4295, 283/ +data (chrtab(i), i=1706,1710) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1711,1715) / 5083, 5146, 5208, 5205, 5139/ +data (chrtab(i), i=1716,1720) / 5074, 4881, 4433, 986, 5144/ +data (chrtab(i), i=1721,1725) / 5141, 5075, 796, 5019, 5081/ +data (chrtab(i), i=1726,1730) / 5076, 5010, 4881, 7, 4615/ +data (chrtab(i), i=1731,1735) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1736,1740) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1741,1745) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1746,1750) / 4551, 0, 540, 4443, 4313/ +data (chrtab(i), i=1751,1755) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1756,1760) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1761,1765) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1766,1770) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1771,1775) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1776,1780) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1781,1785) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1786,1790) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1791,1795) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1796,1800) / 4764, 330, 4492, 4621, 4685/ +data (chrtab(i), i=1801,1805) / 4812, 4874, 4932, 4994, 5122/ +data (chrtab(i), i=1806,1810) / 5188, 5190, 838, 4996, 5059/ +data (chrtab(i), i=1811,1815) / 5123, 778, 4997, 5060, 5124/ +data (chrtab(i), i=1816,1820) / 5189, 0, 220, 4295, 283/ +data (chrtab(i), i=1821,1825) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1826,1830) / 5083, 5146, 5208, 5206, 5140/ +data (chrtab(i), i=1831,1835) / 5075, 4882, 4434, 986, 5144/ +data (chrtab(i), i=1836,1840) / 5142, 5076, 796, 5019, 5081/ +data (chrtab(i), i=1841,1845) / 5077, 5011, 4882, 594, 4817/ +data (chrtab(i), i=1846,1850) / 4879, 5001, 5063, 5191, 5257/ +data (chrtab(i), i=1851,1855) / 5259, 907, 5065, 5128, 5192/ +data (chrtab(i), i=1856,1860) / 721, 4880, 5066, 5129, 5193/ +data (chrtab(i), i=1861,1865) / 5258, 7, 4615, 92, 4315/ +data (chrtab(i), i=1866,1870) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1871,1875) / 4443, 200, 4167, 201, 4231/ +data (chrtab(i), i=1876,1880) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=1881,1885) / 921, 5084, 5078, 5017, 4891/ +data (chrtab(i), i=1886,1890) / 4700, 4508, 4315, 4185, 4182/ +data (chrtab(i), i=1891,1895) / 4244, 4434, 4816, 4943, 5005/ +data (chrtab(i), i=1896,1900) / 5002, 4936, 150, 4308, 4435/ +data (chrtab(i), i=1901,1905) / 4817, 4944, 5006, 219, 4249/ +data (chrtab(i), i=1906,1910) / 4247, 4309, 4436, 4818, 5008/ +data (chrtab(i), i=1911,1915) / 5070, 5067, 5001, 4936, 4743/ +data (chrtab(i), i=1916,1920) / 4551, 4360, 4234, 4173, 4167/ +data (chrtab(i), i=1921,1925) / 4234, 0, 28, 4118, 476/ +data (chrtab(i), i=1926,1930) / 4551, 539, 4616, 604, 4679/ +data (chrtab(i), i=1931,1935) / 1052, 5142, 28, 5148, 263/ +data (chrtab(i), i=1936,1940) / 4871, 92, 4118, 156, 4121/ +data (chrtab(i), i=1941,1945) / 220, 4122, 348, 4123, 732/ +data (chrtab(i), i=1946,1950) / 5147, 860, 5146, 924, 5145/ +data (chrtab(i), i=1951,1955) / 988, 5142, 456, 4423, 457/ +data (chrtab(i), i=1956,1960) / 4487, 585, 4743, 584, 4807/ +data (chrtab(i), i=1961,1965) / 0, 220, 4301, 4362, 4488/ +data (chrtab(i), i=1966,1970) / 4679, 4807, 5000, 5130, 5197/ +data (chrtab(i), i=1971,1975) / 5211, 283, 4364, 4426, 348/ +data (chrtab(i), i=1976,1980) / 4428, 4489, 4552, 4679, 28/ +data (chrtab(i), i=1981,1985) / 4636, 924, 5404, 92, 4315/ +data (chrtab(i), i=1986,1990) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1991,1995) / 4443, 988, 5211, 1244, 5211/ +data (chrtab(i), i=1996,2000) / 0, 92, 4615, 156, 4618/ +data (chrtab(i), i=2001,2005) / 4615, 220, 4682, 987, 4615/ +data (chrtab(i), i=2006,2010) / 28, 4508, 732, 5212, 28/ +data (chrtab(i), i=2011,2015) / 4250, 284, 4314, 348, 4315/ +data (chrtab(i), i=2016,2020) / 860, 5083, 1052, 5083, 0/ +data (chrtab(i), i=2021,2025) / 156, 4487, 220, 4492, 4487/ +data (chrtab(i), i=2026,2030) / 284, 4556, 668, 4556, 4487/ +data (chrtab(i), i=2031,2035) / 668, 4999, 732, 5004, 4999/ +data (chrtab(i), i=2036,2040) / 796, 5068, 1179, 5068, 4999/ +data (chrtab(i), i=2041,2045) / 28, 4572, 668, 4892, 988/ +data (chrtab(i), i=2046,2050) / 5468, 28, 4315, 92, 4314/ +data (chrtab(i), i=2051,2055) / 348, 4378, 412, 4379, 1052/ +data (chrtab(i), i=2056,2060) / 5275, 1308, 5275, 0, 92/ +data (chrtab(i), i=2061,2065) / 4935, 156, 4999, 220, 5063/ +data (chrtab(i), i=2066,2070) / 923, 4232, 28, 4508, 732/ +data (chrtab(i), i=2071,2075) / 5212, 7, 4423, 647, 5191/ +data (chrtab(i), i=2076,2080) / 28, 4314, 284, 4314, 348/ +data (chrtab(i), i=2081,2085) / 4315, 796, 5019, 1052, 5019/ +data (chrtab(i), i=2086,2090) / 136, 4103, 136, 4359, 840/ +data (chrtab(i), i=2091,2095) / 4807, 841, 4871, 841, 5127/ +data (chrtab(i), i=2096,2100) / 0, 92, 4625, 4615, 156/ +data (chrtab(i), i=2101,2105) / 4689, 4680, 220, 4753, 4743/ +data (chrtab(i), i=2106,2110) / 1051, 4753, 28, 4508, 860/ +data (chrtab(i), i=2111,2115) / 5340, 327, 4935, 28, 4251/ +data (chrtab(i), i=2116,2120) / 348, 4315, 924, 5147, 1180/ +data (chrtab(i), i=2121,2125) / 5147, 520, 4487, 521, 4551/ +data (chrtab(i), i=2126,2130) / 649, 4807, 648, 4871, 0/ +data (chrtab(i), i=2131,2135) / 988, 4188, 4182, 860, 4167/ +data (chrtab(i), i=2136,2140) / 924, 4231, 988, 4295, 71/ +data (chrtab(i), i=2141,2145) / 5063, 5069, 156, 4182, 220/ +data (chrtab(i), i=2146,2150) / 4185, 284, 4186, 412, 4187/ +data (chrtab(i), i=2151,2155) / 647, 5064, 775, 5065, 839/ +data (chrtab(i), i=2156,2160) / 5066, 903, 5069, 0, 160/ +data (chrtab(i), i=2161,2165) / 4224, 224, 4288, 160, 4704/ +data (chrtab(i), i=2166,2170) / 128, 4672, 0, 28, 4868/ +data (chrtab(i), i=2171,2175) / 0, 480, 4544, 544, 4608/ +data (chrtab(i), i=2176,2180) / 96, 4640, 64, 4608, 0/ +data (chrtab(i), i=2181,2185) / 278, 4505, 4630, 83, 4504/ +data (chrtab(i), i=2186,2190) / 4819, 408, 4487, 0, 5/ +data (chrtab(i), i=2191,2195) / 4997, 0, 348, 4315, 4249/ +data (chrtab(i), i=2196,2200) / 4246, 4309, 4373, 4438, 4439/ +data (chrtab(i), i=2201,2205) / 4376, 4312, 4247, 215, 4310/ +data (chrtab(i), i=2206,2210) / 4374, 4375, 4311, 219, 4247/ +data (chrtab(i), i=2211,2215) / 153, 4312, 0, 210, 4307/ +data (chrtab(i), i=2216,2220) / 4371, 4369, 4241, 4243, 4308/ +data (chrtab(i), i=2221,2225) / 4437, 4693, 4820, 4883, 4945/ +data (chrtab(i), i=2226,2230) / 4938, 5000, 5063, 723, 4881/ +data (chrtab(i), i=2231,2235) / 4874, 4936, 597, 4756, 4818/ +data (chrtab(i), i=2236,2240) / 4810, 4872, 5063, 5127, 720/ +data (chrtab(i), i=2241,2245) / 4751, 4430, 4237, 4171, 4170/ +data (chrtab(i), i=2246,2250) / 4232, 4423, 4615, 4744, 4810/ +data (chrtab(i), i=2251,2255) / 205, 4235, 4234, 4296, 655/ +data (chrtab(i), i=2256,2260) / 4494, 4365, 4299, 4298, 4360/ +data (chrtab(i), i=2261,2265) / 4423, 0, 220, 4295, 4360/ +data (chrtab(i), i=2266,2270) / 4488, 283, 4361, 28, 4444/ +data (chrtab(i), i=2271,2275) / 4424, 338, 4500, 4629, 4757/ +data (chrtab(i), i=2276,2280) / 4948, 5074, 5135, 5133, 5066/ +data (chrtab(i), i=2281,2285) / 4936, 4743, 4615, 4488, 4426/ +data (chrtab(i), i=2286,2290) / 914, 5072, 5068, 5002, 661/ +data (chrtab(i), i=2291,2295) / 4884, 4947, 5008, 5004, 4937/ +data (chrtab(i), i=2296,2300) / 4872, 4743, 92, 4315, 156/ +data (chrtab(i), i=2301,2305) / 4314, 0, 849, 4946, 4882/ +data (chrtab(i), i=2306,2310) / 4880, 5008, 5010, 4884, 4757/ +data (chrtab(i), i=2311,2315) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2316,2320) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2321,2325) / 5002, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2326,2330) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2331,2335) / 4361, 4424, 4551, 0, 796/ +data (chrtab(i), i=2336,2340) / 4871, 5191, 859, 4936, 604/ +data (chrtab(i), i=2341,2345) / 5020, 4999, 786, 4820, 4693/ +data (chrtab(i), i=2346,2350) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2351,2355) / 4234, 4360, 4551, 4679, 4808/ +data (chrtab(i), i=2356,2360) / 4874, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2361,2365) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2366,2370) / 4361, 4424, 4551, 668, 4891/ +data (chrtab(i), i=2371,2375) / 732, 4890, 905, 5063, 904/ +data (chrtab(i), i=2376,2380) / 5127, 0, 207, 5007, 5009/ +data (chrtab(i), i=2381,2385) / 4947, 4884, 4693, 4565, 4372/ +data (chrtab(i), i=2386,2390) / 4242, 4175, 4173, 4234, 4360/ +data (chrtab(i), i=2391,2395) / 4551, 4679, 4872, 5002, 848/ +data (chrtab(i), i=2396,2400) / 4945, 4883, 210, 4240, 4236/ +data (chrtab(i), i=2401,2405) / 4298, 783, 4882, 4820, 4693/ +data (chrtab(i), i=2406,2410) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2411,2415) / 4361, 4424, 4551, 0, 666/ +data (chrtab(i), i=2416,2420) / 4763, 4699, 4697, 4825, 4827/ +data (chrtab(i), i=2421,2425) / 4764, 4572, 4443, 4378, 4311/ +data (chrtab(i), i=2426,2430) / 4295, 346, 4375, 4360, 476/ +data (chrtab(i), i=2431,2435) / 4507, 4441, 4423, 21, 4693/ +data (chrtab(i), i=2436,2440) / 7, 4615, 200, 4167, 201/ +data (chrtab(i), i=2441,2445) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2446,2450) / 0, 852, 5011, 5076, 5013/ +data (chrtab(i), i=2451,2455) / 4949, 4820, 4755, 405, 4372/ +data (chrtab(i), i=2456,2460) / 4307, 4241, 4239, 4301, 4364/ +data (chrtab(i), i=2461,2465) / 4491, 4619, 4748, 4813, 4879/ +data (chrtab(i), i=2466,2470) / 4881, 4819, 4756, 4629, 4501/ +data (chrtab(i), i=2471,2475) / 275, 4305, 4303, 4365, 653/ +data (chrtab(i), i=2476,2480) / 4815, 4817, 4755, 405, 4436/ +data (chrtab(i), i=2481,2485) / 4370, 4366, 4428, 4491, 523/ +data (chrtab(i), i=2486,2490) / 4684, 4750, 4754, 4692, 4629/ +data (chrtab(i), i=2491,2495) / 205, 4236, 4170, 4169, 4231/ +data (chrtab(i), i=2496,2500) / 4294, 4485, 4741, 4932, 4995/ +data (chrtab(i), i=2501,2505) / 199, 4486, 4742, 4933, 73/ +data (chrtab(i), i=2506,2510) / 4232, 4423, 4743, 4934, 4996/ +data (chrtab(i), i=2511,2515) / 4995, 4929, 4736, 4352, 4161/ +data (chrtab(i), i=2516,2520) / 4099, 4100, 4166, 4359, 256/ +data (chrtab(i), i=2521,2525) / 4225, 4163, 4164, 4230, 4359/ +data (chrtab(i), i=2526,2530) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2531,2535) / 28, 4444, 4423, 337, 4499/ +data (chrtab(i), i=2536,2540) / 4564, 4693, 4885, 5012, 5075/ +data (chrtab(i), i=2541,2545) / 5136, 5127, 915, 5072, 5064/ +data (chrtab(i), i=2546,2550) / 789, 4948, 5009, 4999, 7/ +data (chrtab(i), i=2551,2555) / 4615, 711, 5319, 92, 4315/ +data (chrtab(i), i=2556,2560) / 156, 4314, 200, 4167, 201/ +data (chrtab(i), i=2561,2565) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2566,2570) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2571,2575) / 5191, 1032, 5255, 0, 220/ +data (chrtab(i), i=2576,2580) / 4314, 4442, 4444, 4316, 284/ +data (chrtab(i), i=2581,2585) / 4378, 219, 4443, 213, 4295/ +data (chrtab(i), i=2586,2590) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2591,2595) / 7, 4615, 85, 4308, 149/ +data (chrtab(i), i=2596,2600) / 4307, 200, 4167, 201, 4231/ +data (chrtab(i), i=2601,2605) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=2606,2610) / 348, 4442, 4570, 4572, 4444/ +data (chrtab(i), i=2611,2615) / 412, 4506, 347, 4571, 341/ +data (chrtab(i), i=2616,2620) / 4420, 4353, 4288, 404, 4485/ +data (chrtab(i), i=2621,2625) / 4418, 149, 4565, 4549, 4482/ +data (chrtab(i), i=2626,2630) / 4417, 4288, 4096, 4097, 4099/ +data (chrtab(i), i=2631,2635) / 4163, 4161, 4097, 4098, 213/ +data (chrtab(i), i=2636,2640) / 4436, 277, 4435, 0, 220/ +data (chrtab(i), i=2641,2645) / 4295, 283, 4360, 28, 4444/ +data (chrtab(i), i=2646,2650) / 4423, 916, 4427, 591, 5127/ +data (chrtab(i), i=2651,2655) / 590, 5063, 526, 4999, 725/ +data (chrtab(i), i=2656,2660) / 5269, 7, 4615, 711, 5255/ +data (chrtab(i), i=2661,2665) / 92, 4315, 156, 4314, 789/ +data (chrtab(i), i=2666,2670) / 5012, 1109, 5012, 200, 4167/ +data (chrtab(i), i=2671,2675) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2676,2680) / 4551, 905, 4871, 841, 5191/ +data (chrtab(i), i=2681,2685) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2686,2690) / 28, 4444, 4423, 7, 4615/ +data (chrtab(i), i=2691,2695) / 92, 4315, 156, 4314, 200/ +data (chrtab(i), i=2696,2700) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2701,2705) / 328, 4551, 0, 213, 4295/ +data (chrtab(i), i=2706,2710) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2711,2715) / 337, 4499, 4564, 4693, 4885/ +data (chrtab(i), i=2716,2720) / 5012, 5075, 5136, 5127, 915/ +data (chrtab(i), i=2721,2725) / 5072, 5064, 789, 4948, 5009/ +data (chrtab(i), i=2726,2730) / 4999, 1041, 5203, 5268, 5397/ +data (chrtab(i), i=2731,2735) / 5589, 5716, 5779, 5840, 5831/ +data (chrtab(i), i=2736,2740) / 1619, 5776, 5768, 1493, 5652/ +data (chrtab(i), i=2741,2745) / 5713, 5703, 7, 4615, 711/ +data (chrtab(i), i=2746,2750) / 5319, 1415, 6023, 85, 4308/ +data (chrtab(i), i=2751,2755) / 149, 4307, 200, 4167, 201/ +data (chrtab(i), i=2756,2760) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2761,2765) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2766,2770) / 5191, 1032, 5255, 1608, 5575/ +data (chrtab(i), i=2771,2775) / 1609, 5639, 1737, 5895, 1736/ +data (chrtab(i), i=2776,2780) / 5959, 0, 213, 4295, 276/ +data (chrtab(i), i=2781,2785) / 4360, 21, 4437, 4423, 337/ +data (chrtab(i), i=2786,2790) / 4499, 4564, 4693, 4885, 5012/ +data (chrtab(i), i=2791,2795) / 5075, 5136, 5127, 915, 5072/ +data (chrtab(i), i=2796,2800) / 5064, 789, 4948, 5009, 4999/ +data (chrtab(i), i=2801,2805) / 7, 4615, 711, 5319, 85/ +data (chrtab(i), i=2806,2810) / 4308, 149, 4307, 200, 4167/ +data (chrtab(i), i=2811,2815) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2816,2820) / 4551, 904, 4871, 905, 4935/ +data (chrtab(i), i=2821,2825) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=2826,2830) / 469, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2831,2835) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2836,2840) / 5002, 5069, 5071, 5010, 4884/ +data (chrtab(i), i=2841,2845) / 4693, 4565, 210, 4240, 4236/ +data (chrtab(i), i=2846,2850) / 4298, 842, 5004, 5008, 4946/ +data (chrtab(i), i=2851,2855) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2856,2860) / 4361, 4424, 4551, 583, 4808/ +data (chrtab(i), i=2861,2865) / 4873, 4940, 4944, 4883, 4820/ +data (chrtab(i), i=2866,2870) / 4693, 0, 213, 4288, 276/ +data (chrtab(i), i=2871,2875) / 4353, 21, 4437, 4416, 338/ +data (chrtab(i), i=2876,2880) / 4500, 4629, 4757, 4948, 5074/ +data (chrtab(i), i=2881,2885) / 5135, 5133, 5066, 4936, 4743/ +data (chrtab(i), i=2886,2890) / 4615, 4488, 4426, 914, 5072/ +data (chrtab(i), i=2891,2895) / 5068, 5002, 661, 4884, 4947/ +data (chrtab(i), i=2896,2900) / 5008, 5004, 4937, 4872, 4743/ +data (chrtab(i), i=2901,2905) / 0, 4608, 85, 4308, 149/ +data (chrtab(i), i=2906,2910) / 4307, 193, 4160, 194, 4224/ +data (chrtab(i), i=2911,2915) / 322, 4480, 321, 4544, 0/ +data (chrtab(i), i=2916,2920) / 788, 4864, 851, 4929, 724/ +data (chrtab(i), i=2921,2925) / 4948, 5013, 4992, 786, 4820/ +data (chrtab(i), i=2926,2930) / 4693, 4565, 4372, 4242, 4175/ +data (chrtab(i), i=2931,2935) / 4173, 4234, 4360, 4551, 4679/ +data (chrtab(i), i=2936,2940) / 4808, 4874, 210, 4240, 4236/ +data (chrtab(i), i=2941,2945) / 4298, 469, 4436, 4371, 4304/ +data (chrtab(i), i=2946,2950) / 4300, 4361, 4424, 4551, 576/ +data (chrtab(i), i=2951,2955) / 5184, 769, 4736, 770, 4800/ +data (chrtab(i), i=2956,2960) / 898, 5056, 897, 5120, 0/ +data (chrtab(i), i=2961,2965) / 213, 4295, 276, 4360, 21/ +data (chrtab(i), i=2966,2970) / 4437, 4423, 787, 4884, 4820/ +data (chrtab(i), i=2971,2975) / 4818, 4946, 4948, 4885, 4757/ +data (chrtab(i), i=2976,2980) / 4628, 4498, 4431, 7, 4615/ +data (chrtab(i), i=2981,2985) / 85, 4308, 149, 4307, 200/ +data (chrtab(i), i=2986,2990) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2991,2995) / 328, 4551, 0, 723, 4885/ +data (chrtab(i), i=2996,3000) / 4881, 4819, 4756, 4629, 4373/ +data (chrtab(i), i=3001,3005) / 4244, 4179, 4177, 4239, 4366/ +data (chrtab(i), i=3006,3010) / 4685, 4812, 4873, 148, 4177/ +data (chrtab(i), i=3011,3015) / 144, 4367, 4686, 4813, 780/ +data (chrtab(i), i=3016,3020) / 4808, 83, 4241, 4368, 4687/ +data (chrtab(i), i=3021,3025) / 4814, 4876, 4873, 4808, 4679/ +data (chrtab(i), i=3026,3030) / 4423, 4296, 4233, 4171, 4167/ +data (chrtab(i), i=3031,3035) / 4233, 0, 218, 4300, 4361/ +data (chrtab(i), i=3036,3040) / 4424, 4551, 4679, 4808, 4874/ +data (chrtab(i), i=3041,3045) / 282, 4363, 4425, 218, 4444/ +data (chrtab(i), i=3046,3050) / 4427, 4488, 4551, 21, 4693/ +data (chrtab(i), i=3051,3055) / 0, 213, 4300, 4361, 4424/ +data (chrtab(i), i=3056,3060) / 4551, 4743, 4872, 4937, 5003/ +data (chrtab(i), i=3061,3065) / 276, 4363, 4425, 21, 4437/ +data (chrtab(i), i=3066,3070) / 4427, 4488, 4551, 917, 4999/ +data (chrtab(i), i=3071,3075) / 5319, 980, 5064, 725, 5141/ +data (chrtab(i), i=3076,3080) / 5127, 85, 4308, 149, 4307/ +data (chrtab(i), i=3081,3085) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=3086,3090) / 85, 4551, 149, 4553, 213/ +data (chrtab(i), i=3091,3095) / 4617, 852, 4617, 4551, 21/ +data (chrtab(i), i=3096,3100) / 4501, 597, 5077, 21, 4307/ +data (chrtab(i), i=3101,3105) / 341, 4308, 725, 4948, 917/ +data (chrtab(i), i=3106,3110) / 4948, 0, 149, 4487, 213/ +data (chrtab(i), i=3111,3115) / 4490, 277, 4554, 661, 4554/ +data (chrtab(i), i=3116,3120) / 4487, 661, 4999, 725, 5002/ +data (chrtab(i), i=3121,3125) / 661, 4885, 5066, 1172, 5066/ +data (chrtab(i), i=3126,3130) / 4999, 21, 4565, 981, 5461/ +data (chrtab(i), i=3131,3135) / 21, 4308, 405, 4372, 1045/ +data (chrtab(i), i=3136,3140) / 5268, 1301, 5268, 0, 149/ +data (chrtab(i), i=3141,3145) / 4871, 213, 4935, 277, 4999/ +data (chrtab(i), i=3146,3150) / 852, 4296, 21, 4565, 661/ +data (chrtab(i), i=3151,3155) / 5141, 7, 4487, 583, 5127/ +data (chrtab(i), i=3156,3160) / 85, 4308, 405, 4372, 725/ +data (chrtab(i), i=3161,3165) / 4948, 981, 4948, 200, 4167/ +data (chrtab(i), i=3166,3170) / 200, 4423, 776, 4743, 840/ +data (chrtab(i), i=3171,3175) / 5063, 0, 149, 4615, 213/ +data (chrtab(i), i=3176,3180) / 4617, 277, 4681, 916, 4681/ +data (chrtab(i), i=3181,3185) / 4483, 4353, 4224, 4096, 4097/ +data (chrtab(i), i=3186,3190) / 4099, 4163, 4161, 4097, 4098/ +data (chrtab(i), i=3191,3195) / 21, 4565, 661, 5141, 85/ +data (chrtab(i), i=3196,3200) / 4371, 405, 4372, 789, 5012/ +data (chrtab(i), i=3201,3205) / 981, 5012, 0, 725, 4167/ +data (chrtab(i), i=3206,3210) / 789, 4231, 853, 4295, 853/ +data (chrtab(i), i=3211,3215) / 4181, 4177, 71, 4935, 4939/ +data (chrtab(i), i=3216,3220) / 149, 4177, 213, 4178, 277/ +data (chrtab(i), i=3221,3225) / 4179, 405, 4180, 519, 4936/ +data (chrtab(i), i=3226,3230) / 647, 4937, 711, 4938, 775/ +data (chrtab(i), i=3231,3235) / 4939, 0, 480, 4447, 4382/ +data (chrtab(i), i=3236,3240) / 4316, 4314, 4376, 4439, 4501/ +data (chrtab(i), i=3241,3245) / 4499, 4369, 351, 4381, 4379/ +data (chrtab(i), i=3246,3250) / 4441, 4504, 4566, 4564, 4498/ +data (chrtab(i), i=3251,3255) / 4240, 4494, 4556, 4554, 4488/ +data (chrtab(i), i=3256,3260) / 4423, 4357, 4355, 4417, 271/ +data (chrtab(i), i=3261,3265) / 4493, 4491, 4425, 4360, 4294/ +data (chrtab(i), i=3266,3270) / 4292, 4354, 4417, 4544, 0/ +data (chrtab(i), i=3271,3275) / 160, 4224, 0, 224, 4447/ +data (chrtab(i), i=3276,3280) / 4510, 4572, 4570, 4504, 4439/ +data (chrtab(i), i=3281,3285) / 4373, 4371, 4497, 351, 4509/ +data (chrtab(i), i=3286,3290) / 4507, 4441, 4376, 4310, 4308/ +data (chrtab(i), i=3291,3295) / 4370, 4624, 4366, 4300, 4298/ +data (chrtab(i), i=3296,3300) / 4360, 4423, 4485, 4483, 4417/ +data (chrtab(i), i=3301,3305) / 399, 4365, 4363, 4425, 4488/ +data (chrtab(i), i=3306,3310) / 4550, 4548, 4482, 4417, 4288/ +data (chrtab(i), i=3311,3315) / 0, 77, 4175, 4242, 4371/ +data (chrtab(i), i=3316,3320) / 4499, 4626, 4879, 5006, 5134/ +data (chrtab(i), i=3321,3325) / 5263, 5329, 79, 4241, 4370/ +data (chrtab(i), i=3326,3330) / 4498, 4625, 4878, 5005, 5133/ +data (chrtab(i), i=3331,3335) / 5262, 5329, 5331, 0, 284/ +data (chrtab(i), i=3336,3340) / 4251, 4185, 4183, 4245, 4372/ +data (chrtab(i), i=3341,3345) / 4500, 4629, 4695, 4697, 4635/ +data (chrtab(i), i=3346,3350) / 4508, 4380, 284, 4185, 4245/ +data (chrtab(i), i=3351,3355) / 4500, 4695, 4635, 4380, 412/ +data (chrtab(i), i=3356,3360) / 4251, 4183, 4372, 4629, 4697/ +data (chrtab(i), i=3361,3362) / 4508, 0/ diff --git a/sys/gio/fonts/greek.com b/sys/gio/fonts/greek.com new file mode 100644 index 00000000..82c5fe34 --- /dev/null +++ b/sys/gio/fonts/greek.com @@ -0,0 +1,501 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short gchidx[97] # character index in gchtab +short gchwid[97] # character width table +short gchtab[2140] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (gchidx(i), i=001,005) / 1, 3, 16, 29, 38/ +data (gchidx(i), i=006,010) / 77, 107, 154, 162, 181/ +data (gchidx(i), i=011,015) / 200, 205, 212, 233, 240/ +data (gchidx(i), i=016,020) / 246, 259, 297, 306, 348/ +data (gchidx(i), i=021,025) / 392, 402, 437, 483, 510/ +data (gchidx(i), i=026,030) / 568, 614, 645, 658, 666/ +data (gchidx(i), i=031,035) / 673, 681, 688, 741, 767/ +data (gchidx(i), i=036,040) / 793, 795, 806, 821, 863/ +data (gchidx(i), i=041,045) / 874, 883, 888, 899, 901/ +data (gchidx(i), i=046,050) / 912, 921, 930, 972, 987/ +data (gchidx(i), i=051,055) / 1037, 1067, 1083, 1088, 1117/ +data (gchidx(i), i=056,060) / 1143, 1182, 1207, 1242, 1244/ +data (gchidx(i), i=061,065) / 1253, 1256, 1265, 1267, 1276/ +data (gchidx(i), i=066,070) / 1284, 1321, 1373, 1394, 1436/ +data (gchidx(i), i=071,075) / 1465, 1500, 1525, 1554, 1568/ +data (gchidx(i), i=076,080) / 1610, 1635, 1655, 1679, 1699/ +data (gchidx(i), i=081,085) / 1729, 1746, 1788, 1817, 1849/ +data (gchidx(i), i=086,090) / 1862, 1891, 1893, 1934, 1975/ +data (gchidx(i), i=091,095) / 2006, 2036, 2074, 2079, 2117/ +data (gchidx(i), i=096,096) / 2126/ + + +# Width data. + +data (gchwid(i), i=001,005) / 21, 15, 15, 26, 25/ +data (gchwid(i), i=006,010) / 29, 30, 15, 19, 19/ +data (gchwid(i), i=011,015) / 27, 29, 30, 29, 15/ +data (gchwid(i), i=016,020) / 31, 25, 25, 25, 25/ +data (gchwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (gchwid(i), i=026,030) / 25, 29, 15, 29, 31/ +data (gchwid(i), i=031,035) / 29, 31, 32, 25, 30/ +data (gchwid(i), i=036,040) / 21, 25, 29, 26, 23/ +data (gchwid(i), i=041,045) / 26, 19, 25, 21, 25/ +data (gchwid(i), i=046,050) / 21, 21, 27, 29, 27/ +data (gchwid(i), i=051,055) / 29, 26, 19, 24, 25/ +data (gchwid(i), i=056,060) / 27, 27, 28, 21, 19/ +data (gchwid(i), i=061,065) / 19, 19, 21, 31, 27/ +data (gchwid(i), i=066,070) / 28, 26, 23, 24, 23/ +data (gchwid(i), i=071,075) / 27, 25, 27, 17, 24/ +data (gchwid(i), i=076,080) / 25, 25, 28, 25, 23/ +data (gchwid(i), i=081,085) / 27, 28, 24, 26, 25/ +data (gchwid(i), i=086,090) / 25, 21, 28, 22, 28/ +data (gchwid(i), i=091,095) / 23, 19, 19, 19, 31/ +data (gchwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (gchtab(i), i=0001,0005) / 35, 0, 220, 4250, 4302/ +data (gchtab(i), i=0006,0010) / 4378, 4316, 218, 4308, 201/ +data (gchtab(i), i=0011,0015) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0016,0020) / 213, 4244, 4307, 4372, 4309/ +data (gchtab(i), i=0021,0025) / 199, 4232, 4297, 4360, 4358/ +data (gchtab(i), i=0026,0030) / 4292, 4227, 0, 604, 4224/ +data (gchtab(i), i=0031,0035) / 988, 4608, 145, 5137, 75/ +data (gchtab(i), i=0036,0040) / 5067, 0, 416, 4483, 672/ +data (gchtab(i), i=0041,0045) / 4739, 921, 4952, 5015, 5080/ +data (gchtab(i), i=0046,0050) / 5081, 4955, 4764, 4508, 4315/ +data (gchtab(i), i=0051,0055) / 4185, 4183, 4245, 4308, 4435/ +data (gchtab(i), i=0056,0060) / 4817, 4944, 5070, 87, 4309/ +data (gchtab(i), i=0061,0065) / 4436, 4818, 4945, 5008, 5070/ +data (gchtab(i), i=0066,0070) / 5066, 4936, 4743, 4487, 4296/ +data (gchtab(i), i=0071,0075) / 4170, 4171, 4236, 4299, 4234/ +data (gchtab(i), i=0076,0080) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=0081,0085) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=0086,0090) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=0091,0095) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=0096,0100) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=0101,0105) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=0106,0110) / 0, 1236, 5267, 5330, 5395/ +data (gchtab(i), i=0111,0115) / 5396, 5333, 5269, 5204, 5138/ +data (gchtab(i), i=0116,0120) / 5005, 4874, 4744, 4615, 4423/ +data (gchtab(i), i=0121,0125) / 4232, 4170, 4173, 4239, 4627/ +data (gchtab(i), i=0126,0130) / 4757, 4823, 4825, 4763, 4636/ +data (gchtab(i), i=0131,0135) / 4507, 4441, 4439, 4500, 4625/ +data (gchtab(i), i=0136,0140) / 4938, 5064, 5255, 5319, 5384/ +data (gchtab(i), i=0141,0145) / 5385, 327, 4296, 4234, 4237/ +data (gchtab(i), i=0146,0150) / 4303, 4433, 343, 4501, 5002/ +data (gchtab(i), i=0151,0155) / 5128, 5255, 0, 218, 4251/ +data (gchtab(i), i=0156,0160) / 4316, 4379, 4377, 4311, 4246/ +data (gchtab(i), i=0161,0165) / 0, 608, 4574, 4443, 4311/ +data (gchtab(i), i=0166,0170) / 4242, 4238, 4297, 4421, 4546/ +data (gchtab(i), i=0171,0175) / 4672, 478, 4442, 4375, 4306/ +data (gchtab(i), i=0176,0180) / 4302, 4361, 4422, 4546, 0/ +data (gchtab(i), i=0181,0185) / 96, 4318, 4443, 4567, 4626/ +data (gchtab(i), i=0186,0190) / 4622, 4553, 4421, 4290, 4160/ +data (gchtab(i), i=0191,0195) / 222, 4442, 4503, 4562, 4558/ +data (gchtab(i), i=0196,0200) / 4489, 4422, 4290, 0, 151/ +data (gchtab(i), i=0201,0205) / 5129, 1047, 4233, 0, 664/ +data (gchtab(i), i=0206,0210) / 4743, 144, 5264, 135, 5255/ +data (gchtab(i), i=0211,0215) / 0, 1227, 5195, 5068, 4942/ +data (gchtab(i), i=0216,0220) / 4754, 4691, 4564, 4436, 4307/ +data (gchtab(i), i=0221,0225) / 4241, 4239, 4301, 4428, 4556/ +data (gchtab(i), i=0226,0230) / 4685, 4750, 4946, 5076, 5205/ +data (gchtab(i), i=0231,0235) / 5333, 0, 664, 4743, 152/ +data (gchtab(i), i=0236,0240) / 5272, 144, 5264, 0, 201/ +data (gchtab(i), i=0241,0245) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0246,0250) / 729, 4760, 4823, 4888, 4825/ +data (gchtab(i), i=0251,0255) / 144, 5392, 713, 4744, 4807/ +data (gchtab(i), i=0256,0260) / 4872, 4809, 0, 476, 4379/ +data (gchtab(i), i=0261,0265) / 4248, 4179, 4176, 4235, 4360/ +data (gchtab(i), i=0266,0270) / 4551, 4679, 4872, 5003, 5072/ +data (gchtab(i), i=0271,0275) / 5075, 5016, 4891, 4700, 4572/ +data (gchtab(i), i=0276,0280) / 476, 4443, 4378, 4312, 4243/ +data (gchtab(i), i=0281,0285) / 4240, 4299, 4361, 4424, 4551/ +data (gchtab(i), i=0286,0290) / 583, 4808, 4873, 4939, 5008/ +data (gchtab(i), i=0291,0295) / 5011, 4952, 4890, 4827, 4700/ +data (gchtab(i), i=0296,0300) / 0, 280, 4505, 4700, 4679/ +data (gchtab(i), i=0301,0305) / 539, 4615, 263, 4935, 0/ +data (gchtab(i), i=0306,0310) / 152, 4311, 4246, 4183, 4184/ +data (gchtab(i), i=0311,0315) / 4250, 4315, 4508, 4764, 4955/ +data (gchtab(i), i=0316,0320) / 5018, 5080, 5078, 5012, 4818/ +data (gchtab(i), i=0321,0325) / 4496, 4367, 4237, 4170, 4167/ +data (gchtab(i), i=0326,0330) / 668, 4891, 4954, 5016, 5014/ +data (gchtab(i), i=0331,0335) / 4948, 4754, 4496, 73, 4234/ +data (gchtab(i), i=0336,0340) / 4362, 4680, 4872, 5001, 5066/ +data (gchtab(i), i=0341,0345) / 266, 4679, 4935, 5000, 5066/ +data (gchtab(i), i=0346,0350) / 5068, 0, 152, 4311, 4246/ +data (gchtab(i), i=0351,0355) / 4183, 4184, 4250, 4315, 4508/ +data (gchtab(i), i=0356,0360) / 4764, 4955, 5017, 5014, 4948/ +data (gchtab(i), i=0361,0365) / 4755, 4563, 668, 4891, 4953/ +data (gchtab(i), i=0366,0370) / 4950, 4884, 4755, 659, 4882/ +data (gchtab(i), i=0371,0375) / 5008, 5070, 5067, 5001, 4936/ +data (gchtab(i), i=0376,0380) / 4743, 4487, 4296, 4233, 4171/ +data (gchtab(i), i=0381,0385) / 4172, 4237, 4300, 4235, 849/ +data (gchtab(i), i=0386,0390) / 5006, 5003, 4937, 4872, 4743/ +data (gchtab(i), i=0391,0395) / 0, 666, 4743, 732, 4807/ +data (gchtab(i), i=0396,0400) / 732, 4109, 5133, 455, 4999/ +data (gchtab(i), i=0401,0405) / 0, 220, 4178, 82, 4308/ +data (gchtab(i), i=0406,0410) / 4501, 4693, 4884, 5010, 5071/ +data (gchtab(i), i=0411,0415) / 5069, 5002, 4872, 4679, 4487/ +data (gchtab(i), i=0416,0420) / 4296, 4233, 4171, 4172, 4237/ +data (gchtab(i), i=0421,0425) / 4300, 4235, 597, 4820, 4946/ +data (gchtab(i), i=0426,0430) / 5007, 5005, 4938, 4808, 4679/ +data (gchtab(i), i=0431,0435) / 220, 4956, 219, 4635, 4956/ +data (gchtab(i), i=0436,0440) / 0, 857, 4888, 4951, 5016/ +data (gchtab(i), i=0441,0445) / 5017, 4955, 4828, 4636, 4443/ +data (gchtab(i), i=0446,0450) / 4313, 4247, 4179, 4173, 4234/ +data (gchtab(i), i=0451,0455) / 4360, 4551, 4679, 4872, 5002/ +data (gchtab(i), i=0456,0460) / 5069, 5070, 5009, 4883, 4692/ +data (gchtab(i), i=0461,0465) / 4628, 4435, 4305, 4238, 540/ +data (gchtab(i), i=0466,0470) / 4507, 4377, 4311, 4243, 4237/ +data (gchtab(i), i=0471,0475) / 4298, 4424, 4551, 583, 4808/ +data (gchtab(i), i=0476,0480) / 4938, 5005, 5006, 4945, 4819/ +data (gchtab(i), i=0481,0485) / 4692, 0, 92, 4182, 88/ +data (gchtab(i), i=0486,0490) / 4250, 4380, 4508, 4825, 4953/ +data (gchtab(i), i=0491,0495) / 5018, 5084, 154, 4379, 4507/ +data (gchtab(i), i=0496,0500) / 4825, 988, 5081, 5014, 4753/ +data (gchtab(i), i=0501,0505) / 4687, 4620, 4615, 918, 4689/ +data (gchtab(i), i=0506,0510) / 4623, 4556, 4551, 0, 412/ +data (gchtab(i), i=0511,0515) / 4315, 4249, 4246, 4308, 4499/ +data (gchtab(i), i=0516,0520) / 4755, 4948, 5014, 5017, 4955/ +data (gchtab(i), i=0521,0525) / 4764, 4508, 412, 4379, 4313/ +data (gchtab(i), i=0526,0530) / 4310, 4372, 4499, 659, 4884/ +data (gchtab(i), i=0531,0535) / 4950, 4953, 4891, 4764, 403/ +data (gchtab(i), i=0536,0540) / 4306, 4241, 4175, 4171, 4233/ +data (gchtab(i), i=0541,0545) / 4296, 4487, 4743, 4936, 5001/ +data (gchtab(i), i=0546,0550) / 5067, 5071, 5009, 4946, 4755/ +data (gchtab(i), i=0551,0555) / 403, 4370, 4305, 4239, 4235/ +data (gchtab(i), i=0556,0560) / 4297, 4360, 4487, 647, 4872/ +data (gchtab(i), i=0561,0565) / 4937, 5003, 5007, 4945, 4882/ +data (gchtab(i), i=0566,0570) / 4755, 0, 917, 4946, 4816/ +data (gchtab(i), i=0571,0575) / 4623, 4559, 4368, 4242, 4181/ +data (gchtab(i), i=0576,0580) / 4182, 4249, 4379, 4572, 4700/ +data (gchtab(i), i=0581,0585) / 4891, 5017, 5078, 5072, 5004/ +data (gchtab(i), i=0586,0590) / 4938, 4808, 4615, 4423, 4296/ +data (gchtab(i), i=0591,0595) / 4234, 4235, 4300, 4363, 4298/ +data (gchtab(i), i=0596,0600) / 463, 4432, 4306, 4245, 4246/ +data (gchtab(i), i=0601,0605) / 4313, 4443, 4572, 604, 4827/ +data (gchtab(i), i=0606,0610) / 4953, 5014, 5008, 4940, 4874/ +data (gchtab(i), i=0611,0615) / 4744, 4615, 0, 1247, 5278/ +data (gchtab(i), i=0616,0620) / 5341, 5406, 5407, 5344, 5216/ +data (gchtab(i), i=0621,0625) / 5087, 4957, 4891, 4824, 4756/ +data (gchtab(i), i=0626,0630) / 4616, 4548, 4482, 926, 4956/ +data (gchtab(i), i=0631,0635) / 4888, 4748, 4680, 4613, 4547/ +data (gchtab(i), i=0636,0640) / 4417, 4288, 4160, 4097, 4098/ +data (gchtab(i), i=0641,0645) / 4163, 4226, 4161, 0, 213/ +data (gchtab(i), i=0646,0650) / 4244, 4307, 4372, 4309, 199/ +data (gchtab(i), i=0651,0655) / 4232, 4297, 4360, 4358, 4292/ +data (gchtab(i), i=0656,0660) / 4227, 0, 1180, 4245, 5262/ +data (gchtab(i), i=0661,0665) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0666,0670) / 149, 5397, 144, 5392, 139/ +data (gchtab(i), i=0671,0675) / 5387, 0, 156, 5269, 4238/ +data (gchtab(i), i=0676,0680) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0681,0685) / 1177, 4359, 147, 5395, 141/ +data (gchtab(i), i=0686,0690) / 5389, 0, 1044, 5078, 4951/ +data (gchtab(i), i=0691,0695) / 4759, 4630, 4565, 4498, 4495/ +data (gchtab(i), i=0696,0700) / 4557, 4684, 4876, 5005, 5071/ +data (gchtab(i), i=0701,0705) / 663, 4629, 4562, 4559, 4621/ +data (gchtab(i), i=0706,0710) / 4684, 1047, 5071, 5069, 5196/ +data (gchtab(i), i=0711,0715) / 5324, 5454, 5521, 5523, 5462/ +data (gchtab(i), i=0716,0720) / 5400, 5274, 5147, 4956, 4764/ +data (gchtab(i), i=0721,0725) / 4571, 4442, 4312, 4246, 4179/ +data (gchtab(i), i=0726,0730) / 4176, 4237, 4299, 4425, 4552/ +data (gchtab(i), i=0731,0735) / 4743, 4935, 5128, 5257, 5322/ +data (gchtab(i), i=0736,0740) / 1111, 5135, 5133, 5196, 0/ +data (gchtab(i), i=0741,0745) / 473, 4167, 601, 5063, 537/ +data (gchtab(i), i=0746,0750) / 4999, 205, 4877, 7, 4423/ +data (gchtab(i), i=0751,0755) / 711, 5191, 480, 4447, 4381/ +data (gchtab(i), i=0756,0760) / 4379, 4441, 4568, 4696, 4825/ +data (gchtab(i), i=0761,0765) / 4891, 4893, 4831, 4704, 4576/ +data (gchtab(i), i=0766,0770) / 0, 1295, 5325, 5196, 5068/ +data (gchtab(i), i=0771,0775) / 4941, 4878, 4690, 4627, 4500/ +data (gchtab(i), i=0776,0780) / 4372, 4243, 4177, 4175, 4237/ +data (gchtab(i), i=0781,0785) / 4364, 4492, 4621, 4686, 4882/ +data (gchtab(i), i=0786,0790) / 4947, 5076, 5204, 5331, 5393/ +data (gchtab(i), i=0791,0795) / 5391, 0, 35, 0, 540/ +data (gchtab(i), i=0796,0800) / 4103, 540, 5127, 537, 5063/ +data (gchtab(i), i=0801,0805) / 72, 5064, 7, 5127, 0/ +data (gchtab(i), i=0806,0810) / 1176, 4824, 4567, 4438, 4308/ +data (gchtab(i), i=0811,0815) / 4241, 4239, 4300, 4426, 4553/ +data (gchtab(i), i=0816,0820) / 4808, 5256, 144, 5008, 0/ +data (gchtab(i), i=0821,0825) / 540, 4615, 604, 4679, 407/ +data (gchtab(i), i=0826,0830) / 4310, 4245, 4179, 4176, 4238/ +data (gchtab(i), i=0831,0835) / 4301, 4492, 4812, 5005, 5070/ +data (gchtab(i), i=0836,0840) / 5136, 5139, 5077, 5014, 4823/ +data (gchtab(i), i=0841,0845) / 4503, 407, 4374, 4309, 4243/ +data (gchtab(i), i=0846,0850) / 4240, 4302, 4365, 4492, 716/ +data (gchtab(i), i=0851,0855) / 4941, 5006, 5072, 5075, 5013/ +data (gchtab(i), i=0856,0860) / 4950, 4823, 348, 4892, 327/ +data (gchtab(i), i=0861,0865) / 4871, 0, 220, 4295, 284/ +data (gchtab(i), i=0866,0870) / 4359, 28, 5084, 5078, 5020/ +data (gchtab(i), i=0871,0875) / 7, 4551, 0, 608, 4224/ +data (gchtab(i), i=0876,0880) / 992, 4608, 147, 5139, 77/ +data (gchtab(i), i=0881,0885) / 5069, 0, 160, 4224, 544/ +data (gchtab(i), i=0886,0890) / 4608, 0, 28, 4615, 92/ +data (gchtab(i), i=0891,0895) / 4617, 1052, 4615, 28, 5148/ +data (gchtab(i), i=0896,0900) / 91, 5083, 0, 35, 0/ +data (gchtab(i), i=0901,0905) / 540, 4167, 540, 5063, 537/ +data (gchtab(i), i=0906,0910) / 4999, 7, 4423, 711, 5191/ +data (gchtab(i), i=0911,0915) / 0, 278, 4505, 4630, 83/ +data (gchtab(i), i=0916,0920) / 4504, 4819, 408, 4487, 0/ +data (gchtab(i), i=0921,0925) / 266, 4487, 4618, 77, 4488/ +data (gchtab(i), i=0926,0930) / 4813, 409, 4488, 0, 540/ +data (gchtab(i), i=0931,0935) / 4443, 4313, 4247, 4179, 4176/ +data (gchtab(i), i=0936,0940) / 4236, 4298, 4424, 4615, 4743/ +data (gchtab(i), i=0941,0945) / 4936, 5066, 5132, 5200, 5203/ +data (gchtab(i), i=0946,0950) / 5143, 5081, 4955, 4764, 4636/ +data (gchtab(i), i=0951,0955) / 540, 4507, 4377, 4311, 4243/ +data (gchtab(i), i=0956,0960) / 4240, 4300, 4362, 4488, 4615/ +data (gchtab(i), i=0961,0965) / 647, 4872, 5002, 5068, 5136/ +data (gchtab(i), i=0966,0970) / 5139, 5079, 5017, 4891, 4764/ +data (gchtab(i), i=0971,0975) / 0, 220, 4295, 284, 4359/ +data (gchtab(i), i=0976,0980) / 1052, 5127, 1116, 5191, 28/ +data (gchtab(i), i=0981,0985) / 5404, 7, 4551, 839, 5383/ +data (gchtab(i), i=0986,0990) / 0, 540, 4443, 4313, 4247/ +data (gchtab(i), i=0991,0995) / 4179, 4176, 4236, 4298, 4424/ +data (gchtab(i), i=0996,1000) / 4615, 4743, 4936, 5066, 5132/ +data (gchtab(i), i=1001,1005) / 5200, 5203, 5143, 5081, 4955/ +data (gchtab(i), i=1006,1010) / 4764, 4636, 540, 4507, 4377/ +data (gchtab(i), i=1011,1015) / 4311, 4243, 4240, 4300, 4362/ +data (gchtab(i), i=1016,1020) / 4488, 4615, 647, 4872, 5002/ +data (gchtab(i), i=1021,1025) / 5068, 5136, 5139, 5079, 5017/ +data (gchtab(i), i=1026,1030) / 4891, 4764, 405, 4494, 789/ +data (gchtab(i), i=1031,1035) / 4878, 402, 4882, 401, 4881/ +data (gchtab(i), i=1036,1040) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=1041,1045) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=1046,1050) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=1051,1055) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=1056,1060) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=1061,1065) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=1066,1070) / 0, 92, 4626, 4103, 28/ +data (gchtab(i), i=1071,1075) / 4562, 28, 5084, 5142, 5020/ +data (gchtab(i), i=1076,1080) / 72, 5000, 7, 5063, 5133/ +data (gchtab(i), i=1081,1085) / 4999, 0, 160, 4224, 544/ +data (gchtab(i), i=1086,1090) / 4608, 0, 23, 4121, 4187/ +data (gchtab(i), i=1091,1095) / 4252, 4380, 4443, 4505, 4565/ +data (gchtab(i), i=1096,1100) / 4551, 25, 4251, 4379, 4505/ +data (gchtab(i), i=1101,1105) / 983, 5081, 5019, 4956, 4828/ +data (gchtab(i), i=1106,1110) / 4763, 4697, 4629, 4615, 985/ +data (gchtab(i), i=1111,1115) / 4955, 4827, 4697, 263, 4807/ +data (gchtab(i), i=1116,1120) / 0, 473, 4167, 601, 5063/ +data (gchtab(i), i=1121,1125) / 537, 4999, 205, 4877, 7/ +data (gchtab(i), i=1126,1130) / 4423, 711, 5191, 480, 4447/ +data (gchtab(i), i=1131,1135) / 4381, 4379, 4441, 4568, 4696/ +data (gchtab(i), i=1136,1140) / 4825, 4891, 4893, 4831, 4704/ +data (gchtab(i), i=1141,1145) / 4576, 0, 74, 4231, 4487/ +data (gchtab(i), i=1146,1150) / 4363, 4239, 4178, 4182, 4249/ +data (gchtab(i), i=1151,1155) / 4379, 4572, 4828, 5019, 5145/ +data (gchtab(i), i=1156,1160) / 5206, 5202, 5135, 5003, 4871/ +data (gchtab(i), i=1161,1165) / 5127, 5194, 267, 4302, 4242/ +data (gchtab(i), i=1166,1170) / 4246, 4313, 4443, 4572, 732/ +data (gchtab(i), i=1171,1175) / 4955, 5081, 5142, 5138, 5070/ +data (gchtab(i), i=1176,1180) / 5003, 136, 4424, 840, 5128/ +data (gchtab(i), i=1181,1185) / 0, 157, 4184, 1117, 5144/ +data (gchtab(i), i=1186,1190) / 404, 4431, 852, 4879, 139/ +data (gchtab(i), i=1191,1195) / 4166, 1099, 5126, 155, 5147/ +data (gchtab(i), i=1196,1200) / 154, 5146, 402, 4882, 401/ +data (gchtab(i), i=1201,1205) / 4881, 137, 5129, 136, 5128/ +data (gchtab(i), i=1206,1210) / 0, 604, 4679, 668, 4743/ +data (gchtab(i), i=1211,1215) / 21, 4182, 4309, 4369, 4431/ +data (gchtab(i), i=1216,1220) / 4494, 4621, 86, 4245, 4305/ +data (gchtab(i), i=1221,1225) / 4367, 4430, 4621, 4813, 5006/ +data (gchtab(i), i=1226,1230) / 5071, 5137, 5205, 5270, 717/ +data (gchtab(i), i=1231,1235) / 4942, 5007, 5073, 5141, 5270/ +data (gchtab(i), i=1236,1240) / 5333, 412, 4956, 391, 4935/ +data (gchtab(i), i=1241,1245) / 0, 35, 0, 160, 4224/ +data (gchtab(i), i=1246,1250) / 224, 4288, 160, 4704, 128/ +data (gchtab(i), i=1251,1255) / 4672, 0, 28, 4868, 0/ +data (gchtab(i), i=1256,1260) / 480, 4544, 544, 4608, 96/ +data (gchtab(i), i=1261,1265) / 4640, 64, 4608, 0, 35/ +data (gchtab(i), i=1266,1270) / 0, 1106, 5392, 5198, 917/ +data (gchtab(i), i=1271,1275) / 5328, 5003, 144, 5328, 0/ +data (gchtab(i), i=1276,1280) / 85, 4437, 4809, 277, 4807/ +data (gchtab(i), i=1281,1285) / 1312, 4807, 0, 533, 4436/ +data (gchtab(i), i=1286,1290) / 4306, 4240, 4173, 4170, 4232/ +data (gchtab(i), i=1291,1295) / 4423, 4551, 4680, 4875, 5006/ +data (gchtab(i), i=1296,1300) / 5138, 5205, 533, 4500, 4370/ +data (gchtab(i), i=1301,1305) / 4304, 4237, 4234, 4296, 4423/ +data (gchtab(i), i=1306,1310) / 533, 4757, 4884, 4946, 5066/ +data (gchtab(i), i=1311,1315) / 5128, 5191, 661, 4820, 4882/ +data (gchtab(i), i=1316,1320) / 5002, 5064, 5191, 5255, 0/ +data (gchtab(i), i=1321,1325) / 732, 4635, 4505, 4373, 4306/ +data (gchtab(i), i=1326,1330) / 4238, 4168, 4096, 732, 4699/ +data (gchtab(i), i=1331,1335) / 4569, 4437, 4370, 4302, 4232/ +data (gchtab(i), i=1336,1340) / 4160, 732, 4956, 5083, 5146/ +data (gchtab(i), i=1341,1345) / 5143, 5077, 5012, 4819, 4563/ +data (gchtab(i), i=1346,1350) / 860, 5082, 5079, 5013, 4948/ +data (gchtab(i), i=1351,1355) / 4819, 467, 4818, 4944, 5006/ +data (gchtab(i), i=1356,1360) / 5003, 4937, 4872, 4679, 4551/ +data (gchtab(i), i=1361,1365) / 4424, 4361, 4300, 467, 4754/ +data (gchtab(i), i=1366,1370) / 4880, 4942, 4939, 4873, 4808/ +data (gchtab(i), i=1371,1375) / 4679, 0, 21, 4245, 4372/ +data (gchtab(i), i=1376,1380) / 4434, 4739, 4801, 4864, 149/ +data (gchtab(i), i=1381,1385) / 4308, 4370, 4675, 4737, 4864/ +data (gchtab(i), i=1386,1390) / 4992, 981, 5011, 4880, 4229/ +data (gchtab(i), i=1391,1395) / 4098, 4096, 0, 724, 4693/ +data (gchtab(i), i=1396,1400) / 4565, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1401,1405) / 4233, 4296, 4423, 4551, 4744/ +data (gchtab(i), i=1406,1410) / 4875, 4942, 4945, 4883, 4632/ +data (gchtab(i), i=1411,1415) / 4570, 4572, 4637, 4765, 4892/ +data (gchtab(i), i=1416,1420) / 5018, 469, 4436, 4305, 4238/ +data (gchtab(i), i=1421,1425) / 4234, 4296, 455, 4680, 4811/ +data (gchtab(i), i=1426,1430) / 4878, 4882, 4820, 4695, 4633/ +data (gchtab(i), i=1431,1435) / 4635, 4700, 4828, 5018, 0/ +data (gchtab(i), i=1436,1440) / 850, 4820, 4693, 4437, 4308/ +data (gchtab(i), i=1441,1445) / 4306, 4432, 4623, 341, 4372/ +data (gchtab(i), i=1446,1450) / 4370, 4496, 4623, 527, 4302/ +data (gchtab(i), i=1451,1455) / 4172, 4170, 4232, 4423, 4615/ +data (gchtab(i), i=1456,1460) / 4744, 4874, 527, 4366, 4236/ +data (gchtab(i), i=1461,1465) / 4234, 4296, 4423, 0, 404/ +data (gchtab(i), i=1466,1470) / 4371, 4241, 4174, 4171, 4233/ +data (gchtab(i), i=1471,1475) / 4296, 4423, 4615, 4808, 5002/ +data (gchtab(i), i=1476,1480) / 5133, 5200, 5203, 5077, 4949/ +data (gchtab(i), i=1481,1485) / 4819, 4687, 4554, 4352, 75/ +data (gchtab(i), i=1486,1490) / 4297, 4424, 4616, 4809, 5003/ +data (gchtab(i), i=1491,1495) / 5133, 1107, 5076, 4948, 4818/ +data (gchtab(i), i=1496,1500) / 4687, 4553, 4416, 0, 18/ +data (gchtab(i), i=1501,1505) / 4180, 4309, 4437, 4564, 4627/ +data (gchtab(i), i=1506,1510) / 4688, 4684, 4616, 4416, 19/ +data (gchtab(i), i=1511,1515) / 4244, 4500, 4627, 1045, 5074/ +data (gchtab(i), i=1516,1520) / 5008, 4681, 4484, 4352, 981/ +data (gchtab(i), i=1521,1525) / 5010, 4944, 4681, 0, 17/ +data (gchtab(i), i=1526,1530) / 4115, 4245, 4437, 4500, 4498/ +data (gchtab(i), i=1531,1535) / 4430, 4295, 277, 4436, 4434/ +data (gchtab(i), i=1536,1540) / 4366, 4231, 334, 4562, 4692/ +data (gchtab(i), i=1541,1545) / 4821, 4949, 5076, 5139, 5136/ +data (gchtab(i), i=1546,1550) / 5067, 4864, 853, 5075, 5072/ +data (gchtab(i), i=1551,1555) / 5003, 4800, 0, 277, 4238/ +data (gchtab(i), i=1556,1560) / 4170, 4168, 4231, 4423, 4553/ +data (gchtab(i), i=1561,1565) / 4619, 341, 4302, 4234, 4232/ +data (gchtab(i), i=1566,1570) / 4295, 0, 848, 4883, 4820/ +data (gchtab(i), i=1571,1575) / 4693, 4565, 4372, 4241, 4174/ +data (gchtab(i), i=1576,1580) / 4171, 4233, 4296, 4423, 4551/ +data (gchtab(i), i=1581,1585) / 4744, 4874, 4941, 5010, 5015/ +data (gchtab(i), i=1586,1590) / 4954, 4891, 4764, 4572, 4443/ +data (gchtab(i), i=1591,1595) / 4378, 4377, 4441, 4442, 469/ +data (gchtab(i), i=1596,1600) / 4436, 4305, 4238, 4234, 4296/ +data (gchtab(i), i=1601,1605) / 455, 4680, 4810, 4877, 4946/ +data (gchtab(i), i=1606,1610) / 4951, 4890, 4764, 0, 277/ +data (gchtab(i), i=1611,1615) / 4103, 341, 4167, 917, 5076/ +data (gchtab(i), i=1616,1620) / 5140, 5077, 4949, 4820, 4560/ +data (gchtab(i), i=1621,1625) / 4431, 4303, 335, 4558, 4680/ +data (gchtab(i), i=1626,1630) / 4743, 335, 4494, 4616, 4679/ +data (gchtab(i), i=1631,1635) / 4807, 4936, 5067, 0, 92/ +data (gchtab(i), i=1636,1640) / 4316, 4443, 4506, 4568, 4938/ +data (gchtab(i), i=1641,1645) / 5000, 5063, 220, 4442, 4504/ +data (gchtab(i), i=1646,1650) / 4874, 4936, 5063, 5127, 533/ +data (gchtab(i), i=1651,1655) / 4103, 533, 4167, 0, 341/ +data (gchtab(i), i=1656,1660) / 4096, 405, 4096, 338, 4364/ +data (gchtab(i), i=1661,1665) / 4361, 4487, 4615, 4744, 4874/ +data (gchtab(i), i=1666,1670) / 5005, 1045, 4938, 4936, 4999/ +data (gchtab(i), i=1671,1675) / 5191, 5321, 5387, 1109, 5002/ +data (gchtab(i), i=1676,1680) / 5000, 5063, 0, 277, 4231/ +data (gchtab(i), i=1681,1685) / 341, 4367, 4298, 4231, 981/ +data (gchtab(i), i=1686,1690) / 5009, 4877, 1045, 5074, 5008/ +data (gchtab(i), i=1691,1695) / 4877, 4747, 4553, 4424, 4231/ +data (gchtab(i), i=1696,1700) / 85, 4437, 0, 469, 4372/ +data (gchtab(i), i=1701,1705) / 4241, 4174, 4171, 4233, 4296/ +data (gchtab(i), i=1706,1710) / 4423, 4551, 4744, 4875, 4942/ +data (gchtab(i), i=1711,1715) / 4945, 4883, 4820, 4693, 4565/ +data (gchtab(i), i=1716,1720) / 469, 4436, 4305, 4238, 4234/ +data (gchtab(i), i=1721,1725) / 4296, 455, 4680, 4811, 4878/ +data (gchtab(i), i=1726,1730) / 4882, 4820, 0, 468, 4295/ +data (gchtab(i), i=1731,1735) / 468, 4359, 852, 4935, 852/ +data (gchtab(i), i=1736,1740) / 4999, 18, 4244, 4437, 5269/ +data (gchtab(i), i=1741,1745) / 18, 4243, 4436, 5268, 0/ +data (gchtab(i), i=1746,1750) / 17, 4115, 4245, 4437, 4500/ +data (gchtab(i), i=1751,1755) / 4498, 4429, 4426, 4488, 4551/ +data (gchtab(i), i=1756,1760) / 277, 4436, 4434, 4365, 4362/ +data (gchtab(i), i=1761,1765) / 4424, 4551, 4679, 4808, 4938/ +data (gchtab(i), i=1766,1770) / 5069, 5136, 5205, 5209, 5147/ +data (gchtab(i), i=1771,1775) / 5020, 4892, 4762, 4760, 4821/ +data (gchtab(i), i=1776,1780) / 4946, 5072, 5262, 712, 4939/ +data (gchtab(i), i=1781,1785) / 5005, 5072, 5141, 5145, 5083/ +data (gchtab(i), i=1786,1790) / 5020, 0, 140, 4297, 4360/ +data (gchtab(i), i=1791,1795) / 4487, 4615, 4808, 4939, 5006/ +data (gchtab(i), i=1796,1800) / 5009, 4947, 4884, 4757, 4629/ +data (gchtab(i), i=1801,1805) / 4436, 4305, 4238, 4096, 519/ +data (gchtab(i), i=1806,1810) / 4744, 4875, 4942, 4946, 4884/ +data (gchtab(i), i=1811,1815) / 533, 4500, 4369, 4302, 4096/ +data (gchtab(i), i=1816,1820) / 0, 1109, 4565, 4372, 4241/ +data (gchtab(i), i=1821,1825) / 4174, 4171, 4233, 4296, 4423/ +data (gchtab(i), i=1826,1830) / 4551, 4744, 4875, 4942, 4945/ +data (gchtab(i), i=1831,1835) / 4883, 4820, 4693, 469, 4436/ +data (gchtab(i), i=1836,1840) / 4305, 4238, 4234, 4296, 455/ +data (gchtab(i), i=1841,1845) / 4680, 4811, 4878, 4882, 4820/ +data (gchtab(i), i=1846,1850) / 724, 5204, 0, 596, 4487/ +data (gchtab(i), i=1851,1855) / 596, 4551, 18, 4244, 4437/ +data (gchtab(i), i=1856,1860) / 5141, 18, 4243, 4436, 5140/ +data (gchtab(i), i=1861,1865) / 0, 17, 4115, 4245, 4437/ +data (gchtab(i), i=1866,1870) / 4500, 4498, 4364, 4361, 4487/ +data (gchtab(i), i=1871,1875) / 277, 4436, 4434, 4300, 4297/ +data (gchtab(i), i=1876,1880) / 4360, 4487, 4551, 4744, 4874/ +data (gchtab(i), i=1881,1885) / 5005, 5072, 5075, 5013, 4948/ +data (gchtab(i), i=1886,1890) / 5011, 5072, 909, 5075, 0/ +data (gchtab(i), i=1891,1895) / 35, 0, 145, 4371, 4564/ +data (gchtab(i), i=1896,1900) / 4501, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1901,1905) / 4232, 4295, 4423, 4552, 4683/ +data (gchtab(i), i=1906,1910) / 4750, 75, 4233, 4296, 4424/ +data (gchtab(i), i=1911,1915) / 4553, 4683, 590, 4683, 4744/ +data (gchtab(i), i=1916,1920) / 4807, 4935, 5064, 5195, 5262/ +data (gchtab(i), i=1921,1925) / 5265, 5204, 5141, 5076, 5203/ +data (gchtab(i), i=1926,1930) / 5265, 587, 4745, 4808, 4936/ +data (gchtab(i), i=1931,1935) / 5065, 5195, 0, 604, 4571/ +data (gchtab(i), i=1936,1940) / 4506, 4505, 4568, 4759, 4951/ +data (gchtab(i), i=1941,1945) / 663, 4502, 4373, 4307, 4305/ +data (gchtab(i), i=1946,1950) / 4431, 4622, 4814, 663, 4566/ +data (gchtab(i), i=1951,1955) / 4437, 4371, 4369, 4495, 4622/ +data (gchtab(i), i=1956,1960) / 526, 4365, 4236, 4170, 4168/ +data (gchtab(i), i=1961,1965) / 4294, 4612, 4675, 4673, 4544/ +data (gchtab(i), i=1966,1970) / 4416, 526, 4429, 4300, 4234/ +data (gchtab(i), i=1971,1975) / 4232, 4358, 4612, 0, 860/ +data (gchtab(i), i=1976,1980) / 4544, 924, 4480, 17, 4115/ +data (gchtab(i), i=1981,1985) / 4245, 4437, 4500, 4498, 4429/ +data (gchtab(i), i=1986,1990) / 4426, 4552, 4744, 4873, 5068/ +data (gchtab(i), i=1991,1995) / 5199, 277, 4436, 4434, 4365/ +data (gchtab(i), i=1996,2000) / 4362, 4424, 4551, 4743, 4872/ +data (gchtab(i), i=2001,2005) / 5002, 5133, 5199, 5333, 0/ +data (gchtab(i), i=2006,2010) / 604, 4571, 4506, 4505, 4568/ +data (gchtab(i), i=2011,2015) / 4759, 5079, 5080, 4887, 4629/ +data (gchtab(i), i=2016,2020) / 4435, 4240, 4173, 4171, 4233/ +data (gchtab(i), i=2021,2025) / 4423, 4613, 4675, 4673, 4608/ +data (gchtab(i), i=2026,2030) / 4480, 4417, 662, 4499, 4304/ +data (gchtab(i), i=2031,2035) / 4237, 4235, 4297, 4423, 0/ +data (gchtab(i), i=2036,2040) / 480, 4447, 4382, 4316, 4314/ +data (gchtab(i), i=2041,2045) / 4376, 4439, 4501, 4499, 4369/ +data (gchtab(i), i=2046,2050) / 351, 4381, 4379, 4441, 4504/ +data (gchtab(i), i=2051,2055) / 4566, 4564, 4498, 4240, 4494/ +data (gchtab(i), i=2056,2060) / 4556, 4554, 4488, 4423, 4357/ +data (gchtab(i), i=2061,2065) / 4355, 4417, 271, 4493, 4491/ +data (gchtab(i), i=2066,2070) / 4425, 4360, 4294, 4292, 4354/ +data (gchtab(i), i=2071,2075) / 4417, 4544, 0, 160, 4224/ +data (gchtab(i), i=2076,2080) / 544, 4608, 0, 224, 4447/ +data (gchtab(i), i=2081,2085) / 4510, 4572, 4570, 4504, 4439/ +data (gchtab(i), i=2086,2090) / 4373, 4371, 4497, 351, 4509/ +data (gchtab(i), i=2091,2095) / 4507, 4441, 4376, 4310, 4308/ +data (gchtab(i), i=2096,2100) / 4370, 4624, 4366, 4300, 4298/ +data (gchtab(i), i=2101,2105) / 4360, 4423, 4485, 4483, 4417/ +data (gchtab(i), i=2106,2110) / 399, 4365, 4363, 4425, 4488/ +data (gchtab(i), i=2111,2115) / 4550, 4548, 4482, 4417, 4288/ +data (gchtab(i), i=2116,2120) / 0, 338, 4240, 4430, 533/ +data (gchtab(i), i=2121,2125) / 4304, 4619, 208, 5392, 0/ +data (gchtab(i), i=2126,2130) / 284, 4251, 4185, 4183, 4245/ +data (gchtab(i), i=2131,2135) / 4372, 4500, 4629, 4695, 4697/ +data (gchtab(i), i=2136,2139) / 4635, 4508, 4380, 0/ diff --git a/sys/gio/fonts/greekc.txt b/sys/gio/fonts/greekc.txt new file mode 100644 index 00000000..3dbbf454 --- /dev/null +++ b/sys/gio/fonts/greekc.txt @@ -0,0 +1,96 @@ +2199 +2214 +2213 +2275 +2274 +2271 +2272 +2251 +2221 +2222 +8004 +8002 +8063 +8003 +2210 +8089 +2200 +2201 +2202 +2203 +2204 +2205 +2206 +2207 +2208 +2209 +8081 +2213 +8007 +8033 +8008 +8032 +2273 +2078 +8064 +2199 +2030 +8073 +2047 +2029 +733 +8090 +8079 +2199 +2037 +8075 +8077 +2041 +2042 +2034 +2271 +2044 +8090 +2046 +2078 +2050 +2040 +2049 +2199 +2223 +804 +2224 +2199 +8074 +8067 +2127 +2128 +2148 +2130 +2131 +2147 +2129 +2133 +2135 +8078 +2136 +2137 +2138 +2139 +2141 +2142 +2134 +2143 +2144 +2145 +2146 +2199 +2150 +2140 +2149 +2132 +2225 +8090 +2226 +8076 +2218 diff --git a/sys/gio/fonts/mkfont.c b/sys/gio/fonts/mkfont.c new file mode 100644 index 00000000..841d99f5 --- /dev/null +++ b/sys/gio/fonts/mkfont.c @@ -0,0 +1,199 @@ +#include + +#define DEBUG 0 +#define MASK 0x3F +#define SCALE 1.0 + +#define max(a,b) (a > b ? a : b) +#define min(a,b) (a < b ? a : b) +/* +#define XCOORD() ((*dp - 'R') + 9) +#define YCOORD() (('R' - *dp) + 14) +#define XCOORD() (max(0,min(20,((int)(((*dp - 'R') + 9)*SCALE+0.5))))) +#define XCOORD() (max(0,min(20,((int)(((*dp - 'R') - minx)*SCALE+0.5))))) +#define YCOORD() ((int)((('R' - *dp) + 13) * SCALE + 0.5)) +#define XCOORD() ((int)(((*dp - 'R') - minx) * SCALE + 0.5)) +#define YCOORD() (max(0,min(32,(((int)(('R' - *dp) + 13)*SCALE+0.5))))) +*/ +#define XCOORD() (max(0,((int)(((*dp - 'R') - minx - 2) * SCALE + 0.5)))) +#define YCOORD() (max(0,min(35,(((int)(('R' - *dp) + 16)*SCALE+0.5))))) +#define ENCODE(pen,x,y) ((int)(((pen<<12)|((x&MASK)<<6))|(y&MASK))) + +int chridx[200]; /* Character index table */ +int chrwid[200]; /* Character width table */ +int chrtab[5000]; /* Character stroke table */ + + +struct hershey_tab { + int num; /* hershey number */ + int length; /* length */ + char *code; /* stroke data string */ +} htab[] = { +#include "hershey.dat" +}; + +int encode(); + + +main (argc, argv) +int argc; +char *argv[]; +{ + register int i=0; + int minx, maxx, charnum=0, idx=0, hnum, hindex, hlength; + short x, y, pen, xspace, yspace; + char ch, *dp, *data; + + /* Read all the hershey numbers from standard input and build up a + * table of stroke data. + */ + ch = 32; + while (scanf ("%d", &hnum) != EOF) { + + chridx[charnum] = idx + 1; + + /* Get the index for the given number. */ + for (hindex=0; hnum != htab[hindex].num; hindex++) + ; + + hlength = htab[hindex].length; + dp = data = htab[hindex].code; + + if (DEBUG) + printf ("'%c' %4d: index=%4d len=%3d dlen=%3d %s\n", + ch, hnum, hindex, hlength, strlen(data), + (strlen(data) % 2) ? "ERROR" : ""); + + /* Now decode the stroke data into X-Y pairs, first pair is for + * proportional spacing. + */ + minx = (*dp - 'R'); dp++; + maxx = (*dp - 'R'); dp++; + chrwid[charnum++] = min (32, maxx - minx + 5); + + if (DEBUG) printf("\twidth (%02d) (%d,%d)\n", maxx-minx,minx,maxx); + + /* Next pair is the initial move. The Y coords are flipped + * for what we need so fix that every place we get a Yval. + */ + pen = 0; + x = XCOORD(); dp++; +x = (ch == '1' ? x-3: x); + y = YCOORD(); dp++; + chrtab[idx++] = ENCODE(pen, x, y); + + if (DEBUG) printf ("\tmove (%3d,%3d) '%s'\n", x, y, dp); + + /* The remainder of the codes are move/draw strokes. + */ + for (i=0; i < (hlength-2); i++) { + if (*dp == ' ') { + pen = 0; + x = XCOORD(); dp++; /* skip pen-up coords */ +x = (ch == '1' ? x-3: x); + y = YCOORD(); dp++; + i++; + } else + pen = 1; + x = XCOORD(); dp++; +x = (ch == '1' ? x-3: x); + y = YCOORD(); dp++; + + chrtab[idx++] = ENCODE(pen, x, y); + + if (DEBUG) + printf("\t%s (%3d,%3d) => %6d\n", + pen?"draw":"move", x, y, ENCODE(pen,x,y)); + } + chrtab[idx++] = ENCODE(0, 0, 0); + ch++; + } + + print_prologue (charnum, idx); + print_index (chridx, charnum); + printf ("\n\n# Width data.\n\n"); + print_widths (chrwid, charnum); + printf ("\n\n# Stroke data.\n\n"); + print_strokes (chrtab, idx); +} + + +print_index (idxtab, N) +int *idxtab, N; +{ + register int i, j, start=1, end=5; + + for (i=0; i < N; ) { + printf ("data (chridx(i), i=%03d,%03d) /", start, min(N,end)); + for (j=0; j < 5 && i < N; j++) + printf ("%5d%c", idxtab[i++], (j<4 && i + +# FP_EQUALD -- The following procedure is used to compare two double precision +# numbers for equality to within the machine precision for doubles. A simple +# comparison of the difference of the two numbers with the machine epsilon +# does not suffice unless the numbers are first normalized to near 1.0, the +# constant used to compute the machine epsilon (epsilon is the smallest number +# such that 1.0 + epsilon > 1.0). + +bool procedure fp_equald (x, y) + +double x, y +double x1, x2, normx, normy, tol +int ex, ey + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normd (x, normx, ex) + call fp_normd (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILOND * 32.0D0 + x1 = 1.0D0 + abs (normx - normy) + x2 = 1.0D0 + tol + return (x1 <= x2) + } +end diff --git a/sys/gio/fpequalr.x b/sys/gio/fpequalr.x new file mode 100644 index 00000000..8e9a9354 --- /dev/null +++ b/sys/gio/fpequalr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_EQUALR -- The following procedure is used to compare two single precision +# numbers for equality to within the machine precision for single. A simple +# comparison of the difference of the two numbers with the machine epsilon +# does not suffice unless the numbers are first normalized to near 1.0, the +# constant used to compute the machine epsilon (epsilon is the smallest number +# such that 1.0 + epsilon > 1.0). + +bool procedure fp_equalr (x, y) + +real x, y +real x1, x2, normx, normy, tol +int ex, ey + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normr (x, normx, ex) + call fp_normr (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILONR * 32.0 + x1 = 1.0E0 + abs (normx - normy) + x2 = 1.0E0 + tol + return (x1 <= x2) + } +end diff --git a/sys/gio/fpfixd.x b/sys/gio/fpfixd.x new file mode 100644 index 00000000..64a2f544 --- /dev/null +++ b/sys/gio/fpfixd.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_FIXD -- The following procedure is equivalent to "int(x)", except that +# it preserves the most significant digits of x, when x is greater than the +# largest integer. For example, if an integer is 32 bits and X has a 58 bit +# mantissa, "int(x)" would cause nearly half the precision to be lost. +# +# Algorithm (x is assumed nonnegative): +# (1) find high, low x such that x = highx + lowx +# and highx contains the extra digits of precision. +# (2) subtract highx from x, and truncate the residual by assignment +# into a long integer. +# (3) add truncated lowx and highx to get high precision truncated +# double result. + +double procedure fp_fixd (x) + +double x +double absx, highx, scaledx +int expon +long longx, lowx + +begin + absx = abs (x) + scaledx = absx + expon = 0 + + while (scaledx > MAX_LONG) { + scaledx = scaledx / 10.0D0 + expon = expon + 1 + } + + longx = scaledx + highx = longx * (10.0D0 ** expon) + lowx = absx - highx + + if (x > 0) + return (highx + lowx) + else + return (-highx - lowx) +end diff --git a/sys/gio/fpfixr.x b/sys/gio/fpfixr.x new file mode 100644 index 00000000..fe67c5b8 --- /dev/null +++ b/sys/gio/fpfixr.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_FIXR -- The following procedure is equivalent to "int(x)", except that +# it preserves the most significant digits of x, when x is greater than the +# largest integer. For example, if an integer is 32 bits and X has a 58 bit +# mantissa, "int(x)" would cause nearly half the precision to be lost. +# +# Algorithm (x is assumed nonnegative): +# (1) find high, low x such that x = highx + lowx +# and highx contains the extra digits of precision. +# (2) subtract highx from x, and truncate the residual by assignment +# into a long integer. +# (3) add truncated lowx and highx to get high precision truncated +# real or double result. + +real procedure fp_fixr (x) + +real x +real absx, highx, scaledx +int expon +long longx, lowx + +begin + absx = abs (x) + scaledx = absx + expon = 0 + + while (scaledx > MAX_LONG) { + scaledx = scaledx / 10.0E0 + expon = expon + 1 + } + + longx = scaledx + highx = longx * (10.0E0 ** expon) + lowx = absx - highx + + if (x > 0) + return (highx + lowx) + else + return (-highx - lowx) +end diff --git a/sys/gio/fpndgr.x b/sys/gio/fpndgr.x new file mode 100644 index 00000000..ae471e34 --- /dev/null +++ b/sys/gio/fpndgr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FP_NONDEGENR -- If two floating point numbers are equivalent to within the +# machine epsilon, adjust their values until a nondegenerate range is obtained. +# The boolean function returns true if it has to MAKE the range nondegenerate, +# i.e., if it modifies their values. + +bool procedure fp_nondegenr (x1, x2) + +real x1, x2 # range to be adjusted +int n +bool fp_equalr() + +begin + for (n=0; fp_equalr(x1,x2); n=n+1) { + x1 = x1 - max (abs(x1) * 0.01, 0.01) + x2 = x2 + max (abs(x2) * 0.01, 0.01) + } + + return (n > 0) +end diff --git a/sys/gio/fpnormd.x b/sys/gio/fpnormd.x new file mode 100644 index 00000000..067ef1e0 --- /dev/null +++ b/sys/gio/fpnormd.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_NORMD -- Normalize a double precision number x to the value NORMX, in the +# range [1-10). EXPON is returned such that x = normx * (10.0d0 ** expon). + +procedure fp_normd (x, normx, expon) + +double x # number to be normalized +double normx # X normalized to the range 1-10 (output) +int expon # exponent of normalized X +double absx, tol + +begin + tol = EPSILOND * 10.0D0 + absx = abs (x) + expon = 0 + + if (absx > 0) { + while (absx < (1.0D0 - tol)) { + absx = absx * 10.0D0 + expon = expon - 1 + if (absx == 0.0D0) { # check for underflow to zero + normx = 0 + expon = 0 + return + } + } + while (absx >= (10.0D0 + tol)) { + absx = absx / 10.0D0 + expon = expon + 1 + } + } + + if (x < 0) + normx = -absx + else + normx = absx +end diff --git a/sys/gio/fpnormr.x b/sys/gio/fpnormr.x new file mode 100644 index 00000000..45ad3f2a --- /dev/null +++ b/sys/gio/fpnormr.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_NORMR -- Normalize a single precision number x to the value NORMX, in the +# range [1-10). EXPON is returned such that x = normx * (10.0E0 ** expon). + +procedure fp_normr (x, normx, expon) + +real x # number to be normalized +real normx # X normalized to the range 1-10 (output) +int expon # exponent of normalized X +real absx, tol + +begin + tol = EPSILONR * 10.0 + absx = abs (x) + expon = 0 + + if (absx > 0) { + while (absx < (1.0E0 - tol)) { + absx = absx * 10.0E0 + expon = expon - 1 + if (absx == 0.0) { # check for underflow to zero + normx = 0 + expon = 0 + return + } + } + while (absx >= (10.0E0 + tol)) { + absx = absx / 10.0E0 + expon = expon + 1 + } + } + + if (x < 0) + normx = -absx + else + normx = absx +end diff --git a/sys/gio/gactivate.x b/sys/gio/gactivate.x new file mode 100644 index 00000000..6d3c8da7 --- /dev/null +++ b/sys/gio/gactivate.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GACTIVATE -- Perform the initial activation of the workstation, i.e., +# connect to the graphics kernel and issue the GKI_OPENWS instruction to +# the kernel to physically open the workstation. + +procedure gactivate (gp, flags) + +pointer gp # graphics descriptor +int flags # AW_ bit flags; zero if no flags + +int junk, fd +pointer w, sp, devname + +extern zardbf() +int fstati(), grdwcs(), and(), locpr() +errchk gki_openws, gki_getwcs, gki_reactivatews + +begin + # If WS has already been opened, just make sure it is activated. + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + if (and (GP_GFLAGS(gp), GF_WSACTIVE) == 0) { + call gki_reactivatews (GP_FD(gp), flags) + GP_GFLAGS(gp) = GP_GFLAGS(gp) + GF_WSACTIVE + } + return + } + + call smark (sp) + call salloc (devname, SZ_PATHNAME, TY_CHAR) + + fd = GP_FD(gp) + + # Physically open and activate the workstation. NOTE - the flags + # argument is currently ignored; this should be fixed at some point. + # The UI specification file name, if any, is passed as part of the + # logical device specification (a bit of a kludge, but it avoids + # changing the GKI datastream prototcol and hence obsoleting all the + # old graphics kernels). + + if (GP_UIFNAME(gp) != EOS) { + # gki_openws device = devname,uifname. + call sprintf (Memc[devname], SZ_PATHNAME, "%s,%s") + call pargstr (GP_DEVNAME(gp)) + call pargstr (GP_UIFNAME(gp)) + } else + call strcpy (GP_DEVNAME(gp), Memc[devname], SZ_PATHNAME) + + call gki_openws (fd, Memc[devname], GP_ACMODE(gp)) + + # If the device is being opened in APPEND mode retrieve the WCS + # from either the GIO code in the CL process (if talking to a + # process the FIO driver will not be the standard binary file + # driver) or from an auxiliary file if the device output is being + # spooled in a metafile. + + if (GP_ACMODE(gp) == APPEND) { + w = GP_WCSPTR(gp,1) + if (fstati (fd, F_DEVICE) != locpr (zardbf)) + call gki_getwcs (fd, Memi[w], LEN_WCSARRAY) + else iferr (junk = grdwcs(GP_DEVNAME(gp), Memi[w], LEN_WCSARRAY)) + ; + } + + GP_GFLAGS(gp) = GP_GFLAGS(gp) + (GF_WSOPEN+GF_WSACTIVE) + call sfree (sp) +end diff --git a/sys/gio/gadraw.x b/sys/gio/gadraw.x new file mode 100644 index 00000000..4d8ac8b8 --- /dev/null +++ b/sys/gio/gadraw.x @@ -0,0 +1,284 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define MOVE 0 +define DRAW 1 + +# GADRAW -- Draw absolute. This is the primary line drawing primitive, used +# to transform and clip polylines, polymarkers, and polygons (fill area). +# Our function is to handle INDEFS, the normalization transformation, and +# clipping, building up a polyline in GKI coordinates. Each call processes +# a point of the input polyline, adding zero, one, or two points to the output +# clipped polyline, which is buffered internally in the static polyline buffer +# PL. Plotting an INDEF terminates the polyline and starts a new one, causing +# a gap to appear in the plotted polyline. Long polylines are broken up into +# shorter polylines to simplify buffering. The transformation parameters are +# computed and cached in the GPL common for maximum efficiency. + +procedure gadraw (gp, wx, wy) + +pointer gp # graphics descriptor +real wx, wy # absolute world coordinates of next point + +int i +real x, y +long mx, my +bool inbounds +include "gpl.com" + +begin + # Update cached transformation parameters if device changes or cache + # is invalidated by setting gp_out to null. If the WCS changes it + # is not necessary to flush the polyline but we must update the + # cached transformation parameters. + + if (gp != gp_out) { + call gpl_flush() + call gpl_cache (gp) + } else if (GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Break polyline (visible break in the plotted line) if point is + # indefinite. + + if (IS_INDEFR(wx) || IS_INDEFR(wy)) { + call gamove (gp, wx, wy) + return + } + + # Transform point (wx,wy) to long integer NDC coordinates in the range + # 0 to GKI_MAXNDC. This combines the WCS->NDC->GKI transformations into + # a single transformation and permits use of integer arithmetic for + # clipping. Long integer arithmetic is necessary to provide sufficient + # precision to represent GKI_MAXNDC**2, the largest possible integer + # value in an expression. + + if (xtran == LINEAR && ytran == LINEAR) { + # Optimize the case linear. + x = max (0.0, min (real(GKI_MAXNDC), + ((wx - wxorigin) * xscale) + mxorigin)) + y = max (0.0, min (real(GKI_MAXNDC), + ((wy - wyorigin) * yscale) + myorigin)) + } else { + # General case. + call gpl_wcstogki (gp, wx, wy, x, y) + } + + # Check to see if this is the first point of a new polyline. If so we + # must set the first physical point in the output polyline to the + # current position, making the current point the second physical point + # of the output polyline. If the current position is indefinite + # then we take the current point to define the current position and + # it is put into the polyline on the next call. + + if (op == 1) { + if (IS_INDEF(cx) || IS_INDEF(cy)) { + cx = x + cy = y + return + + } else { + # Place the current pen position in the polyline as the + # first point if it is inbounds. + + mx = cx + my = cy + if (my <= my2 && my >= my1 && mx <= mx2 && mx >= mx1) { + last_point_inbounds = true + pl[op] = mx + op = op + 1 + pl[op] = my + op = op + 1 + } else { + last_point_inbounds = false + do i = 1, 4 { + xs[i] = cx + ys[i] = cy + } + } + } + } + + # Update the current position, maintained in GKI coordinates to make + # the current position invariant with respect to changes in the + # current WCS. The current position is maintained in floating point + # to minimize the accumulation of errors in relative moves and draws. + + cx = x + cy = y + + # Convert to long integer metacode coords for clipping. + + mx = x + my = y + + # Clip at either the viewport boundary or the edge of the device screen, + # if clipping is "disabled". Clipping is performed in NDC space rather + # than world space because NDC space is simpler (mx1 < mx2, my1 < my2, + # no log scaling), and because we need to clip at the device screen + # boundary anyhow. If the boundary is crossed the polyline is broken. + # A line segment may lie entirely outside the viewport, entirely inside, + # may cross from inside to outside, from outside to inside, or may + # cross twice (cross two different boundaries). The clipping algorithm + # used (Harrington, 1983; Sutherland and Hodgman, 1974) clips at each + # of the four boundaries in sequence, using the clipped point from the + # previous iteration as input to the next. It isn't simple but neither + # is the problem. The code is optimized for the usual inbounds case. + # Clipped points are discarded. + + inbounds = (my <= my2 && my >= my1 && mx <= mx2 && mx >= mx1) + + if (inbounds && (last_point_inbounds || pl_pointmode == YES)) { + # Add point to polyline (the fast way). + pl[op] = mx + op = op + 1 + pl[op] = my + op = op + 1 + + } else if (pl_pointmode == NO) { + if (last_point_inbounds) { + # Update coords of last point drawn (necessary since we did + # not use the clipping code for inbounds points). + do i = 1, 4 { + xs[i] = pl[op-2] + ys[i] = pl[op-1] + } + } + call gpl_clipl (DRAW, mx, my) + } + + last_point_inbounds = inbounds + + # Break long polylines to avoid overflowing the polyline output + # buffer. The output buffer contains two cells for each output + # point (x,y pair). There must be space for at least two points + # (four cells) left in the buffer, since a single clip operation + # can add up to two points to the polyline. OP points to the next + # available cell. + + if (op > LEN_PLBUF - 2) + call gpl_flush() +end + + +# GPL_CLIPL -- Clip at left boundary. + +procedure gpl_clipl (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +int newpen +include "gpl.com" + +begin + # Does line cross boundary? + if ((mx >= mx1 && xs[1] < mx1) || (mx <= mx1 && xs[1] > mx1)) { + if (mx >= mx1) + newpen = MOVE + else + newpen = pen + call gpl_clipr (newpen, mx1, + (my - ys[1]) * (mx1 - mx) / (mx - xs[1]) + my) + } + + xs[1] = mx + ys[1] = my + + if (mx >= mx1) + call gpl_clipr (pen, mx, my) +end + + +# GPL_CLIPR -- Clip at right boundary. + +procedure gpl_clipr (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +int newpen +include "gpl.com" + +begin + # Does line cross boundary? + if ((mx <= mx2 && xs[2] > mx2) || (mx >= mx2 && xs[2] < mx2)) { + if (mx <= mx2) + newpen = MOVE + else + newpen = pen + call gpl_clipb (newpen, mx2, + (my - ys[2]) * (mx2 - mx) / (mx - xs[2]) + my) + } + + xs[2] = mx + ys[2] = my + + if (mx <= mx2) + call gpl_clipb (pen, mx, my) +end + + +# GPL_CLIPB -- Clip at bottom boundary. + +procedure gpl_clipb (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +int newpen +include "gpl.com" + +begin + # Does line cross boundary? + if ((my >= my1 && ys[3] < my1) || (my <= my1 && ys[3] > my1)) { + if (my >= my1) + newpen = MOVE + else + newpen = pen + call gpl_clipt (newpen, + (mx - xs[3]) * (my1 - my) / (my - ys[3]) + mx, my1) + } + + xs[3] = mx + ys[3] = my + + if (my >= my1) + call gpl_clipt (pen, mx, my) +end + + +# GPL_CLIPT -- Clip at top boundary and put the final clipped point(s) in +# the output polyline. Note that a "move" at this level does not affect +# the current position (cx,cy), since the vector endpoints have been clipped +# and the current position vector follows the unclipped vector points input +# by the user. + +procedure gpl_clipt (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +include "gpl.com" + +begin + # Does line cross boundary? + if ((my <= my2 && ys[4] > my2) || (my >= my2 && ys[4] < my2)) { + if (my <= my2 || pen == MOVE) + call gpl_flush() + pl[op] = (mx - xs[4]) * (my2 - my) / (my - ys[4]) + mx + op = op + 1 + pl[op] = my2 + op = op + 1 + } + + xs[4] = mx + ys[4] = my + + if (my <= my2) { + if (pen == MOVE) + call gpl_flush() + pl[op] = mx + op = op + 1 + pl[op] = my + op = op + 1 + } +end diff --git a/sys/gio/gamove.x b/sys/gio/gamove.x new file mode 100644 index 00000000..7c40d1b7 --- /dev/null +++ b/sys/gio/gamove.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GAMOVE -- Absolute move. Move the pen to the indicated position in +# preparation for a draw. + +procedure gamove (gp, x, y) + +pointer gp # graphics descriptor +real x, y # new position of pen +include "gpl.com" + +begin + if (op > 1) + call gpl_flush() + + if (IS_INDEF(x) || IS_INDEF(y)) { + # Set current position to indefinite. + cx = INDEF + cy = INDEF + } else { + # Set current position to (x,y) in GKI coordinates. + call gpl_wcstogki (gp, x, y, cx, cy) + } +end diff --git a/sys/gio/gascale.x b/sys/gio/gascale.x new file mode 100644 index 00000000..f2b29926 --- /dev/null +++ b/sys/gio/gascale.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GASCALE -- Scale the world coordinates of either the X or Y axis to fit the +# data vector. This is done by setting the WCS limits to the minimum and +# maximum pixel values of the data vector. The original WCS limits are +# overwritten. + +procedure gascale (gp, v, npts, axis) + +pointer gp # graphics descriptor +real v[ARB] # data vector +int npts # length of data vector +int axis # asis to be scaled (1=X, 2=Y) + +int start, i +real minval, maxval, pixval +pointer w + +begin + # Find first definite valued pixel. If entire data vector is + # indefinite we cannot perform our function and must abort. + + for (start=1; start <= npts; start=start+1) + if (!IS_INDEF (v[start])) + break + if (start > npts) + call syserr (SYS_GINDEF) + + minval = v[start] + maxval = minval + + # Compute min and max values of data vector. + do i = start+1, npts { + pixval = v[i] + if (!IS_INDEF(pixval)) + if (pixval < minval) + minval = pixval + else if (pixval > maxval) + maxval = pixval + } + + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Set the window limits. + switch (axis) { + case 1: + WCS_WX1(w) = minval + WCS_WX2(w) = maxval + case 2: + WCS_WY1(w) = minval + WCS_WY2(w) = maxval + default: + call syserr (SYS_GSCALE) + } + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gcancel.x b/sys/gio/gcancel.x new file mode 100644 index 00000000..30e53ce5 --- /dev/null +++ b/sys/gio/gcancel.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GCANCEL -- Cancel any buffered graphics output (as far as possible). Should +# be called by interrupt handlers to avoid leaving GIO in a funny state +# following an interrupt. +# +# As far as possible, GKI instructions are built up in internal storage and +# written to the output file in a single write. This decreases the likliehood +# of leaving a botched instruction in the output stream in response to an +# interrupt. Do not call FSETI to cancel the file output because that will +# almost certainly guarantee a botched instruction. Instead, we discard any +# partially built polylines still in GPL storage and append the GKI_CANCEL to +# the output instruction stream. The cancel instruction is passed on to the +# graphics kernel which eventually calls FSETI to cancel its output file +# buffer (containing device instructions). If a metacode reader does detect +# a botched instruction it will scan forward for the next BOI to try to resync +# the instruction stream. + +procedure gcancel (gp) + +pointer gp # graphics descriptor +int and() + +begin + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + call gki_cancel (GP_FD(gp)) + call gki_fflush (GP_FD(gp)) + } + call gfrinit (gp) +end diff --git a/sys/gio/gclear.x b/sys/gio/gclear.x new file mode 100644 index 00000000..a3a5d895 --- /dev/null +++ b/sys/gio/gclear.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GCLEAR -- Clear the screen and initialize all internal state variables to +# the original GOPEN state. Plots separated by calls to GCLEAR cannot affect +# each other. See also GFRAME and GRESET if a full state reset is not +# desired. + +procedure gclear (gp) + +pointer gp # graphics descriptor + +begin + call gactivate (gp, 0) + call gpl_flush() + call gki_clear (GP_FD(gp)) + call greset (gp, GR_RESETALL) +end diff --git a/sys/gio/gclose.x b/sys/gio/gclose.x new file mode 100644 index 00000000..a6802a0a --- /dev/null +++ b/sys/gio/gclose.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GCLOSE -- Close a graphics stream previously opened with GOPEN. Flush any +# buffered polyline output, output the close worstation metacode instruction, +# close the output stream, close the graphcap descriptor, and return all +# buffer space. + +procedure gclose (gp) + +pointer gp # graphics descriptor + +int fd +int and() + +begin + fd = GP_FD(gp) + + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + call gflush (gp) + call gki_closews (fd, GP_DEVNAME(gp)) + + # If the output stream is a file rather than a standard graphics + # stream, write a WCS savefile to permit restoration of the WCS if + # the device is subsequently opened in APPEND mode. + + if (fd > STDPLOT) + call gwrwcs (GP_DEVNAME(gp), + Memi[GP_WCSPTR(gp,1)], LEN_WCSARRAY) + + # If the output file was opened by GOPEN (as indicated by the + # CLOSEFD flag), close the file. + + if (and (GP_GFLAGS(gp), GF_CLOSEFD) != 0) + call close (fd) + else + call flush (fd) + } + + call ttycdes (GP_TTY(gp)) + call mfree (gp, TY_STRUCT) + call gki_redir (fd, NULL, NULL, NULL) + call gexfls_clear (fd) +end diff --git a/sys/gio/gctran.x b/sys/gio/gctran.x new file mode 100644 index 00000000..3c804dc8 --- /dev/null +++ b/sys/gio/gctran.x @@ -0,0 +1,138 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GCTRAN -- Transform a point in world coordinate system WCS_A to world +# coordinate system WCS_B. The transformation is performed by transforming +# from WCS_A to NDC, followed by a transformation from NDC to WCS_B. The +# transformation parameters are cached for efficiency when transforming +# multiple points in the same pairs of coordinate systems. Three types of +# transformations are supported: linear, log, and "elog". The latter is +# a logarithmic function defined for all X, i.e., for negative as well as +# positive X. + +procedure gctran (gp, x1,y1, x2,y2, wcs_a, wcs_b) + +pointer gp # graphics descriptor +real x1, y1 # coords of point in WCS_A (input) +real x2, y2 # coords of point in WCS_B (output) +int wcs_a # input WCS +int wcs_b # output WCS + +int w, a +int wcsord, tran[2,2], wcs[2] +real morigin[2,2], worigin[2,2], scale[2,2], ds +real w1[2,2], w2[2,2], s1[2,2], s2[2,2], p1[2], p2[2] +pointer wp + +bool fp_nondegenr() +real elogr(), aelogr() + +begin + # Verify that the WCS has not changed since we were last called. + # WCSORD is a unique integer (ordinal) assigned by GIO each time a + # WCS is fixed. + + if (GP_WCSSTATE(gp) != FIXED || GP_WCSORD(gp) != wcsord) + wcs[1] = -1 + + # Verify that cached transformation parameters are up to date, and if + # not, recompute them. + + if (wcs[1] != wcs_a || wcs[2] != wcs_b) { + wcsord = GP_WCSORD(gp) + wcs[1] = wcs_a + wcs[2] = wcs_b + + # Copy the WCS parameters into 2-dim arrays so that we can use the + # same code for both axes. + + do w = 1, 2 { + wp = GP_WCSPTR (gp, wcs[w]) + tran[1,w] = WCS_XTRAN(wp) + tran[2,w] = WCS_YTRAN(wp) + + # If the window is degenerate enlarge the window until there + # is enough range to make a plot. + + if (fp_nondegenr (WCS_WX1(wp), WCS_WX2(wp))) + GP_WCSSTATE(gp) = MODIFIED + if (fp_nondegenr (WCS_WY1(wp), WCS_WY2(wp))) + GP_WCSSTATE(gp) = MODIFIED + + w1[1,w] = WCS_WX1(wp) + w2[1,w] = WCS_WX2(wp) + w1[2,w] = WCS_WY1(wp) + w2[2,w] = WCS_WY2(wp) + + s1[1,w] = WCS_SX1(wp) + s2[1,w] = WCS_SX2(wp) + s1[2,w] = WCS_SY1(wp) + s2[2,w] = WCS_SY2(wp) + } + + # Compute the transformation parameters for both axes and both + # world coordinate systems. + + do w = 1, 2 # w = wcs index + do a = 1, 2 { # a = axis + morigin[a,w] = s1[a,w] + ds = s2[a,w] - s1[a,w] + + if (tran[a,w] == LINEAR) { + worigin[a,w] = w1[a,w] + scale[a,w] = ds / (w2[a,w] - w1[a,w]) + } else if (tran[a,w] == LOG && w1[a,w] > 0 && w2[a,w] > 0) { + worigin[a,w] = log10 (w1[a,w]) + scale[a,w] = ds / (log10(w2[a,w]) - worigin[a,w]) + } else { + worigin[a,w] = elogr (w1[a,w]) + scale[a,w] = ds / (elogr(w2[a,w]) - worigin[a,w]) + } + } + } + + p1[1] = x1 + p1[2] = y1 + + # Forward Transformation. Transform P1 (point-A) in wcs_a to NDC + # coordinates, if the input WCS is not number zero (the NDC coordinate + # system). + + if (wcs_a != 0) + do a = 1, 2 { + if (tran[a,1] != LINEAR) + if (tran[a,1] == LOG) { + if (p1[a] <= 0) + p1[a] = INDEF + else + p1[a] = log10 (p1[a]) + } else + p1[a] = elogr (p1[a]) + p1[a] = ((p1[a] - worigin[a,1]) * scale[a,1]) + morigin[a,1] + } + + # Inverse Transformation. Transform point P1, now in NDC coordinates, + # to WCS-B. If WCS-B is zero (NDC), we need only copy the points. + + if (wcs_b == 0) { + p2[1] = p1[1] + p2[2] = p1[2] + } else { + do a = 1, 2 { + if (IS_INDEF (p1[a])) + p2[a] = INDEF + else { + p2[a] = (p1[a] - morigin[a,2]) / scale[a,2] + worigin[a,2] + if (tran[a,2] != LINEAR) + if (tran[a,2] == LOG) + p2[a] = 10.0 ** p2[a] + else + p2[a] = aelogr (p2[a]) + } + } + } + + x2 = p2[1] + y2 = p2[2] +end diff --git a/sys/gio/gcurpos.x b/sys/gio/gcurpos.x new file mode 100644 index 00000000..a0d4cb4d --- /dev/null +++ b/sys/gio/gcurpos.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GCURPOS -- Get the current position in world coordinates. The current +# position is maintained internally in GKI coordinates to make it invariant +# with respect to changes in the current WCS. + +procedure gcurpos (gp, x, y) + +pointer gp # graphics descriptor +real x, y # current position in current WCS (output) + +real aelogr() +include "gpl.com" + +begin + if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + if (IS_INDEF(cx) || IS_INDEF(cy)) { + x = INDEF + y = INDEF + + } else { + x = (cx - mxorigin) / xscale + wxorigin + if (xtran != LINEAR) + if (xtran == LOG) + x = 10.0 ** x + else + x = aelogr (x) + + y = (cy - myorigin) / yscale + wyorigin + if (ytran != LINEAR) + if (ytran == LOG) + y = 10.0 ** y + else + y = aelogr (y) + } +end diff --git a/sys/gio/gdeact.x b/sys/gio/gdeact.x new file mode 100644 index 00000000..f61f4133 --- /dev/null +++ b/sys/gio/gdeact.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GDEACTIVATE -- Deactivate the workstation, i.e., for an interactive device +# (graphics terminal) restore the terminal to text mode. This is similar to +# closing the workstation will gclose, except that the graphics state is +# retained and graphics i/o may be resumed following a subsequent call to +# greactivate. These calls are generally no-ops for noninteractive devices. + +procedure gdeactivate (gp, flags) + +pointer gp # graphics descriptor +int flags # action flags + +int and() +errchk gflush +errchk gki_deactivatews + +begin + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + call gflush (gp) + call gki_deactivatews (GP_FD(gp), flags) + if (and (GP_GFLAGS(gp), GF_WSACTIVE) != 0) + GP_GFLAGS(gp) = GP_GFLAGS(gp) - GF_WSACTIVE + } +end diff --git a/sys/gio/gescape.x b/sys/gio/gescape.x new file mode 100644 index 00000000..c6a1bf63 --- /dev/null +++ b/sys/gio/gescape.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GESCAPE -- Pass a device dependent instruction on to the graphics kernel. +# A unique function code should be assigned each escape function. The graphics +# kernel will ignore escapes with unrecognized function codes. + +procedure gescape (gp, fn, instruction, nwords) + +pointer gp # graphics descriptor +int fn # function code (1 - 32767) +short instruction[ARB] # instruction to be transmitted +int nwords # length of instruction + +begin + call gpl_flush() + call gki_escape (GP_FD(gp), fn, instruction, nwords) +end diff --git a/sys/gio/gfill.x b/sys/gio/gfill.x new file mode 100644 index 00000000..4db5d117 --- /dev/null +++ b/sys/gio/gfill.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFILL -- Fill area. Fill the area defined by the polygon (X[i],Y[i]) in the +# indicated style. + +procedure gfill (gp, x, y, npts, style) + +pointer gp # graphics descriptor +real x[ARB], y[ARB] # polygon +int npts # npts in polygon +int style # style for area fill + +pointer ap + +begin + call gpl_flush() + + ap = GP_FAAP(gp) + if (style != FA_STYLE(ap) || FA_STATE(ap) != FIXED) { + FA_STYLE(ap) = style + call gki_faset (GP_FD(gp), ap) + FA_STATE(ap) = FIXED + } + + call gpl_settype (gp, FILLAREA) + call gpline (gp, x, y, npts) + call gpl_settype (gp, POLYLINE) +end diff --git a/sys/gio/gflush.x b/sys/gio/gflush.x new file mode 100644 index 00000000..ef597da8 --- /dev/null +++ b/sys/gio/gflush.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFLUSH -- Flush the graphics output. A simple call to the FIO flush does not +# suffice since the graphics data stream may be spread over three or more +# processes. Flush any buffered polyline output, append the GKI_FLUSH metacode +# instruction, and flush the FIO buffered metacode output. The other processes +# will take similar actions upon receipt of the GKI_FLUSH instruction. + +procedure gflush (gp) + +pointer gp # graphics descriptor + +begin + call gpl_flush() + call gki_flush (GP_FD(gp)) +end diff --git a/sys/gio/gframe.x b/sys/gio/gframe.x new file mode 100644 index 00000000..02a1e41e --- /dev/null +++ b/sys/gio/gframe.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFRAME -- Clear the screen, but do not modify the internal state of GIO, +# other than to reset the WCS and attribute packet states to UNSET, to force +# retranmission to the graphics kernel. + +procedure gframe (gp) + +pointer gp # graphics descriptor + +begin + call gactivate (gp, 0) + call gpl_flush() + call gki_clear (GP_FD(gp)) + call gfrinit (gp) +end diff --git a/sys/gio/gfrinit.x b/sys/gio/gfrinit.x new file mode 100644 index 00000000..bf8181ed --- /dev/null +++ b/sys/gio/gfrinit.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFRINIT -- Initialize the internal state variables of GIO for a new frame. +# The state of all the attribute packets is set to UNSET to force them to be +# retransmitted to the graphics kernel when i/o occurs. + +procedure gfrinit (gp) + +pointer gp # graphics descriptor +pointer ap + +begin + # Force retransmission of the WCS. + GP_WCSSTATE(gp) = UNSET + + # Force retransmission of the attribute packets. + ap = GP_PLAP(gp); PL_STATE(ap) = UNSET + ap = GP_PMAP(gp); PM_STATE(ap) = UNSET + ap = GP_FAAP(gp); FA_STATE(ap) = UNSET + ap = GP_TXAP(gp); TX_STATE(ap) = UNSET + ap = GP_TXAPCUR(gp); TX_STATE(ap) = UNSET + + call gpl_reset() +end diff --git a/sys/gio/ggcell.x b/sys/gio/ggcell.x new file mode 100644 index 00000000..1dfd7a40 --- /dev/null +++ b/sys/gio/ggcell.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGCELL -- Get a cell array, i.e., a two dimensional array of pixels. If the +# resolution of the graphics device does not match that of the cell array the +# kernel is expected to compute the coordinates of each cell array pixel in +# device coordinates and return the value of the nearest device pixel as the +# cell array value. This equates to either subsampling or block replication +# depending on the relative scale of the two devices. See put cell array for +# additional information. + +procedure ggcell (gp, m, nx, ny, x1, y1, x2, y2) + +pointer gp # device descriptor +int nx, ny # size of pixel array +short m[nx,ny] # pixels +real x1, y1 # lower left corner of input window +real x2, y2 # upper right corner of input window + +real dy +int ly1, ly2, i +int sx1, sx2, sy1, sy2 +include "gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Transform cell window to GKI coordinates. The coordinate + # transformation must be linear. + + sx1 = (x1 - wxorigin) * xscale + mxorigin + sx2 = (x2 - wxorigin) * xscale + mxorigin + sy1 = (y1 - wyorigin) * yscale + myorigin + sy2 = (y2 - wyorigin) * yscale + myorigin + + dy = real (sy2 - sy1) / ny # height of a line in GKI coords + + # Read the cell array into M, one line at a time. Take care that the + # GKI integer value of ly1 of one line is the same as the ly2 value + # of the previous line, or there will be a blank line in the output + # image. + + do i = 1, ny { + ly1 = (i-1) * dy + sy1 + ly2 = (i ) * dy + sy1 + call gki_getcellarray (GP_FD(gp), m[1,i], nx,1, sx1,ly1, sx2,ly2) + } +end diff --git a/sys/gio/ggcur.x b/sys/gio/ggcur.x new file mode 100644 index 00000000..40da0a0f --- /dev/null +++ b/sys/gio/ggcur.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GGCUR -- Perform a graphics cursor read. The current graphics cursor is +# read and the cursor value is returned. On output, CN is the cursor number +# which was read, KEY is the key typed to terminate the cursor read, SX,SY +# are the NDC screen coordinates of the cursor, RASTER is the raster number +# or zero, and RX,RY are the raster-relative coordinates of the cursor. If +# the device does not support rasters or if the cursor is not in a rasters +# when read, RASTER is zero on output and RX,RY are the same as SX,SY. + +int procedure ggcur (gp, cn, key, sx, sy, raster, rx, ry) + +pointer gp #I graphics descriptor +int cn #O cursor which was read +int key #O key typed or EOF +real sx, sy #O screen position of cursor in NDC coordinates +int raster #O raster number +real rx, ry #O raster position of cursor in NDC coordinates + +int m_sx, m_sy +int m_rx, m_ry + +begin + call gflush (gp) + call gki_getcursor (GP_FD(gp), GP_CURSOR(gp), + cn, key, m_sx, m_sy, raster, m_rx, m_ry) + + sx = real(m_sx) / GKI_MAXNDC + sy = real(m_sy) / GKI_MAXNDC + rx = real(m_rx) / GKI_MAXNDC + ry = real(m_ry) / GKI_MAXNDC + + return (key) +end diff --git a/sys/gio/ggetb.x b/sys/gio/ggetb.x new file mode 100644 index 00000000..790da996 --- /dev/null +++ b/sys/gio/ggetb.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETB -- Get a boolean device parameter from the graphcap entry for the +# device. A boolean graphcap query tests if the named parameter exists. +# Boolean queries are permitted for any capability, regardless of its actual +# datatype. + +bool procedure ggetb (gp, cap) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +bool ttygetb() + +begin + return (ttygetb (GP_TTY(gp), cap)) +end diff --git a/sys/gio/ggeti.x b/sys/gio/ggeti.x new file mode 100644 index 00000000..31f81bb2 --- /dev/null +++ b/sys/gio/ggeti.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETI -- Get the integer value of an device parameter from the graphcap +# entry for the device. Zero is returned if the device does not have the +# named parameter. + +int procedure ggeti (gp, cap) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +int ttygeti() + +begin + return (ttygeti (GP_TTY(gp), cap)) +end diff --git a/sys/gio/ggetr.x b/sys/gio/ggetr.x new file mode 100644 index 00000000..b595793c --- /dev/null +++ b/sys/gio/ggetr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETR -- Get the real value of an device parameter from the graphcap entry +# for the device. Zero is returned if the device does not have the +# named parameter. + +real procedure ggetr (gp, cap) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +real ttygetr() + +begin + return (ttygetr (GP_TTY(gp), cap)) +end diff --git a/sys/gio/ggets.x b/sys/gio/ggets.x new file mode 100644 index 00000000..d82c7090 --- /dev/null +++ b/sys/gio/ggets.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETS -- Get the string value of a device parameter from the graphcap entry +# for the device. The null string is returned if no entry is found for the +# named capability, or if the capability exists but the value field is null. +# The value of any parameter may be returned as a string, regardless of its +# datatype. Escape sequences are converted to control codes in the output +# string. + +int procedure ggets (gp, cap, outstr, maxch) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +char outstr[ARB] # output string +int maxch +int ttygets() + +begin + return (ttygets (GP_TTY(gp), cap, outstr, maxch)) +end diff --git a/sys/gio/ggscale.x b/sys/gio/ggscale.x new file mode 100644 index 00000000..76dffa2a --- /dev/null +++ b/sys/gio/ggscale.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGSCALE -- Get the WCS scale in world coords per NDC at the point (x,y). +# Used to convert offsets or sizes in NDC coordinates into world coordinates, +# and vice versa. If log scaling is in use we can only locally approximate +# the scale. + +procedure ggscale (gp, x, y, dx, dy) + +pointer gp # graphics descriptor +real x, y # point for which scale is desired +real dx, dy # scale wcs/nds (output) + +pointer w +real x1, x2, y1, y2, xs, ys, elog_scale +real log10e, elogr() +data log10e /0.434294482/ + +begin + w = GP_WCSPTR(gp,GP_WCS(gp)) + + x1 = WCS_WX1(w) + x2 = WCS_WX2(w) + y1 = WCS_WY1(w) + y2 = WCS_WY2(w) + xs = WCS_SX2(w) - WCS_SX1(w) + ys = WCS_SY2(w) - WCS_SY1(w) + + switch (WCS_XTRAN(w)) { + case LOG: + dx = (x / log10e) * log10 (x2 / x1) / xs + case ELOG: + # The following is an approximation. + elog_scale = (elogr(x2) - elogr(x1)) / xs + if (x < 10.0) + dx = (-x / log10e) * elog_scale + else if (x > 10.0) + dx = (x / log10e) * elog_scale + else + dx = (10. / log10e) * elog_scale + default: + # LINEAR + dx = (x2 - x1) / xs + } + + switch (WCS_YTRAN(w)) { + case LOG: + dy = (y / log10e) * log10 (y2 / y1) / ys + case ELOG: + # The following is an approximation. + elog_scale = (elogr(y2) - elogr(y1)) / ys + if (y < 10.0) + dy = (-y / log10e) * elog_scale + else if (y > 10.0) + dy = (y / log10e) * elog_scale + else + dy = (10. / log10e) * elog_scale + default: + # LINEAR + dy = (y2 - y1) / ys + } +end diff --git a/sys/gio/ggview.x b/sys/gio/ggview.x new file mode 100644 index 00000000..486035b6 --- /dev/null +++ b/sys/gio/ggview.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGVIEW -- Get the viewport of the current WCS. + +procedure ggview (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of NDC in X (output) +real y1, y2 # range of NDC in Y (output) +pointer w + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + x1 = WCS_SX1(w) + x2 = WCS_SX2(w) + y1 = WCS_SY1(w) + y2 = WCS_SY2(w) +end diff --git a/sys/gio/ggwind.x b/sys/gio/ggwind.x new file mode 100644 index 00000000..4972fb75 --- /dev/null +++ b/sys/gio/ggwind.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGWIND -- Get the window into world coordinates of the current WCS. + +procedure ggwind (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of world coords in X (output) +real y1, y2 # range of world coords in Y (output) +pointer w + +begin + call gactivate (gp, 0) + w = GP_WCSPTR (gp, GP_WCS(gp)) + + x1 = WCS_WX1(w) + x2 = WCS_WX2(w) + y1 = WCS_WY1(w) + y2 = WCS_WY2(w) +end diff --git a/sys/gio/gim/README b/sys/gio/gim/README new file mode 100644 index 00000000..3c98b736 --- /dev/null +++ b/sys/gio/gim/README @@ -0,0 +1,215 @@ +GIM -- GIO graphics imaging library. This is a developmental library based +on GIO escapes, providing IRAF applications with access to the Gterm widget +imaging functions. This library is tied directly to the Gterm widget and is +expected to be replaced by a more general imaging library in the future. + +This library is intended only for clients that need to directly access the +imaging functions in the Gterm widget for full control over the imaging +capabilities of the Gterm widget. Applications which merely need to display +an image as part of a more complex graphic would probably be better off +using the more device independent gpcell (put cell-array) and gpcmap (put +colormap) calls. + + +The following functions are direct RPC calls to the corresponding Gt-prefixed +imaging functions in the Gterm widget. + + gim_rasterinit (gp) + gim_createraster (gp, raster, type, width, height, depth) + gim_destroyraster (gp, raster) + exists = gim_queryraster (gp, raster, type, width, height, depth) + gim_setraster (gp, raster) # see gseti(gp,G_RASTER,n) + + gim_writepixels (gp, raster, data, nbits, x1, y1, nx, ny) + gim_readpixels (gp, raster, data, nbits, x1, y1, nx, ny) + gim_refreshpix (gp, raster, ct, x1, y1, nx, ny) + gim_setpixels (gp, raster, ct, x1, y1, nx, ny, color, rop) + + gim_writecolormap (gp, colormap, first, nelem, r, g, b) + nelem = gim_readcolormap (gp, colormap, first, maxelem, r, g, b) + gim_loadcolormap (gp, colormap, offset, slope) + gim_freecolormap (gp, colormap) + gim_iomapwrite (gp, iomap, first, nelem) + gim_iomapread (gp, iomap, first, nelem) + + gim_initmappings (gp) + gim_freemapping (gp, mapping) + gim_copyraster (gp, rop, src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + gim_setmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + status = gim_getmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + gim_enablemapping (gp, mapping, refresh) + gim_disablemapping (gp, mapping, erase) + gim_refreshmapping (gp, mapping) + +The following Gterm widget imaging functions have no analogue in the GIM +imaging interface, but can be called from within GUI code. These functions +are not implemented at the GIM level either because they are not essential +and would be too inefficient to be worth using via RPC, or because they +access resources available only to GUI code. + + GtAssignRaster (gt, raster, drawable) + pixmap = GtExtractPixmap (gt, src, ct, x, y, width, height) + GtInsertPixmap (gt, pixmap, dst, ct, x, y, width, height) + raster = GtSelectRaster (gt, dras, dt, dx, dy, rt, rx, ry, mapping) + raster = GtNextRaster (gt) + raster = GtGetRaster (gt) + n = GtNRasters (gt) + pixel = GtGetClientPixel (gt, gterm_pixel) + mapping = GtNextMapping (gt) + active = GtActiveMapping (gt, mapping) + + +The following messaging routines are also defined by the GIO interface. +These are used to set the values of UI parameters (i.e., send messages to +the user interface). + + gmsg (gp, object, message) + gmsg[bcsilrdx] (gp, object, value) + gmprintf (gp, object, format) + + +The imaging model of the Gterm widget defines the following key object or +data types: rasters, mappings, and colors. + + raster A raster is a MxN array of pixels. At present pixels are 8 + bits deep but hooks are built in to the interface to expand + this in the future. Pixel values are indices into the Gterm + virtual colormap, with values starting at zero. A raster + may be any size. A raster is merely a two-dimensional array + in the graphics server; it is not displayed unless mapped. + An exception is raster zero, which is the graphics window. + Rasters are referred to by number, starting with zero. + Initially only raster zero exists; new rasters are created + with gim_createraster. Space for rasters may be allocated + either in the graphics server, or in the X server. This has + implications on performance but is otherwise transparent to + the client. By default rasters are allocated in the + graphics server, i.e., in the X client. + + mapping A mapping defines a projection of a rectangle of the source + raster onto a rectangle of the destination raster. Mappings + may be either enabled (active) or disabled. When a mapping + is enabled, any change to a pixel in the source rect will + cause the corresponding pixels in the destination rect to be + updated. Mappings are referred to by number starting with + one. Initially no mappings are defined. If the size of the + input and output rect is not the same the input rect will be + scaled by pixel replication or subsampling to fill the + output rect. If the argument DW or DH of the destination + rect is negative, the image will be flipped around the + corresponding axis when copied to the destination; the + region of the destination drawn into is the same in either + case. Multiple mappings may reference the same source or + destination raster. Mappings are refreshed in order by the + mapping number. Modifying a mapping causes the changed + regions of the destination rect to be refreshed. + + color The gterm widget provides a fixed number of preassigned colors + corresponding to pixel values 0 through 9. 0 is the background + color, 1 is the foreground color, and 2-9 (8 colors) are + arbitrary colors defined by Gterm widget resources. These + static colors are normally used to draw the background, frame, + axes, titles, etc. of a plot, or to draw color graphics within + the drawing area. The advantage of static colors is that they + are shared with other X clients, and the values of these + colors may be assigned by the user to personalize the way + plots look. + + The gterm widget also allows any number (up to about 200 or + so) additional colors to be defined at runtime by the client + application. These color values start at pixel value 10 and + go up to the maximum pixel value assigned by the client. The + client application allocates colors with gim_writecolormap. + Attempts to overwrite the values of the static colors are + ignored. The values of already allocated colors may be + changed dynamically at runtime using gim_writecolormap to + write the desired range of color values. + + Applications should not assume that there are 10 static + colors and 200 or so allocatable colors. The graphcap entry + for the logical device in use defines these parameters for + the device. Alternatively, the readcolormap call may be + used to dynamically determine how many colors the server has + preallocated when the application starts up. + + An image may use either static and dyamic pixel values or + both types of values, but in most cases imaging applications + involve smoothly shaded surfaces hence will require + dyamically assigned private colors. + + If for some reason the client application cannot use the + gterm widget color model, the IOMAP feature can be used to + make the widget appear to have some externally defined + (i.e., client defined) color model. + + +The maximum number of rasters and maximum number of mappings is defined by +Gterm widget resources (e.g. in the GUI file) when the graphics application +starts up. The maximum values should be much larger than most applications +require. Applications should allocate raster or mapping numbers +sequentially starting at 1 (more or less) to avoid running out of raster or +mapping descriptors. + +The {read|write}pixels routines in the GIM interface operate directly on +raster pixels. The mapping routines support two alternative coordinate +systems, raster pixels and NDC (normalized device coordinates), as indicated +by the ST or DT argument (source or destination coordinate type). Note +that the origin of the pixel coordinate system is the upper left corner of +the display window (consistent with most graphics systems), whereas the origin +of the NDC coordinate system is the lower left corner (consistent with IRAF). + +Pixel coordinates allow precise control of imaging but require the +application to know the window size, and may result in complications e.g. if +the window is resized. NDC coordinates pretty much guarantee that a mapping +will involve sampling, hence are not the most efficient, but the graphics +will be drawn correctly no matter how the window is resized and for most +applications the performance difference is negligible. Most applications +should use NDC coordinates for raster 0 (the display window), and pixel +coordinates for rasters 1-N. + +Although the size of rasters 1 and higher are defined by the client +application, the size of raster zero, the actual gterm display window, is +subject to the constraints of the window system. The client can attempt to +reset the size of the gterm window using gim_createraster with raster=0, +however the Gterm widget, UI containing the gterm widget, and the window +manager are all free to deny such a request. gim_queryraster should be +called to determine the actual size of the window one will be drawing into. + + +EXAMPLE + + A simple example of an imaging application might download an image and +display it in the gterm window, filling the window. This could be done as +follows (following a GOPEN and other GIO calls to prepare the drawing surface). + + gim_createraster Create raster 1 the size of the pixel array + to be displayed. This need not be the same + as the size of the gterm display window. + + gim_setmapping Define a mapping between raster 1 and raster 0, + the display window, using NDC coordinates to + define the region of the display window to be + filled. The mapping number is arbitrary but + mappings should normally be allocated starting + with 1. The mapping is automatically enabled + when first defined. + + gim_writecolormap (Optional). Define the pixel value to RGB + color assignments for the image pixels. + + gim_writepixels This routine is called one or more times to + write pixels into raster 1. At most 32K + pixels (minus a bit for the GKI headers) can + be written in each call. As each write is + made the affected region of the display + window will be updated. + +Alternatively, one could write the pixels and then define the mapping, to +cause the entire image to be displayed at once. + +Note that the GIM calls can be combined with normal GIO graphics to draw text +and graphics around or on top of an image region. The order in which drawing +operations occur is important, e.g., to draw graphics or text on top of an +image the image should be drawn first. diff --git a/sys/gio/gim/gimcpras.x b/sys/gio/gim/gimcpras.x new file mode 100644 index 00000000..ea1ab32f --- /dev/null +++ b/sys/gio/gim/gimcpras.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_COPYRASTER -- Copy a portion of the source raster to a rectangular +# region of the destination raster. + +procedure gim_copyraster (gp, rop, src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + +pointer gp #I graphics descriptor +int rop #I rasterop +int src #I source raster +int st #I coordinate type for source raster +real sx,sy,sw,sh #I source rect +int dst #I destination raster +int dt #I coordinate type for destination raster +real dx,dy,dw,dh #I destination rect + +short gim[GIM_COPYRASTER_LEN] + +begin + gim[GIM_COPYRASTER_OP] = rop + gim[GIM_COPYRASTER_SR] = src + gim[GIM_COPYRASTER_ST] = st + + if (st == CT_PIXEL) { + gim[GIM_COPYRASTER_SX] = sx + gim[GIM_COPYRASTER_SY] = sy + gim[GIM_COPYRASTER_SW] = sw + gim[GIM_COPYRASTER_SH] = sh + } else { + gim[GIM_COPYRASTER_SX] = sx * GKI_MAXNDC + gim[GIM_COPYRASTER_SY] = sy * GKI_MAXNDC + gim[GIM_COPYRASTER_SW] = nint (sw * GKI_MAXNDC) + gim[GIM_COPYRASTER_SH] = nint (sh * GKI_MAXNDC) + } + + gim[GIM_COPYRASTER_DR] = dst + gim[GIM_COPYRASTER_DT] = dt + + if (dt == CT_PIXEL) { + gim[GIM_COPYRASTER_DX] = dx + gim[GIM_COPYRASTER_DY] = dy + gim[GIM_COPYRASTER_DW] = dw + gim[GIM_COPYRASTER_DH] = dh + } else { + gim[GIM_COPYRASTER_DX] = dx * GKI_MAXNDC + gim[GIM_COPYRASTER_DY] = dy * GKI_MAXNDC + gim[GIM_COPYRASTER_DW] = nint (dw * GKI_MAXNDC) + gim[GIM_COPYRASTER_DH] = nint (dh * GKI_MAXNDC) + } + + call gescape (gp, GIM_COPYRASTER, gim, GIM_COPYRASTER_LEN) +end diff --git a/sys/gio/gim/gimcrras.x b/sys/gio/gim/gimcrras.x new file mode 100644 index 00000000..9372f85f --- /dev/null +++ b/sys/gio/gim/gimcrras.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_CREATERASTER -- Create, recreate, or resize a raster. + +procedure gim_createraster (gp, raster, type, width, height, depth) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int type #I raster type (normal,ximage,pixmap) +int width #I raster width in pixels +int height #I raster height in pixels +int depth #I raster depth, bits per pixel + +short gim[GIM_CREATERASTER_LEN] + +begin + gim[GIM_CREATERASTER_RN] = raster + gim[GIM_CREATERASTER_RT] = type + gim[GIM_CREATERASTER_NX] = width + gim[GIM_CREATERASTER_NY] = height + gim[GIM_CREATERASTER_BP] = depth + + call gescape (gp, GIM_CREATERASTER, gim, GIM_CREATERASTER_LEN) +end diff --git a/sys/gio/gim/gimderas.x b/sys/gio/gim/gimderas.x new file mode 100644 index 00000000..9a492759 --- /dev/null +++ b/sys/gio/gim/gimderas.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_DESTROYRASTER -- Destroy a raster. + +procedure gim_destroyraster (gp, raster) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) + +short gim[GIM_DESTROYRASTER_LEN] + +begin + gim[GIM_DESTROYRASTER_RN] = raster + call gescape (gp, GIM_DESTROYRASTER, gim, GIM_DESTROYRASTER_LEN) +end diff --git a/sys/gio/gim/gimdsmap.x b/sys/gio/gim/gimdsmap.x new file mode 100644 index 00000000..a1618413 --- /dev/null +++ b/sys/gio/gim/gimdsmap.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_DISABLEMAPPING -- Disable a previously defined mapping. Disabling a +# mapping does not automatically erase the mapping unless the erase flag +# is set. + +procedure gim_disablemapping (gp, mapping, erase) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited +int erase #I erase flag + +short gim[GIM_DISABLEMAPPING_LEN] + +begin + gim[GIM_DISABLEMAPPING_MP] = mapping + gim[GIM_DISABLEMAPPING_FL] = erase + call gescape (gp, GIM_DISABLEMAPPING, gim, GIM_DISABLEMAPPING_LEN) +end diff --git a/sys/gio/gim/gimenmap.x b/sys/gio/gim/gimenmap.x new file mode 100644 index 00000000..02e9af3b --- /dev/null +++ b/sys/gio/gim/gimenmap.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_ENABLEMAPPING -- Enable a previously defined mapping. Enabling a +# mapping does not automatically refresh the destination unless the refresh +# flag is set (refresh=YES). + +procedure gim_enablemapping (gp, mapping, refresh) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited +int refresh #I refresh flag + +short gim[GIM_ENABLEMAPPING_LEN] + +begin + gim[GIM_ENABLEMAPPING_MP] = mapping + gim[GIM_ENABLEMAPPING_FL] = refresh + call gescape (gp, GIM_ENABLEMAPPING, gim, GIM_ENABLEMAPPING_LEN) +end diff --git a/sys/gio/gim/gimfcmap.x b/sys/gio/gim/gimfcmap.x new file mode 100644 index 00000000..9194e9bf --- /dev/null +++ b/sys/gio/gim/gimfcmap.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_FREECOLORMAP -- Free a colormap. + +procedure gim_freecolormap (gp, colormap) + +pointer gp #I graphics descriptor +int colormap #I colormap number + +short gim[GIM_FREECMAP_LEN] + +begin + gim[GIM_FREECMAP_MP] = colormap + call gescape (gp, GIM_FREECMAP, gim, GIM_FREECMAP_LEN) +end diff --git a/sys/gio/gim/gimfmap.x b/sys/gio/gim/gimfmap.x new file mode 100644 index 00000000..f69355a4 --- /dev/null +++ b/sys/gio/gim/gimfmap.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_FREEMAPPING -- Free a mapping. + +procedure gim_freemapping (gp, mapping) + +pointer gp #I graphics descriptor +int mapping #I mapping number + +short gim[GIM_FREEMAPPING_LEN] + +begin + gim[GIM_FREEMAPPING_MP] = mapping + call gescape (gp, GIM_FREEMAPPING, gim, GIM_FREEMAPPING_LEN) +end diff --git a/sys/gio/gim/gimgetmap.x b/sys/gio/gim/gimgetmap.x new file mode 100644 index 00000000..c58bae0d --- /dev/null +++ b/sys/gio/gim/gimgetmap.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# GIM_GETMAPPING -- Get the parameters defining a mapping. The function value +# is YES if the mapping is defined and enabled and NO if the mapping is +# defined but not enabled. If the mapping is not defined ERR is returned. + +int procedure gim_getmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + +pointer gp #I graphics descriptor +int mapping #I mapping to be queried +int rop #O rasterop +int src #O source raster +int st #O coordinate type for source raster +int sx,sy,sw,sh #O source rect +int dst #O destination raster +int dt #O coordinate type for destination raster +int dx,dy,dw,dh #O destination rect + +int nchars, nread +short gim[GIM_GETMAPPING_LEN] +short retval[GIM_RET_GMAP_LEN] +errchk gescape, flush, read, syserrs +int read(), btoi() + +begin + call gpl_flush() + gim[GIM_GETMAPPING_MP] = mapping + call gescape (gp, GIM_GETMAPPING, gim, GIM_GETMAPPING_LEN) + call flush (GP_FD(gp)) + + # This assumes a normal stream type GKI connection. + nchars = GIM_RET_GMAP_LEN * SZ_SHORT + nread = read (GP_FD(gp), retval, nchars) + call fseti (GP_FD(gp), F_CANCEL, OK) + if (nread != nchars) + call syserrs (SYS_FREAD, "gim_getmapping") + + # EN=0 not defined, EN=1 defined not enabled, EN=2 defined enabled. + if (retval[GIM_RET_GMAP_EN] == 0) + return (ERR) + else { + rop = retval[GIM_RET_GMAP_OP] + + src = retval[GIM_RET_GMAP_SR] + st = retval[GIM_RET_GMAP_ST] + + if (st == CT_PIXEL) { + sx = retval[GIM_RET_GMAP_SX] + sy = retval[GIM_RET_GMAP_SY] + sw = retval[GIM_RET_GMAP_SW] + sh = retval[GIM_RET_GMAP_SH] + } else { + sx = real (retval[GIM_RET_GMAP_SX]) / GKI_MAXNDC + sy = real (retval[GIM_RET_GMAP_SY]) / GKI_MAXNDC + sw = real (retval[GIM_RET_GMAP_SW]) / GKI_MAXNDC + sh = real (retval[GIM_RET_GMAP_SH]) / GKI_MAXNDC + } + + dst = retval[GIM_RET_GMAP_SR] + dt = retval[GIM_RET_GMAP_DT] + + if (dt == CT_PIXEL) { + dx = retval[GIM_RET_GMAP_DX] + dy = retval[GIM_RET_GMAP_DY] + dw = retval[GIM_RET_GMAP_DW] + dh = retval[GIM_RET_GMAP_DH] + } else { + dx = real (retval[GIM_RET_GMAP_DX]) / GKI_MAXNDC + dy = real (retval[GIM_RET_GMAP_DY]) / GKI_MAXNDC + dw = real (retval[GIM_RET_GMAP_DW]) / GKI_MAXNDC + dh = real (retval[GIM_RET_GMAP_DH]) / GKI_MAXNDC + } + + } + + return (btoi (retval[GIM_RET_GMAP_EN] == 2)) +end diff --git a/sys/gio/gim/gimimap.x b/sys/gio/gim/gimimap.x new file mode 100644 index 00000000..2c4a5d28 --- /dev/null +++ b/sys/gio/gim/gimimap.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_INITMAPPINGS -- Initialize the Gterm widget raster mappings. + +procedure gim_initmappings (gp) + +pointer gp #I graphics descriptor + +begin + call gescape (gp, GIM_INITMAPPINGS, 0, GIM_INITMAPPINGS_LEN) +end diff --git a/sys/gio/gim/gimlcmap.x b/sys/gio/gim/gimlcmap.x new file mode 100644 index 00000000..afcd9045 --- /dev/null +++ b/sys/gio/gim/gimlcmap.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_LOADCOLORMAP -- Load a colormap into the display (hardware) colormap. +# Any number of colormaps may be defined, but only one may be loaded at a +# time. A linear transformation may optionally be applied to the (normalized) +# colormap when it is loaded. Set offset=0.5, slope=1.0 to load the colormap +# without scaling. A negative slope inverts the image. +# +# The offset refers to the center of the mapped region of the transfer +# function, which is why the center value is at 0.5. For example, if the +# range of raster pixel intensities is normalized to the range 0.0 to 1.0, +# then a transfer function of [offset=0.3,slope=3.0] will display the region +# of intenstities centered around the normalized intenstity of 0.3, with a +# contrast of 3.0 (the screen intensity changes 3 units for a unit change in +# raster pixel intensity). The transfer function [offset=0.3,slope=-3.0] +# will display the same range of pixel intensitites, but with a negative +# contrast. The transfer function [offset=0.5,slope=1.0] has intercepts +# of [0,0] and [1,1] hence it displays the full range of raster pixel +# intensities - the input colormap is used as is, without resampling. + +procedure gim_loadcolormap (gp, colormap, offset, slope) + +pointer gp #I graphics descriptor +int colormap #I colormap number (0 is display colormap) +real offset, slope #I linear transformation on colormap + +real veclen, scale +short gim[GIM_LOADCMAP_LEN] + +begin + scale = GIM_LOADCMAP_SCALE + gim[GIM_LOADCMAP_MP] = colormap + gim[GIM_LOADCMAP_OF] = ((GKI_MAXNDC + 1) / scale) * + max(-scale, min(scale, offset)) + + if (abs(slope) < EPSILONR) + veclen = GKI_MAXNDC + else { + veclen = GKI_MAXNDC + 1 + veclen = min (veclen / 2, veclen / abs(slope) / 2) + } + gim[GIM_LOADCMAP_DX] = veclen + gim[GIM_LOADCMAP_DY] = veclen * slope + + call gescape (gp, GIM_LOADCMAP, gim, GIM_LOADCMAP_LEN) +end diff --git a/sys/gio/gim/gimqras.x b/sys/gio/gim/gimqras.x new file mode 100644 index 00000000..fa8f5909 --- /dev/null +++ b/sys/gio/gim/gimqras.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_QUERYRASTER -- Query a raster. The function value (YES/NO) indicates +# whether or not the raster exists. If the raster exists, the raster type +# and size are returned as output arguments. + +int procedure gim_queryraster (gp, raster, type, width, height, depth) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int type #O raster type (ximage,pixmap) +int width #O raster width in pixels +int height #O raster height in pixels +int depth #O raster depth, bits per pixel + +int nchars, nread +short gim[GIM_QUERYRASTER_LEN] +short retval[GIM_RET_QRAS_LEN] +errchk gescape, flush, read, syserrs +int read() + +begin + call gpl_flush() + gim[GIM_QUERYRASTER_RN] = raster + call gescape (gp, GIM_QUERYRASTER, gim, GIM_QUERYRASTER_LEN) + call flush (GP_FD(gp)) + + # This assumes a normal stream type GKI connection. + nchars = GIM_RET_QRAS_LEN * SZ_SHORT + nread = read (GP_FD(gp), retval, nchars) + call fseti (GP_FD(gp), F_CANCEL, OK) + if (nread != nchars) + call syserrs (SYS_FREAD, "gim_queryraster") + + type = retval[GIM_RET_QRAS_RT] + width = retval[GIM_RET_QRAS_NX] + height = retval[GIM_RET_QRAS_NY] + depth = retval[GIM_RET_QRAS_BP] + + return (retval[GIM_RET_QRAS_EX]) +end diff --git a/sys/gio/gim/gimrasini.x b/sys/gio/gim/gimrasini.x new file mode 100644 index 00000000..56914746 --- /dev/null +++ b/sys/gio/gim/gimrasini.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_RASTERINIT -- Initialize the Gterm widget imaging subsystem. Destroys +# any existing rasters, mappings, and dynamic colors. + +procedure gim_rasterinit (gp) + +pointer gp #I graphics descriptor + +begin + call gescape (gp, GIM_RASTERINIT, 0, GIM_RASTERINIT_LEN) +end diff --git a/sys/gio/gim/gimrcmap.x b/sys/gio/gim/gimrcmap.x new file mode 100644 index 00000000..8fb9f4d2 --- /dev/null +++ b/sys/gio/gim/gimrcmap.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_READCOLORMAP -- Read a segment of a colormap. The number of cells +# read is returned. The number of cells read may be less than the request +# size if the cells have not yet been allocated. + +int procedure gim_readcolormap (gp, colormap, first, maxelem, r, g, b) + +pointer gp #I graphics descriptor +int colormap #I colormap number (0=screen) +int first #I first colormap entry to be read +int maxelem #I number of elements to read +int r[ARB],g[ARB],b[ARB] #O RGB color values (0-255) + +pointer sp, cm, ip +int ncells, nret, nchars, i +short gim[GIM_READCMAP_LEN] +short retval[GIM_RET_RCMAP_LEN] +int read() + +string s_readcmap "gim_readcolormap" +errchk flush, read, syserrs + +begin + call smark (sp) + call gpl_flush() + + gim[GIM_READCMAP_MP] = colormap + gim[GIM_READCMAP_FC] = first + gim[GIM_READCMAP_NC] = maxelem + call gescape (gp, GIM_READCMAP, gim, GIM_READCMAP_LEN) + call flush (GP_FD(gp)) + + # Get return value instruction header. + nchars = GIM_RET_RCMAP_LEN * SZ_SHORT + if (read (GP_FD(gp), retval, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readcmap) + } + + ncells = retval[GIM_RET_RCMAP_NC] + call salloc (cm, ncells * 3, TY_SHORT) + nret = min (ncells, maxelem) + + # Get the colormap data. + nchars = (ncells * 3) * SZ_SHORT + if (read (GP_FD(gp), Mems[cm], nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readcmap) + } + + do i = 1, nret { + ip = cm + (i - 1) * 3 + r[i] = Mems[ip+0] + g[i] = Mems[ip+1] + b[i] = Mems[ip+2] + } + + call fseti (GP_FD(gp), F_CANCEL, OK) + call sfree (sp) + + return (nret) +end diff --git a/sys/gio/gim/gimref.x b/sys/gio/gim/gimref.x new file mode 100644 index 00000000..dd3085d4 --- /dev/null +++ b/sys/gio/gim/gimref.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_REFRESHMAPPING -- Refresh a previously defined mapping, i.e., repaint +# the destination rect. + +procedure gim_refreshmapping (gp, mapping) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited + +short gim[GIM_REFRESHMAPPING_LEN] + +begin + gim[GIM_REFRESHMAPPING_MP] = mapping + call gescape (gp, GIM_REFRESHMAPPING, gim, GIM_REFRESHMAPPING_LEN) +end diff --git a/sys/gio/gim/gimrefpix.x b/sys/gio/gim/gimrefpix.x new file mode 100644 index 00000000..1d906a1a --- /dev/null +++ b/sys/gio/gim/gimrefpix.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_REFRESHPIX -- Update any mappings defined upon the given region of +# the given source raster, as if the pixel values had been set with a write +# pixels call. + +procedure gim_refreshpix (gp, raster, ct, x1, y1, width, height) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int ct #I coordinate type +real x1, y1 #I region to be refreshed +real width, height #I region to be refreshed + +short gim[GIM_REFRESHPIXELS_LEN] + +begin + gim[GIM_REFRESHPIXELS_RN] = raster + gim[GIM_REFRESHPIXELS_CT] = ct + + if (ct == CT_PIXEL) { + gim[GIM_REFRESHPIXELS_X1] = x1 + gim[GIM_REFRESHPIXELS_Y1] = y1 + gim[GIM_REFRESHPIXELS_NX] = width + gim[GIM_REFRESHPIXELS_NY] = height + } else { + gim[GIM_REFRESHPIXELS_X1] = x1 * GKI_MAXNDC + gim[GIM_REFRESHPIXELS_Y1] = y1 * GKI_MAXNDC + gim[GIM_REFRESHPIXELS_NX] = nint (width * GKI_MAXNDC) + gim[GIM_REFRESHPIXELS_NY] = nint (height * GKI_MAXNDC) + } + + call gescape (gp, GIM_REFRESHPIXELS, gim, GIM_REFRESHPIXELS_LEN) +end diff --git a/sys/gio/gim/gimriomap.x b/sys/gio/gim/gimriomap.x new file mode 100644 index 00000000..0f152ca5 --- /dev/null +++ b/sys/gio/gim/gimriomap.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_IOMAPREAD -- Read a segment of the gterm widget iomap. + +procedure gim_iomapread (gp, iomap, first, nelem) + +pointer gp #I graphics descriptor +int iomap[ARB] #o iomap data +int first #I first iomap cell to be read +int nelem #I number of elements to read + +int nchars +pointer sp, data +short gim[GIM_READIOMAP_LEN] +short retval[GIM_RET_RIOMAP_LEN] +int read() + +string s_readiomap "gim_iomapread" +errchk flush, read, syserrs + +begin + call smark (sp) + call gpl_flush() + + gim[GIM_READIOMAP_FC] = first + gim[GIM_READIOMAP_NC] = nelem + call gescape (gp, GIM_READIOMAP, gim, GIM_READIOMAP_LEN) + call flush (GP_FD(gp)) + + # Get return value instruction header. + nchars = GIM_RET_RIOMAP_LEN * SZ_SHORT + if (read (GP_FD(gp), retval, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readiomap) + } + + if (retval[GIM_RET_RIOMAP_NC] != nelem) + call syserrs (SYS_FREAD, s_readiomap) + + # Get the iomap data. + call salloc (data, nelem, TY_SHORT) + nchars = nelem * SZ_SHORT + if (read (GP_FD(gp), Mems[data], nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readiomap) + } else + call achtsi (Mems[data], iomap, nelem) + + call fseti (GP_FD(gp), F_CANCEL, OK) + call sfree (sp) +end diff --git a/sys/gio/gim/gimrpix.x b/sys/gio/gim/gimrpix.x new file mode 100644 index 00000000..4b6c7e9b --- /dev/null +++ b/sys/gio/gim/gimrpix.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# GIM_READPIXELS -- Read from a rectangular region of a raster. + +procedure gim_readpixels (gp, raster, data, nbits, x1, y1, nx, ny) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +short data[ARB] #O returned pixel data +int nbits #I nbits per raster pixel (1,8,16,32) +int x1, y1 #I first pixel to be written +int nx, ny #I size of region to be written + +int npix, nchars, nwords +short gim[GIM_READPIXELS_LEN] +short retval[GIM_RET_RPIX_LEN] +errchk gpl_flush, gflush, read, syserrs +string s_readpixels "gim_readpixels" +int read() + +begin + call gpl_flush() + npix = nx * ny + nchars = (npix * nbits / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR + nwords = (nchars + SZ_SHORT-1) / SZ_SHORT + + gim[GIM_READPIXELS_RN] = raster + gim[GIM_READPIXELS_EC] = 0 + gim[GIM_READPIXELS_X1] = x1 + gim[GIM_READPIXELS_Y1] = y1 + gim[GIM_READPIXELS_NX] = nx + gim[GIM_READPIXELS_NY] = ny + gim[GIM_READPIXELS_BP] = nbits + + call gki_escape (gp, GIM_READPIXELS, gim, GIM_READPIXELS_LEN) + call flush (GP_FD(gp)) + + # Get return value instruction header. + nchars = GIM_RET_RPIX_LEN * SZ_SHORT + if (read (GP_FD(gp), retval, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readpixels) + } + + # Get the pixel data. + npix = retval[GIM_RET_RPIX_NP] + nchars = (npix * nbits / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR + if (read (GP_FD(gp), data, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readpixels) + } + + call fseti (GP_FD(gp), F_CANCEL, OK) + if (npix != nx * ny) + call syserrs (SYS_IMNOPIX, s_readpixels) +end diff --git a/sys/gio/gim/gimsetmap.x b/sys/gio/gim/gimsetmap.x new file mode 100644 index 00000000..2cf5f7b6 --- /dev/null +++ b/sys/gio/gim/gimsetmap.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_SETMAPPING -- Define a mapping between a source rect and a destination +# rect. While the mapping is enabled, any changes to the source rect will +# be automatically propagated to the destination rect. If the source and +# destination rects are not the same size the source rect will be scaled to +# fit the output rect. A negative DW or DH causes the X or Y axis to be +# flipped during the mapping. Setmapping automatically enables a new +# mapping, but no data is copied until the source rect is subsequently +# modified or the mapping is modified or refreshed. Setmapping may be called +# on an already existing mapping to edit the mapping. If the mapping is +# enabled the effect of the edit will be visible immediately. Only the +# modified regions of the destination rect will be updated by a mapping. + +procedure gim_setmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited +int rop #I rasterop +int src #I source raster +int st #I coordinate type for source raster +real sx,sy,sw,sh #I source rect +int dst #I destination raster +int dt #I coordinate type for destination raster +real dx,dy,dw,dh #I destination rect + +short gim[GIM_SETMAPPING_LEN] +errchk gpl_flush, gpl_cache +include "../gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Output the setmapping escape. + gim[GIM_SETMAPPING_MP] = mapping + gim[GIM_SETMAPPING_OP] = rop + gim[GIM_SETMAPPING_SR] = src + gim[GIM_SETMAPPING_ST] = st + + if (st == CT_PIXEL) { + gim[GIM_SETMAPPING_SX] = sx + gim[GIM_SETMAPPING_SY] = sy + gim[GIM_SETMAPPING_SW] = sw + gim[GIM_SETMAPPING_SH] = sh + } else { + gim[GIM_SETMAPPING_SX] = sx * GKI_MAXNDC + gim[GIM_SETMAPPING_SY] = sy * GKI_MAXNDC + gim[GIM_SETMAPPING_SW] = nint (sw * GKI_MAXNDC) + gim[GIM_SETMAPPING_SH] = nint (sh * GKI_MAXNDC) + } + + gim[GIM_SETMAPPING_DR] = dst + gim[GIM_SETMAPPING_DT] = dt + + if (dt == CT_PIXEL) { + gim[GIM_SETMAPPING_DX] = dx + gim[GIM_SETMAPPING_DY] = dy + gim[GIM_SETMAPPING_DW] = dw + gim[GIM_SETMAPPING_DH] = dh + } else { + gim[GIM_SETMAPPING_DX] = dx * GKI_MAXNDC + gim[GIM_SETMAPPING_DY] = dy * GKI_MAXNDC + gim[GIM_SETMAPPING_DW] = nint (dw * GKI_MAXNDC) + gim[GIM_SETMAPPING_DH] = nint (dh * GKI_MAXNDC) + } + + call gescape (gp, GIM_SETMAPPING, gim, GIM_SETMAPPING_LEN) +end diff --git a/sys/gio/gim/gimsetpix.x b/sys/gio/gim/gimsetpix.x new file mode 100644 index 00000000..09250221 --- /dev/null +++ b/sys/gio/gim/gimsetpix.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_SETPIX -- Set the pixels in a region of a raster to a solid color. +# If width=height=0 the entire raster will be written. + +procedure gim_setpix (gp, raster, ct, x1, y1, width, height, color, rop) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int ct #I coordinate type +real x1, y1 #I region to be refreshed +real width, height #I region to be refreshed +int color #I pixel value +int rop #I rasterop + +short gim[GIM_SETPIXELS_LEN] + +begin + gim[GIM_SETPIXELS_RN] = raster + gim[GIM_SETPIXELS_CT] = ct + gim[GIM_SETPIXELS_CO] = color + gim[GIM_SETPIXELS_OP] = rop + + if (ct == CT_PIXEL) { + gim[GIM_SETPIXELS_X1] = x1 + gim[GIM_SETPIXELS_Y1] = y1 + gim[GIM_SETPIXELS_NX] = width + gim[GIM_SETPIXELS_NY] = height + } else { + gim[GIM_SETPIXELS_X1] = x1 * GKI_MAXNDC + gim[GIM_SETPIXELS_Y1] = y1 * GKI_MAXNDC + gim[GIM_SETPIXELS_NX] = nint (width * GKI_MAXNDC) + gim[GIM_SETPIXELS_NY] = nint (height * GKI_MAXNDC) + } + + call gescape (gp, GIM_SETPIXELS, gim, GIM_SETPIXELS_LEN) +end diff --git a/sys/gio/gim/gimsetras.x b/sys/gio/gim/gimsetras.x new file mode 100644 index 00000000..efb5add5 --- /dev/null +++ b/sys/gio/gim/gimsetras.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_SETRASTER -- Set the raster to be used as the coordinate system for +# graphics drawing operations. A setraster for raster N causes subsequent +# drawing operations to be drawn using any raster-to-screen mappings defined +# for raster N. A setraster to raster=0 restores the normal semantics of +# drawing directly to the screen with no additional transformations. +# Applications which use gim_setraster to draw graphics or text overlays on +# a raster should always restore the raster to zero when done so that +# subsequent drawing operations (e.g., in cursor mode) behave normally. +# The setraster is not reset automatically except in a screen clear. +# +# NOTE - Most applications should use gseti(gp,G_RASTER,n) instead of the +# lower level gim_setraster. + +procedure gim_setraster (gp, raster) + +pointer gp #I graphics descriptor +int raster #I raster number + +short gim[GIM_SETRASTER_LEN] + +begin + gim[GIM_SETRASTER_RN] = raster + call gescape (gp, GIM_SETRASTER, gim, GIM_SETRASTER_LEN) +end diff --git a/sys/gio/gim/gimwcmap.x b/sys/gio/gim/gimwcmap.x new file mode 100644 index 00000000..54a6d3f2 --- /dev/null +++ b/sys/gio/gim/gimwcmap.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GIM_WRITECOLORMAP -- Write to a colormap. + +procedure gim_writecolormap (gp, colormap, first, nelem, r, g, b) + +pointer gp #I graphics descriptor +int colormap #I colormap number (0=screen) +int first #I first colormap entry to be written +int nelem #I number of elements to write +int r[ARB],g[ARB],b[ARB] #I RGB color values (0-255) + +int i +pointer sp, cm, op +short gim[GIM_WRITECMAP_LEN] +errchk gpl_flush + +begin + call gpl_flush() + + call smark (sp) + call salloc (cm, nelem * 3, TY_SHORT) + + gim[GIM_WRITECMAP_MP] = colormap + gim[GIM_WRITECMAP_FC] = first + gim[GIM_WRITECMAP_NC] = nelem + + do i = 1, nelem { + op = cm + (i - 1) * 3 + Mems[op+0] = r[i] + Mems[op+1] = g[i] + Mems[op+2] = b[i] + } + + call gki_wescape (GP_FD(gp), GIM_WRITECMAP, + gim, GIM_WRITECMAP_LEN, Mems[cm], nelem * 3) + + call sfree (sp) +end diff --git a/sys/gio/gim/gimwiomap.x b/sys/gio/gim/gimwiomap.x new file mode 100644 index 00000000..a756a235 --- /dev/null +++ b/sys/gio/gim/gimwiomap.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GIM_IOMAPWRITE -- Write to the iomap. The iomap maps client pixel values +# (colors) to gterm widget pixel value (widget colormap indices). The iomap +# should be set only if the client application does not use the gterm widget +# color model. iomap[i] gives the widget colormap index corresponding to +# client pixel I. + +procedure gim_iomapwrite (gp, iomap, first, nelem) + +pointer gp #I graphics descriptor +int iomap[ARB] #I iomap data +int first #I first iomap entry to be written +int nelem #I number of elements to write + +pointer sp, data +short gim[GIM_WRITEIOMAP_LEN] +errchk gpl_flush + +begin + call gpl_flush() + + call smark (sp) + call salloc (data, nelem, TY_SHORT) + + gim[GIM_WRITEIOMAP_FC] = first + gim[GIM_WRITEIOMAP_NC] = nelem + + call achtis (iomap, Mems[data], nelem) + call gki_wescape (GP_FD(gp), GIM_WRITEIOMAP, + gim, GIM_WRITEIOMAP_LEN, Mems[data], nelem) + + call sfree (sp) +end diff --git a/sys/gio/gim/gimwpix.x b/sys/gio/gim/gimwpix.x new file mode 100644 index 00000000..fc55a55b --- /dev/null +++ b/sys/gio/gim/gimwpix.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_WRITEPIXELS -- Write to a rectangular region of a raster. + +procedure gim_writepixels (gp, raster, data, nbits, x1, y1, nx, ny) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +short data[ARB] #I output pixel data +int nbits #I nbits per raster pixel (1,8,16,32) +int x1, y1 #I first pixel to be written +int nx, ny #I size of region to be written + +int npix, nchars, nwords +short gim[GIM_WRITEPIXELS_LEN] +errchk gpl_flush, gpl_cache +include "../gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Output the writepixels escape. + npix = nx * ny + nchars = (npix * nbits / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR + nwords = (nchars + SZ_SHORT-1) / SZ_SHORT + + gim[GIM_WRITEPIXELS_RN] = raster + gim[GIM_WRITEPIXELS_EC] = 0 + gim[GIM_WRITEPIXELS_X1] = x1 + gim[GIM_WRITEPIXELS_Y1] = y1 + gim[GIM_WRITEPIXELS_NX] = nx + gim[GIM_WRITEPIXELS_NY] = ny + gim[GIM_WRITEPIXELS_BP] = nbits + + call gki_wescape (GP_FD(gp), GIM_WRITEPIXELS, + gim, GIM_WRITEPIXELS_LEN, data, nwords) +end diff --git a/sys/gio/gim/mkpkg b/sys/gio/gim/mkpkg new file mode 100644 index 00000000..9aab719b --- /dev/null +++ b/sys/gio/gim/mkpkg @@ -0,0 +1,32 @@ +# Make the GIM (graphics imaging) interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + gimcpras.x + gimcrras.x + gimderas.x + gimdsmap.x + gimenmap.x + gimfcmap.x + gimfmap.x + gimgetmap.x + gimimap.x + gimlcmap.x + gimqras.x + gimrasini.x + gimrcmap.x + gimref.x + gimrefpix.x + gimriomap.x + gimrpix.x + gimsetmap.x ../gpl.com + gimsetpix.x + gimsetras.x + gimwcmap.x + gimwiomap.x + gimwpix.x ../gpl.com + ; diff --git a/sys/gio/gki/README b/sys/gio/gki/README new file mode 100644 index 00000000..171de8d9 --- /dev/null +++ b/sys/gio/gki/README @@ -0,0 +1,84 @@ +GKI -- The graphics kernel interface. + + The GKI package is used to encode and decode the GKI instructions used to +communicate with a graphics kernel. The kernel may be resident in the same +process, in the CL process, or in a subprocess of the CL. Output may also +be spooled in a metafile. The purposes of the GKI interface are to isolate GIO +from the kernel, to hide the details of packing and unpacking GKI metacode +from both GIO and the kernels, and to hide the details of the communications +protocols required to communicate with the different types of kernels. + + Before any i/o can be done on a GKI graphics stream, GKI must be informed +of the residency of the kernel associated with the stream. Three calls are +provided for this purpose: + + gki_redir (stream, fd, old_type, old_fd) [1] + gki_inline (stream, dd) [2] + gki_subkernel (stream, pid, epa_prpsio) [3] + +Use [1] in the normal case of GIO talking to the CL or to a metafile. The +first call will set, rather than redirect, the FD for a stream. Subsequent +calls may be made to truely redirect a stream and then restore its normal +dataflow. Use [2] when the graphics kernel is in the same process. The +kernel must already have been opened with the driver for the kernel in the +DD array. This is the most efficient mode of operation if a high data +bandwidth is required. Kernel type [2] is used by GIOTR in the CL process +to communicate with external kernels. A slightly different protocol is +required in this case since the input must be switched to the subprocess +before it can read or write the graphics stream. + + + Summary Of Procedures + +1. Initialize GKI + + gki_redir (stream, fd, old_fd, old_type) + gki_inline_kernel (stream, dd) + gki_subkernel (stream, pid, prpsio_epa) + + +2. Metacode interpretation + + gki_fetch_next_instruction (fd, instruction) (EOF|nwords) + gki_execute (gki, dd) + gki_write (fd, gki) + + +3. Instructions + + gki_cancel (fd) + gki_clear (fd) + gki_closews (fd, device) + gki_deactivatews (fd) + gki_eof (fd) + gki_escape (fd, fn, instruction, nwords) + gki_faset (fd, ap) + gki_fillarea (fd, points, npts) + gki_flush (fd) + gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_getcursor (fd, x, y, key, cursor) + gki_getwcs (fd, wcs, len_wcs) + gki_mftitle (fd, title) + gki_openws (fd, device, mode) + gki_plset (fd, ap) + gki_pmset (fd, ap) + gki_polyline (fd, points, npts) + gki_polymarker (fd, points, npts) + gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_reactivatews (fd) + gki_setcursor (fd, x, y, cursor) + gki_setwcs (fd, wcs, len_wcs) + gki_text (fd, x, y, text) + gki_txset (fd, ap) + + +4. Instructions for encoding return values + + gki_retcellarray (fd, m, np) + gki_retcursorvalue (fd, x, y, key, cursor) + + +5. Initialization of the GKIPRINT kernel + + gkp_install (dd, out_fd, verbose_output) + gkp_close () diff --git a/sys/gio/gki/gki.com b/sys/gio/gki/gki.com new file mode 100644 index 00000000..4c5e3152 --- /dev/null +++ b/sys/gio/gki/gki.com @@ -0,0 +1,8 @@ +# Common for the GKI (graphics kernel interface) package. + +int gk_type[LAST_FD] # type of output +int gk_fd[LAST_FD] # output file descriptor +int gk_dd[LEN_GKIDD] # local device driver +int gk_prpsio # EPA of pr_psio procedure + +common /gkicom/ gk_type, gk_fd, gk_dd, gk_prpsio diff --git a/sys/gio/gki/gkicancel.x b/sys/gio/gki/gkicancel.x new file mode 100644 index 00000000..ff2bc5f4 --- /dev/null +++ b/sys/gio/gki/gkicancel.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_CANCEL -- Cancel graphics output and reset internal parameters. +# +# BOI GKI_CANCEL 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_cancel (fd) + +int fd # output file + +int epa +short gki[GKI_CANCEL_LEN] +data gki[1] /BOI/, gki[2] /GKI_CANCEL/, gki[3] /LEN_GKIHDR/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_CANCEL] + if (epa != 0) + call zcall1 (epa, 0) + } else + call write (gk_fd[fd], gki, GKI_CANCEL_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiclear.x b/sys/gio/gki/gkiclear.x new file mode 100644 index 00000000..ac1e5961 --- /dev/null +++ b/sys/gio/gki/gkiclear.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_CLEAR -- Clear the workstation screen. +# +# BOI GKI_CLEAR 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_clear (fd) + +int fd # output file + +int epa +short gki[GKI_CLEAR_LEN] +data gki[1] /BOI/, gki[2] /GKI_CLEAR/, gki[3] /LEN_GKIHDR/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_CLEAR] + if (epa != 0) + call zcall1 (epa, 0) + } else + call write (gk_fd[fd], gki, GKI_CLEAR_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiclose.x b/sys/gio/gki/gkiclose.x new file mode 100644 index 00000000..e7ceea15 --- /dev/null +++ b/sys/gio/gki/gkiclose.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_CLOSEWS -- Close workstation. +# +# BOI GKI_CLOSEWS L N D +# +# L(i) 4 + N +# N(i) number of characters in field D +# D(Nc) device name as in graphcap file + +procedure gki_closews (fd, device) + +int fd # output file +char device[ARB] # device name + +int epa +int ip, nchars, n +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (device) + call salloc (gki, GKI_CLOSEWS_LEN + n, TY_SHORT) + + # Pack the device name as a SHORT integer array. + op = gki + GKI_CLOSEWS_D - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = device[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_CLOSEWS] + if (epa != 0) + call zcall2 (epa, Mems[gki+GKI_CLOSEWS_D-1], n) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_CLOSEWS + Mems[gki+2] = GKI_CLOSEWS_LEN + n + Mems[gki+GKI_CLOSEWS_N-1] = n + + # Send a copy of the close workstation directive to PSIOCTRL in + # the CL process to connect the graphics stream to a kernel, + # before writing to the graphics stream. The GKI instruction + # must be preceded by the integer value of the stream number. + + nchars = (GKI_CLOSEWS_LEN + n) * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, Mems[gki], nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], Mems[gki], nchars) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkideact.x b/sys/gio/gki/gkideact.x new file mode 100644 index 00000000..b742f7ed --- /dev/null +++ b/sys/gio/gki/gkideact.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_DEACTIVATEWS -- Deactivate the workstation (disable graphics). +# +# BOI GKI_DEACTIVATEWS L F +# +# L(i) 4 +# F flags (0,AW_PAUSE,AW_CLEAR) + +procedure gki_deactivatews (fd, flags) + +int fd # output file +int flags # action modifier flags + +int epa, nchars +short gki[GKI_DEACTIVATEWS_LEN] +data gki[1] /BOI/, gki[2] /GKI_DEACTIVATEWS/, gki[3] /GKI_DEACTIVATEWS_LEN/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_DEACTIVATEWS] + if (epa != 0) + call zcall1 (epa, flags) + + } else { + # Send a copy to the pseudofile i/o controller. + gki[GKI_DEACTIVATEWS_F] = flags + nchars = GKI_DEACTIVATEWS_LEN * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], gki, nchars) + } +end diff --git a/sys/gio/gki/gkieof.x b/sys/gio/gki/gkieof.x new file mode 100644 index 00000000..05700156 --- /dev/null +++ b/sys/gio/gki/gkieof.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_EOF -- Signal end of file on a metacode stream. +# +# BOI GKI_EOF 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_eof (fd) + +int fd # output file + +short gki[GKI_EOF_LEN] +data gki[1] /BOI/, gki[2] /GKI_EOF/, gki[3] /LEN_GKIHDR/ +include "gki.com" + +begin + if (!IS_INLINE(fd)) + call write (gk_fd[fd], gki, GKI_EOF_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiesc.x b/sys/gio/gki/gkiesc.x new file mode 100644 index 00000000..a33c769d --- /dev/null +++ b/sys/gio/gki/gkiesc.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_ESCAPE -- Pass a device dependent instruction on to the kernel. +# +# BOI GKI_ESCAPE L FN N DC +# +# L(i) 5 + N +# FN(i) escape function code +# N(i) number of escape data words +# DC(i) escape data words + +procedure gki_escape (fd, fn, instruction, nwords) + +int fd # output file +int fn # function code +short instruction[ARB] # instruction sequence of unknown format +int nwords # number of shorts in instruction + +int epa +short gki[GKI_ESCAPE_LEN] +data gki[1] /BOI/, gki[2] /GKI_ESCAPE/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_ESCAPE] + if (epa != 0) + call zcall3 (epa, fn, instruction, nwords) + } else { + gki[GKI_ESCAPE_L] = GKI_ESCAPE_LEN + nwords + gki[GKI_ESCAPE_N] = nwords + gki[GKI_ESCAPE_FN] = fn + + call write (gk_fd[fd], gki, GKI_ESCAPE_LEN * SZ_SHORT) + call write (gk_fd[fd], instruction, nwords * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkiexe.x b/sys/gio/gki/gkiexe.x new file mode 100644 index 00000000..05e8ec8d --- /dev/null +++ b/sys/gio/gki/gkiexe.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKI_EXECUTE -- Execute a metacode instruction. The instruction is decoded +# and a graphics kernel driver subroutine is called to execute the instruction. +# If the device driver does not include a procedure for the instruction the +# instruction is discarded. Integer and real parameters are unpacked from +# their short integer metacode representation. Character data is passed by +# reference, i.e., as a SHORT integer array (not EOS delimited char!!), along +# with the character count. Attribute packets are passed to the set attribute +# procedure by reference as a short integer array. + +procedure gki_execute (gki, dd) + +short gki[ARB] # graphics kernel instruction +int dd[ARB] # device driver + +int kp # kernel procedure +int m, n, cn, fn, dummy, flags +int x, y, x1, y1, x2, y2 + +begin + switch (gki[GKI_HDR_OPCODE]) { + + case GKI_OPENWS: + kp = dd[GKI_OPENWS] + if (kp != NULL) { + m = gki[GKI_OPENWS_M] + n = gki[GKI_OPENWS_N] + call zcall3 (kp, gki[GKI_OPENWS_D], n, m) + } + case GKI_CLOSEWS: + kp = dd[GKI_CLOSEWS] + if (kp != NULL) { + n = gki[GKI_CLOSEWS_N] + call zcall2 (kp, gki[GKI_CLOSEWS_D], n) + } + case GKI_REACTIVATEWS: + kp = dd[GKI_REACTIVATEWS] + if (kp != NULL) { + flags = gki[GKI_REACTIVATEWS_F] + call zcall1 (kp, flags) + } + case GKI_DEACTIVATEWS: + kp = dd[GKI_DEACTIVATEWS] + if (kp != NULL) { + flags = gki[GKI_DEACTIVATEWS_F] + call zcall1 (kp, flags) + } + case GKI_MFTITLE: + kp = dd[GKI_MFTITLE] + if (kp != NULL) { + n = gki[GKI_MFTITLE_N] + call zcall2 (kp, gki[GKI_MFTITLE_T], n) + } + case GKI_CLEAR: + kp = dd[GKI_CLEAR] + if (kp != NULL) { + call zcall1 (kp, dummy) + } + case GKI_CANCEL: + kp = dd[GKI_CANCEL] + if (kp != NULL) { + call zcall1 (kp, dummy) + } + case GKI_FLUSH: + kp = dd[GKI_FLUSH] + if (kp != NULL) { + call zcall1 (kp, dummy) + } + case GKI_POLYLINE: + kp = dd[GKI_POLYLINE] + if (kp != 0) { + n = gki[GKI_POLYLINE_N] + call zcall2 (kp, gki[GKI_POLYLINE_P], n) + } + case GKI_POLYMARKER: + kp = dd[GKI_POLYMARKER] + if (kp != 0) { + n = gki[GKI_POLYMARKER_N] + call zcall2 (kp, gki[GKI_POLYMARKER_P], n) + } + case GKI_TEXT: + kp = dd[GKI_TEXT] + if (kp != NULL) { + x = gki[GKI_TEXT_P] + y = gki[GKI_TEXT_P+1] + n = gki[GKI_TEXT_N] + call zcall4 (kp, x, y, gki[GKI_TEXT_T], n) + } + case GKI_FILLAREA: + kp = dd[GKI_FILLAREA] + if (kp != 0) { + n = gki[GKI_FILLAREA_N] + call zcall2 (kp, gki[GKI_FILLAREA_P], n) + } + case GKI_PUTCELLARRAY: + kp = dd[GKI_PUTCELLARRAY] + if (kp != NULL) { + x1 = gki[GKI_PUTCELLARRAY_LL] + y1 = gki[GKI_PUTCELLARRAY_LL+1] + x2 = gki[GKI_PUTCELLARRAY_UR] + y2 = gki[GKI_PUTCELLARRAY_UR+1] + m = gki[GKI_PUTCELLARRAY_NC] + n = gki[GKI_PUTCELLARRAY_NL] + call zcall7 (kp, gki[GKI_PUTCELLARRAY_P], m, n, x1,y1, x2,y2) + } + case GKI_SETCURSOR: + kp = dd[GKI_SETCURSOR] + if (kp != NULL) { + cn = gki[GKI_SETCURSOR_CN] + x = gki[GKI_SETCURSOR_POS] + y = gki[GKI_SETCURSOR_POS+1] + call zcall3 (kp, x, y, cn) + } + case GKI_PLSET: + kp = dd[GKI_PLSET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_PMSET: + kp = dd[GKI_PMSET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_TXSET: + kp = dd[GKI_TXSET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_FASET: + kp = dd[GKI_FASET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_GETCURSOR: + kp = dd[GKI_GETCURSOR] + if (kp != NULL) { + cn = gki[GKI_GETCURSOR_CN] + call zcall1 (kp, cn) + } + case GKI_GETCELLARRAY: + kp = dd[GKI_GETCELLARRAY] + if (kp != NULL) { + x1 = gki[GKI_GETCELLARRAY_LL] + y1 = gki[GKI_GETCELLARRAY_LL+1] + x2 = gki[GKI_GETCELLARRAY_UR] + y2 = gki[GKI_GETCELLARRAY_UR+1] + m = gki[GKI_GETCELLARRAY_NC] + n = gki[GKI_GETCELLARRAY_NL] + call zcall6 (kp, m, n, x1,y1, x2,y2) + } + case GKI_ESCAPE: + kp = dd[GKI_ESCAPE] + if (kp != NULL) { + fn = gki[GKI_ESCAPE_FN] + n = gki[GKI_ESCAPE_N] + call zcall3 (kp, fn, gki[GKI_ESCAPE_DC], n) + } + case GKI_SETWCS: + kp = dd[GKI_SETWCS] + if (kp != NULL) { + n = gki[GKI_SETWCS_N] + call zcall2 (kp, gki[GKI_SETWCS_WCS], n) + } + case GKI_GETWCS: + kp = dd[GKI_SETWCS] + if (kp != NULL) { + n = gki[GKI_SETWCS_N] + call zcall2 (kp, gki[GKI_SETWCS_WCS], n) + } + default: + kp = dd[GKI_UNKNOWN] + if (kp != NULL) + call zcall1 (kp, gki) + } +end diff --git a/sys/gio/gki/gkifa.x b/sys/gio/gki/gkifa.x new file mode 100644 index 00000000..328ec7cc --- /dev/null +++ b/sys/gio/gki/gkifa.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_FILLAREA -- Output the fill area instruction. +# +# BOI GKI_FILLAREA L N P +# +# L(i) 4 + (N * 2) +# N(i) number of points defining the polygon to be filled +# P(Np) list of points (x,y pairs) + +procedure gki_fillarea (fd, points, npts) + +int fd # output file +short points[ARB] # polygon defining area to be filled +int npts # number of (x,y) points in polygon + +int epa +short gki[GKI_FILLAREA_LEN] +data gki[1] /BOI/, gki[2] /GKI_FILLAREA/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_FILLAREA] + if (epa != 0) + call zcall2 (epa, points, npts) + } else { + gki[GKI_FILLAREA_L] = GKI_FILLAREA_LEN + (npts * 2) + gki[GKI_FILLAREA_N] = npts + + call write (gk_fd[fd], gki, GKI_FILLAREA_LEN * SZ_SHORT) + call write (gk_fd[fd], points, (npts * 2) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkifaset.x b/sys/gio/gki/gkifaset.x new file mode 100644 index 00000000..7531be73 --- /dev/null +++ b/sys/gio/gki/gkifaset.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_FASET -- Set the fill area attributes. +# +# BOI GKI_FASET L FS CI +# +# L(i) 5 +# FS(i) fill style (0=clear,1=hollow,2=solid,3-6=hatch) +# CI(i) fill area color index + +procedure gki_faset (fd, ap) + +int fd # output file +pointer ap # pointer to fillarea attribute structure + +int epa +short gki[GKI_FASET_LEN] +data gki[1] /BOI/, gki[2] /GKI_FASET/, gki[3] /GKI_FASET_LEN/ +include "gki.com" + +begin + gki[GKI_FASET_FS] = FA_STYLE(ap) + gki[GKI_FASET_CI] = FA_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_FASET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_FASET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkifetch.x b/sys/gio/gki/gkifetch.x new file mode 100644 index 00000000..53fa315b --- /dev/null +++ b/sys/gio/gki/gkifetch.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define LEN_DEFIBUF 2048 +define ONEWORD SZ_SHORT +define TWOWORDS (2*SZ_SHORT) + +# Header fields of a GKI instruction. +define I_BOI Mems[$1+GKI_HDR_BOI-1] +define I_OPCODE Mems[$1+GKI_HDR_OPCODE-1] +define I_LENGTH Mems[$1+GKI_HDR_LENGTH-1] +define I_DATA Mems[$1+GKI_DATAFIELDS-1] + +# GKI_FETCH_NEXT_INSTRUCTION -- Fetch the next GKI metacode instruction from the +# input stream. A pointer to a short integer buffer containing the instruction +# is returned as an output argument. EOF is returned as the function value +# when EOF is seen on the input stream. The instruction buffer may be +# deallocated by our caller at any time, if desired. A new buffer will be +# created automatically when next we are called. + +int procedure gki_fetch_next_instruction (fd, instruction) + +int fd # input file containing metacode +pointer instruction # pointer to instruction (output) + +int len_ibuf, nchars +pointer ibuf +int read() +errchk read, malloc, realloc +data ibuf /NULL/ + +begin + # Allocate a default sized instruction buffer. We can reallocate + # a larger buffer later if necessary. + + if (ibuf == NULL) { + call malloc (ibuf, LEN_DEFIBUF, TY_SHORT) + len_ibuf = LEN_DEFIBUF + } + + # Advance to the next instruction. Nulls and botched portions of + # instructions are ignored. Read the instruction header to determine + # the length of the instruction, and then read the rest of instruction + # into buffer. If the entire instruction cannot be read we have a + # botched instruction and must try again. + + repeat { + repeat { + if (read (fd, I_BOI(ibuf), ONEWORD) == EOF) + return (EOF) + } until (I_BOI(ibuf) == BOI) + + if (read (fd, I_OPCODE(ibuf), TWOWORDS) == EOF) + return (EOF) + + # Make instruction buffer large enough to hold instruction. + # Compute length of remainder of instruction in chars. + + if (I_LENGTH(ibuf) > len_ibuf) { + len_ibuf = I_LENGTH(ibuf) + call realloc (ibuf, len_ibuf, TY_SHORT) + } + + nchars = (I_LENGTH(ibuf) - LEN_GKIHDR) * SZ_SHORT + if (nchars == 0) + break + + } until (read (fd, I_DATA(ibuf), nchars) == nchars) + + instruction = ibuf + + # Check for a soft end of file, otherwise return the length of the + # instruction as the function value. + + if (I_OPCODE(ibuf) == GKI_EOF) + return (EOF) + else + return (I_LENGTH(ibuf)) +end diff --git a/sys/gio/gki/gkifflush.x b/sys/gio/gki/gkifflush.x new file mode 100644 index 00000000..9eebf406 --- /dev/null +++ b/sys/gio/gki/gkifflush.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_FFLUSH -- Flush a graphics stream. This does not issue the GKI_FLUSH +# graphics instruction to the graphics kernel, it merely flushes any buffered +# data in the output stream, and is a no-op in the case of an inline kernel. + +procedure gki_fflush (fd) + +int fd # output file + +errchk seek +include "gki.com" + +begin + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_WRITE) + } else if (!IS_INLINE(fd)) + call flush (gk_fd[fd]) +end diff --git a/sys/gio/gki/gkiflush.x b/sys/gio/gki/gkiflush.x new file mode 100644 index 00000000..878502d4 --- /dev/null +++ b/sys/gio/gki/gkiflush.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_FLUSH -- Flush any buffered output. +# +# BOI GKI_FLUSH 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_flush (fd) + +int fd # output file + +int epa +short gki[GKI_FLUSH_LEN] +data gki[1] /BOI/, gki[2] /GKI_FLUSH/, gki[3] /LEN_GKIHDR/ +errchk write, seek +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_FLUSH] + if (epa != 0) + call zcall1 (epa, 0) + } else { + call write (gk_fd[fd], gki, GKI_FLUSH_LEN * SZ_SHORT) + + # If writing to a subkernel we must call PR_PSIO to give the + # kernel a chance to read the spooled metacode. + + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_WRITE) + } else + call flush (gk_fd[fd]) + } +end diff --git a/sys/gio/gki/gkigca.x b/sys/gio/gki/gkigca.x new file mode 100644 index 00000000..07abf9d3 --- /dev/null +++ b/sys/gio/gki/gkigca.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# GKI_GETCELLARRAY -- Input a cell array (pixel array). +# +# BOI GKI_GETCELLARRAY L LL UR NC NL +# +# L(i) 9 +# LL(p) coordinates of lower left corner of input area +# UR(p) coordinates of upper right corner of input area +# NC(i) number of columns in array +# NL(i) number of lines in array + +procedure gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) + +int fd # output file +int nx, ny # number of columns and lines in M +short m[nx,ny] # output array +int x1, y1 # lower left corner of window to be read +int x2, y2 # upper right corner of window to be read + +int epa, nchars, npts +short ca[GKI_CELLARRAY_LEN] +short gki[GKI_GETCELLARRAY_LEN] +int read() +data gki[1] /BOI/, gki[2] /GKI_GETCELLARRAY/, gki[3] /GKI_GETCELLARRAY_LEN/ +errchk write, seek, flush, read +include "gki.com" + +begin + # If the kernel is inline it will return the cell array value in the + # graphics stream FIO buffer just as if the kernel were resident + # in another process. We rewind the buffer after the kernel writes + # into it in preparation for the read below. + + if (IS_INLINE(fd)) { + call fseti (fd, F_CANCEL, OK) + epa = gk_dd[GKI_GETCELLARRAY] + if (epa != 0) + call zcall6 (epa, nx,ny, x1,y1, x2,y2) + call seek (fd, BOFL) + + } else { + # Write get cell array instruction to the kernel. + + gki[GKI_GETCELLARRAY_LL] = x1 + gki[GKI_GETCELLARRAY_LL+1] = y1 + gki[GKI_GETCELLARRAY_UR] = x2 + gki[GKI_GETCELLARRAY_UR+1] = y2 + gki[GKI_GETCELLARRAY_NC] = nx + gki[GKI_GETCELLARRAY_NL] = ny + + call write (gk_fd[fd], gki, GKI_GETCELLARRAY_LEN) + + # If the kernel is a subprocess we must call PR_PSIO to allow the + # kernel to read the instruction and return the cell array value. + + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_READ) + call seek (fd, BOFL) + } else + call flush (gk_fd[fd]) + } + + # Read and decode the cell array value. + + nchars = GKI_CELLARRAY_LEN * SZ_SHORT + if (read (fd, ca, nchars) < nchars) { + call syserr (SYS_GGCELL) + } else if (ca[1] != BOI || ca[2] != GKI_CELLARRAY || + ca[GKI_CELLARRAY_NP] <= 0) { + call syserr (SYS_GGCELL) + } else { + npts = ca[GKI_CELLARRAY_NP] + nchars = min (nx * ny, npts) * SZ_SHORT + if (read (fd, m, nchars) < nchars) + call syserr (SYS_GGCELL) + } + + call fseti (fd, F_CANCEL, OK) +end diff --git a/sys/gio/gki/gkigcur.x b/sys/gio/gki/gkigcur.x new file mode 100644 index 00000000..e87e030e --- /dev/null +++ b/sys/gio/gki/gkigcur.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# GKI_GETCURSOR -- Read the cursor position in device coordinates. +# +# BOI GKI_GETCURSOR L CN +# +# L(i) 4 +# CN(i) cursor number +# +# The kernel reads graphics cursor number CN and returns the +# keystroke value (if any) and the cursor position in NDC +# coordinates. The cursor attributes are returned in the +# following format: +# +# BOI GKI_CURSORVALUE L CN KEY SX SY RN RX RY +# +# where +# +# L(i) 10 +# CN(i) cursor number +# KEY(i) keystroke value (>= 0 or EOF) +# SX(i) NDC X screen coordinate of cursor +# SY(i) NDC Y screen coordinate of cursor +# RN(i) raster number or zero +# RX(i) NDC X raster coordinate of cursor +# RY(i) NDC Y raster coordinate of cursor +# +# The screen or display window coordinates SX and SY of the cursor are +# returned for all devices. Only some devices support multiple rasters. +# If the device supports rasters and the cursor is in a rasters when read, the +# rasters number and rasters coordinates are returned in RN,RX,RY. This is in +# addition to the screen coordinates SX,SY. If rasters coordinates are not +# returned, the rasters number will be set to zero and RX,RY will be the same +# as SX,SY. + +procedure gki_getcursor (fd, cursor, cn, key, sx, sy, raster, rx, ry) + +int fd #I output file +int cursor #I cursor to be read +int cn #O cursor number actually read +int key #O keystroke value or EOF +int sx, sy #O screen coordinates of cursor +int raster #O raster number +int rx, ry #O raster coordinates of cursor + +int epa +int nchars, read() +short gki[GKI_GETCURSOR_LEN] +short cur[GKI_CURSORVALUE_LEN] +data gki[1] /BOI/, gki[2] /GKI_GETCURSOR/, gki[3] /GKI_GETCURSOR_LEN/ +include "gki.com" +errchk write, flush, read + +begin + # If the kernel is inline it will return the cursor value in the + # graphics stream FIO buffer just as if the kernel were resident + # in another process. We rewind the buffer after the kernel writes + # into it in preparation for the read below. + + if (IS_INLINE(fd)) { + call fseti (fd, F_CANCEL, OK) + epa = gk_dd[GKI_GETCURSOR] + if (epa != 0) + call zcall1 (epa, cursor) + call seek (fd, BOFL) + + } else { + # Write cursor read instruction to the kernel. + gki[GKI_GETCURSOR_CN] = cursor + call write (gk_fd[fd], gki, GKI_GETCURSOR_LEN * SZ_SHORT) + + # If the kernel is a subprocess we must call PR_PSIO to allow the + # kernel to read the instruction and return the cursor value. + + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_READ) + call seek (fd, BOFL) + } else + call flush (gk_fd[fd]) + } + + # Read and decode the cursor value instruction. + nchars = GKI_CURSORVALUE_LEN * SZ_SHORT + if (read (fd, cur, nchars) < nchars) + key = EOF + else if (cur[1] != BOI || cur[2] != GKI_CURSORVALUE) + call syserr (SYS_GGCUR) + else { + cn = cur[GKI_CURSORVALUE_CN] + key = cur[GKI_CURSORVALUE_KEY] + sx = cur[GKI_CURSORVALUE_SX] + sy = cur[GKI_CURSORVALUE_SY] + raster = cur[GKI_CURSORVALUE_RN] + rx = cur[GKI_CURSORVALUE_RX] + ry = cur[GKI_CURSORVALUE_RY] + } + + call fseti (fd, F_CANCEL, OK) +end diff --git a/sys/gio/gki/gkigetwcs.x b/sys/gio/gki/gkigetwcs.x new file mode 100644 index 00000000..f6aa07c2 --- /dev/null +++ b/sys/gio/gki/gkigetwcs.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_GETWCS -- Retrieve the WCS from the CL process. Used when opening a +# (non-metafile) device in append mode. +# +# BOI GKI_GETWCS L N +# +# L(i) 3 +# N(i) number of words of WCS data to be read + +procedure gki_getwcs (fd, wcs, len_wcs) + +int fd # input/output file +int wcs[ARB] # array of WCS structures (output) +int len_wcs # number of ints (struct units) in array + +int nchars, nwords, read() +short gki[GKI_GETWCS_LEN] +data gki[1] /BOI/, gki[2] /GKI_GETWCS/, gki[3] /GKI_GETWCS_LEN/ +errchk syserr, read, write, flush +include "gki.com" + +begin + nwords = (len_wcs * SZ_INT / SZ_SHORT) + gki[GKI_GETWCS_N] = nwords + + # Request CL to send SETWCS instruction back to us. The directive + # must be sent on the pseudofile control stream. + + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, GKI_GETWCS_LEN * SZ_SHORT) + call flush (PSIOCTRL) + + # Read the wcs data. This is returned on the process CLIN channel + # by the CL. + + nchars = nwords * SZ_SHORT + if (read (CLIN, wcs, nchars) != nchars) + call syserr (SYS_GGETWCS) +end diff --git a/sys/gio/gki/gkiinit.x b/sys/gio/gki/gkiinit.x new file mode 100644 index 00000000..0813a708 --- /dev/null +++ b/sys/gio/gki/gkiinit.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_INIT -- Initialize GKI i/o on a graphics stream. Called by GOPEN to +# make the connection to either a metacode stream file or an inline kernel. +# If the stream has already been directed to a kernel we do nothing, else +# we initialize the stream as for a metacode file or remote kernel. If +# gki_inline is called before gopen then this procedure is a nop. + +procedure gki_init (stream) + +int stream # graphics stream to be redirected +include "gki.com" + +begin + if (gk_type[stream] == NULL) { + gk_type[stream] = TY_FILE + gk_fd[stream] = stream + } +end diff --git a/sys/gio/gki/gkiinline.x b/sys/gio/gki/gkiinline.x new file mode 100644 index 00000000..87fc1f29 --- /dev/null +++ b/sys/gio/gki/gkiinline.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_INLINE_KERNEL -- Identify a graphics stream for use with an inline +# kernel, i.e., with a kernel linked into the same process as the high level +# code which calls the GKI procedures. At present there may be at most one +# inline kernel at a time. The entry point addresses of the kernel procedures +# are passed in the array DD. Subsequent GKI calls for the named stream will +# result in direct calls to the inline kernel without encoding and decoding +# GKI instructions, hence this is the most efficient mode of operation. + +procedure gki_inline_kernel (stream, dd) + +int stream # graphics stream to be redirected +int dd[ARB] # device driver for the kernel +include "gki.com" + +begin + gk_type[stream] = TY_INLINE + call amovi (dd, gk_dd, LEN_GKIDD) +end diff --git a/sys/gio/gki/gkikern.x b/sys/gio/gki/gkikern.x new file mode 100644 index 00000000..95c8e648 --- /dev/null +++ b/sys/gio/gki/gkikern.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_SUBKERNEL -- Identify a graphics stream for use with a kernel in a +# connected subprocess of the current process. This type of kernel is +# equivalent to a file for all of the output instructions, but the input +# instructions (e.g., read cursor) must fiddle with process i/o and need +# additional information to do so, i.e., the process id number of the kernel +# process, and the entry point address of the PR_PSIO procedure. We do not +# wish to directly reference the latter procedure as this would require +# all processes which use GKI to link in the process control code, even if +# they never talk directly to a process. Note that processes which talk to +# an external kernel via the CL do so with the normal file interface, hence +# do not need to call us. We are called by the GIOTR (cursor mode) code in +# the CL process when an external kernel is spawned. + +procedure gki_subkernel (stream, pid, prpsio_epa) + +int stream # graphics stream to be redirected +int pid # process id of kernel process +int prpsio_epa # epa of the etc$prpsio procedure. +include "gki.com" + +begin + gk_type[stream] = pid + gk_fd[stream] = stream + gk_prpsio = prpsio_epa +end diff --git a/sys/gio/gki/gkiopen.x b/sys/gio/gki/gkiopen.x new file mode 100644 index 00000000..562ed8c3 --- /dev/null +++ b/sys/gio/gki/gkiopen.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_OPENWS -- Open workstation. +# +# BOI GKI_OPENWS L M N D +# +# L(i) 5 + N +# M(i) access mode (APPEND=4, NEW_FILE=5, TEE=6) +# N(i) number of characters in field D +# D(Nc) device name as in graphcap file + +procedure gki_openws (fd, device, mode) + +int fd # output file +char device[ARB] # device name +int mode # access mode + +int ip, n, epa, nchars +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (device) + call salloc (gki, GKI_OPENWS_LEN + n, TY_SHORT) + + # Pack the device name as a SHORT integer array. + op = gki + GKI_OPENWS_D - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = device[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_OPENWS] + if (epa != 0) + call zcall3 (epa, Mems[gki+GKI_OPENWS_D-1], n, mode) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_OPENWS + Mems[gki+2] = GKI_OPENWS_LEN + n + Mems[gki+GKI_OPENWS_M-1] = mode + Mems[gki+GKI_OPENWS_N-1] = n + + # Send a copy of the open workstation directive to PSIOCTRL in + # the CL process to connect the graphics stream to a kernel, + # before writing to the graphics stream. The GKI instruction + # must be preceded by the integer value of the stream number. + + nchars = (GKI_OPENWS_LEN + n) * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, Mems[gki], nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], Mems[gki], nchars) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkipca.x b/sys/gio/gki/gkipca.x new file mode 100644 index 00000000..b2cf30ab --- /dev/null +++ b/sys/gio/gki/gkipca.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_PUTCELLARRAY -- Output a cell array (pixel array). +# +# BOI GKI_PUTCELLARRAY L LL UR NC NL P +# +# L(i) 9 + (NC * NL) +# LL(p) coordinates of lower left corner of output area +# UR(p) coordinates of upper right corner of output area +# NC(i) number of columns in array +# NL(i) number of lines in array +# P(NCNLi) array of color indices (pixels) stored by row + +procedure gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) + +int fd # output file +int nx, ny # number of columns and lines in M +short m[nx,ny] # pixel array +int x1, y1 # lower left corner of window to be written +int x2, y2 # upper right corner of window to be written + +int epa +short gki[GKI_PUTCELLARRAY_LEN] +data gki[1] /BOI/, gki[2] /GKI_PUTCELLARRAY/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_PUTCELLARRAY] + if (epa != 0) + call zcall7 (epa, m, nx,ny, x1,y1, x2,y2) + } else { + gki[GKI_PUTCELLARRAY_L] = GKI_PUTCELLARRAY_LEN + (nx * ny) + gki[GKI_PUTCELLARRAY_LL] = x1 + gki[GKI_PUTCELLARRAY_LL+1] = y1 + gki[GKI_PUTCELLARRAY_UR] = x2 + gki[GKI_PUTCELLARRAY_UR+1] = y2 + gki[GKI_PUTCELLARRAY_NC] = nx + gki[GKI_PUTCELLARRAY_NL] = ny + + call write (gk_fd[fd], gki, GKI_PUTCELLARRAY_LEN) + call write (gk_fd[fd], m, (nx * ny) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkipl.x b/sys/gio/gki/gkipl.x new file mode 100644 index 00000000..7d36b749 --- /dev/null +++ b/sys/gio/gki/gkipl.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_POLYLINE -- Output a polyline. +# +# BOI GKI_POLYLINE L N P +# +# L(i) 4 + (N * 2) +# N(i) number of points in the polyline +# P(Np) list of points (x,y pairs) + +procedure gki_polyline (fd, points, npts) + +int fd # output file +short points[ARB] # polyline +int npts # number of (x,y) points in polyline + +int epa +short gki[GKI_POLYLINE_LEN] +data gki[1] /BOI/, gki[2] /GKI_POLYLINE/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_POLYLINE] + if (epa != 0) + call zcall2 (epa, points, npts) + } else { + gki[GKI_POLYLINE_L] = GKI_POLYLINE_LEN + (npts * 2) + gki[GKI_POLYLINE_N] = npts + + call write (gk_fd[fd], gki, GKI_POLYLINE_LEN * SZ_SHORT) + call write (gk_fd[fd], points, (npts * 2) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkiplset.x b/sys/gio/gki/gkiplset.x new file mode 100644 index 00000000..1a7b092f --- /dev/null +++ b/sys/gio/gki/gkiplset.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_PLSET -- Set the polyline attributes. +# +# BOI GKI_PLSET L LT LW CI +# +# L(i) 6 +# LT(i) linetype number +# LW(r) linewidth scale factor +# CI(i) polyline color index + +procedure gki_plset (fd, ap) + +int fd # output file +pointer ap # pointer to polyline attribute structure + +int epa +short gki[GKI_PLSET_LEN] +data gki[1] /BOI/, gki[2] /GKI_PLSET/, gki[3] /GKI_PLSET_LEN/ +include "gki.com" + +begin + gki[GKI_PLSET_LT] = PL_LTYPE(ap) + gki[GKI_PLSET_LW] = GKI_PACKREAL (PL_WIDTH(ap)) + gki[GKI_PLSET_CI] = PL_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_PLSET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_PLSET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkipm.x b/sys/gio/gki/gkipm.x new file mode 100644 index 00000000..ea493b54 --- /dev/null +++ b/sys/gio/gki/gkipm.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_POLYMARKER -- Output a polymarker. +# +# BOI GKI_POLYMARKER L N P +# +# L(i) 4 + (N * 2) +# N(i) number of points in the polymarker +# P(Np) list of points (x,y pairs) + +procedure gki_polymarker (fd, points, npts) + +int fd # output file +short points[ARB] # polymarker +int npts # number of (x,y) points in polymarker + +int epa +short gki[GKI_POLYMARKER_LEN] +data gki[1] /BOI/, gki[2] /GKI_POLYMARKER/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_POLYMARKER] + if (epa != 0) + call zcall2 (epa, points, npts) + } else { + gki[GKI_POLYMARKER_L] = GKI_POLYMARKER_LEN + (npts * 2) + gki[GKI_POLYMARKER_N] = npts + + call write (gk_fd[fd], gki, GKI_POLYMARKER_LEN * SZ_SHORT) + call write (gk_fd[fd], points, (npts * 2) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkipmset.x b/sys/gio/gki/gkipmset.x new file mode 100644 index 00000000..7bdc27ac --- /dev/null +++ b/sys/gio/gki/gkipmset.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_PMSET -- Set the polymarker attributes. +# +# BOI GKI_PMSET L MT MW CI +# +# L(i) 6 +# MT(i) marktype (not used at present) +# MW(i) marksize, NDC coords (not used at present) +# CI(i) marker color index + +procedure gki_pmset (fd, ap) + +int fd # output file +pointer ap # pointer to polymarker attribute structure + +int epa +short gki[GKI_PMSET_LEN] +data gki[1] /BOI/, gki[2] /GKI_PMSET/, gki[3] /GKI_PMSET_LEN/ +include "gki.com" + +begin + gki[GKI_PMSET_MT] = PM_LTYPE(ap) + gki[GKI_PMSET_MW] = GKI_PACKREAL (PM_WIDTH(ap)) + gki[GKI_PMSET_CI] = PM_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_PMSET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_PMSET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiprint.x b/sys/gio/gki/gkiprint.x new file mode 100644 index 00000000..14e623bd --- /dev/null +++ b/sys/gio/gki/gkiprint.x @@ -0,0 +1,820 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +.help gkiprint +.nf __________________________________________________________________________ +GKIPRINT -- Graphics kernel for decoding metacode. This graphics kernel +formats metacode instructions into readable form and prints them on the output +file. The gkiprint kernel is useful for examining metafiles and for +debugging kernels which drive specific devices. The driver consists of the +following procedures: + + gkp_openws (devname, n, mode) + gkp_closews (devname, n) + gkp_deactivatews (flags) + gkp_reactivatews (flags) + gkp_mftitle (title, n) ** + gkp_clear (dummy) + gkp_cancel (dummy) + gkp_flush (dummy) + gkp_polyline (p, npts) + gkp_polymarker (p, npts) + gkp_text (x, y, text, n) + gkp_fillarea (p, npts) + gkp_getcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_setcursor (x, y, cursor) + gkp_plset (gki) + gkp_pmset (gki) + gkp_txset (gki) + gkp_faset (gki) + gkp_getcursor (cursor) + gkp_escape (fn, instruction, nwords) ** + gkp_setwcs (wcs, nwords) ** + gkp_getwcs (wcs, nwords) ** + gkp_unknown (gki) ** + +A GKI driven device driver may implement any subset of these procedures. +The starred procedures should be omitted by most drivers. In particular, +the SETWCS and GETWCS instructions are internal instructions which should +be ignored by ordinary device drivers. The procedure names may be anything, +but the arguments lists must be as shown. All coordinates are in GKI units, +0 to 32767. Character strings are passed in ASCII, one character per metacode +word. Whenever a GKI character string appears as an array argument in the +argument list of a procedure, the count N of the number of characters in the +string follows as the next argument. GKI character strings are not EOS +delimited. Polyline, polymarker, and fillarea data is passed as an array +of (x,y) points P, in GKI coordinates, defining the polyline or polygon to +be plotted. + +One additional procedure, GKP_INSTALL, is called by the main program of the +graphics kernel task to install the debugging driver, i.e., to fill the DD +array with the entry point addresses of the driver procedures. For a normal +driver this function is performed by a user supplied procedure named +GKOPEN (graphics kernel open). The user supplied kernel procedures will +be called to execute each instruction as the instructions are decoded by the +main routine. The user supplied procedure GKCLOSE will be called when +interpretation ends and the task is about to exit. + + gkopen (dd) + gkclose () + +Do not confuse GKOPEN and GKCLOSE, which open and close the graphics kernel, +with GKI_OPENWS and GKI_CLOSEWS, the metacode instructions used to direct +an opened kernel to open and close workstations. +.endhelp ___________________________________________________________________ + + +# GKP_INSTALL -- Install the GKI debugging kernel as a graphics kernel +# device driver. The device table DD consists of an array of the entry +# point addresses for the driver procedures. If a driver does not implement +# a particular instruction the table entry for that procedure may be set +# to zero, causing the interpreter to ignore the instruction. + +procedure gkp_install (dd, out_fd, verbose_output, use_gkiunits) + +int dd[ARB] # device table to be initialized +int out_fd # output file +int verbose_output # verbose output desired +int use_gkiunits # print coords in GKI units rather than NDC + +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +extern gkp_openws(), gkp_closews(), gkp_mftitle(), gkp_clear(), gkp_cancel() +extern gkp_flush(), gkp_polyline(), gkp_polymarker(), gkp_text() +extern gkp_fillarea(), gkp_putcellarray(), gkp_setcursor(), gkp_plset() +extern gkp_pmset(), gkp_txset(), gkp_faset(), gkp_getcursor() +extern gkp_getcellarray(), gkp_escape(), gkp_setwcs(), gkp_getwcs() +extern gkp_unknown(), gkp_reactivatews(), gkp_deactivatews() + +begin + # Set the GDC internal parameters. + fd = out_fd + stream = NULL + gkiunits = use_gkiunits + verbose = verbose_output + + # Install the device driver. + call zlocpr (gkp_openws, dd[GKI_OPENWS]) + call zlocpr (gkp_closews, dd[GKI_CLOSEWS]) + call zlocpr (gkp_reactivatews, dd[GKI_REACTIVATEWS]) + call zlocpr (gkp_deactivatews, dd[GKI_DEACTIVATEWS]) + call zlocpr (gkp_mftitle, dd[GKI_MFTITLE]) + call zlocpr (gkp_clear, dd[GKI_CLEAR]) + call zlocpr (gkp_cancel, dd[GKI_CANCEL]) + call zlocpr (gkp_flush, dd[GKI_FLUSH]) + call zlocpr (gkp_polyline, dd[GKI_POLYLINE]) + call zlocpr (gkp_polymarker, dd[GKI_POLYMARKER]) + call zlocpr (gkp_text, dd[GKI_TEXT]) + call zlocpr (gkp_fillarea, dd[GKI_FILLAREA]) + call zlocpr (gkp_putcellarray, dd[GKI_PUTCELLARRAY]) + call zlocpr (gkp_setcursor, dd[GKI_SETCURSOR]) + call zlocpr (gkp_plset, dd[GKI_PLSET]) + call zlocpr (gkp_pmset, dd[GKI_PMSET]) + call zlocpr (gkp_txset, dd[GKI_TXSET]) + call zlocpr (gkp_faset, dd[GKI_FASET]) + call zlocpr (gkp_getcursor, dd[GKI_GETCURSOR]) + call zlocpr (gkp_getcellarray, dd[GKI_GETCELLARRAY]) + call zlocpr (gkp_escape, dd[GKI_ESCAPE]) + call zlocpr (gkp_setwcs, dd[GKI_SETWCS]) + call zlocpr (gkp_getwcs, dd[GKI_GETWCS]) + call zlocpr (gkp_unknown, dd[GKI_UNKNOWN]) +end + + +# GKP_CLOSE -- Close the GKP kernel. + +procedure gkp_close() +begin +end + + +# GKP_GRSTREAM -- Set the FD of the graphics stream, from which we shall read +# metacode instructions and to which we shall return cell arrays and cursor +# values. + +procedure gkp_grstream (graphics_stream) + +int graphics_stream # FD of the new graphics stream +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + stream = graphics_stream +end + + +# GKP_OPENWS -- Open the named workstation. + +procedure gkp_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +int junk +pointer sp, buf +int itoc() +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + + call fprintf (fd, "open_workstation '%s', mode=%s\n") + call pargstr (Memc[buf]) + switch (mode) { + case NEW_FILE: + call pargstr ("new_file") + case APPEND: + call pargstr ("append") + default: + junk = itoc (mode, Memc[buf], SZ_FNAME) + } + + call sfree (sp) +end + + +# GKP_CLOSEWS -- Close the named workstation. + +procedure gkp_closews (devname, n) + +short devname[ARB] # device name +int n # length of device name +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, n, TY_CHAR) + + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + + call fprintf (fd, "close_workstation '%s'\n") + call pargstr (Memc[buf]) + call flush (fd) + + call sfree (sp) +end + + +# GKP_REACTIVATEWS -- Reactivate the workstation (enable graphics). + +procedure gkp_reactivatews (flags) + +int flags # action flags +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "reactivatews %d\n") + call pargi (flags) +end + + +# GKP_DEACTIVATEWS -- Deactivate the workstation (disable graphics). + +procedure gkp_deactivatews (flags) + +int flags # action flags +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "deactivatews %d\n") + call pargi (flags) + call flush (fd) +end + + +# GKP_MFTITLE -- Metafile title or comment. A nonfunctional instruction used +# to document a metafile. + +procedure gkp_mftitle (title, n) + +short title[ARB] # title string +int n # length of title string +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, n, TY_CHAR) + + call achtsc (title, Memc[buf], n) + Memc[buf+n] = EOS + + call fprintf (fd, "title '%s'\n") + call pargstr (Memc[buf]) + + call sfree (sp) +end + + +# GKP_CLEAR -- Clear the workstation screen. + +procedure gkp_clear (dummy) + +int dummy # not used at present +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "clear\n") +end + + +# GKP_CANCEL -- Cancel output. + +procedure gkp_cancel (dummy) + +int dummy # not used at present +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "cancel\n") + call flush (fd) +end + + +# GKP_FLUSH -- Flush output. + +procedure gkp_flush (dummy) + +int dummy # not used at present +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "flush\n") + call flush (fd) +end + + +# GKP_POLYLINE -- Draw a polyline. + +procedure gkp_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + # Print statistics on polyline. + call gkp_pstat (fd, p, npts, "polyline", verbose, gkiunits) +end + + +# GKP_POLYMARKER -- Draw a polymarker. + +procedure gkp_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + # Print statistics on polymarker. + call gkp_pstat (fd, p, npts, "polymarker", verbose, gkiunits) +end + + +# GKP_FILLAREA -- Fill a closed area. + +procedure gkp_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + # Print statistics on the fillarea polygon. + call gkp_pstat (fd, p, npts, "fillarea", verbose, gkiunits) +end + + +# GKP_TEXT -- Draw a text string. + +procedure gkp_text (x, y, text, n) + +int x, y # where to draw text string +short text[ARB] # text string +int n # number of characters + +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, n, TY_CHAR) + + call achtsc (text, Memc[buf], n) + Memc[buf+n] = EOS + + if (gkiunits == YES) { + call fprintf (fd, "text %5d, %5d, '%s'\n") + call pargi (x) + call pargi (y) + call pargstr (Memc[buf]) + } else { + call fprintf (fd, "text %4.2f, %4.2f, '%s'\n") + call pargr (real(x) / GKI_MAXNDC) + call pargr (real(y) / GKI_MAXNDC) + call pargstr (Memc[buf]) + } + + call sfree (sp) +end + + +# GKP_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +short m[nx,ny] # cell array +int x1, y1 # lower left corner of output window +int x2, y2 # lower left corner of output window + +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "put_cellarray nx=%d, ny=%d, ") + call pargi (nx) + call pargi (ny) + + if (gkiunits == YES) { + call fprintf (fd, "x1=%5d, y1=%5d, x2=%5d, y2=%5d\n") + call pargi (x1) + call pargi (y1) + call pargi (x2) + call pargi (y2) + } else { + call fprintf (fd, "x1=%4.2f, y1=%4.2f, x2=%4.2f, y2=%4.2f\n") + call pargr (real(x1) / GKI_MAXNDC) + call pargr (real(y1) / GKI_MAXNDC) + call pargr (real(x2) / GKI_MAXNDC) + call pargr (real(y2) / GKI_MAXNDC) + } + + if (verbose == YES) + call gkp_dump (fd, m, (nx * ny)) +end + + +# GKP_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkp_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "get_cellarray nx=%d, ny=%d, ") + call pargi (nx) + call pargi (ny) + + if (gkiunits == YES) { + call fprintf (fd, "x1=%5d, y1=%5d, x2=%5d, y2=%5d\n") + call pargi (x1) + call pargi (y1) + call pargi (x2) + call pargi (y2) + } else { + call fprintf (fd, "x1=%4.2f, y1=%4.2f, x2=%4.2f, y2=%4.2f\n") + call pargr (real(x1) / GKI_MAXNDC) + call pargr (real(y1) / GKI_MAXNDC) + call pargr (real(x2) / GKI_MAXNDC) + call pargr (real(y2) / GKI_MAXNDC) + } + + if (stream == NULL) + return + + call smark (sp) + call salloc (buf, nx * ny, TY_SHORT) + call amovks (short(-1), Mems[buf], nx * ny) + + call flush (fd) + iferr { + call gki_retcellarray (stream, Mems[buf], nx * ny) + call flush (stream) + } then + ; + + call sfree (sp) +end + + +# GKP_SETCURSOR -- Set the position of a cursor. + +procedure gkp_setcursor (x, y, cursor) + +int x, y # new position of cursor +int cursor # cursor to be set +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + if (gkiunits == YES) { + call fprintf (fd, "set_cursor %5d, %5d, cursor=%d\n") + call pargi (x) + call pargi (y) + call pargi (cursor) + } else { + call fprintf (fd, "set_cursor %4.2f, %4.2f, cursor=%d\n") + call pargr (real(x) / GKI_MAXNDC) + call pargr (real(y) / GKI_MAXNDC) + call pargi (cursor) + } +end + + +# GKP_GETCURSOR -- Get the position of a cursor. + +procedure gkp_getcursor (cursor) + +int cursor +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "get_cursor cursor=%d\n") + call pargi (cursor) + call flush (fd) + + if (stream != NULL) + iferr { + # gki_retcursorvalue (stream, cn, key, sx, sy, rn, rx, ry) + call gki_retcursorvalue (stream, 0, EOF, 0, 0, 0, 0, 0) + call flush (stream) + } then + ; +end + + +# GKP_PLSET -- Set the polyline attributes. + +procedure gkp_plset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_polyline ltype=%d, lwidth=%0.2f, color=%d\n") + call pargs (gki[GKI_PLSET_LT]) + call pargr (GKI_UNPACKREAL (gki[GKI_PLSET_LW])) + call pargs (gki[GKI_PLSET_CI]) +end + + +# GKP_PMSET -- Set the polymarker attributes. + +procedure gkp_pmset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_polymarker mtype=%d, mwidth=%0.2f, color=%d\n") + call pargs (gki[GKI_PMSET_MT]) + call pargr (GKI_UNPACKREAL (gki[GKI_PMSET_MW])) + call pargs (gki[GKI_PMSET_CI]) +end + + +# GKP_FASET -- Set the fillarea attributes. + +procedure gkp_faset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_fillarea style=%d, color=%d\n") + call pargs (gki[GKI_FASET_FS]) + call pargs (gki[GKI_FASET_CI]) +end + + +# GKP_TXSET -- Set the text drawing attributes. + +procedure gkp_txset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_text up=%d, path=%d, hjustify=%s, ") + call pargs (gki[GKI_TXSET_UP]) + call gkp_txparg (gki[GKI_TXSET_P]) + call gkp_txparg (gki[GKI_TXSET_HJ]) + call fprintf (fd, "vjustify=%s, font=%s,\n") + call gkp_txparg (gki[GKI_TXSET_VJ]) + call gkp_txparg (gki[GKI_TXSET_F]) + + call fprintf (fd, "\tsize=%0.2f, spacing=%0.2f, color=%d, quality=%s\n") + call pargr (GKI_UNPACKREAL (gki[GKI_TXSET_SZ])) + call pargr (GKI_UNPACKREAL (gki[GKI_TXSET_SP])) + call pargs (gki[GKI_TXSET_CI]) + call gkp_txparg (gki[GKI_TXSET_Q]) +end + + +# GKP_ESCAPE -- Device dependent instruction. + +procedure gkp_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "escape %d, nwords=%d\n") + call pargi (fn) + call pargi (nwords) + + # Dump the instruction. + if (verbose == YES) + call gkp_dump (fd, instruction, nwords) +end + + +# GKP_SETWCS -- Set the world coordinate systems. Internal GIO instruction. + +procedure gkp_setwcs (wcs, nwords) + +short wcs[ARB] # WCS data +int nwords # number of words of data + +int i, nwcs +pointer sp, wcs_temp, w +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (wcs_temp, LEN_WCSARRAY, TY_STRUCT) + + call fprintf (fd, "set_wcs nwords=%d\n") + call pargi (nwords) + + nwcs = nwords * SZ_SHORT / SZ_STRUCT / LEN_WCS + if (verbose == YES && nwcs > 1) { + call amovi (wcs, Memi[wcs_temp], nwcs * LEN_WCS) + + do i = 1, nwcs { + w = ((i - 1) * LEN_WCS) + wcs_temp + if ((WCS_WX1(w) > EPSILON) || + (abs(1.0 - WCS_WX2(w)) > EPSILON) || + (WCS_WY1(w) > EPSILON) || + (abs(1.0 - WCS_WY2(w)) > EPSILON)) { + + call fprintf (fd, "\t%2d %g %g %g %g ") + call pargi (i) + call pargr (WCS_WX1(w)) + call pargr (WCS_WX2(w)) + call pargr (WCS_WY1(w)) + call pargr (WCS_WY2(w)) + + call fprintf (fd, "%4.2f %4.2f %4.2f %4.2f ") + call pargr (WCS_SX1(w)) + call pargr (WCS_SX2(w)) + call pargr (WCS_SY1(w)) + call pargr (WCS_SY2(w)) + + call fprintf (fd, "%d %d %d\n") + call pargi (WCS_XTRAN(w)) + call pargi (WCS_YTRAN(w)) + call pargi (WCS_CLIP(w)) + } + } + } + + call sfree (sp) +end + + +# GKP_GETWCS -- Get the world coordinate systems. Internal GIO instruction. + +procedure gkp_getwcs (wcs, nwords) + +short wcs[ARB] # WCS data +int nwords # number of words of data +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "get_wcs nwords=%d\n") + call pargi (nwords) +end + + +# GKP_UNKNOWN -- The unknown instruction. Called by the interpreter whenever +# an unrecognized opcode is encountered. Should never be called. + +procedure gkp_unknown (gki) + +short gki[ARB] # the GKI instruction +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "unknown\n") +end + + +# GKP_PSTAT -- Compute and print on the standard error output a statistical +# summary of a sequence of (x,y) points. If verbose mode is enabled, follow +# this by the values of the points themselves. + +procedure gkp_pstat (fd, p, npts, label, verbose, gkiunits) + +int fd # output file +short p[npts] # array of points, i.e., (x,y) pairs +int npts # number of points +char label[ARB] # type of instruction +int verbose # verbose output desired +int gkiunits # print coords in GKI rather than NDC units + +int i +real x, y, xsum, xmin, xmax, ysum, ymin, ymax, scale + +begin + if (gkiunits == YES) + scale = 1.0 + else + scale = 1.0 / GKI_MAXNDC + + xsum = 0 + xmin = 1.0 + xmax = 0 + ysum = 0 + ymin = 1.0 + ymax = 0 + + # Compute mean, minimum, and maximum values. + do i = 1, npts * 2, 2 { + x = real (p[i]) * scale + xsum = xsum + x + if (x < xmin) + xmin = x + if (x > xmax) + xmax = x + + y = real (p[i+1]) * scale + ysum = ysum + y + if (y < ymin) + ymin = y + if (y > ymax) + ymax = y + } + + # Print summary of statistics. + call fprintf (fd, "%s np=%d, ") + call pargstr (label) + call pargi (npts) + + if (gkiunits == YES) + call fprintf (fd, "xmin=%d,xmax=%d,xavg=%d, ") + else + call fprintf (fd, "xmin=%4.2f,xmax=%4.2f,xavg=%4.2f, ") + if (npts == 0) { + do i = 1, 3 + call pargr (INDEF) + } else { + call pargr (xmin) + call pargr (xmax) + call pargr (xsum / npts) + } + + if (gkiunits == YES) + call fprintf (fd, "ymin=%d,ymax=%d,yavg=%d\n") + else + call fprintf (fd, "ymin=%4.2f,ymax=%4.2f,yavg=%4.2f\n") + if (npts == 0) { + do i = 1, 3 + call pargr (INDEF) + } else { + call pargr (ymin) + call pargr (ymax) + call pargr (ysum / npts) + } + + # Dump the points if verbose output is enabled. + if (verbose == NO && npts > 0) + return + + call fprintf (fd, "\t") + for (i=1; i <= npts * 2; i=i+2) { + if (i > 1 && mod (i-1, 10) == 0) + call fprintf (fd, "\n\t") + if (gkiunits == YES) + call fprintf (fd, "%5d %5d ") + else + call fprintf (fd, "%5.3f %5.3f ") + call pargr (real(p[i]) * scale) + call pargr (real(p[i+1]) * scale) + } + call fprintf (fd, "\n") +end + + +# GKP_DUMP -- Print a sequence of metacode words as a table, formatted eight +# words per line, in decimal. + +procedure gkp_dump (fd, data, nwords) + +int fd # output file +short data[ARB] # metacode data +int nwords # number of words of data +int i + +begin + if (nwords <= 0) + return + + call fprintf (fd, "\t") + + for (i=1; i <= nwords; i=i+1) { + if (i > 1 && mod (i-1, 8) == 0) + call fprintf (fd, "\n\t") + call fprintf (fd, "%7d") + call pargs (data[i]) + } + + call fprintf (fd, "\n") +end diff --git a/sys/gio/gki/gkirca.x b/sys/gio/gki/gkirca.x new file mode 100644 index 00000000..54b38813 --- /dev/null +++ b/sys/gio/gki/gkirca.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKI_RETCELLARRAY -- Return a cell array (pixel array). Used by a graphics +# kernel to return a cell array to GIO in response to a GETCELLARRAY +# instruction. +# +# BOI GKI_CELLARRAY L NP P +# +# L(i) 4 + NP +# NP(i) number of pixels in cell array +# P(NPi) cell array + +procedure gki_retcellarray (fd, m, np) + +int fd # output file +short m[ARB] # cell array +int np # number of pixels in cell array + +short gki[GKI_CELLARRAY_LEN] +data gki[1] /BOI/, gki[2] /GKI_CELLARRAY/ + +begin + gki[GKI_CELLARRAY_L] = GKI_CELLARRAY_LEN + np + gki[GKI_CELLARRAY_NP] = np + + call write (fd, gki, GKI_CELLARRAY_LEN * SZ_SHORT) + call write (fd, m, np * SZ_SHORT) +end diff --git a/sys/gio/gki/gkircval.x b/sys/gio/gki/gkircval.x new file mode 100644 index 00000000..9bfb3052 --- /dev/null +++ b/sys/gio/gki/gkircval.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKI_RETCURSORVALUE -- Return a cursor value. Used by a graphics kernel to +# return a cursor value to GIO in response to a GETCURSOR instruction. +# +# BOI GKI_CURSORVALUE L CN KEY SX SY RN RX RY +# +# where +# +# L(i) 10 +# CN(i) cursor number +# KEY(i) keystroke value (>= 0 or EOF) +# SX(i) NDC X screen coordinate of cursor +# SY(i) NDC Y screen coordinate of cursor +# RN(i) raster number or zero +# RX(i) NDC X raster coordinate of cursor +# RY(i) NDC Y raster coordinate of cursor +# +# The screen or display window coordinates SX and SY of the cursor are +# returned for all devices. Only some devices support multiple rasters. +# If the device supports rasters and the cursor is in a raster when read, the +# raster number and raster coordinates are returned in RN,RX,RY. This is in +# addition to the screen coordinates SX,SY. If raster coordinates are not +# returned, the raster number will be set to zero and RX,RY will be the same +# as SX,SY. + +procedure gki_retcursorvalue (fd, cn, key, sx, sy, raster, rx, ry) + +int fd #I output file +int cn #I cursor number +int key #I keystroke value +int sx, sy #I screen coordinates of cursor (GKI coords) +int raster #I raster number +int rx, ry #I raster coordinates of cursor (GKI coords) + +short gki[GKI_CURSORVALUE_LEN] +data gki[1] /BOI/, gki[2] /GKI_CURSORVALUE/, gki[3] /GKI_CURSORVALUE_LEN/ + +begin + gki[GKI_CURSORVALUE_CN ] = cn + gki[GKI_CURSORVALUE_KEY] = key + gki[GKI_CURSORVALUE_SX ] = sx + gki[GKI_CURSORVALUE_SY ] = sy + gki[GKI_CURSORVALUE_RN ] = raster + gki[GKI_CURSORVALUE_RX ] = rx + gki[GKI_CURSORVALUE_RY ] = ry + + call write (fd, gki, GKI_CURSORVALUE_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkireact.x b/sys/gio/gki/gkireact.x new file mode 100644 index 00000000..a84ad95d --- /dev/null +++ b/sys/gio/gki/gkireact.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_REACTIVATEWS -- Reactivate the workstation (enable graphics). +# +# BOI GKI_REACTIVATEWS L F +# +# L(i) 4 +# F flags (0,AW_PAUSE,AW_CLEAR) + +procedure gki_reactivatews (fd, flags) + +int fd # output file +int flags # action modifier flags + +int epa, nchars +short gki[GKI_REACTIVATEWS_LEN] +data gki[1] /BOI/, gki[2] /GKI_REACTIVATEWS/, gki[3] /GKI_REACTIVATEWS_LEN/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_REACTIVATEWS] + if (epa != 0) + call zcall1 (epa, flags) + + } else { + # Send a copy to the pseudofile i/o controller. + gki[GKI_REACTIVATEWS_F] = flags + nchars = GKI_REACTIVATEWS_LEN * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], gki, nchars) + } +end diff --git a/sys/gio/gki/gkiredir.x b/sys/gio/gki/gkiredir.x new file mode 100644 index 00000000..3e204bf0 --- /dev/null +++ b/sys/gio/gki/gkiredir.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_REDIR -- Redirect (or set) a graphics stream. All i/o will be to the +# file FD until the graphics stream is reset in another call to GKI_REDIR. +# The current encoded value for a stream is retured so that a subsequent call +# (with FD=0) may be made to undo the redirection. A call with FD<0 may be +# used to stat the stream without changing anything. NOTE: This procedure +# (or either GKI_INLINE_KERNEL or GKI_SUBKERNEL) must be called before using +# the GKI package for a graphics stream. + +procedure gki_redir (stream, fd, old_fd, old_type) + +int stream # graphics stream to be redirected +int fd # file to be connected to the stream +int old_fd, old_type # old values for later restoration + +include "gki.com" + +begin + if (fd == NULL) { + gk_type[stream] = old_type + gk_fd[stream] = old_fd + } else { + old_type = gk_type[stream] + old_fd = gk_fd[stream] + if (fd > 0) { + gk_type[stream] = TY_FILE + gk_fd[stream] = fd + } + } +end diff --git a/sys/gio/gki/gkiscur.x b/sys/gio/gki/gkiscur.x new file mode 100644 index 00000000..f3ca7c53 --- /dev/null +++ b/sys/gio/gki/gkiscur.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_SETCURSOR -- Set the position of a device cursor. +# +# BOI GKI_SETCURSOR L CN POS +# +# L(i) 6 +# CN(i) cursor number +# POS(p) new cursor position + +procedure gki_setcursor (fd, x, y, cursor) + +int fd # output file +int x, y # new cursor position +int cursor # cursor to be set + +int epa +short gki[GKI_SETCURSOR_LEN] +data gki[1] /BOI/, gki[2] /GKI_SETCURSOR/, gki[3] /GKI_SETCURSOR_LEN/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_SETCURSOR] + if (epa != 0) + call zcall3 (epa, x, y, cursor) + } else { + gki[GKI_SETCURSOR_CN] = cursor + gki[GKI_SETCURSOR_POS] = x + gki[GKI_SETCURSOR_POS+1] = y + + call write (gk_fd[fd], gki, GKI_SETCURSOR_LEN * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkisetwcs.x b/sys/gio/gki/gkisetwcs.x new file mode 100644 index 00000000..f8d0e896 --- /dev/null +++ b/sys/gio/gki/gkisetwcs.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_SETWCS -- Copy the set of 16 WCS to the graphics controller in the CL +# process. The WCS are transmitted as a binary array of WCS structures. +# +# BOI GKI_SETWCS L N WCS +# +# L(i) 4 + N +# N(i) length of WCS field in words +# WCS binary copy of the 16 WCS structures, transmitted +# in a single call to WRITE + +procedure gki_setwcs (fd, wcs, len_wcs) + +int fd # output file +int wcs[ARB] # array of WCS structures +int len_wcs # number of ints (struct units) in array + +int nshorts +short gki[GKI_SETWCS_LEN] +data gki[1] /BOI/, gki[2] /GKI_SETWCS/ +include "gki.com" + +begin + if (IS_FILE(fd)) { + nshorts = (len_wcs * SZ_INT) / SZ_SHORT + gki[GKI_SETWCS_L] = GKI_SETWCS_LEN + nshorts + gki[GKI_SETWCS_N] = nshorts + + if (fd >= STDGRAPH && fd <= STDPLOT) { + # Send a copy of the WCS information to the PSIO control + # stream if the graphics output is a standard graphics stream. + + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, GKI_SETWCS_LEN * SZ_SHORT) + call write (PSIOCTRL, wcs, nshorts * SZ_SHORT) + call flush (PSIOCTRL) + } + + call write (gk_fd[fd], gki, GKI_SETWCS_LEN * SZ_SHORT) + call write (gk_fd[fd], wcs, nshorts * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkititle.x b/sys/gio/gki/gkititle.x new file mode 100644 index 00000000..397bd50a --- /dev/null +++ b/sys/gio/gki/gkititle.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_MFTITLE -- Write the metafile title. +# +# BOI GKI_MFTITLE L N T +# +# L(i) 4 + N +# N(i) number of characters in field T +# T(Nc) title string identifying metafile + +procedure gki_mftitle (fd, title) + +int fd # output file +char title[ARB] # title string + +int epa +int ip, n +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (title) + call salloc (gki, GKI_MFTITLE_LEN + n, TY_SHORT) + + # Pack the title name as a SHORT integer array. + op = gki + GKI_MFTITLE_T - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = title[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_MFTITLE] + if (epa != 0) + call zcall2 (epa, Mems[gki+GKI_MFTITLE_T-1], n) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_MFTITLE + Mems[gki+2] = GKI_MFTITLE_LEN + n + Mems[gki+3] = n + call write (gk_fd[fd], Mems[gki], (GKI_MFTITLE_LEN + n) * SZ_SHORT) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkitx.x b/sys/gio/gki/gkitx.x new file mode 100644 index 00000000..7cc616ba --- /dev/null +++ b/sys/gio/gki/gkitx.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_TEXT -- Text drawing instruction. +# +# BOI GKI_TEXT L P N T +# +# L(i) 6 + N +# P(p) starting point of character string +# N(i) number of characters in string T +# T(Nc) string of N ASCII characters + +procedure gki_text (fd, x, y, text) + +int fd # output file +int x, y # position at which text is to be drawn +char text[ARB] # text string to be drawn + +int epa +int ip, n +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (text) + call salloc (gki, GKI_TEXT_LEN + n, TY_SHORT) + + # Pack the text string as a SHORT integer array. + op = gki + GKI_TEXT_T - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = text[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_TEXT] + if (epa != 0) + call zcall4 (epa, x, y, Mems[gki+GKI_TEXT_T-1], n) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_TEXT + Mems[gki+2] = GKI_TEXT_LEN + n + Mems[gki+GKI_TEXT_L-1] = GKI_TEXT_LEN + n + Mems[gki+GKI_TEXT_P-1] = x + Mems[gki+GKI_TEXT_P-1+1] = y + Mems[gki+GKI_TEXT_N-1] = n + + call write (gk_fd[fd], Mems[gki], (GKI_TEXT_LEN + n) * SZ_SHORT) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkitxset.x b/sys/gio/gki/gkitxset.x new file mode 100644 index 00000000..93f427b9 --- /dev/null +++ b/sys/gio/gki/gkitxset.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_TXSET -- Set the text drawing attributes. +# +# BOI GKI_TXSET L UP SZ SP P HJ VJ F Q CI +# +# L(i) 12 +# UP(i) character up vector (degrees) +# SZ(r) character size scale factor +# SP(r) character spacing +# P(i) path (0,1=right,2=left,3=up,4=down) +# HJ(i) horizontal justification +# (0=normal,1=center,2=left,3=right) +# VJ(i) vertical justification +# (0=normal,1=center,2=up,3=down) +# F(i) font (0,1=roman,2=greek,3=italic,4=bold) +# Q(i) quality (0=normal,1=low,2=medium,3=high) +# CI(i) text color index + +procedure gki_txset (fd, ap) + +int fd # output file +pointer ap # pointer to attribute structure + +int epa +short gki[GKI_TXSET_LEN] +data gki[1] /BOI/, gki[2] /GKI_TXSET/, gki[3] /GKI_TXSET_LEN/ +include "gki.com" + +begin + gki[GKI_TXSET_UP] = TX_UP(ap) + gki[GKI_TXSET_SZ] = GKI_PACKREAL (TX_SIZE(ap)) + gki[GKI_TXSET_SP] = GKI_PACKREAL (TX_SPACING(ap)) + gki[GKI_TXSET_P ] = TX_PATH(ap) + gki[GKI_TXSET_HJ] = TX_HJUSTIFY(ap) + gki[GKI_TXSET_VJ] = TX_VJUSTIFY(ap) + gki[GKI_TXSET_F ] = TX_FONT(ap) + gki[GKI_TXSET_Q ] = TX_QUALITY(ap) + gki[GKI_TXSET_CI] = TX_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_TXSET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_TXSET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiwesc.x b/sys/gio/gki/gkiwesc.x new file mode 100644 index 00000000..bd4c8571 --- /dev/null +++ b/sys/gio/gki/gkiwesc.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_WESCAPE -- Write a GKI escape instruction, used to pass device +# dependent instructions on to a graphics kernel. This version of gki_escape +# is used in cases where the escape instruction consists of the escape header +# followed by a block of data, and it is inconvenient to have to combine the +# header and the data into one array. +# +# BOI GKI_ESCAPE L FN N DC +# +# L(i) 5 + N +# FN(i) escape function code +# N(i) number of escape data words +# DC(i) escape data words + +procedure gki_wescape (fd, fn, hdr, hdrlen, data, datalen) + +int fd #I output file +int fn #I escape function code +short hdr[ARB] #I escape instruction header +int hdrlen #I header length, shorts +short data[ARB] #I escape instruction data +int datalen #I data length, shorts + +pointer sp, buf +int epa, nwords +short gki[GKI_ESCAPE_LEN] +data gki[1] /BOI/, gki[2] /GKI_ESCAPE/ +include "gki.com" + +begin + nwords = hdrlen + datalen + + if (IS_INLINE(fd)) { + call smark (sp) + call salloc (buf, nwords, TY_SHORT) + + call amovs (hdr, Mems[buf], hdrlen) + call amovs (data, Mems[buf+hdrlen], datalen) + + epa = gk_dd[GKI_ESCAPE] + if (epa != 0) + call zcall3 (epa, fn, Mems[buf], nwords) + + call sfree (sp) + + } else { + gki[GKI_ESCAPE_L] = GKI_ESCAPE_LEN + nwords + gki[GKI_ESCAPE_N] = nwords + gki[GKI_ESCAPE_FN] = fn + + call write (gk_fd[fd], gki, GKI_ESCAPE_LEN * SZ_SHORT) + call write (gk_fd[fd], hdr, hdrlen * SZ_SHORT) + call write (gk_fd[fd], data, datalen * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkiwrite.x b/sys/gio/gki/gkiwrite.x new file mode 100644 index 00000000..65d911b1 --- /dev/null +++ b/sys/gio/gki/gkiwrite.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_WRITE -- Write a GKI metacode instruction to a graphics kernel. If the +# kernel is inline the kernel is directly called to execute the instruction, +# otherwise the instruction is written into the graphics stream for the +# kernel. This procedure is functionally equivalent to GKI_EXECUTE, but works +# for both inline and external kernels. + +procedure gki_write (fd, gki) + +int fd # graphics stream +short gki[ARB] # encoded instruction +int length +include "gki.com" + +begin + if (IS_INLINE(fd)) + call gki_execute (gki, gk_dd) + else { + length = gki[GKI_HDR_LENGTH] + call write (gk_fd[fd], gki, length * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkptxparg.x b/sys/gio/gki/gkptxparg.x new file mode 100644 index 00000000..75d7325a --- /dev/null +++ b/sys/gio/gki/gkptxparg.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKP_TXPARG -- Convert a short integer text attribute code into a string +# and pass the string to FMTIO. + +procedure gkp_txparg (code) + +short code # defined in + +begin + switch (code) { + case GT_NORMAL: + call pargstr ("normal") + case GT_CENTER: + call pargstr ("center") + case GT_LEFT: + call pargstr ("left") + case GT_RIGHT: + call pargstr ("right") + case GT_UP: + call pargstr ("up") + case GT_DOWN: + call pargstr ("down") + case GT_TOP: + call pargstr ("top") + case GT_BOTTOM: + call pargstr ("bottom") + case GT_ROMAN: + call pargstr ("roman") + case GT_GREEK: + call pargstr ("greek") + case GT_ITALIC: + call pargstr ("italic") + case GT_BOLD: + call pargstr ("bold") + case GT_LOW: + call pargstr ("low") + case GT_MEDIUM: + call pargstr ("medium") + case GT_HIGH: + call pargstr ("high") + default: + call pargstr ("??") + } +end diff --git a/sys/gio/gki/mkpkg b/sys/gio/gki/mkpkg new file mode 100644 index 00000000..c71f2e71 --- /dev/null +++ b/sys/gio/gki/mkpkg @@ -0,0 +1,46 @@ +# Make the GKI (graphics kernel interface) package. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + gkicancel.x gki.com + gkiclear.x gki.com + gkiclose.x gki.com + gkideact.x gki.com + gkieof.x gki.com + gkiesc.x gki.com + gkiexe.x + gkifa.x gki.com + gkifaset.x gki.com + gkifetch.x + gkifflush.x gki.com + gkiflush.x gki.com + gkigca.x gki.com + gkigcur.x gki.com + gkigetwcs.x gki.com + gkiinit.x gki.com + gkiinline.x gki.com + gkikern.x gki.com + gkiopen.x gki.com + gkipca.x gki.com + gkipl.x gki.com + gkiplset.x gki.com + gkipm.x gki.com + gkipmset.x gki.com + gkiprint.x + gkirca.x + gkircval.x + gkireact.x gki.com + gkiredir.x gki.com + gkiscur.x gki.com + gkisetwcs.x gki.com + gkititle.x gki.com + gkitx.x gki.com + gkitxset.x gki.com + gkiwesc.x gki.com + gkiwrite.x gki.com + gkptxparg.x + ; diff --git a/sys/gio/gki/zzdebug.x b/sys/gio/gki/zzdebug.x new file mode 100644 index 00000000..e56c5cc0 --- /dev/null +++ b/sys/gio/gki/zzdebug.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +task ggcur = t_ggcur + + +# GGCUR -- Debug cursor read in inline graphics kernel. + +procedure t_ggcur() + +pointer gp +char device[SZ_FNAME] + +real cx, cy +int key, xres, yres, hardchar +int dd[LEN_GKIDD] +pointer gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + hardchar = YES + xres = 0 + yres = 0 + + call fseti (STDGRAPH, F_TYPE, SPOOL_FILE) + call fseti (STDGRAPH, F_CANCEL, OK) + + call stg_open (device, dd, STDIN, STDOUT, xres, yres, hardchar) + call gki_inline_kernel (STDGRAPH, dd) + + gp = gopen (device, NEW_FILE, STDGRAPH) + call ggcur (gp, cx, cy, key) + + call gclose (gp) + call stg_close() + + call printf ("cx=%f, cy=%f, key=%d\n") + call pargr (cx) + call pargr (cy) + call pargi (key) +end diff --git a/sys/gio/gks/README b/sys/gio/gks/README new file mode 100644 index 00000000..fc3307c7 --- /dev/null +++ b/sys/gio/gks/README @@ -0,0 +1,50 @@ +GKS - This directory contains code for a partial implementation of the Fortran +binding of GKS level OA. The GKS functions are layered upon GIO. The functions +provided are: + + gacwk --- activate workstation + gca --- output (integer) cell array + gcas --- output (short) cell array + gclks --- close GKS + gclrwk --- clear workstation + gclwk --- close workstation + gdawk --- deactivate workstation + gfa --- fill area + gopks --- open GKS + gopwk --- open workstation + gpl --- polyline + gpm --- polymarker + gqasf --- query aspect source flag + gqchh --- query character height + gqchup --- query character up vector + gqcntn --- query current transformation number + gqnt --- query normalization transformation (window and viewport) + gqopwk --- query open workstations + gqplci --- query polyline color index + gqpmi --- query polymarker index + gqtxal --- query text alignment + gqtxci --- query text color index + gqtxp --- query text path + gqwks --- query workstation state + qsasf --- query aspect source flag + gschh --- set character height + gschup --- set character up vector + gscr --- set color representation + gselnt --- set normalization transformation + gsfaci --- set fill area color index + gsfais --- set fill area interior style + gslwsc --- set line width scale factor + gsmk --- set marker type + gsplci --- set polyline color index + gspmci --- set polymarker color index + gspmi --- set polymarker index + gstxal --- set text alignment + gstxci --- set text color index + gstxp --- set text path + gsvp --- set viewport + gswn --- set window + gtx --- text (gtx.f, gxgtx.x) + +Two functions were added 8Sep86: + gsclip --- set clipping flag + gqclip --- query clipping flag diff --git a/sys/gio/gks/gacwk.x b/sys/gio/gks/gacwk.x new file mode 100644 index 00000000..c9393d07 --- /dev/null +++ b/sys/gio/gks/gacwk.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GACWK -- Activate workstation. + +procedure gacwk (wkid) + +int wkid # Workstation identifier +include "gks.com" + +begin + # This procedure sets the active flag for a particular workstation. + gk_status[wkid] = ACTIVE + + # Also, set gk_std to be the first activated workstation. Once + # gk_std has been set, it will no longer = NULL. + if (gk_std == NULL) + gk_std = wkid +end diff --git a/sys/gio/gks/gca.x b/sys/gio/gks/gca.x new file mode 100644 index 00000000..918c3e37 --- /dev/null +++ b/sys/gio/gks/gca.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GCA -- Cell array. Output a cell array to the specified output device +# area. + +procedure gca (px, py, qx, qy, dimx, dimy, ncs, nrs, dx, dy, colia) + +real px, py, qx, qy # Two points (P, Q) in world coordinates +int dx, dy # Number of columns, number of rows +int dimx, dimy # Dimensions of color index array +int ncs, nrs # Starting column, row of color array +int colia[dimx,dimy] # Colour index array + +int i, j, off +pointer sp, pixels +include "gks.com" + +begin + # Extract subraster and convert to type short. + call smark (sp) + call salloc (pixels, dx * dy, TY_SHORT) + do j = 1, dy { + off = (j - 1) * dx + call achtis (colia[ncs,nrs+j-1], Mems[pixels+off], dx) + } + + # Output color array to all active workstations. + do i = 1, NDEV + if (gk_status[i] == ACTIVE) + call gpcell (gp[i], Mems[pixels], dx, dy, px, py, qx, qy) + + call sfree (sp) +end diff --git a/sys/gio/gks/gcas.x b/sys/gio/gks/gcas.x new file mode 100644 index 00000000..3ab44f99 --- /dev/null +++ b/sys/gio/gks/gcas.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GCAS -- Cell array. Output a cell array to the specified output device +# area. This version of GCA intended for input color array of type short. + +procedure gcas (px, py, qx, qy, dimx, dimy, ncs, nrs, dx, dy, colia) + +real px, py, qx, qy # Two points (P, Q) in world coordinates +int dx, dy # Number of columns, number of rows +int dimx, dimy # Dimensions of color index array +int ncs, nrs # Starting column, row of color array +short colia[dimx, dimy] # Colour index array + +int i, j, off +pointer sp, pixels +include "gks.com" + +begin + if (ncs == 1 && nrs == 1) { + # Output color array to all active workstations. + do i = 1, NDEV + if (gk_status[i] == ACTIVE) + call gpcell (gp[i], Mems[pixels], dx, dy, px, py, qx, qy) + + } else { + # Cell array is subraster of a larger array + call smark (sp) + call salloc (pixels, dx * dy, TY_SHORT) + + # Extract subraster + do j = 1, dy { + off = (j - 1) * dx + call amovs (colia[ncs,nrs+j-1], Mems[off], dx) + } + + # Output color array to all active workstations. + do i = 1, NDEV + if (gk_status[i] == ACTIVE) + call gpcell (gp[i], Mems[pixels], dx, dy, px, py, qx, qy) + + call sfree (sp) + } +end diff --git a/sys/gio/gks/gclks.x b/sys/gio/gks/gclks.x new file mode 100644 index 00000000..a82b760d --- /dev/null +++ b/sys/gio/gks/gclks.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GCLKS -- Close GKS. + +procedure gclks () + +begin + # This procedure performs no function in the GKS emulator. +end diff --git a/sys/gio/gks/gclrwk.x b/sys/gio/gks/gclrwk.x new file mode 100644 index 00000000..7f92bc91 --- /dev/null +++ b/sys/gio/gks/gclrwk.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GCLRWK -- Clear workstation. + +procedure gclrwk (wkid, cofl) + +int wkid # Workstation identifier +int cofl # Control flags (GCONDI, GALWAY) +include "gks.com" + +begin + # Clear the screen or advance film on the specified workstation. GKS + # allows this to be done conditionally, dependent on whether or not + # something has been drawn. + + call gclear (gp[wkid]) +end diff --git a/sys/gio/gks/gclwk.x b/sys/gio/gks/gclwk.x new file mode 100644 index 00000000..6fc3c16a --- /dev/null +++ b/sys/gio/gks/gclwk.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GCLWK -- Close workstation. + +procedure gclwk (wkid) + +int wkid # Workstation identifier +include "gks.com" + +begin + call gclose (gp[wkid]) +end diff --git a/sys/gio/gks/gdawk.x b/sys/gio/gks/gdawk.x new file mode 100644 index 00000000..23eaff14 --- /dev/null +++ b/sys/gio/gks/gdawk.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GDAWK -- Deactivate workstation. + +procedure gdawk (wkid) + +int wkid # Workstation identifier +int i +include "gks.com" + +begin + # This procedure sets the status flag to INACTIVE for a particular + # device. Because this workstation may have been the reference + # workstation, gk_std, it may also necessary to update gk_std. + # In this case, the reference workstation will be the one with the + # lowest workstation id number. + + gk_status[wkid] = INACTIVE + + if (wkid == gk_std) { + gk_std = NULL + # Find next activated workstation, if any + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) { + gk_std = i + break + } + } + } +end diff --git a/sys/gio/gks/gfa.x b/sys/gio/gks/gfa.x new file mode 100644 index 00000000..9eb612b2 --- /dev/null +++ b/sys/gio/gks/gfa.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GFA -- Fill area. The style of fill has already been set and is read +# from gio.com. + +procedure gfa (n, px, py) + +int n # Number of points +real px[n], py[n] # Coordinates of points in world coordinates + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gfill (gp[i], px, py, n, gk_style) + } +end diff --git a/sys/gio/gks/gks.com b/sys/gio/gks/gks.com new file mode 100644 index 00000000..63c20568 --- /dev/null +++ b/sys/gio/gks/gks.com @@ -0,0 +1,10 @@ +# Common for GKS emulator. + +pointer gp[NDEV] # Graphics file descriptor for gio calls +int gk_status[NDEV] # Active bit = INACTIVE or ACTIVE +int gk_std # Index of gp array used for reference in set/get calls +int gk_style # Fill area type of fill - set by GSFAIS +int gk_marker # Marker type for use by GPM +int gk_asf[NASF] # Array for maintaining aspect source flags + +common /gksemu/ gp, gk_status, gk_std, gk_style, gk_marker, gk_asf diff --git a/sys/gio/gks/gks.h b/sys/gio/gks/gks.h new file mode 100644 index 00000000..2373c55f --- /dev/null +++ b/sys/gio/gks/gks.h @@ -0,0 +1,40 @@ +# Definitions for the gks emulator. + +define NDEV 10 # Maximum number of open devices possible +define INACTIVE 0 +define ACTIVE 1 +define MAX_WCS 16 # Maximum number of world coordinate systems +define NASF 13 # Number of aspect source flags + +# Following are emuneration types used by the GKS emulator. +define GRIGHT 0 +define GLEFT 1 +define GUP 2 +define GDOWN 3 +define GAHNOR 0 +define GALEFT 1 +define GACENT 2 +define GARITE 3 +define GAVNOR 0 +define GATOP 1 +define GACAP 2 +define GAHALF 3 +define GABASE 4 +define GABOTT 5 +define GPOINT 1 +define GPLUS 2 +define GAST 3 +define GOMARK 4 +define GXMARK 5 +define GHOLLO 0 +define GSOLID 1 +define GPATTR 2 +define GHATCH 3 +define GBUNDL 0 +define GINDIV 1 +define GRIGHT 0 +define GLEFT 1 +define GUP 2 +define GDOWN 3 +define GCONDI 0 +define GALWAY 1 diff --git a/sys/gio/gks/gopks.x b/sys/gio/gks/gopks.x new file mode 100644 index 00000000..48f39de0 --- /dev/null +++ b/sys/gio/gks/gopks.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GOPKS -- Open GKS. In the GIO implementation, this routine sets the +# file to receive error output to STDERR and initializes all possible +# workstations to inactive. It also initializes the ASF array to GINDIV. + +procedure gopks (errfil) + +int errfil # Unit number for error output +int i +include "gks.com" + +begin + # This procedure initializes the gk_status and gk_std variables. + do i = 1, NDEV + gk_status[i] = INACTIVE + + gk_std = NULL + + do i = 1, NASF + gk_asf[i] = GINDIV +end diff --git a/sys/gio/gks/gopwk.x b/sys/gio/gks/gopwk.x new file mode 100644 index 00000000..baa040e3 --- /dev/null +++ b/sys/gio/gks/gopwk.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GOPWK -- Open workstation. + +procedure gopwk (wkid, conid, wtype) + +int wkid # Workstation identifier +int conid # Connection identifier, not used. +int wtype # Workstation type + +include "gks.com" + + +begin + # This procedure sets "gp[wkid]" to be the "gp" of workstation "wkid". + # Procedure gopen has been called by the calling routine. The wkid + # runs sequentially from 1 to the maximum allowable number of open + # workstations. Parameter wtype is the gp returned from gopen. + + gp[wkid] = wtype +end diff --git a/sys/gio/gks/gpl.x b/sys/gio/gks/gpl.x new file mode 100644 index 00000000..ea5b880f --- /dev/null +++ b/sys/gio/gks/gpl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GPL -- Polyline. Draw a line connecting the points. + +procedure gpl (n, px, py) + +int n # Number of points +real px[n], py[n] # Coordinates of points in world coordinates + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gpline (gp[i], px, py, n) + } +end diff --git a/sys/gio/gks/gpm.x b/sys/gio/gks/gpm.x new file mode 100644 index 00000000..1a7d8ac7 --- /dev/null +++ b/sys/gio/gks/gpm.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GPM -- Polymarker. Draw marks of type "gk_marker" and size 2.0 +# at the given positions. Marker type has already been set. + +procedure gpm (n, px, py) + +int n # Number of points +real px[n], py[n] # Coordinates of points in world coordinates + +int i +real size +include "gks.com" + +begin + # Marker size is a constant. + size = 2.0 + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gpmark (gp[i], px, py, n, gk_marker, size, size) + } +end diff --git a/sys/gio/gks/gqasf.x b/sys/gio/gks/gqasf.x new file mode 100644 index 00000000..828ddef0 --- /dev/null +++ b/sys/gio/gks/gqasf.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GQASF -- Inquire aspect source flags. + +procedure gqasf (ierror, lasf) + +int lasf[13] # Array of source aspect flags +int ierror # Error indicator, where ierror = 0 for no error +int i +include "gks.com" + +begin + ierror = 0 + do i = 1, NASF + lasf[i] = gk_asf[i] +end diff --git a/sys/gio/gks/gqchh.x b/sys/gio/gks/gqchh.x new file mode 100644 index 00000000..733d0a2a --- /dev/null +++ b/sys/gio/gks/gqchh.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCHH - Inquire character height. + +procedure gqchh (ierror, chh) + +int ierror # Error indicator +real chh # Character height, in world coordinates + +real dx, dy +real gstatr() +include "gks.com" +errchk gstatr, ggscale + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + chh = -1.0 + return + } else + ierror = 0 + + iferr { + chh = gstatr (gp[gk_std], G_CHARSIZE) + + # The character height is expressed in NDC units. It must be + # converted to world coordinates before returning. + + call ggscale (gp[gk_std], 0., 0., dx, dy) + chh = chh * dy + } then { + ierror = 1 + chh = -1.0 + } +end diff --git a/sys/gio/gks/gqchup.x b/sys/gio/gks/gqchup.x new file mode 100644 index 00000000..3f12d8c4 --- /dev/null +++ b/sys/gio/gks/gqchup.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCHUP -- Inquire character up vector. + +procedure gqchup (ierror, chupx, chupy) + +int ierror # Error code; ierror = 0 for no error +real chupx, chupy # Character up vector x and y components + +int angle +real txup +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + chupx = 0.0 + chupy = 0.0 + return + } else + ierror = 0 + + iferr { + angle = gstati (gp[gk_std], G_TXUP) + + txup = real (angle) * 3.1415926 / 180. + chupx = cos (txup) + chupy = sin (txup) + } then { + ierror = 1 + chupx = 0.0 + chupy = 0.0 + } +end diff --git a/sys/gio/gks/gqclip.x b/sys/gio/gks/gqclip.x new file mode 100644 index 00000000..5694b353 --- /dev/null +++ b/sys/gio/gks/gqclip.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCLIP -- Inquire value of clipping flag + +procedure gqclip (errind, iclip, iar) + +int errind # Error indicator +int iclip # Clipping flag - returned value +real iar[4] # Clipping array + +int gstati() +include "gks.com" + +begin + # Until I know what this argument is, set iar to full viewport. + # Consulting with NCAR was not enlightning. This argument (iar) + # is not documented in the GKS level 0A standard. + iar[1] = 0.0 + iar[2] = 1.0 + iar[3] = 0.0 + iar[4] = 1.0 + + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + iclip = -1 + return + } else + errind = 0 + + iferr { + iclip = gstati (gp[gk_std], G_CLIP) + } then { + errind = 1 + iclip = -1 + } +end diff --git a/sys/gio/gks/gqcntn.x b/sys/gio/gks/gqcntn.x new file mode 100644 index 00000000..aaaa79bf --- /dev/null +++ b/sys/gio/gks/gqcntn.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCNTN -- Inquire current normalization transformation number (WCS). + +procedure gqcntn (errind, cntr) + +int errind # Error indicator; errind = 0 means no error +int cntr # Current normalization transformation number +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + cntr = -1 + return + } else + errind = 0 + + iferr { + cntr = gstati (gp[gk_std], G_WCS) + } then { + errind = 1 + cntr = -1 + } +end diff --git a/sys/gio/gks/gqmk.x b/sys/gio/gks/gqmk.x new file mode 100644 index 00000000..0e90fbe7 --- /dev/null +++ b/sys/gio/gks/gqmk.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQMK -- Query marker type. Integer variable "marker" is read from +# "gks.com" and returned. + +procedure gqmk (ierr, mtype) + +int ierr # Error indicator - no way it can be set +int mtype # Marker type for polymarker +include "gks.com" + +begin + ierr = 0 + switch (gk_marker) { + case GM_POINT: + mtype = GPOINT + case GM_PLUS: + mtype = GPLUS + case GM_BOX: + mtype = GAST + case GM_DIAMOND: + mtype = GOMARK + case GM_CROSS: + mtype = GXMARK + default: + mtype = GPOINT + } +end diff --git a/sys/gio/gks/gqnt.x b/sys/gio/gks/gqnt.x new file mode 100644 index 00000000..c172647f --- /dev/null +++ b/sys/gio/gks/gqnt.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQNT -- Inquire normalization transformation (window and vport). Note +# that this procedure gets the information for WCS ntnr, then resets to +# the current WCS before returning. + +procedure gqnt (ntnr, errind, window, vport) + +int ntnr # Normalization transformation number to query +int errind # Error indicator; errind = 0 means no error +real window[4] # Window coordinates for WCS ntnr +real vport[4] # Viewport coordinates for WCS ntnr + +int current_wcs +int gstati() +include "gks.com" +errchk gstati, gseti, ggwind, ggview + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + window[1] = 0.0 + window[2] = 0.0 + window[3] = 0.0 + window[4] = 0.0 + vport[1] = -1.0 + vport[2] = -1.0 + vport[3] = -1.0 + vport[4] = -1.0 + return + } else + errind = 0 + + if (ntnr < 0 || ntnr > MAX_WCS) { + errind = 50 + window[1] = 0.0 + window[2] = 0.0 + window[3] = 0.0 + window[4] = 0.0 + vport[1] = -1.0 + vport[2] = -1.0 + vport[3] = -1.0 + vport[4] = -1.0 + return + } + + iferr { + current_wcs = gstati (gp[gk_std], G_WCS) + + call gseti (gp[gk_std], G_WCS, ntnr) + call ggwind (gp[gk_std], window[1], window[2], window[3], window[4]) + call ggview (gp[gk_std], vport[1], vport[2], vport[3], vport[4]) + + call gseti (gp[gk_std], G_WCS, current_wcs) + } then { + errind = 1 + window[1] = 0.0 + window[2] = 0.0 + window[3] = 0.0 + window[4] = 0.0 + vport[1] = -1.0 + vport[2] = -1.0 + vport[3] = -1.0 + vport[4] = -1.0 + } +end diff --git a/sys/gio/gks/gqopwk.x b/sys/gio/gks/gqopwk.x new file mode 100644 index 00000000..cf297f45 --- /dev/null +++ b/sys/gio/gks/gqopwk.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GQOPWK -- Inquire number of open work stations. From looking at how this +# procedure is called, it seems to have two functions, depending on the value +# of "n". It returns either the number of active workstations (n=0), or the +# wkid for nth open workstation. + +procedure gqopwk (n, errind, ol, wkid) + +int n # Number of workstation to query +int errind # Error indicator; errind = 0 means no error +int ol # Returned value (number of open workstations) +int wkid # WKID of nth open workstation - returned + +int i, this_wkstation +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + wkid = -1 + return + } else + errind = 0 + + if (n < 0 || n > NDEV) { + # Invalid workstation identifier + wkid = -1 + errind = 502 + return + } else { + ol = 0 + if (n == 0) { + # return the number of active workstations + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + ol = ol + 1 + } + } else { + # Find the nth open workstation and return its wkid + this_wkstation = 0 + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) { + this_wkstation = this_wkstation + 1 + if (this_wkstation == n) { + wkid = i + break + } + } + } + } + } +end diff --git a/sys/gio/gks/gqplci.x b/sys/gio/gks/gqplci.x new file mode 100644 index 00000000..23858491 --- /dev/null +++ b/sys/gio/gks/gqplci.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQPLCI -- Inquire Polyline color index. + +procedure gqplci (errind, coli) + +int coli # Color index - returned value +int errind # Error indicator +real gstatr() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + coli = -1 + return + } else + errind = 0 + + iferr { + coli = int (gstatr (gp[gk_std], G_PLWIDTH)) + } then { + errind = 1 + coli = -1 + } +end diff --git a/sys/gio/gks/gqpmci.x b/sys/gio/gks/gqpmci.x new file mode 100644 index 00000000..d1760d15 --- /dev/null +++ b/sys/gio/gks/gqpmci.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQPMCI -- Inquire Polymarker color index. + +procedure gqpmci (errind, coli) + +int coli # Color index - returned value +int errind # Error indicator +real gstatr() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + coli = -1 + return + } else + errind = 0 + + iferr { + coli = int (gstatr (gp[gk_std], G_PMWIDTH)) + } then { + errind = 1 + coli = -1 + } +end diff --git a/sys/gio/gks/gqpmi.x b/sys/gio/gks/gqpmi.x new file mode 100644 index 00000000..b1332b54 --- /dev/null +++ b/sys/gio/gks/gqpmi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQPMI -- Inquire Polymarker index. + +procedure gqpmi (errind, index) + +real index # Polymarker index - returned value. +int errind # Error indicator +include "gks.com" + +begin + errind = 0 + index = 1.0 +end diff --git a/sys/gio/gks/gqtxal.x b/sys/gio/gks/gqtxal.x new file mode 100644 index 00000000..36a90186 --- /dev/null +++ b/sys/gio/gks/gqtxal.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQTXAL -- Inquire text alignment. + +procedure gqtxal (ierror, txalh, txalv) + +int ierror # Error indicator; ierror = 0 means no error +int txalh # Horizontal text alignment +int txalv # Vertical text alignment + +int justify +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + txalh = -1 + txalv = -1 + return + } else + ierror = 0 + + iferr { + # Get value of horizontal text justification + justify = gstati (gp[gk_std], G_TXHJUSTIFY) + + switch (justify) { + case GT_NORMAL: + txalh = GAHNOR + case GT_CENTER: + txalh = GACENT + case GT_LEFT: + txalh = GALEFT + case GT_RIGHT: + txalh = GARITE + default: + txalh = GAHNOR + } + + # Get value of vertical text justification + justify = gstati (gp[gk_std], G_TXVJUSTIFY) + + switch (justify) { + case GT_NORMAL: + txalv = GAVNOR + case GT_CENTER: + txalv = GAHALF + case GT_TOP: + txalv = GATOP + case GT_BOTTOM: + txalv = GABOTT + default: + txalv = GAVNOR + } + } then { + ierror = 1 + txalv = -1 + txalh = -1 + } +end diff --git a/sys/gio/gks/gqtxci.x b/sys/gio/gks/gqtxci.x new file mode 100644 index 00000000..e327660b --- /dev/null +++ b/sys/gio/gks/gqtxci.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQTXCI -- Inquire text color index. + +procedure gqtxci (ierror, coli) + +int ierror # Error indicator +int coli # Color index - returned value. +int gstati () +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + coli = -1 + return + } else + ierror = 0 + + iferr { + coli = gstati (gp[gk_std], G_TXCOLOR) + } then { + ierror = 1 + coli = -1 + } +end diff --git a/sys/gio/gks/gqtxp.x b/sys/gio/gks/gqtxp.x new file mode 100644 index 00000000..53dfd1af --- /dev/null +++ b/sys/gio/gks/gqtxp.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQTXP -- Inquire text path. + +procedure gqtxp (ierror, path) + +int ierror # Error indicator +int path # Text path - returned value. + +int text_path +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + path = -1 + return + } else + ierror = 0 + + iferr { + text_path = gstati (gp[gk_std], G_TXPATH) + + switch (text_path) { + case (GT_LEFT): + path = GLEFT + case (GT_RIGHT): + path = GRIGHT + case (GT_UP): + path = GUP + case (GT_DOWN): + path = GDOWN + default: + path = GRIGHT + } + } then { + ierror = 1 + path = -1 + } +end diff --git a/sys/gio/gks/gqwks.x b/sys/gio/gks/gqwks.x new file mode 100644 index 00000000..b555fee0 --- /dev/null +++ b/sys/gio/gks/gqwks.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GQWKS -- Inquire workstation state. State is either ACTIVE or INACTIVE; +# this information has been stored in gks.com by GACWK. + +procedure gqwks (wkid, errind, state) + +int wkid # Workstation id for inquire +int errind # Error indicator +int state # Returned state value: ACTIVE or INACTIVE +include "gks.com" + +begin + errind = 0 + if (wkid > NDEV) + errind = 1 + else + state = gk_status[wkid] +end diff --git a/sys/gio/gks/gsasf.x b/sys/gio/gks/gsasf.x new file mode 100644 index 00000000..be321060 --- /dev/null +++ b/sys/gio/gks/gsasf.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GSASF -- Set aspect source flags. Aspect source flags allow the following +# elements to be set to either GBUNDL or GINDIV: +# 1 linetype ASF +# 2 linewidth scale factor ASF +# 3 polyline colour index ASF +# 4 marker type ASF +# 5 marker size scale factor ASF +# 6 polymarker colout index ASF +# 7 text font and precision factor ASF +# 8 character expansion factor ASF +# 9 character spacing ASF +# 10 text colour index ASF +# 11 fill area interior style ASF +# 12 fill area style index ASF +# 13 fill area colout index ASF + +procedure gsasf (lasf) + +int lasf[13] # List of aspect source flags +int i +include "gks.com" + +begin + do i = 1, NASF + gk_asf[i] = lasf[i] +end diff --git a/sys/gio/gks/gsaw.x b/sys/gio/gks/gsaw.x new file mode 100644 index 00000000..dbbc0190 --- /dev/null +++ b/sys/gio/gks/gsaw.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSAW[IR] -- Sets integer or real parameters for all active workstations. + +procedure gsawi (param, value) + +int param # Parameter to be set +int value # New value for parameter + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gseti (gp[i], param, value) + } +end + + +procedure gsawr (param, value) + +int param # Parameter to be set +real value # New value for parameter + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gsetr (gp[i], param, value) + } +end diff --git a/sys/gio/gks/gschh.x b/sys/gio/gks/gschh.x new file mode 100644 index 00000000..172af231 --- /dev/null +++ b/sys/gio/gks/gschh.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSCHH -- Set character height. + +procedure gschh (chh) + +real chh # Character height in world coordinates + +real dx, dy, ndc_chh +include "gks.com" + +begin + # Input chh is in world coordinates; it must be transformed to NDC. + # Assuming spatial transformation is linear, input coordinates to + # ggscale are not used and so are set to 0.0. + + call ggscale (gp[gk_std], 0.0, 0.0, dx, dy) + if (dy != 0) { + ndc_chh = chh / dy + call gsawr (G_CHARSIZE, ndc_chh) + } else + call gsawr (G_CHARSIZE, chh) +end diff --git a/sys/gio/gks/gschup.x b/sys/gio/gks/gschup.x new file mode 100644 index 00000000..d7698c41 --- /dev/null +++ b/sys/gio/gks/gschup.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSCHUP -- Set character up vector. + +procedure gschup (chux, chuy) + +real chux, chuy # Character up vector, in world coordinates +int char_up +bool fp_equalr() + +begin + # Find the angle normal to the text baseline. The angle is stored + # in degrees between -180 and +180. + + if (fp_equalr (chux, 0.0)) + char_up = 90 + else + char_up = nint (atan2 (chuy, chux) * 180. / 3.1415926) + + call gsawi (G_TXUP, char_up) +end diff --git a/sys/gio/gks/gsclip.x b/sys/gio/gks/gsclip.x new file mode 100644 index 00000000..80fe32c0 --- /dev/null +++ b/sys/gio/gks/gsclip.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSCLIP -- Set clipping flag. + +procedure gsclip (iclip) + +int iclip # New value of clipping flag + +begin + call gsawi (G_CLIP, iclip) +end diff --git a/sys/gio/gks/gscr.x b/sys/gio/gks/gscr.x new file mode 100644 index 00000000..39a248e1 --- /dev/null +++ b/sys/gio/gks/gscr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSCR -- Set color representation. Currently implemented as a no-op. + +procedure gscr (wkstation, color_index, rgb) + +int wkstation # Workstation id +int color_index +real rgb[3] +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gselnt.x b/sys/gio/gks/gselnt.x new file mode 100644 index 00000000..dfe39a3b --- /dev/null +++ b/sys/gio/gks/gselnt.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSELNT -- Select normalization transformation (same as world coord sys) + +procedure gselnt (wcs) + +int wcs # Transformation number + +begin + call gsawi (G_WCS, wcs) +end diff --git a/sys/gio/gks/gsfaci.x b/sys/gio/gks/gsfaci.x new file mode 100644 index 00000000..620b0bca --- /dev/null +++ b/sys/gio/gks/gsfaci.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSFACI -- Set fill area color index. Currently implemented as a no-op. + +procedure gsfaci (index) + +int index # Fill area color index. + +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gsfais.x b/sys/gio/gks/gsfais.x new file mode 100644 index 00000000..461cab8d --- /dev/null +++ b/sys/gio/gks/gsfais.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSFAIS -- Set fill area interior style. Integer variable "gk_style" is +# set and stored in "gks.com". Procedure GFA will use this value. + +procedure gsfais (ints) + +int ints # Fill area interior style + +include "gks.com" + +begin + switch (ints) { + case GHOLLO: + gk_style = GF_HOLLOW + case GSOLID: + gk_style = GF_SOLID + case GPATTR: + gk_style = GF_HATCH4 + case GHATCH: + gk_style = GF_HATCH1 + default: + gk_style = GF_HOLLOW + } +end diff --git a/sys/gio/gks/gslwsc.x b/sys/gio/gks/gslwsc.x new file mode 100644 index 00000000..b6f75963 --- /dev/null +++ b/sys/gio/gks/gslwsc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSLWSC -- Set linewidth scale. Currently implemented as a no-op. + +procedure gslwsc (width) + +real width # Linewidth scale width. + +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gsmk.x b/sys/gio/gks/gsmk.x new file mode 100644 index 00000000..41a7b05d --- /dev/null +++ b/sys/gio/gks/gsmk.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSMK -- Set marker type. Integer variable "marker" is set and +# stored in "gks.com". Procedure gpm uses this value. + +procedure gsmk (mtype) + +int mtype # Marker type for polymarker +include "gks.com" + +begin + switch (mtype) { + case GPOINT: + gk_marker = GM_POINT + case GPLUS: + gk_marker = GM_PLUS + case GAST: + gk_marker = GM_BOX + case GOMARK: + gk_marker = GM_DIAMOND + case GXMARK: + gk_marker = GM_CROSS + default: + gk_marker = GM_POINT + } +end diff --git a/sys/gio/gks/gsmksc.x b/sys/gio/gks/gsmksc.x new file mode 100644 index 00000000..4936d7ea --- /dev/null +++ b/sys/gio/gks/gsmksc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSMKSC -- Set marker scale. Currently implemented as a no-op. + +procedure gsmksc (width) + +real width # Marker scale width. + +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gsplci.x b/sys/gio/gks/gsplci.x new file mode 100644 index 00000000..afb74b4d --- /dev/null +++ b/sys/gio/gks/gsplci.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSPLC -- Set polyline colour index. This function is currently +# implemented as setting the polyline width, not color. + +procedure gsplci (coli) + +int coli # Polyline colour index + +begin + call gsawr (G_PLWIDTH, real (coli)) +end diff --git a/sys/gio/gks/gspmci.x b/sys/gio/gks/gspmci.x new file mode 100644 index 00000000..909800cf --- /dev/null +++ b/sys/gio/gks/gspmci.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSPMCI -- Set polymarker colour index. This function is currently +# implemented as setting the polymarker width, not color. + +procedure gspmci (coli) + +int coli # Polymarker colour index. + +begin + call gsawr (G_PMCOLOR, real (coli)) +end diff --git a/sys/gio/gks/gspmi.x b/sys/gio/gks/gspmi.x new file mode 100644 index 00000000..e238fc10 --- /dev/null +++ b/sys/gio/gks/gspmi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSPMI -- Set polymarker index. This function is currently +# implemented as a no-op. + +procedure gspmi (index) + +int index # Polymarker index. (whatever that is) + +begin + ; +end diff --git a/sys/gio/gks/gstxal.x b/sys/gio/gks/gstxal.x new file mode 100644 index 00000000..aecae88f --- /dev/null +++ b/sys/gio/gks/gstxal.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSTXAL -- Set format alignment. + +procedure gstxal (txalh, txalv) + +int txalh # Horizontal alignment +int txalv # Vertical alignment + +begin + switch (txalh) { + case GAHNOR: + call gsawi (G_TXHJUSTIFY, GT_NORMAL) + case GALEFT: + call gsawi (G_TXHJUSTIFY, GT_LEFT) + case GACENT: + call gsawi (G_TXHJUSTIFY, GT_CENTER) + case GARITE: + call gsawi (G_TXHJUSTIFY, GT_RIGHT) + default: + call gsawi (G_TXHJUSTIFY, GT_NORMAL) + } + + switch (txalv) { + case GAVNOR: + call gsawi (G_TXVJUSTIFY, GT_NORMAL) + case GATOP: + call gsawi (G_TXVJUSTIFY, GT_TOP) + case GACAP: + call gsawi (G_TXVJUSTIFY, GT_TOP) + case GAHALF: + call gsawi (G_TXVJUSTIFY, GT_CENTER) + case GABASE: + call gsawi (G_TXVJUSTIFY, GT_BOTTOM) + case GABOTT: + call gsawi (G_TXVJUSTIFY, GT_BOTTOM) + default: + call gsawi (G_TXVJUSTIFY, GT_NORMAL) + } +end diff --git a/sys/gio/gks/gstxci.x b/sys/gio/gks/gstxci.x new file mode 100644 index 00000000..ec04132c --- /dev/null +++ b/sys/gio/gks/gstxci.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSTXCI -- Set colour index. This function is currently implemented +# by setting the text font to bold when the color index > 1, and to +# the default (roman) otherwise. + +procedure gstxci (coli) + +int coli # Text colour index + +begin + if (coli > 1) + call gsawi (G_TXFONT, GT_BOLD) + else + call gsawi (G_TXFONT, GT_ROMAN) +end diff --git a/sys/gio/gks/gstxp.x b/sys/gio/gks/gstxp.x new file mode 100644 index 00000000..cf87e4f2 --- /dev/null +++ b/sys/gio/gks/gstxp.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSTXP -- Set text path. + +procedure gstxp (txp) + +int txp # Text path to be set + +begin + switch (txp) { + case GRIGHT: + call gsawi (G_TXPATH, GT_RIGHT) + case GLEFT: + call gsawi (G_TXPATH, GT_LEFT) + case GUP: + call gsawi (G_TXPATH, GT_UP) + case GDOWN: + call gsawi (G_TXPATH, GT_DOWN) + default: + call gsawi (G_TXPATH, GT_RIGHT) + } +end diff --git a/sys/gio/gks/gsvp.x b/sys/gio/gks/gsvp.x new file mode 100644 index 00000000..f2a61711 --- /dev/null +++ b/sys/gio/gks/gsvp.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSVP -- Set viewport. This procedure sets the viewport for world coord +# sys "wcs", which may not be the current WCS. + +procedure gsvp (wcs, x1, x2, y1, y2) + +int wcs # Number of world coordinate system +real x1, x2 # Range of viewport coordinate in x (NDC) +real y1, y2 # Range of viewport coordinate in y (NDC) + +int current_wcs, i +int gstati() +include "gks.com" + +begin + current_wcs = gstati (gp[gk_std], G_WCS) + call gsawi (G_WCS, wcs) + + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gsview (gp[i], x1, x2, y1, y2) + } + + # Now return to the current WCS + call gsawi (G_WCS, current_wcs) +end diff --git a/sys/gio/gks/gswn.x b/sys/gio/gks/gswn.x new file mode 100644 index 00000000..713ae487 --- /dev/null +++ b/sys/gio/gks/gswn.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSWN -- Set window. Window of world coord system "wcs" is set, which +# is not necessarily the current WCS. + +procedure gswn (wcs, x1, x2, y1, y2) + +int wcs # Number of world coordinate system (transformation) +real x1, x2 # Range of world coordinates in x +real y1, y2 # Range of world coordinates in y + +int current_wcs, i +int gstati() +include "gks.com" + +begin + current_wcs = gstati (gp[gk_std], G_WCS) + call gsawi (G_WCS, wcs) + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gswind (gp[i], x1, x2, y1, y2) + } + + # Now return to current WCS before returning + call gsawi (G_WCS, current_wcs) +end diff --git a/sys/gio/gks/gtx.f b/sys/gio/gks/gtx.f new file mode 100644 index 00000000..c09ef7c4 --- /dev/null +++ b/sys/gio/gks/gtx.f @@ -0,0 +1,16 @@ +c GTX -- Text. Unpack an f77 string and call gx_gtx to output the string. +c + subroutine gtx (px, py, f77chars) +c + real px, py + character*(*) f77chars + integer*2 sppchars(161) +c +c +c Unpack characters from packed input array +c + call f77upk (f77chars, sppchars, min (len(f77chars), 161)) + call gxgtx (px, py, sppchars) +c +c + end diff --git a/sys/gio/gks/gxgtx.x b/sys/gio/gks/gxgtx.x new file mode 100644 index 00000000..0ca39bb5 --- /dev/null +++ b/sys/gio/gks/gxgtx.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GXGTX -- Text. Ouptut an spp string with gtext. The string has already +# been unpacked from an f77 to spp string. + +procedure gxgtx (px, py, chars) + +real px, py # Text position in world coordinates +char chars[ARB] # String of characters + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gtext (gp[i], px, py, chars, "") + } +end diff --git a/sys/gio/gks/mkpkg b/sys/gio/gks/mkpkg new file mode 100644 index 00000000..864c3ba7 --- /dev/null +++ b/sys/gio/gks/mkpkg @@ -0,0 +1,58 @@ +# Make the GKS emulator. + +$checkout libgks.a lib$ +$update libgks.a +$checkin libgks.a lib$ +$exit + +libgks.a: + gacwk.x gks.com gks.h + gca.x gks.com gks.h + gcas.x gks.com gks.h + gclks.x + gclrwk.x gks.com gks.h + gclwk.x gks.com gks.h + gdawk.x gks.com gks.h + gfa.x gks.h gks.com + gopks.x gks.com gks.h + gopwk.x gks.com gks.h + gpl.x gks.com gks.h + gpm.x gks.com gks.h + gqasf.x gks.com gks.h + gqchh.x gks.com gks.h + gqchup.x gks.com gks.h + gqclip.x gks.com gks.h + gqcntn.x gks.com gks.h + gqmk.x gks.com gks.h + gqnt.x gks.com gks.h + gqopwk.x gks.com gks.h + gqplci.x gks.com gks.h + gqpmci.x gks.com gks.h + gqpmi.x gks.com gks.h + gqtxal.x gks.com gks.h + gqtxci.x gks.com gks.h + gqtxp.x gks.com gks.h + gqwks.x gks.com gks.h + gsasf.x gks.com gks.h + gsaw.x gks.com gks.h + gschh.x gks.com gks.h + gschup.x + gsclip.x + gscr.x gks.com gks.h + gselnt.x + gsfaci.x gks.com gks.h + gsfais.x gks.com gks.h + gslwsc.x gks.com gks.h + gsmk.x gks.com gks.h + gsmksc.x gks.com gks.h + gsplci.x + gspmci.x + gspmi.x + gstxal.x gks.h + gstxci.x + gstxp.x gks.h + gsvp.x gks.com gks.h + gswn.x gks.com gks.h + gtx.f + gxgtx.x gks.com gks.h + ; diff --git a/sys/gio/glabax/README b/sys/gio/glabax/README new file mode 100644 index 00000000..4c9f9ad5 --- /dev/null +++ b/sys/gio/glabax/README @@ -0,0 +1 @@ +GLABAX -- GIO axis drawing and labelling package. diff --git a/sys/gio/glabax/glabax.h b/sys/gio/glabax/glabax.h new file mode 100644 index 00000000..070918ec --- /dev/null +++ b/sys/gio/glabax/glabax.h @@ -0,0 +1,46 @@ +# GLABAX.H -- Axis drawing and labelling. + +define SZ_FORMAT 19 +define SZ_LABEL 19 +define MAX_LINEARITY 1.0 # no log scaling if gt +define LEFT_BORDER 9 # nchars at l|r edge +define BOTTOM_BORDER 5 # nlines at bottom edge +define Y_LABELOFFSET 7 # Y label dist from axis +define MAX_SZTITLEBLOCK 0.5 # max sztitleblock, NDC +define MIN_NTITLELINES 2 # min lines in titleblk +define TOL (EPSILONR*10.0) + +define LEN_AX 85 +define AX_POS Memd[P2D($1)+$2-1] # tick coords +define AX_DRAWME Memi[$1+4] # draw this axis +define AX_HORIZONTAL Memi[$1+5] # axis is horizontal +define AX_SCALING Memi[$1+6] # type of scaling +define AX_DRAWTICKS Memi[$1+7] # draw the ticks +define AX_START Memr[P2R($1+8+$2-1)] # axis starts here +define AX_END Memr[P2R($1+10+$2-1)] # axis ends here +define AX_TICK1 Memr[P2R($1+12+$2-1)] # first tick is here +define AX_STEP Memr[P2R($1+14+$2-1)] # offset between ticks +define AX_ISTEP Memr[P2R($1+16+$2-1)] # intial offset +define AX_KSTEP Memr[P2R($1+18)] # step scalar at majors +define AX_IKSTEP Memr[P2R($1+19)] # initial kstep +define AX_NMINOR Memi[$1+20] # nminor ticks +define AX_NLEFT Memi[$1+21] # nminor to next major +define AX_INLEFT Memi[$1+22] # initial nleft +define AX_NDIGITS Memi[$1+23] # ndigits of precision +define AX_MINORTICK Memr[P2R($1+24+$2-1)] # offset to draw minor +define AX_MAJORTICK Memr[P2R($1+26+$2-1)] # offset to draw major +define AX_MINORWIDTH Memr[P2R($1+28)] # minor tick linewidth +define AX_MAJORWIDTH Memr[P2R($1+29)] # major tick linewidth +define AX_LABELTICKS Memi[$1+30] # draw tick labels +define AX_TICKLABELOFFSET Memr[P2R($1+31+$2-1)] # offset to ticklabel +define AX_TICKLABELSIZE Memr[P2R($1+33)] # char size of ticklabel +define AX_TICKLABELCOLOR Memi[$1+34] # char size of ticklabel +define AX_TICKCOLOR Memi[$1+35] # grid between ticks +define AX_AXISLABELSIZE Memr[P2R($1+36)] # char size axislabel +define AX_AXISLABELCOLOR Memi[$1+37] # char size axislabel +define AX_AXISWIDTH Memr[P2R($1+38)] # axis linewidth +define AX_AXISCOLOR Memi[$1+39] # axis linewidth +define AX_GRIDCOLOR Memi[$1+40] # grid between ticks + +define AX_TICKLABELPOS Memc[P2C($1+45)] # gtext format +define AX_TICKFORMAT Memc[P2C($1+65)] # numeric format diff --git a/sys/gio/glabax/glabax.x b/sys/gio/glabax/glabax.x new file mode 100644 index 00000000..0c30021b --- /dev/null +++ b/sys/gio/glabax/glabax.x @@ -0,0 +1,264 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLABAX -- Draw and label the axes of the plot (normally the viewport +# boundary). This is done in two steps. First we compute all the required +# parameters, and then we draw and label the axes. Up to four axes can be +# drawn. To simplify matters, all four axes are treated equally and +# independently. The axes are drawn a tick at a time in world coordinates. + +procedure glabax (gp, title, xlabel, ylabel) + +pointer gp # graphics descriptor +char title[ARB] # plot title (may be more than one line) +char xlabel[ARB] # X axis label +char ylabel[ARB] # Y axis label + +char label[SZ_LABEL] +int axis, wcs, ntitlelines, ip, major_tick +int save_plcolor, save_txcolor, save_facolor +int save_pltype, save_clip, save_txfont +real xv[4], yv[4], x1, x2, y1, y2 +real save_plwidth, save_txsize +real dx, dy, x, y, sx, sy, scalar, wc, wstep +pointer sp, axes[4], ax, w + +real gstatr() +bool ttygetb() +int gstati(), glb_gettick() +errchk glb_setup, gadraw, grdraw, gamove, gtext +errchk glb_label_axis, glb_plot_title, glb_gettick + +begin + call smark (sp) + call salloc (axes[1], LEN_AX, TY_STRUCT) + call salloc (axes[2], LEN_AX, TY_STRUCT) + call salloc (axes[3], LEN_AX, TY_STRUCT) + call salloc (axes[4], LEN_AX, TY_STRUCT) + + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + + # Count the number of lines in the title block. + ntitlelines = 0 + if (title[1] != EOS) { + for (ip=1; title[ip] != EOS; ip=ip+1) + if (title[ip] == '\n' && title[ip+1] != EOS) + ntitlelines = ntitlelines + 1 + ntitlelines = ntitlelines + 1 + } + ntitlelines = max (ntitlelines, GP_NTITLELINES(gp)) + + # Fix the coordinates systems and set the axis drawing parameters. + # The number of lines in the title block is needed to determine how + # much space to allow at the top of the screen. + + call glb_setup (gp, axes, ntitlelines, xlabel, ylabel) + + # Save the values of any user parameters we must change while drawing + # the axes. + + save_pltype = gstati (gp, G_PLTYPE) + save_plwidth = gstatr (gp, G_PLWIDTH) + save_plcolor = gstati (gp, G_PLCOLOR) + save_txfont = gstati (gp, G_TXFONT) + save_txsize = gstatr (gp, G_TXSIZE) + save_txcolor = gstati (gp, G_TXCOLOR) + save_facolor = gstati (gp, G_FACOLOR) + save_clip = WCS_CLIP(w) + + # Prepare the background. + if (ttygetb (GP_TTY(gp), "fa") && + GP_FRAMECOLOR(gp) != 0 && GP_FRAMEDRAWN(gp) == NO) { + + call ggview (gp, x1, x2, y1, y2) + call gseti (gp, G_WCS, 0) + call gseti (gp, G_CLIP, NO) + + xv[1] = 0.0; yv[1] = 0.0 + xv[2] = 1.0; yv[2] = 0.0 + xv[3] = 1.0; yv[3] = 1.0 + xv[4] = 0.0; yv[4] = 1.0 + call gseti (gp, G_FACOLOR, GP_FRAMECOLOR(gp)) + call gfill (gp, xv, yv, 4, GF_SOLID) + + xv[1] = x1; yv[1] = y1 + xv[2] = x2; yv[2] = y1 + xv[3] = x2; yv[3] = y2 + xv[4] = x1; yv[4] = y2 + call gseti (gp, G_FACOLOR, 0) + call gfill (gp, xv, yv, 4, GF_SOLID) + + call gseti (gp, G_CLIP, save_clip) + call gseti (gp, G_WCS, wcs) + GP_FRAMEDRAWN(gp) = YES + } + + # Draw and label the four axes. First set the linetype and linewidth + # to be used to draw the axes and ticks; these may be different than + # that used to plot the data. Draws are preferred to moves to minimize + # the number of polylines needed to draw the axis. An axis is drawn + # by moving to the start of the axis, drawing each tick in sequence, + # and then moving to the end of the axis. Tick labels are drawn at + # the major ticks if required. The axes and ticks must be drawn in + # world coords to get the proper scaling. Clipping is turned off while + # drawing the axes to avoid clipping portions of the axes due to small + # floating point errors. + + call gseti (gp, G_PLTYPE, 1) + call gseti (gp, G_CLIP, NO) + call gseti (gp, G_TXFONT, GT_BOLD) + + do axis = 1, 4 { + ax = axes[axis] + if (AX_DRAWME(ax) == NO) + next + +# call eprintf ("axis %d: tick1=(%g,%g) istep=(%g,%g) kstep=%g\n") +# call pargi (axis) +# call pargr (AX_TICK1(ax,1)); call pargr (AX_TICK1(ax,2)) +# call pargr (AX_ISTEP(ax,1)); call pargr (AX_ISTEP(ax,2)) +# call pargr (AX_IKSTEP(ax)) +# call eprintf ("\tstart=(%g,%g) end=(%g,%g)\n") +# call pargr (AX_START(ax,1)); call pargr (AX_START(ax,2)) +# call pargr (AX_END(ax,1)); call pargr (AX_END(ax,2)) +# call eprintf ("nminor=%d, inleft=%d, minortick=(%g,%g), majortick=(%g,%g)\n") +# call pargi (AX_NMINOR(ax)); call pargi (AX_INLEFT(ax)) +# call pargr (AX_MINORTICK(ax,1)); call pargr (AX_MINORTICK(ax,2)) +# call pargr (AX_MAJORTICK(ax,1)); call pargr (AX_MAJORTICK(ax,2)) + + # Set the axis linewidth and move to the start of the axis. + call gsetr (gp, G_PLWIDTH, AX_AXISWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_AXISCOLOR(ax)) + call gamove (gp, AX_START(ax,1), AX_START(ax,2)) + + # Draw the axis and label the major ticks if so indicated. + # First set flag to initialize glb_gettick. + + AX_NLEFT(ax) = -1 + while (glb_gettick (gp, ax, x, y, major_tick) != EOF) { + + # Advance to the next tick. + call gsetr (gp, G_PLWIDTH, AX_AXISWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_AXISCOLOR(ax)) + call gadraw (gp, x, y) + + if (major_tick == YES) { + # Draw a major tick. + + call gsetr (gp, G_PLWIDTH, AX_MAJORWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_TICKCOLOR(ax)) + dx = AX_MAJORTICK(ax,1) + dy = AX_MAJORTICK(ax,2) + call grdraw (gp, dx, dy) + call grdraw (gp, -dx, -dy) + + if (AX_LABELTICKS(ax) == YES) { + # Get the tick label position in NDC coords. World + # coords cannot be used for an offset outside the + # viewport as the coords might be indefinite if log + # scaling. + + call gseti (gp, G_WCS, 0) + call gcurpos (gp, sx, sy) + dx = AX_TICKLABELOFFSET(ax,1) + dy = AX_TICKLABELOFFSET(ax,2) + + # Format the numeric tick label string. The scalar + # multiplier is used to compute the step size between + # major ticks. + + scalar = AX_NMINOR(ax) + 1.0 + if (AX_HORIZONTAL(ax) == YES) { + wc = x + wstep = AX_STEP(ax,1) * scalar + } else { + wc = y + wstep = AX_STEP(ax,2) * scalar + } + + # Draw the label string. + call gsetr (gp, G_TXSIZE, AX_TICKLABELSIZE(ax)) + call gseti (gp, G_TXCOLOR, AX_TICKLABELCOLOR(ax)) + + # If log scaling, label the ticks in log units. + if (AX_SCALING(ax) == LINEAR) { + call glb_encode (wc, label, SZ_LABEL, + AX_TICKFORMAT(ax), wstep) + call gtext (gp, sx + dx, sy + dy, label, + AX_TICKLABELPOS(ax)) + } else { + call glb_loglab (gp, sx+dx, sy+dy, wc, + AX_TICKLABELPOS(ax), AX_SCALING(ax)) + } + + # Leave the pen back at the base of the tick. + call gamove (gp, sx, sy) + call gseti (gp, G_WCS, wcs) + } + + } else { + # Draw a minor tick. + + dx = AX_MINORTICK(ax,1) + dy = AX_MINORTICK(ax,2) + + call gsetr (gp, G_PLWIDTH, AX_MINORWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_TICKCOLOR(ax)) + call grdraw (gp, dx, dy) + call grdraw (gp, -dx, -dy) + } + } + + # Draw line segment from last tick to the end of the axis. + call gadraw (gp, AX_END(ax,1), AX_END(ax,2)) + + # Flush the graphics output. When working interactively, this + # gives the user something to watch while we generate the rest + # of the plot. + + if (AX_NMINOR(ax) > 0) + call gflush (gp) + } + + # Draw grid between major ticks. + if (GL_DRAWGRID (GP_XAP(gp)) == YES) { + call gseti (gp, G_PLCOLOR, AX_GRIDCOLOR(axes[3])) + call glb_drawgrid (gp, axes[3], axes[2]) + } + if (GL_DRAWGRID (GP_YAP(gp)) == YES) { + call gseti (gp, G_PLCOLOR, AX_GRIDCOLOR(axes[1])) + call glb_drawgrid (gp, axes[1], axes[4]) + } + + # Label the X and Y axes. + do axis = 1, 4 { + ax = axes[axis] + if (AX_DRAWME(ax) == YES && AX_LABELTICKS(ax) == YES) { + call gseti (gp, G_TXCOLOR, AX_AXISLABELCOLOR(ax)) + call glb_label_axis (gp, ax, xlabel, ylabel) + } + } + + # Draw plot title block. + call gseti (gp, G_TXCOLOR, GP_TITLECOLOR(gp)) + call glb_plot_title (gp, title, ntitlelines) + + # Restore the parameters we were originally called with. + call gseti (gp, G_WCS, wcs) + call gseti (gp, G_CLIP, save_clip) + call gseti (gp, G_PLTYPE, save_pltype) + call gsetr (gp, G_PLWIDTH, save_plwidth) + call gseti (gp, G_PLCOLOR, save_plcolor) + call gsetr (gp, G_TXSIZE, save_txsize) + call gseti (gp, G_TXFONT, save_txfont) + call gseti (gp, G_TXCOLOR, save_txcolor) + call gseti (gp, G_FACOLOR, save_facolor) + + call gflush (gp) + call sfree (sp) +end diff --git a/sys/gio/glabax/glbencode.x b/sys/gio/glabax/glbencode.x new file mode 100644 index 00000000..cbed6875 --- /dev/null +++ b/sys/gio/glabax/glbencode.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "glabax.h" + +# GLB_ENCODE -- Encode a floating point number as a character string for a +# tick label. We have to be careful how we do this, since on the one hand +# we want the most concise label possible (e.g., 500 not 500.00) but on the +# other we must provide enough precision to discriminate between ticks that +# are close together (e.g., 500.02 and 500.04). The extra information is +# given by the "ndigits" argument, which was calculated knowing the range +# and step at setup time. + +procedure glb_encode (x, out, maxch, format, step) + +real x # number to be encoded +char out[ARB] # output string +int maxch # max chars out +char format[ARB] # sprintf format +real step # tick spacing + +int ip, op +real nicex +define trim_ 91 + +begin + # Test for the zero tick, to avoid tick labels that look like the + # machine epsilon. + + if (abs (x / step) < TOL) + nicex = 0 + else + nicex = x + + # Encode number. + call sprintf (out, maxch, format) + call pargr (nicex) + + # Lop off any insignificant trailing zeros or periods. Watch out for + # trailing zeros in exponential format, e.g., "1.0E10". + + for (ip=1; out[ip] != EOS; ip=ip+1) + if (out[ip] == 'E' || out[ip] == 'D') + goto trim_ + + for (ip=ip-1; ip > 1 && out[ip] == '0'; ip=ip-1) + ; + if (ip > 1 && out[ip] == '.') + ip = ip - 1 + if (ip >= 1) + out[ip+1] = EOS + + # Lop off any insignificant leading zeros, but be sure to leave at + # least one digit. +trim_ + for (op=1; out[op] == '-' || out[op] == '+'; op=op+1) + ; + for (ip=op; out[ip] == '0' && out[ip+1] != EOS; ip=ip+1) + ; + while (out[ip] != EOS) { + out[op] = out[ip] + op = op + 1 + ip = ip + 1 + } + out[op] = EOS +end diff --git a/sys/gio/glabax/glbfind.x b/sys/gio/glabax/glbfind.x new file mode 100644 index 00000000..b9ff3975 --- /dev/null +++ b/sys/gio/glabax/glbfind.x @@ -0,0 +1,339 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_FIND_TICKS -- Find the optimal positions for the tick marks on an axis. +# If rounding is enabled, extend the WCS out to the next tick outside the +# boundary on either end of the axis. Since this routine may modify the WCS +# it must be called before any other routines (e.g., glb_setaxes). Our task +# is to position the major ticks in world coordinates at round numbers, e.g., +# 10, 20, 30 for a linear scale or 10, 100, 1000 for a log scale. The minor +# ticks are evenly distributed over the range between the major ticks. If +# log scaling is in use the step size between ticks will change by an order +# of magnitude (by the factor KSTEP) in each decade of the log scale, i.e., +# at each major tick. All tick positions and offsets are output in world +# coordinates. + +procedure glb_find_ticks (gp, ap, ax1, ax2, angle) + +pointer gp # graphics descriptor +pointer ap # axis parameters (from graphics descriptor) +pointer ax1, ax2 # axis descriptors (output) +int angle # axis orientation, 0 or 90 degrees + +pointer w +int logflag, nminor, scaling, t1, t2 +real char_height, char_width, wctick, tval +real p1, p2, tp1, tp2, wcp1, tick1, step, minor_step, length + +bool fp_equalr() +int gt_ndigits() +real ggetr(), elogr(), aelogr(), glb_minorstep() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Start by zeroing the AX structures so that we do not have to zero + # fields explicitly. This is a bit tricky because we are implicitly + # setting fields that are not named, but it saves time and space. + + call aclri (Memi[ax1], LEN_AX) + call aclri (Memi[ax2], LEN_AX) + + # If ticks are not to be drawn or if there are fewer than 2 ticks then + # we are done. + + if (GL_NMAJOR(ap) <= 2) + return + + # Call the tick placement algorithm to determine where to put the major + # tick marks. The output of this block are the variables P1 and P1, + # the world coords of the ends of the axis, and TICK1 and STEP, the + # world coords of the first tick and separation in world coords between + # major ticks. + + if (angle == 0) { + p1 = WCS_WX1(w) + p2 = WCS_WX2(w) + scaling = WCS_XTRAN(w) + } else { + p1 = WCS_WY1(w) + p2 = WCS_WY2(w) + scaling = WCS_YTRAN(w) + } + + AX_SCALING(ax1) = scaling + AX_SCALING(ax2) = scaling + + if (scaling == LOG) { + p1 = log10 (p1) + p2 = log10 (p2) + logflag = YES + } else if (scaling == ELOG) { + p1 = elogr (p1) + p2 = elogr (p2) + logflag = YES + } else + logflag = NO + + # Call the tick placement algorithm. + call gtickr (p1, p2, GL_NMAJOR(ap), logflag, tick1, step) + + # If rounding is enabled, extend the WCS out to the next major tick + # position outward on either end. Always round if log scaling. + + if (GL_ROUND(ap) == YES || scaling != LINEAR) { + if (!fp_equalr (p1, tick1)) { + tick1 = tick1 - step + p1 = tick1 + } + + length = (p2 - p1) / step + if (!fp_equalr (p1 + int(length) * step, p2)) + p2 = p1 + (int(length) + 1) * step + + if (scaling == ELOG) { + tp1 = aelogr (p1) + tp2 = aelogr (p2) + } else if (scaling == LOG) { + tp1 = 10.0 ** p1 + tp2 = 10.0 ** p2 + } else { + tp1 = p1 + tp2 = p2 + } + + if (angle == 0) { + WCS_WX1(w) = tp1 + WCS_WX2(w) = tp2 + } else { + WCS_WY1(w) = tp1 + WCS_WY2(w) = tp2 + } + + GP_WCSSTATE(gp) = MODIFIED + } + + # Compute the coords of the axis endpoint and of the first tick in world + # coords. + + if (scaling == LINEAR) { + wctick = tick1 + wcp1 = p1 + } else if (scaling == LOG) { + wctick = 10.0 ** tick1 + wcp1 = 10.0 ** p1 + } else { + wctick = aelogr (tick1) + wcp1 = aelogr (p1) + } + + # Compute the number of minor ticks. If we are log scaling there + # are either no minor ticks or 8 minor ticks. If the scaling is + # linear the tick placement algorithm is used to compute the best + # number of minor ticks, using GL_NMINOR as a close estimate. If + # NMINOR is negative automatic tick selection is disabled and exactly + # abs(NMINOR) ticks will be drawn. If NMINOR is zero no minor ticks + # are drawn. + + if (GL_NMINOR(ap) == 0) # no minor ticks + nminor = 0 + else if (logflag == YES) # log scaling + nminor = 8 + else { + minor_step = glb_minorstep (tick1, tick1+step, GL_NMINOR(ap)) + nminor = nint (abs (step / minor_step)) - 1 + } + + AX_NMINOR(ax1) = nminor + AX_NMINOR(ax2) = nminor + + # Compute the step size in world coords between minor ticks and the + # number of minor ticks to be drawn initially until the first major + # tick (tick1) is reached. Note that for ELOG scaling the minor + # step size and number of minor ticks are different in the range + # +-10 (which is linear) than elsewhere, but we ignore that here. + + if (scaling == LINEAR) { + minor_step = step / (nminor + 1) + AX_INLEFT(ax1) = abs (int ((wctick - wcp1) / minor_step)) + } else { + t1 = nint (tick1) + t2 = nint (tick1 + step) + if (scaling == LOG) + minor_step = (10.0 ** t2 - 10.0 ** t1) / 9. + else + minor_step = (aelogr(real(t2)) - aelogr(real(t1))) / 9. + if (nminor == 0) + minor_step = minor_step * 9. + AX_INLEFT(ax1) = 0 + } + + AX_INLEFT(ax2) = AX_INLEFT(ax1) + + # Set KSTEP, the adjustment to the step size at each major tick. This + # is always 1.0 if the scale is linear. Set KSTEP to negative if ELOG + # scaling, to tell the drawing code to invert kstep (.1->10 or 10->.1) + # when passing through the origin (necessary for ELOG scaling). The + # sign is not otherwise significant. If heading toward the origin + # initially then KSTEP is inverted for ELOG scaling vs LOG scaling. + + if (scaling == LINEAR) { + AX_IKSTEP(ax1) = 1.0 + } else if (scaling == ELOG) { + tval = p1 + if (abs (tval + step) > abs(t1)) + AX_IKSTEP(ax1) = -10.0 + else + AX_IKSTEP(ax1) = -0.1 + } else + AX_IKSTEP(ax1) = 10.0 ** step + AX_IKSTEP(ax2) = AX_IKSTEP(ax1) + + # Set those parameters which differ depending on whether the axis is + # horizontal or vertical. + + if (angle == 0) { + AX_TICK1(ax1,1) = wctick - (AX_INLEFT(ax1) * minor_step) + AX_TICK1(ax2,1) = wctick - (AX_INLEFT(ax2) * minor_step) + + if (GL_SETAXISPOS(ap) == YES) { + AX_TICK1(ax1,2) = GL_AXISPOS1(ap) + AX_TICK1(ax2,2) = GL_AXISPOS2(ap) + } else { + AX_TICK1(ax1,2) = WCS_WY1(w) + AX_TICK1(ax2,2) = WCS_WY2(w) + } + + AX_ISTEP(ax1,1) = minor_step + AX_ISTEP(ax2,1) = minor_step + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + char_height = char_height * GL_TICKLABELSIZE(ap) + + AX_TICKLABELOFFSET(ax2,2) = 0.5 * char_height + AX_TICKLABELOFFSET(ax1,2) = -AX_TICKLABELOFFSET(ax2,2) + + # Set gtext format for tick labels. + call strcpy ("hj=c,vj=t", AX_TICKLABELPOS(ax1), SZ_FORMAT) + call strcpy ("hj=c,vj=b", AX_TICKLABELPOS(ax2), SZ_FORMAT) + + } else { + if (GL_SETAXISPOS(ap) == YES) { + AX_TICK1(ax1,1) = GL_AXISPOS1(ap) + AX_TICK1(ax2,1) = GL_AXISPOS2(ap) + } else { + AX_TICK1(ax1,1) = WCS_WX1(w) + AX_TICK1(ax2,1) = WCS_WX2(w) + } + + AX_TICK1(ax1,2) = wctick - (AX_INLEFT(ax1) * minor_step) + AX_TICK1(ax2,2) = wctick - (AX_INLEFT(ax2) * minor_step) + + AX_ISTEP(ax1,2) = minor_step + AX_ISTEP(ax2,2) = minor_step + + char_width = ggetr (gp, "cw") + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + char_width = char_width * GL_TICKLABELSIZE(ap) + + AX_TICKLABELOFFSET(ax2,1) = 0.5 * char_width + AX_TICKLABELOFFSET(ax1,1) = -AX_TICKLABELOFFSET(ax2,1) + + call strcpy ("hj=r,vj=c", AX_TICKLABELPOS(ax1), SZ_FORMAT) + call strcpy ("hj=l,vj=c", AX_TICKLABELPOS(ax2), SZ_FORMAT) + } + + # Set the tick parameters that are identical for the two axes and + # which do not depend on whether the axis is horizontal or vertical. + + AX_DRAWTICKS(ax1) = GL_DRAWTICKS(ap) + AX_DRAWTICKS(ax2) = GL_DRAWTICKS(ap) + AX_TICKLABELSIZE(ax1) = GL_TICKLABELSIZE(ap) + AX_TICKLABELSIZE(ax2) = GL_TICKLABELSIZE(ap) + AX_TICKLABELCOLOR(ax1) = GL_TICKLABELCOLOR(ap) + AX_TICKLABELCOLOR(ax2) = GL_TICKLABELCOLOR(ap) + AX_TICKCOLOR(ax1) = GL_TICKCOLOR(ap) + AX_TICKCOLOR(ax2) = GL_TICKCOLOR(ap) + AX_GRIDCOLOR(ax1) = GL_GRIDCOLOR(ap) + AX_GRIDCOLOR(ax2) = GL_GRIDCOLOR(ap) + AX_AXISLABELSIZE(ax1) = GL_AXISLABELSIZE(ap) + AX_AXISLABELSIZE(ax2) = GL_AXISLABELSIZE(ap) + AX_AXISLABELCOLOR(ax1) = GL_AXISLABELCOLOR(ap) + AX_AXISLABELCOLOR(ax2) = GL_AXISLABELCOLOR(ap) + AX_AXISWIDTH(ax1) = GL_AXISWIDTH(ap) + AX_AXISWIDTH(ax2) = GL_AXISWIDTH(ap) + AX_AXISCOLOR(ax1) = GL_AXISCOLOR(ap) + AX_AXISCOLOR(ax2) = GL_AXISCOLOR(ap) + AX_MINORWIDTH(ax1) = GL_MINORWIDTH(ap) + AX_MINORWIDTH(ax2) = GL_MINORWIDTH(ap) + AX_MAJORWIDTH(ax1) = GL_MAJORWIDTH(ap) + AX_MAJORWIDTH(ax2) = GL_MAJORWIDTH(ap) + + # Compute the number of digits of precision needed for the tick labels. + AX_NDIGITS(ax1) = max (1, gt_ndigits (p1, p2, step)) + AX_NDIGITS(ax2) = AX_NDIGITS(ax1) + + # If both axes are to be drawn label ticks if enabled. If only one + # axis is to be drawn that is the axis that must be labelled. + + if (GL_DRAWAXES(ap) > 0) { + AX_LABELTICKS(ax1) = GL_LABELTICKS(ap) + AX_LABELTICKS(ax2) = GL_LABELTICKS(ap) + } + if (GL_DRAWAXES(ap) == 1 || GL_DRAWAXES(ap) == 3) + AX_LABELTICKS(ax2) = NO + else if (GL_DRAWAXES(ap) == 2) + AX_LABELTICKS(ax1) = NO + + # The user may override the tick label format if desired. + if (GL_TICKFORMAT(ap) == EOS) { + call sprintf (AX_TICKFORMAT(ax1), SZ_FORMAT, "%%0.%dg") + call pargi (AX_NDIGITS(ax1) + 1) + } else + call strcpy (GL_TICKFORMAT(ap), AX_TICKFORMAT(ax1), SZ_FORMAT) + call strcpy (AX_TICKFORMAT(ax1), AX_TICKFORMAT(ax2), SZ_FORMAT) +end + + +# GLB_MINORSTEP -- Determine the step size for the minor ticks. Adapted +# from a routine by J. Eisenhamer (STScI) which was based on some MONGO code. + +real procedure glb_minorstep (x1, x2, nminor) + +real x1, x2 #I interval between major ticks +int nminor #I suggested number of minor ticks, or actual# if neg + +int iexp +real amant, diff, num, range + +begin + range = abs (x2 - x1) + if (nminor < 0) + return (range / real (-nminor + 1)) + else { + # Determine magnitude of the intervals. + diff = log10 (range / nminor) + iexp = int (diff) + if (diff < 0) + iexp = iexp - 1 + amant = diff - real(iexp) + + # Determine an appropriate step size. + if (amant < 0.15) + num = 1.0 + else if (amant < 0.50) + num = 2.0 + else if (amant < 0.85) + num = 5.0 + else + num = 10.0 + + return (num * 10.0**iexp) + } +end diff --git a/sys/gio/glabax/glbgrid.x b/sys/gio/glabax/glbgrid.x new file mode 100644 index 00000000..ecb24ffb --- /dev/null +++ b/sys/gio/glabax/glbgrid.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_DRAWGRID -- Draw a grid across the plotting surface, i.e., draw +# dotted lines between the major tick marks. + +procedure glb_drawgrid (gp, ax1, ax2) + +pointer gp # graphics descriptor +pointer ax1 # descriptor for first axis +pointer ax2 # descriptor for second axis + +int wcs, major_tick +real x, y, tolerance +real x1, y1, x2, y2, sx, sy +int glb_gettick() +errchk glb_gettick, gseti, gsetr, gline, gctran + +begin + tolerance = TOL + wcs = GP_WCS(gp) + + # Cache the NDC coordinates of the ends of an axis. + call gctran (gp, AX_START(ax1,1), AX_START(ax1,2), x1,y1, wcs, 0) + call gctran (gp, AX_END(ax1,1), AX_END(ax1,2), x2,y2, wcs, 0) + + # Set polyline linetype for a dotted line. + call gseti (gp, G_PLTYPE, GL_DOTTED) + call gsetr (gp, G_PLWIDTH, 1.0) + + AX_NLEFT(ax1) = -1 + while (glb_gettick (gp, ax1, x, y, major_tick) != EOF) { + if (major_tick == NO) + next + + # Draw grid line if we are at a major tick, provided the tick + # is not at the end of the axis. + + call gctran (gp, x,y, sx,sy, wcs, 0) + if (AX_HORIZONTAL(ax1) == YES) { + if (sx - x1 > tolerance && sx - x2 < tolerance) + call gline (gp, x, AX_END(ax1,2), x, AX_END(ax2,2)) + } else { + if (sy - y1 > tolerance && sy - y2 < tolerance) + call gline (gp, AX_END(ax1,1), y, AX_END(ax2,1), y) + } + } + + call gseti (gp, G_PLTYPE, GL_SOLID) +end diff --git a/sys/gio/glabax/glbgtick.x b/sys/gio/glabax/glbgtick.x new file mode 100644 index 00000000..cc70fd3a --- /dev/null +++ b/sys/gio/glabax/glbgtick.x @@ -0,0 +1,252 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_GETTICK -- Get the position and type of the next tick on an axis. +# Ticks are accessed sequentially. There are three types of tick scalings, +# LINEAR, LOG, and ELOG. The tick scaling need not necessarily agree with +# the WCS scaling, hence linear tick scaling might be used on a nonlinear +# coordinate system. If the scaling is linear then the first tick need not +# fall at the endpoint of the axis. If log (or elog) scaling is in use then +# the axis will have been rounded out to a decade and the first tick will +# necessarily fall on the axis endpoint. The scalings are described by the +# following parameters: +# +# (variables) +# nleft number of minor ticks left to next major tick +# step(x,y) displacement between minor ticks (world coords) +# +# (constants) +# tick1(x,y) world coords of the first tick on an axis +# nminor number of minor ticks between major ticks +# istep(x,y) initial step (actual step may differ) +# kstep(x,y) adjustment to step at major ticks +# +# KSTEP is unity if the scaling is linear. The log scalings have a KSTEP of +# either 10.0 or 0.1. A negative KSTEP value is used to flag ELOG scaling. +# ELOG, or extended range log scaling, is a log scaling which is defined for +# X <=0 as well as x > 0. This function is logarithmic for values less than +# -10 or greater than 10, and linear in the range [-10:+10]. This complicates +# tick computation because the usual 8 minor ticks per decade characteristic +# of log scaling are not appropriate in the linear regime. If the scaling +# is ELOG then we ignore NMINOR and ISTEP in the linear range, changing the +# values of these parameters temporarily to reflect 4 minor ticks with a tick +# spacing of 2.0. +# +# (Note to the reader: don't feel discouraged if you don't understand this +# (stuff, it is so complicated I don't understand it either! Having to deal +# (with linear, log, and elog scaling with both major and minor ticks, +# (sometimes no minor ticks, with the axis starting at any part of the scale +# (seems an inherently difficult problem to program compactly. Barring +# (programming each case separately, the best approach I could come up with was +# (to walkthrough the code separately for each case, from all initial +# (conditions, until it works for all cases. If you have problems determine +# (the initial conditions (the case) and do a similar walkthough. Of course, +# (if you make a change affecting one case, you may well make the code fail for +# (a different case. + +int procedure glb_gettick (gp, ax, x, y, major_tick) + +pointer gp # graphics descriptor +pointer ax # axis descriptor +real x, y # coordinates of next tick (output) +int major_tick # YES if next tick is a major tick + +int i, axis, wcs, w, scaling, nminor, expon +real kstep, step, astep, ten, sx, sy, tolerance, pos, norm_pos +bool glb_eq() +define logscale_ 91 + +begin + if (AX_DRAWTICKS(ax) == NO) + return (EOF) + + tolerance = TOL + scaling = AX_SCALING(ax) + nminor = AX_NMINOR(ax) + kstep = AX_KSTEP(ax) + + if (AX_HORIZONTAL(ax) == YES) + axis = 1 + else + axis = 2 + + # Count down a minor tick. If nleft is negative then we are being + # called for the first time for this axis. + + if (AX_NLEFT(ax) < 0) { + + # Initialize everything and return coords of the first tick. + AX_KSTEP(ax) = AX_IKSTEP(ax) + AX_NLEFT(ax) = AX_INLEFT(ax) + do i = 1, 2 { + AX_POS(ax,i) = AX_TICK1(ax,i) + AX_STEP(ax,i) = AX_ISTEP(ax,i) + } + + step = AX_STEP(ax,axis) + astep = abs (step) + + if (AX_NLEFT(ax) == 0) { + # Note that there may not be any minor ticks. + major_tick = YES + AX_NLEFT(ax) = nminor + if (nminor > 0) + if (scaling == ELOG && (astep >= .99 && astep < 2.0)) { + # Elog scaling in linear region. + AX_NLEFT(ax) = 4 + if (step < 0) + step = -2.0 + else + step = 2.0 + AX_STEP(ax,axis) = step + } + } else { + AX_NLEFT(ax) = AX_NLEFT(ax) - 1 + major_tick = NO + } + + # Elog scaling in linear region. KSTEP must be inverted as we + # pass through the origin. This normally occurs upon entry to the + # linear region, but if we start out at +/- 10 we must set KSTEP + # to its linear value during setup. + + if (scaling == ELOG && glb_eq(step,2.0)) + AX_KSTEP(ax) = -10.0 + + } else { + # All ticks after the first tick. + do i = 1, 2 + AX_POS(ax,i) = AX_POS(ax,i) + AX_STEP(ax,i) + AX_NLEFT(ax) = AX_NLEFT(ax) - 1 + + # If we are log scaling the ticks will never have more than 2 + # digits of precision. Try to correct for the accumulation of + # error by rounding. When log scaling the error increases by + # a factor of ten in each decade and can get quite large if + # the log scale covers a large range. + + if (scaling != LINEAR) { + pos = AX_POS(ax,axis) + call fp_normr (pos, norm_pos, expon) + pos = nint (norm_pos * 10.0) / 10.0 + pos = pos * (10.0 ** expon) + AX_POS(ax,axis) = pos + } + + if (AX_NLEFT(ax) < 0) { + # Next tick is a major tick. If log scaling we must reset + # the tick parameters for the next decade. + + major_tick = YES + AX_NLEFT(ax) = nminor + + # The following handles the special case of ELOG scaling in + # the linear regime when the number of minor ticks is zero. + # The step size in such a case is 9 to some power in the log + # region and +/- 10 in the linear region. + + if (scaling == ELOG && nminor == 0) { + pos = AX_POS(ax,axis) + if (step < 0) + ten = -10. + else + ten = 10. + + if (glb_eq (pos, 10.0)) { + if (glb_eq (step, 10.0)) { + if (step < 0) + AX_STEP(ax,axis) = -9. + else + AX_STEP(ax,axis) = 9. + goto logscale_ + } else + step = ten + } else if (glb_eq (pos, 0.0)) { + step = ten + if (pos / step < 0) + AX_KSTEP(ax) = -0.1 + else + AX_KSTEP(ax) = -10.0 + } else + goto logscale_ + AX_STEP(ax,axis) = step + + } else if (scaling != LINEAR) { + # Adjust the tick step by the kstep factor, provided we + # are not at the origin in ELOG scaling (the step is 1 + # on either side of the origin for ELOG scaling). Reset + # the step size to 1.0 if ELOG scaling and just coming out + # of the linear regime. +logscale_ + step = AX_STEP(ax,axis) + if (scaling != ELOG || abs(AX_POS(ax,axis)) > 0.1) { + if (scaling == ELOG && glb_eq (step, 2.0)) + AX_STEP(ax,axis) = step / 2.0 + + do i = 1, 2 + AX_STEP(ax,i) = AX_STEP(ax,i) * abs (AX_KSTEP(ax)) + } + + # Adjust the step size to 2.0 if ELOG scaling and in the + # linear regime (initial step size of 1). + + step = AX_STEP(ax,axis) + if (scaling == ELOG && glb_eq(step,1.0)) { + if (step < 0) + step = -2.0 + else + step = 2.0 + AX_STEP(ax,axis) = step + } + + # If elog scaling and we have just entered the linear + # regime, adjust the number of ticks and the KSTEP factor. + + if (scaling == ELOG && glb_eq(step,2.0)) { + # Elog scaling in linear region. KSTEP must be + # inverted as we pass through the origin. + + if (abs(AX_POS(ax,axis)) > 0.1) + AX_KSTEP(ax) = -10.0 + + if (nminor > 0) + AX_NLEFT(ax) = 4 + } + } + } else + major_tick = NO + } + + x = AX_POS(ax,1) + y = AX_POS(ax,2) + + # Return EOF if tick falls beyond end of axis. The comparison is made + # in NDC coords to avoid having to check if the WCS is increasing or + # decreasing and to avoid the problems of comparing unnormalized + # floating point numbers. + + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + + call gctran (gp, x,y, sx,sy, wcs, 0) + if (sx - WCS_SX2(w) > tolerance || sy - WCS_SY2(w) > tolerance) + return (EOF) + else + return (OK) +end + + +# GLB_EQ -- Compare two (near normalized) floating point numbers for +# equality, using the absolute value of the first argument. + +bool procedure glb_eq (a, b) + +real a # compare absolute value of this number +real b # to this positive number + +begin + return (abs (abs(a) - b) < 0.1) +end diff --git a/sys/gio/glabax/glblabel.x b/sys/gio/glabax/glblabel.x new file mode 100644 index 00000000..ecf57c94 --- /dev/null +++ b/sys/gio/glabax/glblabel.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_LABEL_AXIS -- Label an axis. If both axes were drawn only the first is +# labelled, otherwise the label is placed on withever axis was drawn. This is +# done by drawing the axis labels just outside the tick mark labels, wherever +# those happened to be. The axis label offset is in the same direction as the +# tick label offset and is centered on each axis. The distance from the axis +# is a function of the size of the tick labels. + +procedure glb_label_axis (gp, ax, xlabel, ylabel) + +pointer gp # graphics descriptor +pointer ax # axis descriptor +char xlabel[ARB] # X axis label +char ylabel[ARB] # Y axis label + +int wcs +real x1, x2, y1, y2, x, y, dx, dy +real char_height, char_width +int strlen() +real ggetr() + +begin + wcs = GP_WCS(gp) + + # Get character height and width in NDC coords. + char_height = ggetr (gp, "ch") + char_width = ggetr (gp, "cw") + + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + + # Compute axis center in NDC coords. + call gctran (gp, AX_START(ax,1), AX_START(ax,2), x1,y1, wcs, 0) + call gctran (gp, AX_END(ax,1), AX_END(ax,2), x2,y2, wcs, 0) + x = (x1 + x2) / 2.0 + y = (y1 + y2) / 2.0 + + # Set relative text size and get device character size for a text + # size of 1.0. Set WCS to NDC coords since the offset to the + # tick label is in NDC coordinates. + + call gsetr (gp, G_TXSIZE, AX_AXISLABELSIZE(ax)) + call gseti (gp, G_WCS, 0) + + # Draw the axis label. + + if (AX_HORIZONTAL(ax) == YES) { + # Axis is horizontal. Tick label vector tells us whether to + # draw axis label above or below axis. + + if (strlen (xlabel) > 0) { + dy = 2.0 * AX_TICKLABELSIZE(ax) * char_height + + 0.5 * AX_AXISLABELSIZE(ax) * char_height + if (AX_TICKLABELOFFSET(ax,2) < 0) + dy = -dy + call gtext (gp, x, y + dy, xlabel, "hj=c;vj=c") + } + } else { + # Axis is vertical. Always put label fixed distance from axis + # regardless of size of tick labels (for consistency and to + # avoid clipping at the device screen boundary). Label runs + # bottom to top in a vertical field with char up pointing to + # the left. + + if (strlen (ylabel) > 0) { + dx = (Y_LABELOFFSET * char_width * AX_TICKLABELSIZE(ax)) + + 0.5 * AX_AXISLABELSIZE(ax) * char_height + + if (AX_TICKLABELOFFSET(ax,1) < 0) + dx = -dx + call gtext (gp, x + dx, y, ylabel, "up=180;hj=c;vj=c") + } + } + + call gseti (gp, G_WCS, wcs) +end diff --git a/sys/gio/glabax/glbloglab.x b/sys/gio/glabax/glbloglab.x new file mode 100644 index 00000000..6e7ec1cc --- /dev/null +++ b/sys/gio/glabax/glbloglab.x @@ -0,0 +1,139 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +define SZ_MANTISSA 3 # "10" or "-10" +define SZ_EXPONENT 4 # largest is "-999" + + +# GLB_LOGLAB -- Draw a tick label in log units at the given position. +# A log tick is a power of ten, e.g. 10^2, where the ^ signifies that +# the 2 is to be drawn one half character height higher than the 10. + +procedure glb_loglab (gp, sx, sy, val, fmt, scaling) + +pointer gp # graphics descriptor +real sx, sy # NDC coords of label +real val # value to be encoded (not the log of) +char fmt[ARB] # tick label gtext format (justification) +int scaling # type of scaling on axis + +bool zero +char mantissa[SZ_MANTISSA] +char exponent[SZ_EXPONENT] +int len_mantissa, len_exponent, ip, hj, vj +real logval, char_height, char_width, left, xpos, ypos, txsize + +bool fp_equalr() +real elogr(), gstatr(), ggetr() +int strlen(), strmatch(), itoc() + +begin + # Compute the log value to be encoded. + if (scaling == LOG) + logval = log10 (val) + else { + logval = elogr (val) + zero = fp_equalr (logval, 0.0) + } + + txsize = gstatr (gp, G_TXSIZE) + + # Get char height and width in NDC coords. + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + char_height = char_height * txsize + + char_width = ggetr (gp, "cw") + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + char_width = char_width * txsize + + # Encode the mantissa and exponent strings. + if (zero) { + call strcpy ("0", mantissa, SZ_MANTISSA) + } else if (logval < 0 && scaling == ELOG) { + call strcpy ("-10", mantissa, SZ_MANTISSA) + logval = abs (logval) + } else + call strcpy ("10", mantissa, SZ_MANTISSA) + + len_mantissa = strlen (mantissa) + if (zero) + len_exponent = 0 + else + len_exponent = itoc (nint(logval), exponent, SZ_EXPONENT) + + # Determine type of horizontal justification required. + ip = strmatch (fmt, "hj=") + if (ip <= 0) + hj = 'c' + else + hj = fmt[ip] + + # Determine type of vertical justification required. + ip = strmatch (fmt, "vj=") + if (ip <= 0) + vj = 'c' + else + vj = fmt[ip] + + # On devices with adjustable character sizes the most pleasing results + # are obtained if the digits "10" are nicely aligned on the vertical + # axis, regardless of the actual number of characters in the exponent + # string, minus signs etc (this type of alignment is more natural + # because the exponent is printed at half size). Hence if we are on + # a vertical axis (hj != c) fix the number of characters in the two + # strings so that the alignment comes out the same regardless of the + # actual number of chars in either field. The length of the exponent + # field is not completely fixed, rather we allow a little more space + # if the exponent is large. For small exponents len_exponent=1. + + if (hj != 'c') { + len_mantissa = 2 + len_exponent = (len_exponent + 1) / 2 + } + + # Compute XPOS, the NDC X coord of the point halfway between the + # last char of the mantissa and the first char of the exponent. + + switch (hj) { + case 'l': + left = sx + case 'r': + left = sx - (len_mantissa + len_exponent) * char_width + default: + left = sx - ((len_mantissa + len_exponent) * char_width) / 2.0 + } + + xpos = left + len_mantissa * char_width + + # Compute YPOS, the NDC Y coord of the center of a mantissa character + # and of the bottom of an exponent character. Using the same coordinate + # to address both positions makes the label come out the same regardless + # of the plot magnification, even on a device where the character size + # is fixed by the hardware. + + switch (vj) { + case 'b': + ypos = sy + char_height / 2.0 + case 't': + ypos = sy - char_height / 2.0 + default: + ypos = sy + } + + # Draw the mantissa. + call gtext (gp, xpos, ypos, mantissa, "hj=r,vj=c") + + # Draw the exponent if there is one. + if (!zero) { + call gsetr (gp, G_TXSIZE, txsize / 2.0) + call gtext (gp, xpos, ypos, exponent, "hj=l;vj=b") + call gsetr (gp, G_TXSIZE, txsize) + } +end diff --git a/sys/gio/glabax/glbsetax.x b/sys/gio/glabax/glbsetax.x new file mode 100644 index 00000000..f0c9aa29 --- /dev/null +++ b/sys/gio/glabax/glbsetax.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_SET_AXES -- Set all axis descriptor parameters not pertaining to the +# ticks. The WCS has already been fixed by the time we get here. + +procedure glb_set_axes (gp, ap, ax1, ax2, angle) + +pointer gp # graphics descriptor +pointer ap # axis parameters (from graphics descriptor) +pointer ax1, ax2 # axis descriptors (output) +int angle # axis orientation, 0 or 90 degrees + +pointer w +int axis +real p1, p2 +real x1, x2, y1, y2 +real glb_ticklen() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # If the window was rounded in Y in the second call to find_ticks, + # then the Y positions of the first ticks set in the first call will + # be in error and must be corrected. If the user has elected to set + # the axis position explicitly, however, then we must leave it alone. + + if (angle == 0 && GL_SETAXISPOS(GP_XAP(gp)) == NO) { + AX_TICK1(ax1,2) = WCS_WY1(w) + AX_TICK1(ax2,2) = WCS_WY2(w) + } + + # Set the tick lengths. This is done here rather than in findticks + # due to rounding, as noted above. The tick offsets in world + # coordinates. The GL values are given in NDC coordinates. + + if (angle == 0) { + axis = 2 + AX_HORIZONTAL(ax1) = YES + AX_HORIZONTAL(ax2) = YES + } else { + axis = 1 + AX_HORIZONTAL(ax1) = NO + AX_HORIZONTAL(ax2) = NO + } + + AX_MAJORTICK(ax1,axis) = glb_ticklen (gp, ax1, GL_MAJORLENGTH(ap)) + AX_MINORTICK(ax1,axis) = glb_ticklen (gp, ax1, GL_MINORLENGTH(ap)) + AX_MAJORTICK(ax2,axis) = glb_ticklen (gp, ax2, -GL_MAJORLENGTH(ap)) + AX_MINORTICK(ax2,axis) = glb_ticklen (gp, ax2, -GL_MINORLENGTH(ap)) + + # Select none, either, or both axes to be drawn. If only the second + # axis is drawn then that is the side we must draw the tick and axis + # labels on. + + switch (GL_DRAWAXES(ap)) { + case 0: + AX_DRAWME(ax1) = NO + AX_DRAWME(ax2) = NO + return + case 1: + AX_DRAWME(ax1) = YES + AX_DRAWME(ax2) = NO + case 2: + AX_DRAWME(ax1) = NO + AX_DRAWME(ax2) = YES + default: + AX_DRAWME(ax1) = YES + AX_DRAWME(ax2) = YES + } + + # Determine the endpoints of the axis. These default to the corners of + # the viewport (in world coordinates), but the positions may be + # overriden by the user if desired. + + # First get the positions of the two axes. + if (GL_SETAXISPOS(ap) == YES) { + p1 = GL_AXISPOS1(ap) + p2 = GL_AXISPOS2(ap) + } else if (angle == 0) { + p1 = WCS_WY1(w) + p2 = WCS_WY2(w) + } else { + p1 = WCS_WX1(w) + p2 = WCS_WX2(w) + } + + # Convert these positions into the world coordinates of the endpoints. + if (angle == 0) { + x1 = WCS_WX1(w) + x2 = WCS_WX2(w) + y1 = p1 + y2 = p2 + } else { + x1 = p1 + x2 = p2 + y1 = WCS_WY1(w) + y2 = WCS_WY2(w) + } + + if (angle == 0) { + # Set the left and right endpoints of the axes. + + AX_START(ax1,1) = x1 + AX_START(ax1,2) = y1 + AX_END(ax1,1) = x2 + AX_END(ax1,2) = y1 + + AX_START(ax2,1) = x1 + AX_START(ax2,2) = y2 + AX_END(ax2,1) = x2 + AX_END(ax2,2) = y2 + + } else { + # Set the lower and upper endpoints of the axes. + + AX_START(ax1,1) = x1 + AX_START(ax1,2) = y1 + AX_END(ax1,1) = x1 + AX_END(ax1,2) = y2 + + AX_START(ax2,1) = x2 + AX_START(ax2,2) = y1 + AX_END(ax2,1) = x2 + AX_END(ax2,2) = y2 + } +end diff --git a/sys/gio/glabax/glbsetup.x b/sys/gio/glabax/glbsetup.x new file mode 100644 index 00000000..a609d2ad --- /dev/null +++ b/sys/gio/glabax/glbsetup.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GLB_SETUP -- Set up the axis drawing and labelling parameters. These are +# the coordinate transformations, i.e., log scaling, window and viewport +# coordinates, plus the parameters which pertain only to axis drawing and +# labelling. The order in which the subprocedures are called is significant. + +procedure glb_setup (gp, axes, ntitlelines, xlabel, ylabel) + +pointer gp # graphics descriptor +pointer axes[4] # array of pointers to axis descriptors +int ntitlelines # number of lines in title block +char xlabel[ARB] # x axis label +char ylabel[ARB] # y axis label + +pointer w +bool fp_nondegenr() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Verify that there is sufficient range in the wcs X and Y. + if (fp_nondegenr (WCS_WX1(w), WCS_WX2(w))) + GP_WCSSTATE(gp) = MODIFIED + if (fp_nondegenr (WCS_WY1(w), WCS_WY2(w))) + GP_WCSSTATE(gp) = MODIFIED + + # If log scaling is in effect on either axis, verify that log scaling + # is sensible and if so select either LOG or ELOG scaling. + + call glb_verify_log_scaling (gp) + + # Set the viewport if not already set. + call glb_set_viewport (gp, ntitlelines, xlabel, ylabel) + + # Find the best positions for the tick marks, and if rounding is + # enabled, extend the WCS outward to the next tick mark on either + # end. + + call glb_find_ticks (gp, GP_XAP(gp), axes[1], axes[4], 0) + call glb_find_ticks (gp, GP_YAP(gp), axes[3], axes[2], 90) + + # Set the remaining parameters in the axis drawing descriptors. + # Must not be called until the window and viewport coordinates are + # fixed. + + call glb_set_axes (gp, GP_XAP(gp), axes[1], axes[4], 0) + call glb_set_axes (gp, GP_YAP(gp), axes[3], axes[2], 90) +end diff --git a/sys/gio/glabax/glbsview.x b/sys/gio/glabax/glbsview.x new file mode 100644 index 00000000..1b099b1a --- /dev/null +++ b/sys/gio/glabax/glbsview.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_SET_VIEWPORT -- If the viewport has not yet been set, i.e., if the +# viewport is still [0:1,0:1], compute the size of the largest viewport which +# leaves sufficient room around the border for the axis labels and plot title. +# If a nonzero aspect ratio is specified make the viewport have that aspect +# ratio. + +procedure glb_set_viewport (gp, ntitlelines, xlabel, ylabel) + +pointer gp # graphics descriptor +int ntitlelines # number of lines to reserve for title block +char xlabel[ARB] # x axis label +char ylabel[ARB] # y axis label + +pointer w, xap, yap +bool draw_title, draw_xlabel, draw_ylabel, draw_xticks, draw_yticks +real char_height, char_width +real aspect, cur_aspect, dev_aspect, dx, dy +real xwidth, ywidth, yreserve +real ggetr() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + xap = GP_XAP(gp) + yap = GP_YAP(gp) + + if ((WCS_SX1(w) > EPSILON) || (abs(1.0 - WCS_SX2(w)) > EPSILON) || + (WCS_SY1(w) > EPSILON) || (abs(1.0 - WCS_SY2(w)) > EPSILON)) + return + + draw_title = (ntitlelines > 0 && GP_DRAWTITLE(gp) == YES) + draw_xticks = (GL_DRAWAXES(xap) > 0 && GL_LABELTICKS(xap) == YES) + draw_xlabel = + (draw_xticks && xlabel[1] != EOS && GL_LABELAXIS(xap) == YES) + draw_yticks = (GL_DRAWAXES(yap) > 0 && GL_LABELTICKS(yap) == YES) + draw_ylabel = + (draw_yticks && ylabel[1] != EOS && GL_LABELAXIS(yap) == YES) + + char_width = ggetr (gp, "cw") + char_height = ggetr (gp, "ch") + + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + + # X axis. + if (draw_yticks && draw_ylabel) + xwidth = max (4, LEFT_BORDER + 2) + else if (draw_yticks) + xwidth = max (4, LEFT_BORDER) + else + xwidth = 0 + xwidth = xwidth * char_width * GL_TICKLABELSIZE(xap) + + # Y axis. + if (draw_xticks && draw_xlabel) + ywidth = BOTTOM_BORDER + else if (draw_xticks) + ywidth = max (2, (BOTTOM_BORDER - 2)) + else + ywidth = 0 + ywidth = ywidth * char_height * GL_TICKLABELSIZE(yap) + + # Compute amount of extra space to allow for the title block, which + # may contain more than one line. + + if (!draw_title && !draw_xticks && !draw_yticks) + yreserve = 0 + else if (!draw_title && GP_ASPECT(gp) > 0.9) + yreserve = 0 + else { + yreserve = min (MAX_SZTITLEBLOCK, + max (MIN_NTITLELINES, ntitlelines + 1) * + char_height * GP_TITLESIZE(gp)) + } + + # Set the viewport. The viewport is the largest area yielding the + # desired borders. The viewport is centered in X and positioned just + # below the title block in Y. + + WCS_SX1(w) = xwidth + WCS_SX2(w) = 1.0 - xwidth + WCS_SY1(w) = ywidth + WCS_SY2(w) = 1.0 - yreserve + + # Adjust the viewport to achieve the specified aspect ratio, if a + # nonzero aspect ratio was given. + + dev_aspect = GP_DEVASPECT(gp) # device aspect ratio + aspect = GP_ASPECT(gp) # user desired aspect ratio + + if (aspect > EPSILON) { + dx = WCS_SX2(w) - WCS_SX1(w) + dy = WCS_SY2(w) - WCS_SY1(w) + cur_aspect = dy / dx * dev_aspect + + if (cur_aspect > aspect) { + # Viewport is taller than desired. + dy = aspect / dev_aspect * dx + WCS_SY1(w) = (1.0 - dy) / 2.0 + WCS_SY2(w) = 1.0 - WCS_SY1(w) + } else { + # Viewport is not as wide as desired. + dx = dev_aspect * dy / aspect + WCS_SX1(w) = (1.0 - dx) / 2.0 + WCS_SX2(w) = 1.0 - WCS_SX1(w) + } + } + + GP_WCSSTATE(gp) = MODIFIED +end diff --git a/sys/gio/glabax/glbticlen.x b/sys/gio/glabax/glbticlen.x new file mode 100644 index 00000000..de557757 --- /dev/null +++ b/sys/gio/glabax/glbticlen.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_TICKLEN -- Compute the length of a tick in world coordinates. All tick +# drawing is performed in world coordinates since the ticks show the world +# coordinate system. The position of a tick must be computed in world coords +# when the axis is drawn to reflect log scaling (or any other nonlinear +# scaling. Less obviously, the tick offset should be given in world coords +# so that when the tick is drawn by a GRDRAW the tick will follow a line of +# constant X or Y in world coordinates, and this line will not necessarily be +# a line of constant X or Y in NDC coordinates. + +real procedure glb_ticklen (gp, ax, ndc_length) + +pointer gp # graphics descriptor +pointer ax # axis descriptor +real ndc_length # length of tick in NDC units + +int wcs +real x, y, wx, wy + +begin + wcs = GP_WCS(gp) + call gctran (gp, AX_TICK1(ax,1), AX_TICK1(ax,2), x, y, wcs, 0) + + if (AX_HORIZONTAL(ax) == YES) + y = y + ndc_length + else + x = x + ndc_length + + call gctran (gp, x, y, wx, wy, 0, wcs) + if (AX_HORIZONTAL(ax) == YES) { + call pargr (wy - AX_TICK1(ax,2)) + return (wy - AX_TICK1(ax,2)) + } else { + call pargr (wx - AX_TICK1(ax,1)) + return (wx - AX_TICK1(ax,1)) + } +end diff --git a/sys/gio/glabax/glbtitle.x b/sys/gio/glabax/glbtitle.x new file mode 100644 index 00000000..d8c43c67 --- /dev/null +++ b/sys/gio/glabax/glbtitle.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_PLOT_TITLE -- Draw plot title block. The block may contain several lines. +# Lines are plotted with center, left, or right justification, immediately +# above the top viewport boundary (not immediately above the drawn axis, +# which need not be at the viewport boundary). + +procedure glb_plot_title (gp, title, ntitlelines) + +pointer gp # graphics descriptor +char title[ARB] # title block +int ntitlelines # number of lines in title block + +int lineno, ip, wcs +real char_height, x, y, dy +pointer sp, op, lbuf, format, w +real ggetr() + +begin + if (title[1] == EOS || ntitlelines < 1) + return + + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (format, SZ_FORMAT, TY_CHAR) + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT * GP_TITLESIZE(gp) + + wcs = GP_WCS(gp) + w = GP_WCSPTR (gp, wcs) + y = min (1.0 - char_height, + WCS_SY2(w) + (ntitlelines - 1 + 0.5) * char_height) + + call sprintf (Memc[format], SZ_FORMAT, "hj=%c,vj=b") + switch (GP_TITLEJUST(gp)) { + case GT_LEFT: + call pargi ('l') + x = WCS_SX1(w) + case GT_RIGHT: + call pargi ('r') + x = WCS_SX2(w) + default: + call pargi ('c') + x = (WCS_SX1(w) + WCS_SX2(w)) / 2.0 + } + + call gsetr (gp, G_TXSIZE, GP_TITLESIZE(gp)) + call gseti (gp, G_WCS, 0) + lineno = 1 + op = lbuf + + for (ip=1; title[ip] != EOS; ip=ip+1) + if (title[ip] == '\n' || (title[ip+1] == EOS && op > lbuf)) { + if (title[ip] != '\n') { + Memc[op] = title[ip] + op = op + 1 + } + Memc[op] = EOS + dy = (lineno - 1) * char_height + call gtext (gp, x, y - dy, Memc[lbuf], Memc[format]) + lineno = lineno + 1 + op = lbuf + } else { + Memc[op] = title[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/gio/glabax/glbverify.x b/sys/gio/glabax/glbverify.x new file mode 100644 index 00000000..6666b06a --- /dev/null +++ b/sys/gio/glabax/glbverify.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_VERIFY_LOG_SCALING -- Verify that log scaling makes sense, i.e., that +# the range covered by an axis compared to its distance from the origin is +# large enough to permit log scaling. If log scaling is reasonable check if +# the window goes negative, and switch to ELOG scaling if such is the case. + +procedure glb_verify_log_scaling (gp) + +pointer gp # graphics descriptor +pointer w + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Force ELOG scaling if any data <= 0. + + if (WCS_XTRAN(w) != LINEAR) + if (WCS_WX1(w) <= 0 || WCS_WX2(w) <= 0) + WCS_XTRAN(w) = ELOG + + if (WCS_YTRAN(w) != LINEAR) + if (WCS_WY1(w) <= 0 || WCS_WY2(w) <= 0) + WCS_YTRAN(w) = ELOG + + # Set the WCS state to modified even if it wasn't. This is safe + # and in any case the WCS is changed in the main glabax routine + # shortly after we are called. + + GP_WCSSTATE(gp) = MODIFIED +end diff --git a/sys/gio/glabax/mkpkg b/sys/gio/glabax/mkpkg new file mode 100644 index 00000000..c8990e1a --- /dev/null +++ b/sys/gio/glabax/mkpkg @@ -0,0 +1,22 @@ +# Make the GLABAX axis drawing and labelling package. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + glabax.x glabax.h + glbencode.x glabax.h + glbfind.x glabax.h + glbgrid.x glabax.h + glbgtick.x glabax.h + glblabel.x glabax.h + glbloglab.x glabax.h + glbsetax.x glabax.h + glbsetup.x + glbsview.x glabax.h + glbticlen.x glabax.h + glbtitle.x glabax.h + glbverify.x glabax.h + ; diff --git a/sys/gio/gline.x b/sys/gio/gline.x new file mode 100644 index 00000000..ee346527 --- /dev/null +++ b/sys/gio/gline.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GLINE -- Draw a line connecting two points. + +procedure gline (gp, x1, y1, x2, y2) + +pointer gp # graphics descriptor +real x1, y1 # first point +real x2, y2 # second point + +begin + call gamove (gp, x1, y1) + call gadraw (gp, x2, y2) +end diff --git a/sys/gio/gmark.x b/sys/gio/gmark.x new file mode 100644 index 00000000..a9517b79 --- /dev/null +++ b/sys/gio/gmark.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GMARK -- Draw a marker of the indicated type and size. A mark is represented +# as a polyline normalized to the unit square. Drawing a mark is a simple +# matter of drawing this normalized polyline in a window the size and position +# of the mark. While the mark window defines the transformation upon the +# normalized marker polyline, clipping is performed on the WCS viewport boundary +# (if enabled), independently of the size and position of the mark. Redrawing +# a mark with a linetype of clear will erase the mark, device permitting. +# Drawing is carried out in world coordinates, hence the marker shape will +# relect logarithmic scaling if in effect. + +procedure gmark (gp, x, y, marktype, xsize, ysize) + +pointer gp # graphics descriptor +real x, y # world coordinates of center of marker +int marktype # type of marker to be drawn +real xsize, ysize # marker size in X and Y + +int i, m, fill +int and() +include "markers.inc" + +begin + # The point marker type cannot be combined with the other types and + # is treated as a special case. The remaining markers are drawn + # using GUMARK, which draws marks represented as polygons + + if (marktype == GM_POINT || (xsize == 0 && ysize == 0)) { + call gpl_settype (gp, POLYMARKER) + call gamove (gp, x, y) + call gadraw (gp, x, y) + call gpl_settype (gp, POLYLINE) + + } else { + # Some marks can be drawn using area fill. + if (and (marktype, GM_FILL) != 0) + fill = YES + else + fill = NO + + # Draw and overlay each mark. The polylines for the standard + # marks are stored in MPX and MPY at offsets MXO and MYO. + + do i = GM_FIRSTMARK, GM_LASTMARK + if (and (marktype, 2 ** i) != 0) { + m = i - GM_FIRSTMARK + 1 + call gumark (gp, mpx[moff[m]], mpy[moff[m]], mnpts[m], + x, y, xsize, ysize, fill) + } + } +end diff --git a/sys/gio/gmftitle.x b/sys/gio/gmftitle.x new file mode 100644 index 00000000..0e7d0322 --- /dev/null +++ b/sys/gio/gmftitle.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GMFTITLE -- Insert a title (comment) into the output metacode instruction +# stream. No graphics output is generated. The purpose of the metafile +# title is to document the contents of metafiles. + +procedure gmftitle (gp, mftitle) + +pointer gp # graphics descriptor +char mftitle[ARB] # metafile title + +begin + call gpl_flush() + call gki_mftitle (GP_FD(gp), mftitle) +end diff --git a/sys/gio/gmprintf.x b/sys/gio/gmprintf.x new file mode 100644 index 00000000..9353b483 --- /dev/null +++ b/sys/gio/gmprintf.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GMPRINTF -- Formatted write a string value to a UI (user interface) +# parameter. +# +# NOTE - I don't think this code works yet. Don't use it, use gmsg. + +procedure gmprintf (gp, object, format) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +char format[ARB] #I print format + +pointer sp, fmt + +begin + call smark (sp) + call salloc (fmt, SZ_LINE, TY_CHAR) + + call sprintf (Memc[fmt], SZ_LINE, "\031%s %s\035\037") + call pargstr (object) + call pargstr (format) + + call flush (STDOUT) + call printf (Memc[fmt]) + call sfree (sp) +end diff --git a/sys/gio/gmsg.x b/sys/gio/gmsg.x new file mode 100644 index 00000000..360996be --- /dev/null +++ b/sys/gio/gmsg.x @@ -0,0 +1,232 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GMSG -- Write a string value to a UI (user interface) parameter. Another +# way to look at this is that we are sending a message to a UI object, hence +# this is called a message facility. +# +# NOTE -- This routine quotes the string with curly braces { } and prefaces +# the string with a "setValue", as required to set the value of a GUI client +# state variable. This is done here rather than build knowledge into the +# lower level i/o system about the requirements for sending messages to UI +# parameters. The low level i/o system just sends arbitrary messages to +# named UI objects; setting the value of a UI parameter object is a higher +# level abstraction layered upon the general i/o mechanism. +# +# One limitation of the UI parameter mechanism as it currently stands is that +# if the message contains curly braces, they must match up to avoid having +# the message be prematurely delimited (fortunately curly braces tend to +# match up in any valid text that uses them). So far I haven't found a way +# around this. The problem is that while Tcl allows braces to be backslash +# escaped to avoid being treated as delimiters, the backslashes are not +# removed, they are left in the message as data. Hence they cannot be +# inserted in an arbitrary string without changing the string. +# +# Messages may be arbitrarily large and may extend over multiple lines. The +# only restriction is that if the messages contain curly braces they must +# match up. + +procedure gmsg (gp, object, message) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +char message[ARB] #I message text + +int flushnl, control_stream +int fstati() +bool ttygetb() + +begin + call gflush (gp) + call flush (STDOUT) + call flush (STDERR) + + control_stream = STDERR + + if (ttygetb (GP_TTY(gp), "EM")) { + flushnl = fstati (control_stream, F_FLUSHNL) + if (flushnl == YES) + call fseti (control_stream, F_FLUSHNL, NO) + + call putci (control_stream, EM) + call putline (control_stream, object) + call putci (control_stream, ' ') + call putline (control_stream, "setValue ") + + call putci (control_stream, '{') + call putline (control_stream, message) + call putci (control_stream, '}') + + call putci (control_stream, GS) + call putci (control_stream, US) + call flush (control_stream) + + if (flushnl == YES) + call fseti (control_stream, F_FLUSHNL, YES) + } +end + + +# GMSGB -- Set the value of a boolean UI parameter. + +procedure gmsgb (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +bool value #I value + +begin + if (value) + call gmsg (gp, object, "yes") + else + call gmsg (gp, object, "no") +end + + +# GMSGC -- Set the value of a character UI parameter. + +procedure gmsgc (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +char value #I value + +char buf[10] +int junk, ctocc() + +begin + junk = ctocc (value, buf, 10) + call gmsg (gp, object, buf) +end + + +# GMSGS -- Set the value of a short integer UI parameter. + +procedure gmsgs (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +short value #I value + +long val +char buf[32] +int junk, ltoc() + +begin + if (IS_INDEFS (value)) + call gmsg (gp, object, "INDEF") + else { + val = value + junk = ltoc (val, buf, 32) + call gmsg (gp, object, buf) + } +end + + +# GMSGI -- Set the value of an integer UI parameter. + +procedure gmsgi (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +int value #I value + +long val +char buf[32] +int junk, ltoc() + +begin + if (IS_INDEFI (value)) + call gmsg (gp, object, "INDEF") + else { + val = value + junk = ltoc (val, buf, 32) + call gmsg (gp, object, buf) + } +end + + +# GMSGL -- Set the value of a long integer UI parameter. + +procedure gmsgl (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +long value #I value + +char buf[32] +int junk, ltoc() + +begin + if (IS_INDEFL (value)) + call gmsg (gp, object, "INDEF") + else { + junk = ltoc (value, buf, 32) + call gmsg (gp, object, buf) + } +end + + +# GMSGR -- Set the value of a type real UI parameter. + +procedure gmsgr (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +real value #I value + +double dval +char buf[MAX_DIGITS] +int junk, dtoc() + +begin + if (IS_INDEFR (value)) + call gmsg (gp, object, "INDEF") + else { + dval = value + junk = dtoc (dval, buf, MAX_DIGITS, NDIGITS_RP, 'g', MAX_DIGITS) + call gmsg (gp, object, buf) + } +end + + +# GMSGD -- Set the value of a type double UI parameter. + +procedure gmsgd (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +double value #I value + +char buf[MAX_DIGITS] +int junk, dtoc() + +begin + if (IS_INDEFR (value)) + call gmsg (gp, object, "INDEF") + else { + junk = dtoc (value, buf, MAX_DIGITS, NDIGITS_DP, 'g', MAX_DIGITS) + call gmsg (gp, object, buf) + } +end + + +# GMSGX -- Set the value of a type complex UI parameter. + +procedure gmsgx (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +complex value #I value + +char buf[MAX_DIGITS] +int junk, xtoc() + +begin + junk = xtoc (value, buf, MAX_DIGITS, NDIGITS_RP, 'g', MAX_DIGITS/2) + call gmsg (gp, object, buf) +end diff --git a/sys/gio/gopen.x b/sys/gio/gopen.x new file mode 100644 index 00000000..7f973016 --- /dev/null +++ b/sys/gio/gopen.x @@ -0,0 +1,187 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# GOPENUI -- Open a graphics stream for output to the named device on file FD. +# If a logical device name is given the actual device name is fetched from the +# environment. If a UI file is specified the named user interface definition +# file is downloaded to the graphics server. The device parameters are then +# retrieved from the graphcap entry for the device. GIO is initialized, and +# if the device is being opened in APPEND mode, the WCS set when the device +# was last read are retrieved from the CL (if output is to a standard stream) +# or from the WCS savefile for the device. + +pointer procedure gopenui (device, mode, uifname, fd) + +char device[ARB] #I logical or physical device name +int mode #I access mode: NEW_FILE or APPEND +char uifname[ARB] #I user interface specification file +int fd #I metacode output file + +pointer gp, tty +int outfd, stream_type, junk +bool close_at_end, kf_ok, vdm_device, std_stream +pointer sp, devname, envname, kfname + +bool streq() +extern gflush() +pointer ttygdes() +int envgets(), envfind(), open(), locpr(), access(), ttygets() +errchk syserr, syserrs, ttygdes +errchk greset, gki_openws, calloc + +string stdgraph "stdgraph" +string stdimage "stdimage" +string stdplot "stdplot" +string vdm "vdm" +string stdvdm "stdvdm" + +begin + call smark (sp) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (envname, SZ_FNAME, TY_CHAR) + call salloc (kfname, SZ_FNAME, TY_CHAR) + + call flush (STDOUT) + + # If one of the logical devices STDGRAPH, STDIMAGE, or STDPLOT is + # named look up the actual device name in the environment. The + # standard metafile "device", STDVDM, is implemented as an actual + # device with an actual graphcap entry, so we do not have to map + # its name. + + if (streq (device, stdgraph) || streq (device, stdimage) || + streq (device, stdplot)) { + if (envgets (device, Memc[devname], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, device) + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + # The special name "none" indicates that graphics is not supported + # on this stream for the local site or workstation (e.g., when using + # a nongraphics terminal). + + if (streq (Memc[devname], "none")) + switch (fd) { + case STDGRAPH: + call syserr (SYS_GGNONE) + case STDIMAGE: + call syserr (SYS_GINONE) + case STDPLOT: + call syserr (SYS_GPNONE) + default: + call syserr (SYS_GPNONE) + } + + # Fetch the graphcap entry for the device. + tty = ttygdes (Memc[devname]) + + # If the output device is "stdvdm" or "vdm" and the FD supplied by the + # user is that of a standard stream, open the standard metafile and + # append output directly to that. The metafile is always opened in + # APPEND mode regardless of the mode in which the graphics device is + # opened. + + outfd = fd + close_at_end = false + call gki_redir (fd, -1, junk, stream_type) + std_stream = (fd == STDGRAPH || fd == STDIMAGE || fd == STDPLOT) + vdm_device = (streq(device,stdvdm) || streq(device,vdm)) + + if (vdm_device && std_stream) { + # Get filename of virtual device metafile. + call strcpy (stdvdm, Memc[devname], SZ_DEVNAME) + if (envfind (stdvdm, Memc[envname], SZ_FNAME) <= 0) + call strcpy ("uparm$vdm", Memc[envname], SZ_FNAME) + + # Open VDM for appending. + iferr (outfd = open (Memc[envname], APPEND, BINARY_FILE)) { + call ttycdes (tty) + call erract (EA_ERROR) + } + close_at_end = true + + } else if (std_stream && stream_type != TY_INLINE) { + # Verify that there is a GIO kernel specified for the device before + # trying to open it via PSIOCTRL, since the latter does not return + # an error status if it fails to connect a kernel, causing the error + # to go undetected until the CL fails to connect a kernel, which + # causes an error which cannot be caught in an IFERR in the current + # process. Catching the error here is faster and works with IFERR. + # No checking for a kernel is performed if the metacode output is + # being directed to a user opened stream. + + kf_ok = false + if (ttygets (tty, "kf", Memc[kfname], SZ_FNAME) > 0) + if (streq (Memc[kfname], "cl")) + kf_ok = true + else if (access (Memc[kfname], 0,0) == YES) + kf_ok = true + + if (!kf_ok) { + call ttycdes (tty) + call syserrs (SYS_GNOKF, Memc[devname]) + } + } + + # Allocate and initialize the GIO graphics descriptor. Initialize + # GKI (the graphics kernel interface) on the stream, if the stream + # has not already been directed to a kernel. + + call calloc (gp, LEN_GDES, TY_STRUCT) + + GP_FD(gp) = outfd + GP_TTY(gp) = tty + if (close_at_end) + GP_GFLAGS(gp) = GF_CLOSEFD + + # Set the access mode; default to NEW_FILE if not specified. + GP_ACMODE(gp) = mod (mode, AW_DEFER) + if (GP_ACMODE(gp) == 0) + GP_ACMODE(gp) = NEW_FILE + + call greset (gp, GR_RESETALL) + call gki_init (outfd) + call strcpy (Memc[devname], GP_DEVNAME(gp), SZ_DEVNAME) + call strcpy (uifname, GP_UIFNAME(gp), SZ_UIFNAME) + + # Set up info for GEXFLS, called by CLGCUR to flush the graphics + # output prior to a cursor read. + + call gexfls_set (outfd, gp, locpr(gflush)) + + # Activate (physically open) the workstation, unless the defer flag + # is set, eg., mode = NEW_FILE+AW_DEFER. + + if (mode < AW_DEFER) + iferr (call gactivate (gp, 0)) { + call ttycdes (tty) + call gexfls_clear (outfd) + call mfree (gp, TY_STRUCT) + call erract (EA_ERROR) + } + + call sfree (sp) + return (gp) +end + + +# GOPEN -- Open a graphics stream for output to the named device on file FD. +# Identical to GOPENUI except that the default UI is used. + +pointer procedure gopen (device, mode, fd) + +char device[ARB] #I logical or physical device name +int mode #I access mode: NEW_FILE or APPEND +int fd #I metacode output file + +pointer gopenui() + +begin + return (gopenui (device, mode, "", fd)) +end diff --git a/sys/gio/gpagefile.x b/sys/gio/gpagefile.x new file mode 100644 index 00000000..df950e71 --- /dev/null +++ b/sys/gio/gpagefile.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GPAGEFILE -- File pager which works in or out of cursor mode. If in graphics +# mode, the workstation is deactivated, the file paged, and graphics mode later +# restored. + +procedure gpagefile (gp, fname, prompt) + +pointer gp # graphics descriptor +char fname[ARB] # name of file to be paged +char prompt[ARB] # user prompt string + +bool wsactive +int and() + +begin + wsactive = (and (GP_GFLAGS(gp), GF_WSACTIVE) != 0) + + if (wsactive) + call gdeactivate (gp, 0) + iferr (call pagefile (fname, prompt)) + call erract (EA_WARN) + if (wsactive) + call greactivate (gp, AW_PAUSE) +end diff --git a/sys/gio/gpcell.x b/sys/gio/gpcell.x new file mode 100644 index 00000000..17588647 --- /dev/null +++ b/sys/gio/gpcell.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPCELL -- Put a cell array. Display a two dimensional array of pixels in the +# given window, scaling as necessary to fit the window. For maximum efficiency +# no clipping is performed. Only linear coordinate transformations are +# permitted. The cell array is defined by (x1,y1) and (x2,y2), the NDC coords +# of the corners of the display area. The graphics kernel is expected to +# map cell array pixels into device pixels by mapping the coordinates of a +# device pixel into the cell array and assigning the value of the nearest +# cell array pixel to the device pixel. In other words, the cell array is +# sampled or block replicated as necessary to fit the device window. The kernel +# is not expected to perform area integration or filtering (interpolation) +# to map cell array pixels into device pixels. In the limiting case M may +# contain a single pixel which will be replicated to fill the specified window, +# e.g., nx=ny=1, (x1,y1)=(0,0), and (x2,y2)=(1,1). +# +# +--+--+--+--Q (x2,y2) +# 4 | | | | | +# +--+--+--+--+ +# 3 | | | | | Sample Cell Array +# Y +--+--+--+--+ nx = ny = 4 +# 2 | | | | | +# +--+--+--+--+ +# 1 | | | | | +# (x1,y1) P--+--+--+--+ +# +# 1 2 3 4 X +# +# A sample 4 by 4 cell array is shown above. The coordinates of the device +# window into which the cell array is to be mapped refer to the corners P and +# Q of the first and last pixels in the cell array. + +procedure gpcell (gp, m, nx, ny, x1, y1, x2, y2) + +pointer gp # device descriptor +short m[nx,ny] # pixels +int nx, ny # size of pixel array +real x1, y1 # lower left corner of output window +real x2, y2 # upper right corner of output window + +real dy +int ly1, ly2, i +int sx1, sx2, sy1, sy2 +include "gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Transform cell window to GKI coordinates. The coordinate + # transformation must be linear. + + sx1 = (x1 - wxorigin) * xscale + mxorigin + sx2 = (x2 - wxorigin) * xscale + mxorigin + sy1 = (y1 - wyorigin) * yscale + myorigin + sy2 = (y2 - wyorigin) * yscale + myorigin + + dy = real (sy2 - sy1) / ny # height of a line in GKI coords + + # Write out the cell array, one line at a time. Take care that the + # GKI integer value of ly1 of one line is the same as the ly2 value + # of the previous line, or there will be a blank line in the output + # image. + + do i = 1, ny { + ly1 = (i-1) * dy + sy1 + ly2 = (i ) * dy + sy1 + call gki_putcellarray (GP_FD(gp), m[1,i], nx,1, sx1,ly1, sx2,ly2) + } +end diff --git a/sys/gio/gpl.com b/sys/gio/gpl.com new file mode 100644 index 00000000..76d0d5c7 --- /dev/null +++ b/sys/gio/gpl.com @@ -0,0 +1,20 @@ +# GPL.COM -- Polyline generator common. + +bool last_point_inbounds # last point was inbounds +int xtran, ytran # scaling function for X, Y axes (linear,log,,) +int op # index of next cell in polyline array +int pl_type # type of instruction (polyline, polymarker,...) +int pl_pointmode # plotting points (polymarker), not vectors +int wcs # WCS for which cache is valid +long mxorigin, myorigin # origin in world coordinates for transform +real wxorigin, wyorigin # origin in world coordinates for transform +real xscale, yscale # scale factor, world to GKI, for transform +real cx, cy # current pen position, world coords +long mx1, mx2, my1, my2 # clipping viewport, GKI coords +long xs[4], ys[4] # last point plotted (for clipping code) +pointer gp_out # device which owns current polyline +short pl[LEN_PLBUF] # output polyline buffer + +common /gplcom/ last_point_inbounds, xtran, ytran, op, pl_type, pl_pointmode, + mxorigin, myorigin, wxorigin, wyorigin, xscale, yscale, cx, cy, + mx1, mx2, my1, my2, xs, ys, gp_out, wcs, pl diff --git a/sys/gio/gplcache.x b/sys/gio/gplcache.x new file mode 100644 index 00000000..88201365 --- /dev/null +++ b/sys/gio/gplcache.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPL_CACHE -- Cache the transformation parameters for a device in the GADRAW +# common. Must be called whenever the current WCS changes. We need only +# check that the WCS has not changed because anything more serious than a +# change current WCS call will cause the cache to be invalidated. + +procedure gpl_cache (gp) + +pointer gp # graphics descriptor +pointer w +real wx1, wx2, wy1, wy2 +bool fp_nondegenr() +real elogr() + +int wcsord +data wcsord /0/ +include "gpl.com" + +begin + gp_out = gp + wcs = GP_WCS(gp) + w = GP_WCSPTR (gp, wcs) + + # The WCS must be fixed to the output device (kernel) when used for + # coordinate transformations in metacode output. + + if (GP_WCSSTATE(gp) != FIXED) { + call gactivate (gp, 0) + call gpl_flush() + call gki_setwcs (GP_FD(gp), Memi[GP_WCSPTR(gp,1)], + LEN_WCS * MAX_WCS) + GP_WCSSTATE(gp) = FIXED + wcsord = wcsord + 1 + GP_WCSORD(gp) = wcsord + } + + mx1 = WCS_SX1(w) * GKI_MAXNDC + mx2 = WCS_SX2(w) * GKI_MAXNDC + my1 = WCS_SY1(w) * GKI_MAXNDC + my2 = WCS_SY2(w) * GKI_MAXNDC + + # Compute world -> GKI coordinate transformation. If log scaling is + # indicated but one or both window coords are negative, use ELOG + # scaling instead. + + mxorigin = mx1 + xtran = WCS_XTRAN(w) + + wx1 = WCS_WX1(w) + wx2 = WCS_WX2(w) + + # Ensure that the window is nondegenerate. + if (fp_nondegenr (wx1, wx2)) + ; + + if (xtran == LINEAR) { + wxorigin = wx1 + xscale = (mx2 - mx1) / (wx2 - wx1) + } else if (xtran == LOG && wx1 > 0 && wx2 > 0) { + wxorigin = log10 (wx1) + xscale = (mx2 - mx1) / (log10(wx2) - wxorigin) + } else { + wxorigin = elogr (wx1) + xscale = (mx2 - mx1) / (elogr(wx2) - wxorigin) + } + + myorigin = my1 + ytran = WCS_YTRAN(w) + + wy1 = WCS_WY1(w) + wy2 = WCS_WY2(w) + + # Ensure that the window is nondegenerate. + if (fp_nondegenr (wy1, wy2)) + ; + + if (ytran == LINEAR) { + wyorigin = wy1 + yscale = (my2 - my1) / (wy2 - wy1) + } else if (ytran == LOG && wy1 > 0 && wy2 > 0) { + wyorigin = log10 (wy1) + yscale = (my2 - my1) / (log10(wy2) - wyorigin) + } else { + wyorigin = elogr (wy1) + yscale = (my2 - my1) / (elogr(wy2) - wyorigin) + } + + # If clipping is disabled move the clipping viewport out to the + # boundary of the device. + + if (and (WCS_FLAGS(w), WF_CLIP) == 0) { + mx1 = 0 + mx2 = GKI_MAXNDC + my1 = 0 + my2 = GKI_MAXNDC + } +end diff --git a/sys/gio/gplcancel.x b/sys/gio/gplcancel.x new file mode 100644 index 00000000..416bd787 --- /dev/null +++ b/sys/gio/gplcancel.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPL_CANCEL -- Cancel any buffered polyline output. + +procedure gpl_cancel() + +include "gpl.com" + +begin + op = 1 +end diff --git a/sys/gio/gplflush.x b/sys/gio/gplflush.x new file mode 100644 index 00000000..403adc9c --- /dev/null +++ b/sys/gio/gplflush.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPL_FLUSH -- Flush the buffered "polyline", i.e., array of transformed and +# clipped points. For a polyline or fill area polygon there must be at least +# two points (4 cells) or it will be discarded. A single point polymarker is +# permitted. + +procedure gpl_flush() + +int fd +pointer ap +include "gpl.com" + +begin + if (op > 2 && gp_out != NULL) { + fd = GP_FD(gp_out) + + switch (pl_type) { + case POLYMARKER: + ap = GP_PMAP(gp_out) + if (PM_STATE(ap) != FIXED) { + call gki_pmset (fd, ap) + PM_STATE(ap) = FIXED + } + call gki_polymarker (fd, pl, op / 2) + + case FILLAREA: + ap = GP_FAAP(gp_out) + if (FA_STATE(ap) != FIXED) { + call gki_faset (fd, ap) + FA_STATE(ap) = FIXED + } + if (op > 4) + call gki_fillarea (fd, pl, op / 2) + + default: # (case POLYLINE) + ap = GP_PLAP(gp_out) + if (PL_STATE(ap) != FIXED) { + call gki_plset (fd, ap) + PL_STATE(ap) = FIXED + } + if (op > 4) + call gki_polyline (fd, pl, op / 2) + } + + op = 1 + } +end diff --git a/sys/gio/gpline.x b/sys/gio/gpline.x new file mode 100644 index 00000000..ed0e8439 --- /dev/null +++ b/sys/gio/gpline.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GPLINE -- Polyline. Draw a line connecting the points (X[i],Y[i]), i.e., +# move to the first point and draw a straight line from there to the second +# point, from the second to the third, and so on. + +procedure gpline (gp, x, y, npts) + +pointer gp # graphics descriptor +real x[ARB], y[ARB] # points defining the polyline +int npts +int i + +begin + call gamove (gp, x[1], y[1]) + do i = 2, npts + call gadraw (gp, x[i], y[i]) +end diff --git a/sys/gio/gploto.x b/sys/gio/gploto.x new file mode 100644 index 00000000..a76de4fd --- /dev/null +++ b/sys/gio/gploto.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GPLOTV -- Plot a vector on an open graphics device. This routine is +# provided for the convenience of the user who does not need to exercise +# fine control over the details of how the plot is generated, but who may +# wish to select an output device other than stdgraph or who may wish to +# leave the device open for annotation. + +procedure gploto (gp, v, npts, x1, x2, title) + +pointer gp # graphics descriptor +real v[ARB] # data vector +int npts # number of data points +real x1, x2 # range of X in data vector +char title[ARB] # plot title +errchk gswind, gascale, glabax + +begin + call gswind (gp, x1, x2, INDEF, INDEF) + call gascale (gp, v, npts, 2) + call glabax (gp, title, "", "") + call gvline (gp, v, npts, x1, x2) +end diff --git a/sys/gio/gplotv.x b/sys/gio/gplotv.x new file mode 100644 index 00000000..1d9239e5 --- /dev/null +++ b/sys/gio/gplotv.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GPLOTV -- Plot a vector. This routine is provided for the convenience of +# the user who does not need to exercise fine control over the details of +# how the plot is generated. + +procedure gplotv (v, npts, x1, x2, title) + +real v[ARB] # data vector +int npts # number of data points +real x1, x2 # range of X in data vector +char title[ARB] # plot title + +pointer gp +pointer gopen() +errchk gopen, gploto + +begin + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + call gploto (gp, v, npts, x1, x2, title) + call gclose (gp) +end diff --git a/sys/gio/gplreset.x b/sys/gio/gplreset.x new file mode 100644 index 00000000..888fd99e --- /dev/null +++ b/sys/gio/gplreset.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPL_RESET -- Reset the state of the GPL common, forcing a call to +# re-initialize the cache in the next GADRAW call. Should be called at +# GOPEN time and thereafter whenever the a WCS is modified or an polyline, +# polymarker, etc. attribute is set. + +procedure gpl_reset() + +bool first_time +include "gpl.com" +data first_time /true/ + +begin + if (first_time) { + op = 1 + first_time = false + } else + call gpl_flush() + + wcs = -1 + gp_out = NULL + pl_type = POLYLINE + last_point_inbounds = false +end diff --git a/sys/gio/gplstype.x b/sys/gio/gplstype.x new file mode 100644 index 00000000..68056abd --- /dev/null +++ b/sys/gio/gplstype.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPL_SETTYPE -- Set type (polyline, polymarker, fillarea) of point array PL. +# Determines instruction type generated when PL is flushed. + +procedure gpl_settype (gp, type) + +pointer gp # graphics descriptor +int type # type of instruction +include "gpl.com" + +begin + if (op > 1 && pl_type != type) + call gpl_flush() + + if (type == POINTMODE) { + pl_type = POLYMARKER + pl_pointmode = YES + } else { + pl_type = type + pl_pointmode = NO + } +end diff --git a/sys/gio/gpmark.x b/sys/gio/gpmark.x new file mode 100644 index 00000000..dbe0b362 --- /dev/null +++ b/sys/gio/gpmark.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPMARK -- Polymarker. Output at sequence of markers at the vertices of a +# polygon, all markers the same type and size. The marker type GM_POINT is +# a special case. + +procedure gpmark (gp, x, y, npts, marktype, xsize, ysize) + +pointer gp # graphics descriptor +real x[ARB], y[ARB] # vertices of polygon +int npts # number of points +int marktype # marker type +real xsize, ysize # marker size +int i + +begin + if (marktype == GM_POINT) { + call gpl_settype (gp, POINTMODE) + call gpline (gp, x, y, npts) + call gpl_settype (gp, POLYLINE) + } else { + do i = 1, npts + call gmark (gp, x[i], y[i], marktype, xsize, ysize) + } +end diff --git a/sys/gio/gqverify.x b/sys/gio/gqverify.x new file mode 100644 index 00000000..7f081f3b --- /dev/null +++ b/sys/gio/gqverify.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define QUERY "Type `q' to verify quit, `return' to return to cursor loop:" + +# GQVERIFY -- Print a message in the status line asking the user if they really +# want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure gqverify() + +int ch +int getci() + +begin + call printf (QUERY) + call flush (STDOUT) + + call fseti (STDIN, F_RAW, YES) + while (getci (STDIN, ch) != EOF) + if (ch == 'q' || ch == '\r' || ch == '\n') + break + + call printf ("\n\n") + call flush (STDOUT) + call fseti (STDIN, F_RAW, NO) + + if (ch == 'q') + return (YES) + else + return (NO) +end diff --git a/sys/gio/grdraw.x b/sys/gio/grdraw.x new file mode 100644 index 00000000..7cd44a74 --- /dev/null +++ b/sys/gio/grdraw.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GRDRAW -- Relative draw, i.e., move the pen to the specified offset from the +# current position. + +procedure grdraw (gp, x, y) + +pointer gp # graphics descriptor +real x, y # offset from current position +real cx, cy + +begin + if (IS_INDEF(x) || IS_INDEF(y)) + call gadraw (gp, x, y) + else { + call gcurpos (gp, cx, cy) + if (IS_INDEF(cx) || IS_INDEF(cy)) + call gadraw (gp, INDEF, INDEF) + else + call gadraw (gp, cx + x, cy + y) + } +end diff --git a/sys/gio/grdwcs.x b/sys/gio/grdwcs.x new file mode 100644 index 00000000..3ded4e9e --- /dev/null +++ b/sys/gio/grdwcs.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help savewcs +.nf __________________________________________________________________________ +SAVEWCS -- A package for saving the WCS in a file for later restoration when +a device is opened in append mode. + + gwrwcs (devname, wcs, len_wcs) save wcs in file + len = grdwcs (devname, wcs, len_wcs) read wcs from file + +Only the 16+1 WCS structures are currently saved. There is no provision for +saving the WCSSTATE and the index of the current WCS. +.endhelp _____________________________________________________________________ + + +# GWRWCS -- Save the WCS in a binary file in the user directory UPARM. +# Any existing file is overwritten. + +procedure gwrwcs (devname, wcs, len_wcs) + +char devname[ARB] # device name +int wcs[ARB] # array to be saved +int len_wcs + +pointer sp, fname +int fd +int open() +errchk open, write + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call gwcs_mkfilename (devname, Memc[fname], SZ_FNAME) + iferr (call delete (Memc[fname])) + ; + fd = open (Memc[fname], NEW_FILE, BINARY_FILE) + call write (fd, wcs, len_wcs * SZ_INT) + call close (fd) + + call sfree (sp) +end + + +# GRDWCS -- Read the WCS from a binary file in the user directory UPARM. +# The actual number of size int elements read is returned as the function +# value. It is not an error if there is no file or the file cannot be read. + +int procedure grdwcs (devname, wcs, len_wcs) + +char devname[ARB] # device name +int wcs[ARB] # array to be returned +int len_wcs # max ints to read + +pointer sp, fname +int fd, nchars +int open(), read() +errchk read + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call gwcs_mkfilename (devname, Memc[fname], SZ_FNAME) + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) + nchars = 0 + else { + nchars = read (fd, wcs, len_wcs * SZ_INT) + call close (fd) + } + + call sfree (sp) + return (nchars / SZ_INT) +end + + +# GWCS_MKFILENAME -- Make the filename of the WCS savefile for the named +# device. The filename is "uparm$fname.gd", where the "fname" is the +# device name with any illegal filename characters deleted. The mapping +# is not necessarily unique. + +procedure gwcs_mkfilename (devname, fname, maxch) + +char devname[ARB] # device name +char fname[ARB] # generated filename (output) +int maxch + +int ip, op, ch +int gstrcpy() + +begin + # Leave OP pointing to last char output. + op = gstrcpy ("uparm$", fname, maxch) + + for (ip=1; devname[ip] != EOS; ip=ip+1) { + ch = devname[ip] + if (IS_ALNUM(ch) || ch == '.' || ch == '_') { + op = min (maxch, op + 1) + fname[op] = ch + } + } + + fname[op+1] = EOS +end diff --git a/sys/gio/greact.x b/sys/gio/greact.x new file mode 100644 index 00000000..e201d543 --- /dev/null +++ b/sys/gio/greact.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GREACTIVATE -- Reactivate the workstation, i.e., for an interactive device +# (graphics terminal) restore the terminal to graphics mode, following a call +# to gdeactivate to do some normal terminal mode text i/o. + +procedure greactivate (gp, flags) + +pointer gp # graphics descriptor +int flags # action flags + +int and() +errchk gki_reactivatews, gactivate + +begin + call flush (STDOUT) + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + # The workstation is already open - just reactivate it. + call gki_reactivatews (GP_FD(gp), flags) + if (and (GP_GFLAGS(gp), GF_WSACTIVE) == 0) + GP_GFLAGS(gp) = GP_GFLAGS(gp) + GF_WSACTIVE + } else { + # Open the workstation (implies an automatic reactivatews). + call gactivate (gp, flags) + } + + if (and (flags, AW_CLEAR) != 0) + call gfrinit (gp) +end diff --git a/sys/gio/greset.x b/sys/gio/greset.x new file mode 100644 index 00000000..1002e2b9 --- /dev/null +++ b/sys/gio/greset.x @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GRESET -- Initialize the internal state variables of GIO to their default +# values. Called upon startup and by GCANCEL and GCLEAR. + +procedure greset (gp, flags) + +pointer gp #I graphics descriptor +int flags #I flags indicating what to reset + +int color, ch, i +real char_height, aspect +bool reset_wcs, reset_gio, reset_glabax +pointer sp, glbcolor, param, w, ap, ax, ax1, ax2, ip, op + +bool streq() +real ggetr() +int envfind(), ctoi(), strncmp() +define next_ 91 +errchk ggetr + +begin + call smark (sp) + call salloc (glbcolor, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + + # Initialize for a new frame; this is always done. + call gfrinit (gp) + + reset_glabax = (and (flags, GR_RESETGLABAX) != 0) + reset_wcs = (and (flags, GR_RESETWCS) != 0) + reset_gio = (and (flags, GR_RESETGIO) != 0) + + # Reset general GIO device and drawing parameters? + if (reset_gio) { + GP_CURSOR(gp) = 1 + + # All default sizes in NDC units are scaled to the height of a + # device character. + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + aspect = ggetr (gp, "ar") + if (aspect < EPSILON) + aspect = 1.0 + GP_DEVASPECT(gp) = aspect + + # Set default marker sizes. + do i = 1, 4 + GP_SZMARKER(gp,i) = (char_height * i) / 4.0 + + # Set polyline attributes. + ap = GP_PLAP(gp) + PL_LTYPE(ap) = 1 + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + + # Set polymarker attributes. + ap = GP_PMAP(gp) + PM_LTYPE(ap) = 1 + PM_WIDTH(ap) = 1.0 + PM_COLOR(ap) = 1 + + # Set fill area attributes. + ap = GP_FAAP(gp) + FA_STYLE(ap) = 1 + FA_COLOR(ap) = 1 + + # Set default text attributes. + ap = GP_TXAP(gp) + TX_UP(ap) = 90 + TX_SIZE(ap) = 1.0 + TX_PATH(ap) = GT_RIGHT + TX_SPACING(ap) = 0.0 + TX_HJUSTIFY(ap) = GT_LEFT + TX_VJUSTIFY(ap) = GT_DOWN + TX_FONT(ap) = GT_ROMAN + TX_QUALITY(ap) = GT_NORMAL + TX_COLOR(ap) = 1 + } + + # Reset GLABAX parameters? + if (reset_glabax) { + # Set general GLABAX parameters. + GP_DRAWTITLE(gp) = YES + GP_TITLESIZE(gp) = 1.0 + GP_TITLECOLOR(gp) = 1 + GP_TITLEJUST(gp) = GT_CENTER + GP_NTITLELINES(gp) = 0 + GP_FRAMECOLOR(gp) = 0 + GP_FRAMEDRAWN(gp) = 0 + + # Set GLABAX parameters for the X and Y axes. + do i = 1, 2 { + if (i == 1) + ax = GP_XAP(gp) + else + ax = GP_YAP(gp) + + GL_DRAWAXES(ax) = 3 + GL_SETAXISPOS(ax) = NO + GL_AXISPOS1(ax) = 0.0 + GL_AXISPOS2(ax) = 0.0 + GL_DRAWGRID(ax) = NO + GL_GRIDCOLOR(ax) = 1 + GL_ROUND(ax) = NO + GL_LABELAXIS(ax) = YES + GL_AXISLABELSIZE(ax) = 1.0 + GL_AXISLABELCOLOR(ax) = 1 + GL_DRAWTICKS(ax) = YES + GL_LABELTICKS(ax) = YES + GL_NMAJOR(ax) = 6 + GL_NMINOR(ax) = 4 + GL_MAJORLENGTH(ax) = 0.6 * char_height + GL_MINORLENGTH(ax) = 0.3 * char_height + GL_MAJORWIDTH(ax) = 2.0 + GL_MINORWIDTH(ax) = 2.0 + GL_AXISWIDTH(ax) = 2.0 + GL_AXISCOLOR(ax) = 1 + GL_TICKLABELSIZE(ax) = 1.0 + GL_TICKLABELCOLOR(ax) = 1 + GL_TICKCOLOR(ax) = 1 + GL_TICKFORMAT(ax) = EOS + } + + # Correct the default tick length for the aspect ratio. + ax = GP_XAP(gp) + GL_MAJORLENGTH(ax) = GL_MAJORLENGTH(ax) / aspect + GL_MINORLENGTH(ax) = GL_MINORLENGTH(ax) / aspect + + # Set user color defaults if specified. This is a simple string + # parameter of the form "pt=i,fr=i,ax=i,..." where I is the color + # index. The actual color corresponding to this index is defined + # externally, e.g. by the graphics server. + + if (envfind ("glbcolor", Memc[glbcolor], SZ_LINE) > 0) { + ax1 = GP_XAP(gp) + ax2 = GP_YAP(gp) + + for (ip=glbcolor; Memc[ip] != EOS; ) { + # Get color parameter code. + for (op=param; Memc[ip] != EOS && + Memc[ip] != '=' && Memc[ip] != ':'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + ch = Memc[param+2] + + # Get color index. + if (Memc[ip] == '=' || Memc[ip] == ':') + ip = ip + 1 + if (ctoi (Memc, ip, color) <= 0) + goto next_ + + # Set parameter. The two character parameter name may + # have an "x" or "y" appended to set only one axis. For + # example, "pt=4,fr=3,ax=1,tk=1,al=5,tl=6". The color + # parameter code names are as follows: + # + # pt plot title + # fr viewport frame + # gr[xy] grid between tick marks + # ax[xy] axis + # al[xy] axis label + # tk[xy] tick + # tl[xy] tick label + # + # The color codes are simple integers corresponding to + # graphics device color codes, e.g. 0, 1, 2, and so on. + + if (streq (Memc[param], "pt")) { + GP_TITLECOLOR(gp) = color + } else if (streq (Memc[param], "fr")) { + GP_FRAMECOLOR(gp) = color + } else if (strncmp (Memc[param], "gr", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_GRIDCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_GRIDCOLOR(ax2) = color + } else if (strncmp (Memc[param], "ax", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_AXISCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_AXISCOLOR(ax2) = color + } else if (strncmp (Memc[param], "al", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_AXISLABELCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_AXISLABELCOLOR(ax2) = color + } else if (strncmp (Memc[param], "tk", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_TICKCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_TICKCOLOR(ax2) = color + } else if (strncmp (Memc[param], "tl", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_TICKLABELCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_TICKLABELCOLOR(ax2) = color + } +next_ + while (Memc[ip] != EOS && Memc[ip] != ',') + ip = ip + 1 + if (Memc[ip] == ',') + ip = ip + 1 + } + } + } + + # Reset the WCS? + if (reset_wcs) { + GP_WCS(gp) = 1 + + # Initialize the WCS to NDC coordinates. + do i = 0, MAX_WCS { + w = GP_WCSPTR(gp,i) + WCS_WX1(w) = 0.0 + WCS_WX2(w) = 1.0 + WCS_WY1(w) = 0.0 + WCS_WY2(w) = 1.0 + WCS_SX1(w) = 0.0 + WCS_SX2(w) = 1.0 + WCS_SY1(w) = 0.0 + WCS_SY2(w) = 1.0 + WCS_XTRAN(w) = LINEAR + WCS_YTRAN(w) = LINEAR + WCS_FLAGS(w) = WF_NEWFORMAT+WF_CLIP + } + } + + call sfree (sp) +end diff --git a/sys/gio/grmove.x b/sys/gio/grmove.x new file mode 100644 index 00000000..aa4e5b45 --- /dev/null +++ b/sys/gio/grmove.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GRMOVE -- Relative move, i.e., move the pen to the specified offset from the +# current position (without generating any output). + +procedure grmove (gp, x, y) + +pointer gp # graphics descriptor +real x, y # offset from current position +real cx, cy + +begin + call gpl_flush() + if (IS_INDEF(x) || IS_INDEF(y)) + call gadraw (gp, x, y) + else { + call gcurpos (gp, cx, cy) + if (!(IS_INDEF(cx) || IS_INDEF(cy))) + call gamove (gp, cx + x, cy + y) + } +end diff --git a/sys/gio/grscale.x b/sys/gio/grscale.x new file mode 100644 index 00000000..76c06ebc --- /dev/null +++ b/sys/gio/grscale.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GRSCALE -- Rescale the world coordinates of either the X or Y axis to fit the +# data vector. This is done by taking the minimum and maximum of the current +# WCS limits and the data vector. May be called repeatedly to find the range +# of a family of vectors. + +procedure grscale (gp, v, npts, axis) + +pointer gp # graphics descriptor +real v[ARB] # data vector +int npts # length of data vector +int axis # asis to be scaled (1=X, 2=Y) + +int start, i +real minval, maxval, pixval +pointer w + +begin + # Find first definite valued pixel. If entire data vector is + # indefinite we merely ignore it, since the window is presumably + # already set. + + for (start=1; start <= npts; start=start+1) + if (!IS_INDEF (v[start])) + break + if (start > npts) + return + + minval = v[start] + maxval = minval + + # Compute min and max values of data vector. + do i = start+1, npts { + pixval = v[i] + if (!IS_INDEF(pixval)) + if (pixval < minval) + minval = pixval + else if (pixval > maxval) + maxval = pixval + } + + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Update the window limits. + switch (axis) { + case 1: + WCS_WX1(w) = min (WCS_WX1(w), minval) + WCS_WX2(w) = max (WCS_WX2(w), maxval) + case 2: + WCS_WY1(w) = min (WCS_WY1(w), minval) + WCS_WY2(w) = max (WCS_WY2(w), maxval) + default: + call syserr (SYS_GSCALE) + } + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gscan.x b/sys/gio/gscan.x new file mode 100644 index 00000000..ac8f82bd --- /dev/null +++ b/sys/gio/gscan.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSCAN -- Scan commands from a string or a file. + +procedure gscan (gp, command) + +pointer gp # graphics descriptor +char command[ARB] # command to be scanned + +begin +end diff --git a/sys/gio/gscur.x b/sys/gio/gscur.x new file mode 100644 index 00000000..2892e397 --- /dev/null +++ b/sys/gio/gscur.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSCUR -- Set the current graphics cursor to the position (x,y) in world +# coordinates. + +procedure gscur (gp, x, y) + +pointer gp # graphics descriptor +real x, y # new position for cursor +real mx, my + +begin + call gpl_flush() + call gpl_wcstogki (gp, x, y, mx, my) + call gki_setcursor (GP_FD(gp), nint(mx), nint(my), GP_CURSOR(gp)) +end diff --git a/sys/gio/gseti.x b/sys/gio/gseti.x new file mode 100644 index 00000000..f3517358 --- /dev/null +++ b/sys/gio/gseti.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSETI -- Set any GIO parameter of type integer or real. Precision may be +# lost if the actual parameter is of type real (call GSETR instead in such +# a case). + +procedure gseti (gp, param, value) + +pointer gp # graphics descriptor +int param # parameter to be set +int value # new value for parameter + +begin + call gsetr (gp, param, real(value)) +end diff --git a/sys/gio/gsetr.x b/sys/gio/gsetr.x new file mode 100644 index 00000000..9358f046 --- /dev/null +++ b/sys/gio/gsetr.x @@ -0,0 +1,276 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GSETR -- Set any GIO parameter of type integer or real. Real values are +# silently coerced to integer if the actual parameter value is integer. + +procedure gsetr (gp, param, rval) + +pointer gp # graphics descriptor +int param # parameter to be set +real rval # new value for parameter + +real char_height +int wcs, axes, field, ax[2], wflags, i +pointer w, p, pl, pm, tx, fa +real ggetr() + +begin + # Compute pointers to substructures once, here, to save space later. + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + wflags = WCS_FLAGS(w) + + pl = GP_PLAP(gp) + pm = GP_PMAP(gp) + tx = GP_TXAP(gp) + fa = GP_FAAP(gp) + + switch (param) { + + # General GIO parameters. + + case G_FD: + GP_FD(gp) = nint(rval) + case G_TTY: + GP_TTY(gp) = nint(rval) + case G_WCS: + GP_WCS(gp) = nint(rval) + case G_CURSOR: + GP_CURSOR(gp) = nint(rval) + + # These parameters affect the current WCS. + + case G_XTRAN: + WCS_XTRAN(w) = nint(rval) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + case G_YTRAN: + WCS_YTRAN(w) = nint(rval) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + case G_CLIP: + if (nint(rval) == 0) + WCS_FLAGS(w) = and (wflags, not(WF_CLIP)) + else + WCS_FLAGS(w) = or (wflags, WF_CLIP) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + case G_RASTER: + WCS_FLAGS(w) = WF_SETRASTER (wflags, nint(rval)) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + + # Default marker sizes (NDC coords). + + case G_SZMARKER1: + GP_SZMARKER(gp,1) = rval + case G_SZMARKER2: + GP_SZMARKER(gp,2) = rval + case G_SZMARKER3: + GP_SZMARKER(gp,3) = rval + case G_SZMARKER4: + GP_SZMARKER(gp,4) = rval + + # Polyline attributes. + + case G_PLTYPE: + call gst_set_attribute_i (nint(rval), PL_LTYPE(pl), PL_STATE(pl)) + case G_PLWIDTH: + call gst_set_attribute_r (rval, PL_WIDTH(pl), PL_STATE(pl)) + case G_PLCOLOR: + call gst_set_attribute_i (nint(rval), PL_COLOR(pl), PL_STATE(pl)) + + # Polymarker attributes. + + case G_PMLTYPE: + call gst_set_attribute_i (nint(rval), PM_LTYPE(pm), PM_STATE(pm)) + case G_PMWIDTH: + call gst_set_attribute_r (rval, PM_WIDTH(pm), PM_STATE(pm)) + case G_PMCOLOR: + call gst_set_attribute_i (nint(rval), PM_COLOR(pm), PM_STATE(pm)) + + # Text drawing attributes. + + case G_TXUP: + call gst_set_attribute_i (nint(rval), TX_UP(tx), TX_STATE(tx)) + case G_TXSIZE: + call gst_set_attribute_r (rval, TX_SIZE(tx), TX_STATE(tx)) + case G_TXPATH: + call gst_set_attribute_i (nint(rval), TX_PATH(tx), TX_STATE(tx)) + case G_TXSPACING: + call gst_set_attribute_r (rval, TX_SPACING(tx), TX_STATE(tx)) + case G_TXHJUSTIFY: + call gst_set_attribute_i (nint(rval), TX_HJUSTIFY(tx), TX_STATE(tx)) + case G_TXVJUSTIFY: + call gst_set_attribute_i (nint(rval), TX_VJUSTIFY(tx), TX_STATE(tx)) + case G_TXFONT: + call gst_set_attribute_i (nint(rval), TX_FONT(tx), TX_STATE(tx)) + case G_TXQUALITY: + call gst_set_attribute_i (nint(rval), TX_QUALITY(tx), TX_STATE(tx)) + case G_TXCOLOR: + call gst_set_attribute_i (nint(rval), TX_COLOR(tx), TX_STATE(tx)) + + # Fill area attributes. + + case G_FASTYLE: + call gst_set_attribute_i (nint(rval), FA_STYLE(fa), FA_STATE(fa)) + case G_FACOLOR: + call gst_set_attribute_i (nint(rval), FA_COLOR(fa), FA_STATE(fa)) + + # Axis labelling parameters affecting more than one axis. + + case G_DRAWTITLE: + GP_DRAWTITLE(gp) = nint(rval) + case G_TITLESIZE: + GP_TITLESIZE(gp) = rval + case G_TITLECOLOR: + GP_TITLECOLOR(gp) = nint(rval) + case G_TITLEJUST: + GP_TITLEJUST(gp) = nint(rval) + case G_NTITLELINES: + GP_NTITLELINES(gp) = nint(rval) + case G_FRAMECOLOR: + GP_FRAMECOLOR(gp) = nint(rval) + case G_ASPECT: + GP_ASPECT(gp) = rval + + case G_CHARSIZE: + # Set the character size (height) in NDC units. This can also be + # done by querying for "ch" and setting the relative size, but the + # function is fundamental enough to be worth implementing as a + # single call. + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + call gst_set_attribute_r (rval / char_height, TX_SIZE(tx), + TX_STATE(tx)) + + default: + # The GLABAX parameters for the X and Y axes may be set separately + # for each axis or simultaneously for both. The parameter codes + # are encoded as 100 (X only) 200 (Y only) or 300 (both) plus the + # code for the field in the lower digits. + + if (param < FIRST_GLABAX_PARAM || param > LAST_GLABAX_PARAM) + call syserr (SYS_GSET) + + axes = param / 100 + field = mod (param, 100) + 300 + + ax[1] = 0 + ax[2] = 0 + if (axes == 1 || axes == 3) + ax[1] = YES + if (axes == 2 || axes == 3) + ax[2] = YES + + do i = 1, 2 { + if (ax[i] == YES) { + if (i == 1) + p = GP_XAP(gp) + else + p = GP_YAP(gp) + + switch (field) { + case G_DRAWAXES: + GL_DRAWAXES(p) = nint(rval) + case G_SETAXISPOS: + GL_SETAXISPOS(p) = nint(rval) + case G_AXISPOS1: + GL_AXISPOS1(p) = rval + case G_AXISPOS2: + GL_AXISPOS2(p) = rval + case G_DRAWGRID: + GL_DRAWGRID(p) = nint(rval) + case G_GRIDCOLOR: + GL_GRIDCOLOR(p) = nint(rval) + case G_ROUND: + GL_ROUND(p) = nint(rval) + case G_LABELAXIS: + GL_LABELAXIS(p) = nint(rval) + case G_AXISLABELSIZE: + GL_AXISLABELSIZE(p) = rval + case G_AXISLABELCOLOR: + GL_AXISLABELCOLOR(p) = nint(rval) + case G_DRAWTICKS: + GL_DRAWTICKS(p) = nint(rval) + case G_LABELTICKS: + GL_LABELTICKS(p) = nint(rval) + case G_NMAJOR: + GL_NMAJOR(p) = nint(rval) + case G_NMINOR: + GL_NMINOR(p) = nint(rval) + case G_MAJORLENGTH: + GL_MAJORLENGTH(p) = rval + case G_MINORLENGTH: + GL_MINORLENGTH(p) = rval + case G_MAJORWIDTH: + GL_MAJORWIDTH(p) = rval + case G_MINORWIDTH: + GL_MINORWIDTH(p) = rval + case G_AXISWIDTH: + GL_AXISWIDTH(p) = rval + case G_AXISCOLOR: + GL_AXISCOLOR(p) = nint(rval) + case G_TICKLABELSIZE: + GL_TICKLABELSIZE(p) = rval + case G_TICKLABELCOLOR: + GL_TICKLABELCOLOR(p) = nint(rval) + case G_TICKCOLOR: + GL_TICKCOLOR(p) = nint(rval) + # case G_TICKFORMAT: + # not a real parameter + default: + call syserr (SYS_GSET) + } + } + } + } +end + + +# GST_SET_ATTRIBUTE_I -- Compare the new value of an attribute to the current +# value. If the new value is not different, exit without modifying the +# attribute packet, making no-op GSET calls efficient. If the packet must +# be modified, flush any buffered polyline output first else it will be +# written using the new attribute (this is not necessary for text attributes, +# but is harmless and it is unlikely that GSET will be called to modify a +# text attribute while in the midst of building a polyline). Set the +# parameter and flag the attribute packet as modified. + +procedure gst_set_attribute_i (new_value, value, state) + +int new_value # value in GSET argument list +int value # current value in GP struct +int state # packet state + +begin + if (new_value != value) { + call gpl_flush() + value = new_value + state = MODIFIED + } +end + + +# GST_SET_ATTRIBUTE_R -- Ditto, for real valued parameters. + +procedure gst_set_attribute_r (new_value, value, state) + +real new_value # value in GSET argument list +real value # current value in GP struct +int state # packet state + +begin + if (abs (new_value - value) > EPSILON) { + call gpl_flush() + value = new_value + state = MODIFIED + } +end diff --git a/sys/gio/gsets.x b/sys/gio/gsets.x new file mode 100644 index 00000000..ad72d000 --- /dev/null +++ b/sys/gio/gsets.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GSETS -- Set a string valued GIO parameter. + +procedure gsets (gp, param, value) + +pointer gp # graphics descriptor +int param # parmeter to be set +char value[ARB] # new value of parameter +int i +pointer gl[2] + +begin + gl[1] = GP_XAP(gp) + gl[2] = GP_YAP(gp) + + switch (param) { + case G_XTICKFORMAT: + call strcpy (value, GL_TICKFORMAT(gl[1]), SZ_TICKFORMAT) + case G_YTICKFORMAT: + call strcpy (value, GL_TICKFORMAT(gl[2]), SZ_TICKFORMAT) + case G_TICKFORMAT: + do i = 1, 2 + call strcpy (value, GL_TICKFORMAT(gl[i]), SZ_TICKFORMAT) + default: + call syserr (SYS_GSET) + } +end diff --git a/sys/gio/gstati.x b/sys/gio/gstati.x new file mode 100644 index 00000000..2298b39b --- /dev/null +++ b/sys/gio/gstati.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTATI -- Get any GIO parameter of type integer or real. Precision may be +# lost if the actual parameter is of type real (call GSTATR instead in such +# a case). + +int procedure gstati (gp, param) + +pointer gp # graphics descriptor +int param # parameter to be inspected + +real gstatr() + +begin + return (gstatr (gp, param)) +end diff --git a/sys/gio/gstatr.x b/sys/gio/gstatr.x new file mode 100644 index 00000000..d0ba3d8b --- /dev/null +++ b/sys/gio/gstatr.x @@ -0,0 +1,215 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GSTATR -- Get any GIO parameter of type integer or real. Integer values are +# silently coerced to real if the actual parameter value is integer. + +real procedure gstatr (gp, param) + +pointer gp # graphics descriptor +int param # parameter to be set + +real char_height +int wcs, axes, field, ax[2], i +pointer w, p, pl, pm, tx, fa +real ggetr() + +begin + # Compute pointers to substructures once, here, to save space later. + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + pl = GP_PLAP(gp) + pm = GP_PMAP(gp) + tx = GP_TXAP(gp) + fa = GP_FAAP(gp) + + switch (param) { + + # General GIO parameters. + + case G_FD: + return (GP_FD(gp)) + case G_TTY: + return (GP_TTY(gp)) + case G_WCS: + return (GP_WCS(gp)) + case G_CURSOR: + return (GP_CURSOR(gp)) + + # These parameters affect the current WCS. + + case G_XTRAN: + return (WCS_XTRAN(w)) + case G_YTRAN: + return (WCS_YTRAN(w)) + case G_CLIP: + return (and (WCS_FLAGS(w), WF_CLIP)) + case G_RASTER: + return (WF_RASTER (WCS_FLAGS(w))) + + # Default marker sizes (NDC coords). + + case G_SZMARKER1: + return (GP_SZMARKER(gp,1)) + case G_SZMARKER2: + return (GP_SZMARKER(gp,2)) + case G_SZMARKER3: + return (GP_SZMARKER(gp,3)) + case G_SZMARKER4: + return (GP_SZMARKER(gp,4)) + + # Polyline attributes. + + case G_PLTYPE: + return (PL_LTYPE(pl)) + case G_PLWIDTH: + return (PL_WIDTH(pl)) + case G_PLCOLOR: + return (PL_COLOR(pl)) + + # Polymarker attributes. + + case G_PMLTYPE: + return (PM_LTYPE(pm)) + case G_PMWIDTH: + return (PM_WIDTH(pm)) + case G_PMCOLOR: + return (PM_COLOR(pm)) + + # Text drawing attributes. + + case G_TXUP: + return (TX_UP(tx)) + case G_TXSIZE: + return (TX_SIZE(tx)) + case G_TXPATH: + return (TX_PATH(tx)) + case G_TXSPACING: + return (TX_SPACING(tx)) + case G_TXHJUSTIFY: + return (TX_HJUSTIFY(tx)) + case G_TXVJUSTIFY: + return (TX_VJUSTIFY(tx)) + case G_TXFONT: + return (TX_FONT(tx)) + case G_TXQUALITY: + return (TX_QUALITY(tx)) + case G_TXCOLOR: + return (TX_COLOR(tx)) + + # Fill area attributes. + + case G_FASTYLE: + return (FA_STYLE(fa)) + case G_FACOLOR: + return (FA_COLOR(fa)) + + # Axis labelling parameters affecting more than one axis. + + case G_DRAWTITLE: + return (GP_DRAWTITLE(gp)) + case G_TITLESIZE: + return (GP_TITLESIZE(gp)) + case G_TITLECOLOR: + return (GP_TITLECOLOR(gp)) + case G_NTITLELINES: + return (GP_NTITLELINES(gp)) + case G_FRAMECOLOR: + return (GP_FRAMECOLOR(gp)) + case G_ASPECT: + return (GP_ASPECT(gp)) + + case G_CHARSIZE: + # Return the current character size in NDC units. + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + return (char_height * TX_SIZE(tx)) + + default: + # The GLABAX parameters for the X and Y axes may be set separately + # for each axis or simultaneously for both. The parameter codes + # are encoded as 100 (X only) 200 (Y only) or 300 (both) plus the + # code for the field in the lower digits. + + if (param < FIRST_GLABAX_PARAM || param > LAST_GLABAX_PARAM) + call syserr (SYS_GSTAT) + + axes = param / 100 + field = mod (param, 100) + 300 + + ax[1] = 0 + ax[2] = 0 + if (axes == 1 || axes == 3) + ax[1] = YES + if (axes == 2 || axes == 3) + ax[2] = YES + + do i = 1, 2 { + if (ax[i] == YES) { + if (i == 1) + p = GP_XAP(gp) + else + p = GP_YAP(gp) + + switch (field) { + case G_DRAWAXES: + return (GL_DRAWAXES(p)) + case G_SETAXISPOS: + return (GL_SETAXISPOS(p)) + case G_AXISPOS1: + return (GL_AXISPOS1(p)) + case G_AXISPOS2: + return (GL_AXISPOS2(p)) + case G_DRAWGRID: + return (GL_DRAWGRID(p)) + case G_GRIDCOLOR: + return (GL_GRIDCOLOR(p)) + case G_ROUND: + return (GL_ROUND(p)) + case G_LABELAXIS: + return (GL_LABELAXIS(p)) + case G_AXISLABELSIZE: + return (GL_AXISLABELSIZE(p)) + case G_AXISLABELCOLOR: + return (GL_AXISLABELCOLOR(p)) + case G_DRAWTICKS: + return (GL_DRAWTICKS(p)) + case G_LABELTICKS: + return (GL_LABELTICKS(p)) + case G_NMAJOR: + return (GL_NMAJOR(p)) + case G_NMINOR: + return (GL_NMINOR(p)) + case G_MAJORLENGTH: + return (GL_MAJORLENGTH(p)) + case G_MINORLENGTH: + return (GL_MINORLENGTH(p)) + case G_MAJORWIDTH: + return (GL_MAJORWIDTH(p)) + case G_MINORWIDTH: + return (GL_MINORWIDTH(p)) + case G_AXISWIDTH: + return (GL_AXISWIDTH(p)) + case G_AXISCOLOR: + return (GL_AXISCOLOR(p)) + case G_TICKLABELSIZE: + return (GL_TICKLABELSIZE(p)) + case G_TICKLABELCOLOR: + return (GL_TICKLABELCOLOR(p)) + case G_TICKCOLOR: + return (GL_TICKCOLOR(p)) + # case G_TICKFORMAT: + # not a real parameter + default: + call syserr (SYS_GSTAT) + } + } + } + } +end diff --git a/sys/gio/gstats.x b/sys/gio/gstats.x new file mode 100644 index 00000000..14fd7c35 --- /dev/null +++ b/sys/gio/gstats.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GSTATS -- Get the value of a string valued GIO parameter. + +int procedure gstats (gp, param, outstr, maxch) + +pointer gp # graphics descriptor +int param # parmeter to be set +char outstr[ARB] # output string +int maxch +int gstrcpy() + +int i, value +pointer p[2] + +begin + p[1] = GP_XAP(gp) + p[2] = GP_XAP(gp) + + switch (param) { + case G_XTICKFORMAT: + return (gstrcpy (GL_TICKFORMAT(p[1]), value, maxch)) + case G_YTICKFORMAT: + return (gstrcpy (GL_TICKFORMAT(p[2]), value, maxch)) + case G_TICKFORMAT: + do i = 1, 2 + return (gstrcpy (GL_TICKFORMAT(p[i]), value, maxch)) + default: + call syserr (SYS_GSTAT) + } +end diff --git a/sys/gio/gsview.x b/sys/gio/gsview.x new file mode 100644 index 00000000..7ed83b31 --- /dev/null +++ b/sys/gio/gsview.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSVIEW -- Set the viewport of the current WCS. + +procedure gsview (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of NDC in X +real y1, y2 # range of NDC in Y +pointer w + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + WCS_SX1(w) = x1 + WCS_SX2(w) = x2 + WCS_SY1(w) = y1 + WCS_SY2(w) = y2 + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gswind.x b/sys/gio/gswind.x new file mode 100644 index 00000000..81f7b6a3 --- /dev/null +++ b/sys/gio/gswind.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSWIND -- Set the window into world coordinates of the current WCS. + +procedure gswind (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of world coords in X +real y1, y2 # range of world coords in Y +pointer w + +begin + call gpl_flush() + w = GP_WCSPTR (gp, GP_WCS(gp)) + + if (!IS_INDEF(x1)) + WCS_WX1(w) = x1 + if (!IS_INDEF(x2)) + WCS_WX2(w) = x2 + if (!IS_INDEF(y1)) + WCS_WY1(w) = y1 + if (!IS_INDEF(y2)) + WCS_WY2(w) = y2 + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gtext.x b/sys/gio/gtext.x new file mode 100644 index 00000000..abb26ef4 --- /dev/null +++ b/sys/gio/gtext.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTEXT -- Draw text. All textual output via GIO is via this primitive. Unlike +# polyline, polymarker, fill area, and cell array output, textual output is not +# subjected to clipping by GIO. Clipping may be performed at the kernel level +# if a workstation viewport is defined. Our task here is principally to parse +# the format string and set up the text attributes, then insert the text drawing +# instruction into the GKI instruction stream. The real work of text generation +# is very device dependent and is therefore left to the kernel. + +procedure gtext (gp, x, y, text, format) + +pointer gp # graphics descriptor +real x, y # position at which text is to be drawn +char text[ARB] # text to be drawn +char format[ARB] # text drawing parameters + +int ip, i +real mx, my +pointer sp, ap, tx +bool text_attributes_modified + +begin + call smark (sp) + call salloc (ap, LEN_TX, TY_STRUCT) + + # Set up pointers to text attribute packets and initialize the + # new packet to the default values. Two text attribute packets + # are maintained in GP: TXAP, the default packet, and TXAPCUR, + # the packet last sent to the device. In what follows, AP is + # the new packet and TX is the packet last sent to the device. + # We start by initializing the new packet at AP to the default + # text drawing parameters. + + call amovi (Memi[GP_TXAP(gp)], Memi[ap], LEN_TX) + tx = GP_TXAPCUR(gp) + + # Parse the format string and set the text attributes. The code is + # more general than need be, i.e., the entire attribute name string + # is extracted but only the first character is used. Whitespace is + # permitted and ignored. + + ip = 1 + call gtxset (ap, format, ip) + + # If the old text attribute packet was never fixed always fix the + # new packet, otherwise determine whether or not any text attributes + # were actually modified and only fix the new packet if it is + # different. + + text_attributes_modified = false + for (i=2; i <= LEN_TX; i=i+1) + if (Memi[ap+i-1] != Memi[tx+i-1]) { + text_attributes_modified = true + break + } + + # Flush any buffered polyline output, and transform the text coordinates + # to GKI device coordinates. + + call gpl_flush() + call gpl_wcstogki (gp, x, y, mx, my) + + # Update text attributes if necessary. + if (text_attributes_modified || TX_STATE(tx) != FIXED) { + call amovi (Memi[ap], Memi[tx], LEN_TX) + call gki_txset (GP_FD(gp), tx) + TX_STATE(tx) = FIXED + } + + # Output text drawing instruction. + call gki_text (GP_FD(gp), nint(mx), nint(my), text) + + call sfree (sp) +end diff --git a/sys/gio/gtick.gx b/sys/gio/gtick.gx new file mode 100644 index 00000000..157fae1e --- /dev/null +++ b/sys/gio/gtick.gx @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTICK -- Determine the best number and placement of ticks for the interval +# [x1:x2]. If log scaling is in use we try to put the ticks at positions which +# are 1.0 times some power of ten, otherwise we divide the interval an integral +# number of times and place the ticks at the interval boundaries. The basic +# algorithm is simple, but implementation is tricky due to the quirks of +# floating point computations and the desire to have the algorithm work for all +# X, and all ranges of X. For example, we might want to plot a large range +# near zero, or a small range where both X1 and X2 have a very large exponent. +# +# N.B.: this is a generic source; it may be preprocessed with the IRAF "generic" +# preprocessor to produce either a single or double precision SPP source file. + +procedure gtick$t (x1, x2, rough_nticks, logflag, x_tick1, step) + +PIXEL x1, x2 # range for which ticks are desired +int rough_nticks # approximate number of ticks desired +int logflag # nonzero if log scaling in use +PIXEL x_tick1 # x coord of first tick (output) +PIXEL step # tick spacing along X (output) + +PIXEL x, tol +int ndiv +int log +#int nticks +int expon +PIXEL gt_distance() + +begin + log = logflag + tol = EPSILON$T * 10.0 + + # If log, decrease ndiv until an x of 1.0 is obtained. If an x of 1.0 + # cannot be produced, repeat the calculation once more with ndiv fixed. + + repeat { + ndiv = max (1, rough_nticks - 1) + + repeat { + if (log == YES) + x = 1.0 + else + x = abs ((x2 - x1) / ndiv) + + # Scale approximate tick spacing to the range [1-10). Select + # a logical tick spacing, given calculated and scaled spacing. + + call fp_norm$t (x, x, expon) + if (x < 1.5) + x = 1.0 + else if (x < 2.5) + x = 2.0 + else if (x < 4.0) + x = 2.5 + else if (x < 7.5) + x = 5.0 + else { + x = 1.0 + expon = expon + 1 + } + + # Calculate the first tick and the tick increment (step size). + if (log == YES) + step = 1.0 + else + step = x * (10.0 ** expon) + + if (gt_distance (x1, step, x_tick1) / step < tol) + # x_tick1 = x1 + else if (x1 < x2 && x_tick1 < x1) + x_tick1 = x_tick1 + step + else if (x1 > x2 && x_tick1 > x1) + x_tick1 = x_tick1 - step + + if (x1 > x2) + step = -step + ndiv = ndiv - 1 + + } until (abs(abs(x) - 1.0) < tol || log == NO || ndiv == 0) + + # Terminate if not in log mode, if the tick separation is a power + # of ten and there are ndivisions tick marks, or if the tick + # separation is one magnitude and there are at least two tick marks + # within the range x1:x2. + + # if (log == NO) { + # return + # } else if (step == 1.0 || x == 1.0) { + # if (step == 1.0) + # nticks = 1 + # else + # nticks = max (2, rough_nticks - 1) + + # if (x1 > x2 && x_tick1 + nticks * step >= x2) + # return + # else if (x1 < x2 && x_tick1 + nticks * step <= x2) + # return + # else + # log = NO + # } else + # log = NO + + return + } +end + + +# GT_NDIGITS -- Calculate the number of digits of precision needed to label +# ticks in the range x1 to x2 (i.e., if x1=100000 and x2=100001, 7 digits +# will be required, whereas in many cases 1 or 2 is enough). + +int procedure gt_ndigits (x1, x2, step) + +PIXEL x1, x2 # range covered by numbers +PIXEL step # tick separation +PIXEL ratio +int n + +begin + if (x1 == x2) + n = 2 + else { + ratio = abs ((x1+x2) / (x1-x2)) + n = log10 (max (1.0, ratio)) + 2.0 + } + + return (n) +end + + +# GT_LINEARITY -- The following function returns a large number if there is +# little difference between a log scale and a linear scale for the range X1 +# to X2. if the linearity of the interval is large, there is no point in +# using a logarithmic scale. + +PIXEL procedure gt_linearity (x1, x2) + +PIXEL x1, x2 +PIXEL linearity, difflog +PIXEL elog$t() + +begin + if (x1 <= 0 || x2 <= 0) + difflog = abs (elog$t(x1) - elog$t(x2)) + else + difflog = abs (log10(x1) - log10(x2)) + + if (difflog == 0.0) + linearity = 1E10 + else + linearity = 1.0 / difflog + + return (linearity) +end + + +# GT_DISTANCE -- Compute the distance of X from the nearest integral multiple +# of "step". + +PIXEL procedure gt_distance (x, step, nearest_tick) + +PIXEL x # number to be tested +PIXEL step # tick separation +PIXEL nearest_tick # X coord of tick nearest X + +PIXEL ltick, rtick, absx +PIXEL fp_fix$t() + +begin + absx = abs (x) + + ltick = fp_fix$t (absx / step) * step + rtick = ltick + step + + if (abs(absx - ltick) < abs(rtick - absx)) { + if (x < 0) + nearest_tick = -ltick + else + nearest_tick = ltick + return (absx - ltick) + + } else { + if (x < 0) + nearest_tick = -rtick + else + nearest_tick = rtick + return (rtick - absx) + } +end diff --git a/sys/gio/gtickr.x b/sys/gio/gtickr.x new file mode 100644 index 00000000..cd227363 --- /dev/null +++ b/sys/gio/gtickr.x @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTICK -- Determine the best number and placement of ticks for the interval +# [x1:x2]. If log scaling is in use we try to put the ticks at positions which +# are 1.0 times some power of ten, otherwise we divide the interval an integral +# number of times and place the ticks at the interval boundaries. The basic +# algorithm is simple, but implementation is tricky due to the quirks of +# floating point computations and the desire to have the algorithm work for all +# X, and all ranges of X. For example, we might want to plot a large range +# near zero, or a small range where both X1 and X2 have a very large exponent. +# +# N.B.: this is a generic source; it may be preprocessed with the IRAF "generic" +# preprocessor to produce either a single or double precision SPP source file. + +procedure gtickr (x1, x2, rough_nticks, logflag, x_tick1, step) + +real x1, x2 # range for which ticks are desired +int rough_nticks # approximate number of ticks desired +int logflag # nonzero if log scaling in use +real x_tick1 # x coord of first tick (output) +real step # tick spacing along X (output) + +real x, tol +int ndiv +int log +#int nticks +int expon +real gt_distance() + +begin + log = logflag + tol = EPSILONR * 10.0 + + # If log, decrease ndiv until an x of 1.0 is obtained. If an x of 1.0 + # cannot be produced, repeat the calculation once more with ndiv fixed. + + repeat { + ndiv = max (1, rough_nticks - 1) + + repeat { + if (log == YES) + x = 1.0 + else + x = abs ((x2 - x1) / ndiv) + + # Scale approximate tick spacing to the range [1-10). Select + # a logical tick spacing, given calculated and scaled spacing. + + call fp_normr (x, x, expon) + if (x < 1.5) + x = 1.0 + else if (x < 2.5) + x = 2.0 + else if (x < 4.0) + x = 2.5 + else if (x < 7.5) + x = 5.0 + else { + x = 1.0 + expon = expon + 1 + } + + # Calculate the first tick and the tick increment (step size). + if (log == YES) + step = 1.0 + else + step = x * (10.0 ** expon) + + if (gt_distance (x1, step, x_tick1) / step < tol) + # x_tick1 = x1 + else if (x1 < x2 && x_tick1 < x1) + x_tick1 = x_tick1 + step + else if (x1 > x2 && x_tick1 > x1) + x_tick1 = x_tick1 - step + + if (x1 > x2) + step = -step + ndiv = ndiv - 1 + + } until (abs(abs(x) - 1.0) < tol || log == NO || ndiv == 0) + + # Terminate if not in log mode, if the tick separation is a power + # of ten and there are ndivisions tick marks, or if the tick + # separation is one magnitude and there are at least two tick marks + # within the range x1:x2. + + # if (log == NO) { + # return + # } else if (step == 1.0 || x == 1.0) { + # if (step == 1.0) + # nticks = 1 + # else + # nticks = max (2, rough_nticks - 1) + + # if (x1 > x2 && x_tick1 + nticks * step >= x2) + # return + # else if (x1 < x2 && x_tick1 + nticks * step <= x2) + # return + # else + # log = NO + # } else + # log = NO + + return + } +end + + +# GT_NDIGITS -- Calculate the number of digits of precision needed to label +# ticks in the range x1 to x2 (i.e., if x1=100000 and x2=100001, 7 digits +# will be required, whereas in many cases 1 or 2 is enough). + +int procedure gt_ndigits (x1, x2, step) + +real x1, x2 # range covered by numbers +real step # tick separation +real ratio +int n + +begin + if (x1 == x2) + n = 2 + else { + ratio = abs ((x1+x2) / (x1-x2)) + n = log10 (max (1.0, ratio)) + 2.0 + } + + return (n) +end + + +# GT_LINEARITY -- The following function returns a large number if there is +# little difference between a log scale and a linear scale for the range X1 +# to X2. if the linearity of the interval is large, there is no point in +# using a logarithmic scale. + +real procedure gt_linearity (x1, x2) + +real x1, x2 +real linearity, difflog +real elogr() + +begin + if (x1 <= 0 || x2 <= 0) + difflog = abs (elogr(x1) - elogr(x2)) + else + difflog = abs (log10(x1) - log10(x2)) + + if (difflog == 0.0) + linearity = 1E10 + else + linearity = 1.0 / difflog + + return (linearity) +end + + +# GT_DISTANCE -- Compute the distance of X from the nearest integral multiple +# of "step". + +real procedure gt_distance (x, step, nearest_tick) + +real x # number to be tested +real step # tick separation +real nearest_tick # X coord of tick nearest X + +real ltick, rtick, absx +real fp_fixr() + +begin + absx = abs (x) + + ltick = fp_fixr (absx / step) * step + rtick = ltick + step + + if (abs(absx - ltick) < abs(rtick - absx)) { + if (x < 0) + nearest_tick = -ltick + else + nearest_tick = ltick + return (absx - ltick) + + } else { + if (x < 0) + nearest_tick = -rtick + else + nearest_tick = rtick + return (rtick - absx) + } +end diff --git a/sys/gio/gtxset.x b/sys/gio/gtxset.x new file mode 100644 index 00000000..de386a69 --- /dev/null +++ b/sys/gio/gtxset.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define MAXCH 15 + +# GTXSET -- Parse a text drawing format string and set the values of the text +# attributes in the TX output structure. + +procedure gtxset (tx, format, ip) + +pointer tx # text attribute structure +char format[ARB] # text attribute format string +int ip # pointer into format string + +char attribute[MAXCH], value[MAXCH] +int op, tip, temp, ch +int h_v[4], v_v[4], f_v[4], q_v[4], p_v[4] +int ctoi(), ctor(), stridx() +define badformat_ 91 + +string h_c "nclr" +data h_v /GT_NORMAL, GT_CENTER, GT_LEFT, GT_RIGHT/ +string v_c "nctb" +data v_v /GT_NORMAL, GT_CENTER, GT_TOP, GT_BOTTOM/ +string f_c "rgib" +data f_v /GT_ROMAN, GT_GREEK, GT_ITALIC, GT_BOLD/ +string q_c "nlmh" +data q_v /GT_NORMAL, GT_LOW, GT_MEDIUM, GT_HIGH/ +string p_c "lrud" +data p_v /GT_LEFT, GT_RIGHT, GT_UP, GT_DOWN/ + +begin + # Parse the format string and set the text attributes. The code is + # more general than need be, i.e., the entire attribute name string + # is extracted but only the first character is used. Whitespace is + # permitted and ignored. + + for (; format[ip] != EOS; ip=ip+1) { + # Extract the next "attribute=value" construct. + while (IS_WHITE (format[ip])) + ip = ip +1 + + op = 1 + for (ch=format[ip]; ch != EOS && ch != '='; ch=format[ip]) { + if (op <= MAXCH) { + attribute[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + } + attribute[op] = EOS + + if (ch == '=') + ip = ip + 1 + + op = 1 + while (IS_WHITE (format[ip])) + ip = ip +1 + ch = format[ip] + while (ch != EOS && ch != ';' && ch != ',') { + if (op <= MAXCH) { + value[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + ch = format[ip] + } + value[op] = EOS + + if (attribute[1] == EOS || value[1] == EOS) + break + + # Decode the assignment and set the corresponding text attribute + # in the graphics descriptor. + + switch (attribute[1]) { + case 'u': # character up vector + tip = 1 + if (ctoi (value, tip, TX_UP(tx)) <= 0) { + TX_UP(tx) = 90 + goto badformat_ + } + + case 'p': # path + temp = stridx (value[1], p_c) + if (temp <= 0) + goto badformat_ + else + TX_PATH(tx) = p_v[temp] + + case 'c': # color + tip = 1 + if (ctoi (value, tip, TX_COLOR(tx)) <= 0) { + TX_COLOR(tx) = 1 + goto badformat_ + } + + case 's': # character size scale factor + tip = 1 + if (ctor (value, tip, TX_SIZE(tx)) <= 0) { + TX_SIZE(tx) = 1.0 + goto badformat_ + } + + case 'h': # horizontal justification + temp = stridx (value[1], h_c) + if (temp <= 0) + goto badformat_ + else + TX_HJUSTIFY(tx) = h_v[temp] + + case 'v': # vertical justification + temp = stridx (value[1], v_c) + if (temp <= 0) + goto badformat_ + else + TX_VJUSTIFY(tx) = v_v[temp] + + case 'f': # font + temp = stridx (value[1], f_c) + if (temp <= 0) + goto badformat_ + else + TX_FONT(tx) = f_v[temp] + + case 'q': # font quality + temp = stridx (value[1], q_c) + if (temp <= 0) + goto badformat_ + else + TX_QUALITY(tx) = q_v[temp] + + default: +badformat_ call eprintf ("Warning (GIO): bad gtext format '%s'\n") + call pargstr (format) + } + + if (format[ip] == EOS) + break + } +end diff --git a/sys/gio/gumark.x b/sys/gio/gumark.x new file mode 100644 index 00000000..cafb42bc --- /dev/null +++ b/sys/gio/gumark.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GUMARK -- Draw a user defined mark. The mark is defined by the polygon +# (x[i],y[i], i=1,npts), normalized to the unit square. This mark is mapped +# into the window at (XCEN,YCEN) of size XSIZE, YSIZE, where the mark center +# is always given in world coordinates but the size may be given in any of a +# number of ways, independently in X and Y. + +procedure gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) + +pointer gp # graphics descriptor +real x[ARB] # X coordinates of marker polygon (unit square) +real y[ARB] # Y coordinates of marker polygon (unit square) +int npts # number of points in marker polygon +real xcen, ycen # world coordinates of center of marker +real xsize, ysize # marker size in X and Y +int fill # draw marker using area fill + +pointer plap, pmap +bool scale_unset +int save_linetype, index, i +real x1, y1, xs, ys, dx, dy +real size[2], ndc_size[2], wcs_size[2] + +begin + plap = GP_PLAP(gp) + pmap = GP_PMAP(gp) + + # Determine the marker size in world coordinates. Marksizes 1:4 are + # "standard size" markers. A marksize of [0-1) is an explicit marker + # size in NDC coordinates, while a negative marksize is an explicit + # marker size in world coordinates. + + size[1] = xsize + size[2] = ysize + scale_unset = true + + do i = 1, 2 + if (size[i] > 0) { + if (size[i] - 1.0 > -EPSILON) { + # Use a default marker size. + index = min (MAX_SZMARKER, int(size[i])) + ndc_size[i] = GP_SZMARKER (gp, index) + + # Correct for the aspect ratio. + if (i == 1) + ndc_size[1] = ndc_size[1] * GP_DEVASPECT(gp) + } else + ndc_size[i] = size[i] + + # Convert to size in world coords. + if (scale_unset) { + # Get the scale in wcs units per ndc unit at (x,y). + call ggscale (gp, xcen, ycen, dx, dy) + scale_unset = false + } + if (i == 1) + wcs_size[1] = ndc_size[1] * abs(dx) + else + wcs_size[2] = ndc_size[2] * abs(dy) + + } else + wcs_size[i] = -size[i] + + # Set fill area instruction type if filling, otherwise set linetype + # if marker will be drawn as a polyline. Do nothing if polymarker + # linetype is same as polyline linetype. + + if (fill == YES) + call gpl_settype (gp, FILLAREA) + else { + save_linetype = PL_LTYPE(plap) + if (save_linetype != PM_LTYPE(pmap)) { + call gpl_flush() + PL_LTYPE(plap) = PM_LTYPE(pmap) + PL_STATE(plap) = MODIFIED + } + } + + # Draw the marker, scaling as necessary to fit the mark window. Final + # mark need not have the same aspect ratio as the normalized mark. + # Leave the pen positioned to the center of the marker. + + xs = wcs_size[1] + ys = wcs_size[2] + x1 = xcen - (xs / 2.0) + y1 = ycen - (ys / 2.0) + + call gamove (gp, x[1] * xs + x1, y[1] * ys + y1) + do i = 2, npts + call gadraw (gp, x[i] * xs + x1, y[i] * ys + y1) + call gamove (gp, xcen, ycen) + + # If the polyline linetype was modified restore the original value. + # Do not need to do anything if polymarker linetype was same as + # polyline linetype. + + if (fill == YES) + call gpl_settype (gp, POLYLINE) + else if (save_linetype != PM_LTYPE(pmap)) { + call gpl_flush() + PL_LTYPE(plap) = save_linetype + PL_STATE(plap) = MODIFIED + } +end diff --git a/sys/gio/gvline.x b/sys/gio/gvline.x new file mode 100644 index 00000000..929fab44 --- /dev/null +++ b/sys/gio/gvline.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GVLINE -- Vector polyline. Draw a line connecting the points (X[i],V[i]), +# where the X[i] are evenly distributed from X1 to X2. + +procedure gvline (gp, v, npts, x1, x2) + +pointer gp # graphics descriptor +real v[ARB] # Y coordinates of the polyline +int npts # number of polyline points +real x1, x2 # range of X coordinates of the polyline + +int i +real dx + +begin + if (npts > 1) { + dx = (x2 - x1) / (npts - 1) + call gamove (gp, x1, v[1]) + do i = 2, npts + call gadraw (gp, (i-1) * dx + x1, v[i]) + } +end diff --git a/sys/gio/gvmark.x b/sys/gio/gvmark.x new file mode 100644 index 00000000..219f8bae --- /dev/null +++ b/sys/gio/gvmark.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GVMARK -- Vector polymarker. Output at sequence of markers at the vertices +# of a polygon, all markers the same type and size. The polygon is given by +# the set of points (X[i],V[i]), where the X[i] are evenly distributed from X1 +# to X2. The marker type GM_POINT is a special case. + +procedure gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) + +pointer gp # graphics descriptor +real v[ARB] # Y[i] polygon +int npts # number of points +real x1, x2 # range of X[i] +int marktype # marker type +real xsize, ysize # marker size + +int i +real dx + +begin + if (npts > 1) + if (marktype == GM_POINT) { + call gpl_settype (gp, POLYMARKER) + call gvline (gp, v, npts, x1, x2) + call gpl_settype (gp, POLYLINE) + } else { + dx = (x2 - x1) / (npts - 1) + do i = 1, npts + call gmark (gp, (i-1) * dx + x1, v[i], marktype, + xsize, ysize) + } +end diff --git a/sys/gio/imdkern/README b/sys/gio/imdkern/README new file mode 100644 index 00000000..da041be0 --- /dev/null +++ b/sys/gio/imdkern/README @@ -0,0 +1,85 @@ +IMDKERN - + +This directory contains the source for the simple GIO/IMD kernel, used to +draw graphics in a display frame buffer. It uses the data stream +interface to open the frame buffer and uses code from SGI to rasterize +the graphics. + +Special graphcap entries used by this kernel: + + CI Color index of graphics pixels + FN Display frame buffer + LO Width in pixels of line size 1.0 + LS Difference in pixels between line sizes + DB Print debug messages? + + +Revision notes... +---------------- +IMDKERN notes 20 December 1989 Z. G. Levay, STScI + + + o Make private copy idskern of gio/sgikern. + + o Change "sgi" filename and procedure prefixes to "imd" throughout + the code. Change sgk.x to idk.x. Changed imd_open to imd_fopen to + aviod conflict with a procedure in libds. The files are: + + font.com, font.h, idk.com, idk.h, idk.x, imd.com, imd.h, + imdcancel.x, imdclear.x, imdclose.x, imdclws.x, imdcolor.x, + imddrawch.x, imdescape.x, imdfa.x, imdfaset.x, imdflush.x, + imdfont.x, imdfopen.x, imdgcell.x, imdinit.x, imdipl.x, + imdkern.par, imdline.x, imdopenws.x, imdpcell.x, imdpl.x, + imdplset.x, imdpm.x, imdpmset.x, imdreset.x, imdtx.x, imdtxset.x, + ltype.dat, mkpkg, t_imdkern.x, x_imdkern.x, + + o Modify mkpkg to build the task locally without updating the system + library or install the task. + + o Add global parameters "frame" and "color" to task imdkern. + Modified imd_fopen to read task parameters and pass as arguments to + imd_openws. Added these parameters to imd_openws and the call to + idk_open. + + o In idk_open, added frame and color to the calling sequence. Added + a call to imd_mapframe to open the frame buffer as an image, + changed setting the bitmap size to use the frame buffer size (via + IMIO) instead of graphcap parameters. Set the bits per bitmap word + to 8. Set the maximum bitmap size to 2048x2048 pixels. Ripped out + the code for opening the SGI metacode file, DD string manipulation, + etc. Added ttygeti calls to read the frame and color from the + graphcap in case they were passed as INDEF. + + In idk_frame, changed the code to map an input and output section + of the frame buffer (via IMIO), read the bitmap line by line, + testing each word for any on bits, and writing the color index + value to the frame buffer pixel for each on bitmap bit. Set the + I/O buffer sizes to 64 lines (somewhat arbitrarily). + + In idk_open, Changed the code to compute the x and y max (right and + top edges) of the bitmap by one pixel to draw to the edge. In + idk_linewidth, changed the code to compute the gap at the frame + edges by one pixel. + + Removed sections of code dealing with non-bitmap format, rotated or + flipped bitmaps. + + +---------------- +Installation and checkout. (12/21/89 dct) + +Installed code in gio/imdkern. +Put hooks for new task IMDKERN in the PLOT package. +Moved imdkern.par to plot, moved frame,color params to after "generic". +Deleted file imdipl.x, identical to imdpl.x. +Renamed imdfopen.x to imdopen.x for consistency with other kernels; + changed procedure name to imd_opendev to avoid name collision with imdopen. +Deleted idk.h, contains only SGI metecode defs not used in idk.x. +In t_imdkern.x, moved the clgeti's for color,frame to after the clgeti for + "generic" (required by startup protocol for graphics subkernel). For the + generic case, added initializers to set values to -1 to flag not set. + Got rid of the IS_INDEFs in idk.x. Nothing wrong with these, I just try + to avoid using INDEF in low level system code. +mkpkg - link xx_imdkern.e, not x_imdkern.e, rename in the install (this is + necessary to permit local testing of new versions, else the installed BIN + version is used). diff --git a/sys/gio/imdkern/font.com b/sys/gio/imdkern/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/imdkern/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/imdkern/font.h b/sys/gio/imdkern/font.h new file mode 100644 index 00000000..eb2e72f4 --- /dev/null +++ b/sys/gio/imdkern/font.h @@ -0,0 +1,29 @@ +# FONT.H -- Font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/imdkern/idk.com b/sys/gio/imdkern/idk.com new file mode 100644 index 00000000..62e4eaf7 --- /dev/null +++ b/sys/gio/imdkern/idk.com @@ -0,0 +1,50 @@ +# IDK.COM -- The common for the IDK kernel. A common is used here for maximum +# efficiency (minimum indirection) when rasterizing vectors and encoding +# metacode. The maximum bitmap size is set at compile time in idk.h. + +# Booleans put here to avoid possible alignment problems. + +bool mf_bitmap # metafile type, metacode or bitmap +bool mf_rotate # rotate (swap x and y) +bool mf_yflip # flip y axis end for end +bool mf_update # update bitmap +bool mf_delete # delete metacode file after dispose +bool mf_debug # print kernel debugging messages +bool mf_swap2 # swap every 2 bytes on output +bool mf_swap4 # swap every 4 bytes on output +bool mf_oneperfile # store each frame in a new file + +common /idkboo/ mf_bitmap, mf_rotate, mf_yflip, mf_update, mf_delete, mf_debug, + mf_swap2, mf_swap4, mf_oneperfile + +# Everything else goes here. + +int mf_fd # image descriptor of frame buffer +int mf_frame # frame counter +char mf_fname[SZ_PATHNAME] # metafile filename +char mf_dispose[SZ_OSCMD] # host dispose command + +int mf_op # [MCODE] index into obuf +short mf_obuf[LEN_OBUF] # metacode buffer + +int mf_cx, mf_cy # [BITMAPS] current pen position +int mf_nbpb # packing factor, bits per byte +int mf_pxsize, mf_pysize # physical x, y size of bitmap, bits +int mf_wxsize, mf_wysize # x, y size of bitmap window, bits +int mf_xorigin, mf_yorigin # origin of bitmap window +real mf_xscale, mf_yscale # to convert from NDC to device coords +int mf_xmin, mf_xmax # x clipping limits +int mf_ymin, mf_ymax # y clipping limits +int mf_lenframe # frame size, words +int mf_linewidth # relative line width +int mf_lworigin # device width of line size 1.0 +real mf_lwslope # device pixels per line size increment +int mf_fbuf[LEN_FBUF] # frame buffer (BIG) +int mf_bitmask[BPW] # bit mask table +int mf_color # color index + +common /idkcom/ mf_fd, mf_frame, mf_op, mf_cx, mf_cy, mf_nbpb, mf_pxsize, + mf_pysize, mf_wxsize, mf_wysize, mf_xorigin, mf_yorigin, mf_xscale, + mf_yscale, mf_xmin, mf_xmax, mf_ymin, mf_ymax, mf_lenframe, + mf_linewidth, mf_lworigin, mf_lwslope, mf_fbuf, mf_bitmask, mf_color, + mf_obuf, mf_fname, mf_dispose diff --git a/sys/gio/imdkern/idk.x b/sys/gio/imdkern/idk.x new file mode 100644 index 00000000..4d711e12 --- /dev/null +++ b/sys/gio/imdkern/idk.x @@ -0,0 +1,509 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +.help idk +.nf --------------------------------------------------------------------------- +IDK -- Simple image display graphics interface. The purpose of this +interface is to provide a means of drawing into a graphics overlay in +an image display server via the IRAF data stream interface. The +interface works by rasterizing the GKI metacode, reading the display +frame buffer, merging the graphics raster with the frame buffer, and +writing back the raster to the frame buffer. + + g_out = idk_open (frame, color, tty) # device open + idk_close (g_out) # device close + idk_flush (g_out) # flush output + + idk_frame (g_out) # start a new frame + idk_move (g_out, x, y) # move to (x,y) + idk_draw (g_out, x, y) # draw a vector to (x,y) + idk_linewidth (g_out, width) # set line width (>=1) + +The procedures comprising the top end of the IDK interface are summarized +above and the code is included in this file. These procedures could be +rewritten by the user to talk directly to a graphics device if desired, +although the metacode file interface is likely to be simpler in most cases. + +The size of the bitmap is taken from the size of the display frame +buffer. Values of the frame buffer are set to the specified color index +for each set bitmap pixel. The final displayed color depends on the +display server. + +The following graphcap fields apply: + + DB have the kernel print debug messages during execution + LO width in device pixels of a line of size 1.0 + LS difference in device pixels between line sizes + CI color index, i.e., the frame buffer pixel value + FN display frame number + +.endhelp ---------------------------------------------------------------------- + +# NOTE -- The mf_physbit lookup table, used to map logical screen bits into +# physical bits in the bitmap (for NB != 8) is equivalenced to the mf_obuf +# array which is not otherwise used for bitmap devices. The length of the +# mf_obuf array must therefore be >= PX. + +define mf_physbit mf_obuf # union these two arrays [[[NOTE]]] +define BPW 32 # nbits in an integer +define LEN_FBUF (8192*8192/BPW) # max size bitmap / frame buffer +define LEN_OBUF 8192 # max size of buffer line +define SZ_DDSTR 256 # max size graphcap.DD +define SZ_OSCMD 256 # OS dispose command from graphcap.DD +define IOLINES 64 # image lines per i/o transfer + + +# IDK_OPEN -- Open the metacode file. Open the frame buffer as an image. +# Initialize the bitmap based on the size of the frame. + +int procedure idk_open (a_frame, a_color, tty) + +int a_color #I display device color index +int a_frame #I display buffer frame number +pointer tty #I pointer to graphcap descriptor + +real x, y +char strval[1] +int byte, off, i, j +int wcs, key, frame, color + +bool ttygetb() +real ttygetr() +int imd_mapframe(), ttygeti(), shifti(), imdrcur() +errchk imd_mapframe, ttygetr, ttygeti, ttygetb +include "idk.com" + +begin + frame = a_frame + color = a_color + + # The DB flag may be set in the graphcap entry for an IMD device to + # print debug messages during execution. + + mf_debug = ttygetb (tty, "DB") + if (mf_debug) { + call eprintf ("idk: open frame %d, color = %d\n") + call pargi (frame) + call pargi (color) + } + + mf_update = false + + # If the frame number was not specified as a parameter see if it is + # specified in the graphcap, else try to query the display to determine + # the current display frame and plot into that. + + if (frame <= 0) + iferr (frame = ttygeti (tty, "FN")) + frame = 0 + if (frame <= 0) + if (imdrcur ("stdimage", x, y, wcs, key, strval, 1, 0, NO) >= 0) + frame = max (1, wcs / 100) + else + frame = 1 + + # Find the color index in graphcap? + if (color < 0) + color = max(0, ttygeti (tty, "CI")) + + # Map the frame buffer as an image. + mf_fd = imd_mapframe (frame, READ_WRITE, YES) + + # Initialize bitmap parameters. + mf_pxsize = IM_LEN(mf_fd, 1) + mf_pysize = IM_LEN(mf_fd, 2) + mf_xorigin = 0 + mf_yorigin = 0 + mf_wxsize = IM_LEN(mf_fd, 1) - 1 + mf_wysize = IM_LEN(mf_fd, 2) - 1 + mf_nbpb = 8 + + # Line width parameters. + mf_lworigin = max (1, ttygeti (tty, "LO")) + mf_lwslope = ttygetr (tty, "LS") + + # Size of the frame buffer. + mf_lenframe = (mf_pxsize * mf_pysize + BPW-1) / BPW + + mf_color = color + mf_linewidth = mf_lworigin + + # Initial "pen" position. + mf_cx = 0 + mf_cy = 0 + + mf_xmin = mf_xorigin + mf_ymin = mf_yorigin + mf_xmax = mf_xmin + mf_wxsize + mf_ymax = mf_ymin + mf_wysize + + mf_xscale = real(mf_wxsize) / real(GKI_MAXNDC) + mf_yscale = real(mf_wysize) / real(GKI_MAXNDC) + + if (mf_lenframe > LEN_FBUF) + call error (1, "imdkern: bitmap too large") + + # Initialize the bit mask table. + do j = 1, (BPW/NBITS_BYTE) + do i = 1, NBITS_BYTE { + off = (j - 1) * NBITS_BYTE + mf_bitmask[off+i] = shifti (1, off + NBITS_BYTE - i) + } + + # Initialize the bit offset lookup table. This gives the physical + # x-offset into the lookup table of each addressable x-coordinate + # on the device. If NB is NBITS_BYTE the mapping is one-to-one. + # Note that the table contains zero-indexed bit offsets. + + do i = 1, mf_pxsize { + byte = (i - 1) / mf_nbpb + mf_physbit[i] = min (mf_pxsize, + byte * NBITS_BYTE + (i - (byte * mf_nbpb))) - 1 + } + + if (mf_debug) { + call eprintf ("bitmap [%d,%d] origin=[%d,%d] wsize=[%d,%d]\n") + call pargi (mf_pxsize); call pargi (mf_pysize) + call pargi (mf_xorigin); call pargi (mf_yorigin) + call pargi (mf_wxsize); call pargi (mf_wysize) + } + + return (mf_fd) +end + + +# IDK_CLOSE -- Update the display frame buffer and close the display. + +procedure idk_close (fd) + +int fd # output stream [NOT USED] + +errchk idk_frame, imunmap +include "idk.com" + +begin + if (mf_debug) + call eprintf ("close device\n") + + call idk_frame (mf_fd) + + if (mf_fd != NULL) { + call imunmap (mf_fd) + mf_fd = NULL + } +end + + +# IDK_FLUSH -- Flush any buffered metacode output. + +procedure idk_flush (fd) + +int fd # output stream [NOT USED] +include "idk.com" + +begin + if (mf_fd != NULL) + call imflush (mf_fd) +end + + +# IDK_FRAME -- Output a frame. Overlay the bitmap on the frame buffer. +# Map the display frame as an image section and process the bitmap line by +# line. + +procedure idk_frame (fd) + +int fd # output stream [NOT USED] + +int x1, x2, y1, y2 +int bmw # Bitmap word offset +int npix # Pixels in local I/O buffer +int fbp # Frame buffer section offset +int fbp0 +int i, j +int line +pointer ob, ib + +pointer imps2s(), imgs2s() +include "idk.com" + +begin + # Ignore frame commands if frame is empty. + if (!mf_update) + return + + if (mf_debug) { + call eprintf ("Write the frame, color = %d\n") + call pargi (mf_color) + } + + # Write the bitmap to the output frame buffer. + + y2 = 0 + for (y1=1; y2 < mf_pysize; y1=y1+IOLINES) { + # For each buffer section of the frame. + y2 = min (y1 + IOLINES-1, mf_pysize) + x1 = 1 + x2 = mf_pxsize + + # Map the frame section. + ob = imps2s (mf_fd, x1, x2, y1, y2) + ib = imgs2s (mf_fd, x1, x2, y1, y2) + + npix = mf_pxsize * (y2 - y1 + 1) + + if (ob != ib) + # Copy the input buffer to the output buffer + call amovs (Mems[ib], Mems[ob], npix) + + do line = y1, y2 { + # Each line in the local frame buffer section + fbp0 = (line - y1) * mf_pxsize + + do i = 1, mf_pxsize / BPW { + # Each word in the bitmap line. + bmw = (line - 1) * mf_pxsize / BPW + i + + if (mf_fbuf[bmw] != 0) { + do j = 1, BPW { + # Each bit in the bitmap word. + + if (and (mf_fbuf[bmw], mf_bitmask[j]) != 0) { + # An ON bit. + fbp = fbp0 + (i-1) * BPW + j + Mems[ob+fbp-1] = mf_color + } + } + } + } + } + } + + mf_update = false +end + + +# IDK_MOVE -- Output a pen move instruction. + +procedure idk_move (fd, x, y) + +int fd # output stream [NOT USED] +int x, y # point to move to + +include "idk.com" + +begin + mf_cx = x + mf_cy = y + + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + mf_cx = max (mf_xmin, min (mf_xmax, + int (mf_cx * mf_xscale) + mf_xorigin)) + mf_cy = max (mf_ymin, min (mf_ymax, + int (mf_cy * mf_yscale) + mf_yorigin)) +end + + +# IDK_DRAW -- Output a pen draw instruction. + +procedure idk_draw (fd, a_x, a_y) + +int fd # output stream [NOT USED] +int a_x, a_y # point to draw to + +int xshift, yshift, dx, dy +int new_x, new_y, x1, y1, x2, y2, n, i +include "idk.com" + +begin + new_x = a_x + new_y = a_y + + if (!mf_update) { + # We are called when the first drawing instruction is output for a + # new frame. We clear the bitmap. + + # Zero out all the bits in a bitmap. + call aclri (mf_fbuf, mf_lenframe) + + mf_update = true + } + + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + new_x = max (mf_xmin, min (mf_xmax, + int (new_x * mf_xscale) + mf_xorigin)) + new_y = max (mf_ymin, min (mf_ymax, + int (new_y * mf_yscale) + mf_yorigin)) + + if (mf_linewidth <= 1) + call idk_vector (mf_cx, mf_cy, new_x, new_y) + else { + # Redraw the vector several times with small normal shifts to + # produce a wider line. + + xshift = 0 + yshift = 0 + + if (abs (new_x - mf_cx) > abs (new_y - mf_cy)) { + dx = 0 + dy = 1 + } else { + dx = 1 + dy = 0 + } + + do i = 1, mf_linewidth { + x1 = mf_cx + xshift + y1 = mf_cy + yshift + x2 = new_x + xshift + y2 = new_y + yshift + + call idk_vector (x1, y1, x2, y2) + + n = (i + 1) / 2 + if (and (i, 1) == 0) { + xshift = dx * n + yshift = dy * n + } else { + xshift = -dx * n + yshift = -dy * n + } + } + } + + # Update the current pen position, and set the update flag so that + # the bitmap will be written to the output file. + + mf_cx = new_x + mf_cy = new_y +end + + +# IDK_VECTOR -- Write a vector (line) of unit width into the bitmap. The line +# endpoints are expressed in physical device coordinates. + +procedure idk_vector (a_x1, a_y1, a_x2, a_y2) + +int a_x1, a_y1 # start point of line +int a_x2, a_y2 # end point of line + +real dydx, dxdy +long fbit, wbit, word +int wpln, mask, dx, dy, x, y, x1, y1, x2, y2, or() +include "idk.com" + +begin + x1 = a_x1; y1 = a_y1 + x2 = a_x2; y2 = a_y2 + + dx = x2 - x1 + dy = y2 - y1 + + if (abs(dx) > abs(dy)) { + if (x1 > x2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dy == 0 && mf_nbpb == NBITS_BYTE) { + # Somewhat optimized code for the case of a horiz. vector. + + fbit = y1 * mf_pxsize + x1 + word = fbit / BPW + wbit = and (fbit, BPW-1) + + do x = x1, x2 { + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + wbit = wbit + 1 + if (wbit >= BPW) { + wbit = 0 + word = word + 1 + } + } + + } else { + # The general case for a mostly-X vector. + + dydx = real(dy) / real(dx) + do x = x1, x2 { + y = int ((x - x1) * dydx) + y1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else if (dy != 0) { + if (y1 > y2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dx == 0) { + # Optimized code for the case of a vertical vector. + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + 1 + wbit = and (fbit, BPW-1) + wpln = (mf_pxsize + BPW-1) / BPW + mask = mf_bitmask[wbit+1] + + do y = y1, y2 { + mf_fbuf[word] = or (mf_fbuf[word], mask) + word = word + wpln + } + + } else { + # The general case of a mostly-Y vector. + + dxdy = real(dx) / real(dy) + do y = y1, y2 { + x = int ((y - y1) * dxdy) + x1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else { + # Plot a single point (dx=dy=0). + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } +end + + +# IDK_LINEWIDTH -- Output a line width set instruction. + +procedure idk_linewidth (fd, width) + +int fd # output stream [NOT USED] +int width # new line width + +int gap +include "idk.com" + +begin + # Set the line width in device pixels. + mf_linewidth = max (1, mf_lworigin + int ((width-1) * mf_lwslope)) + + # Set the clipping limits. Allow for shifting to widen lines. + gap = mf_linewidth / 2 + mf_xmin = mf_xorigin + gap + mf_ymin = mf_yorigin + gap + mf_xmax = mf_xorigin + mf_wxsize - gap + mf_ymax = mf_yorigin + mf_wysize - gap +end diff --git a/sys/gio/imdkern/imd.com b/sys/gio/imdkern/imd.com new file mode 100644 index 00000000..12cba65e --- /dev/null +++ b/sys/gio/imdkern/imd.com @@ -0,0 +1,18 @@ +# IMD common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_kt # kernel transform graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in, g_out # input, output files +int g_xres, g_yres # desired device resolution +int g_frame, g_color # display frame and graphics color +char g_device[SZ_GDEVICE] # force output to named device + +common /gioimd/ g_kt, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_out, g_xres, g_yres, g_frame, g_color, g_device diff --git a/sys/gio/imdkern/imd.h b/sys/gio/imdkern/imd.h new file mode 100644 index 00000000..a0e5d2d5 --- /dev/null +++ b/sys/gio/imdkern/imd.h @@ -0,0 +1,77 @@ +# IMD global definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_GDEVICE 31 # maxsize forced device name +define DEF_MAXFRAMES 16 # maximum frames/metafile + +# The IMD state/device descriptor. + +define LEN_IMD 81 + +define IMD_SBUF Memi[$1] # string buffer +define IMD_SZSBUF Memi[$1+1] # size of string buffer +define IMD_NEXTCH Memi[$1+2] # next char pos in string buf +define IMD_NCHARSIZES Memi[$1+3] # number of character sizes +define IMD_POLYLINE Memi[$1+4] # device supports polyline +define IMD_POLYMARKER Memi[$1+5] # device supports polymarker +define IMD_FILLAREA Memi[$1+6] # device supports fillarea +define IMD_CELLARRAY Memi[$1+7] # device supports cell array +define IMD_XRES Memi[$1+8] # device resolution in X +define IMD_YRES Memi[$1+9] # device resolution in Y +define IMD_ZRES Memi[$1+10] # device resolution in Z +define IMD_FILLSTYLE Memi[$1+11] # number of fill styles +define IMD_ROAM Memi[$1+12] # device supports roam +define IMD_ZOOM Memi[$1+13] # device supports zoom +define IMD_SELERASE Memi[$1+14] # device has selective erase +define IMD_PIXREP Memi[$1+15] # device supports pixel replic. +define IMD_STARTFRAME Memi[$1+16] # frame advance at metafile BOF +define IMD_ENDFRAME Memi[$1+17] # frame advance at metafile EOF + # extra space +define IMD_CURSOR Memi[$1+20] # last cursor accessed +define IMD_COLOR Memi[$1+21] # last color set +define IMD_TXSIZE Memi[$1+22] # last text size set +define IMD_TXFONT Memi[$1+23] # last text font set +define IMD_TYPE Memi[$1+24] # last line type set +define IMD_WIDTH Memi[$1+25] # last line width set +define IMD_DEVNAME Memi[$1+26] # name of open device +define IMD_FRAME Memi[$1+27] # frame buffer number + # extra space +define IMD_CHARHEIGHT Memi[$1+30+$2-1] # character height +define IMD_CHARWIDTH Memi[$1+40+$2-1] # character width +define IMD_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define IMD_PLAP ($1+60) # polyline attributes +define IMD_PMAP ($1+64) # polymarker attributes +define IMD_FAAP ($1+68) # fill area attributes +define IMD_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/imdkern/imdcancel.x b/sys/gio/imdkern/imdcancel.x new file mode 100644 index 00000000..68832ae4 --- /dev/null +++ b/sys/gio/imdkern/imdcancel.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_CANCEL -- Cancel any buffered output. + +procedure imd_cancel (dummy) + +int dummy # not used at present +include "imd.com" + +begin + if (g_kt == NULL) + return + call imd_reset() +end diff --git a/sys/gio/imdkern/imdclear.x b/sys/gio/imdkern/imdclear.x new file mode 100644 index 00000000..bf471998 --- /dev/null +++ b/sys/gio/imdkern/imdclear.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure imd_clear (dummy) + +int dummy # not used at present + +int idk_open() +errchk idk_open +include "imd.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_kt == NULL || g_ndraw == 0) + return + + # Start a new frame. This is done either by issuing the frame advance + # instruction or by starting a new metafile. Close the output file and + # start a new metafile if the maximum frame count has been reached. + # This disposes of the metafile to the system, causing the actual + # plots to be drawn. Open a new metafile ready to receive next frame. + + g_nframes = g_nframes + 1 + if (g_nframes >= g_maxframes) { + + # Does this device require a frame advance at end of metafile? + if (IMD_ENDFRAME(g_kt) == YES) + call idk_frame (g_out) + + g_nframes = 0 + call idk_close (g_out) + #g_out = idk_open (Memc[IMD_DEVNAME(g_kt)], g_tty) + g_out = idk_open (g_frame, g_color, g_tty) + + # Does this device require a frame advance at beginning of metafile? + if (IMD_STARTFRAME(g_kt) == YES) + call idk_frame (g_out) + + } else { + # Merely output frame instruction to start a new frame in the same + # metafile. + + call idk_frame (g_out) + } + + # Init kernel data structures. + call imd_reset() + g_ndraw = 0 +end diff --git a/sys/gio/imdkern/imdclose.x b/sys/gio/imdkern/imdclose.x new file mode 100644 index 00000000..7283f5db --- /dev/null +++ b/sys/gio/imdkern/imdclose.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_CLOSE -- Close the IMD translation kernel. Close the spool file so +# the output is finally plotted. Free up storage. + +procedure imd_close() + +include "imd.com" + +begin + # Check for a redundant imd_close call. + if (g_kt == NULL) + return + + # If there is anything in the metafile, flush it and add a frame + # advance if required for the device. + + if (g_ndraw > 0 || g_nframes > 0) { + # Does this device require a frame advance at end of metafile? + if (IMD_ENDFRAME(g_kt) == YES) + call idk_frame (g_out) + } + + # Close output metafile, disposing of it to the host system. + call idk_close (g_out) + + # Return tty descriptor. + call ttycdes (g_tty) + + # Free kernel data structures. + call mfree (IMD_SBUF(g_kt), TY_CHAR) + call mfree (g_kt, TY_STRUCT) + + g_kt = NULL +end diff --git a/sys/gio/imdkern/imdclws.x b/sys/gio/imdkern/imdclws.x new file mode 100644 index 00000000..45072697 --- /dev/null +++ b/sys/gio/imdkern/imdclws.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_CLOSEWS -- Close the named workstation. Flush the output. +# The spool file is closed only on the next plot or at gktclose time. +# If the spool file is closed here, APPEND mode would not work. + +procedure imd_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +include "imd.com" + +begin + # For the IMD kernel, all display graphics writes are in append mode, + # so we may as well shutdown completely for closews (this also ensures + # that the display is updated at closews time). + + #call idk_flush (g_out) + call imd_close() +end diff --git a/sys/gio/imdkern/imdcolor.x b/sys/gio/imdkern/imdcolor.x new file mode 100644 index 00000000..581af9a2 --- /dev/null +++ b/sys/gio/imdkern/imdcolor.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_COLOR -- Set line drawing color. + +procedure imd_color (index) + +int index # index for color switch statement +include "imd.com" + +begin + # switch (index) { + # case WHITE: + # case RED: + # case GREEN: + # case BLUE: + # default: + # } +end diff --git a/sys/gio/imdkern/imddrawch.x b/sys/gio/imdkern/imddrawch.x new file mode 100644 index 00000000..17327563 --- /dev/null +++ b/sys/gio/imdkern/imddrawch.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# IMD_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure imd_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +int mx, my +real px, py, coso, sino, theta +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" +include "imd.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call imd_font (font) + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + mx = x + px * coso + py * sino + my = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call idk_move (g_out, mx, my) + else + call idk_draw (g_out, mx, my) + } +end diff --git a/sys/gio/imdkern/imdescape.x b/sys/gio/imdkern/imdescape.x new file mode 100644 index 00000000..2c2c3a26 --- /dev/null +++ b/sys/gio/imdkern/imdescape.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMD_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The IDK kernel does not have any escape functions at present. + +procedure imd_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +begin +end diff --git a/sys/gio/imdkern/imdfa.x b/sys/gio/imdkern/imdfa.x new file mode 100644 index 00000000..03bf446e --- /dev/null +++ b/sys/gio/imdkern/imdfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_FILLAREA -- Fill a closed area. + +procedure imd_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "imd.com" + +begin + # Not implemented yet. + call imd_polyline (p, npts) +end diff --git a/sys/gio/imdkern/imdfaset.x b/sys/gio/imdkern/imdfaset.x new file mode 100644 index 00000000..b790cef9 --- /dev/null +++ b/sys/gio/imdkern/imdfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_FASET -- Set the fillarea attributes. + +procedure imd_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "imd.com" + +begin + fa = IMD_FAAP(g_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/imdkern/imdflush.x b/sys/gio/imdkern/imdflush.x new file mode 100644 index 00000000..d22f04c9 --- /dev/null +++ b/sys/gio/imdkern/imdflush.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_FLUSH -- Flush output. + +procedure imd_flush (dummy) + +int dummy # not used at present +include "imd.com" + +begin + call idk_flush (g_out) +end diff --git a/sys/gio/imdkern/imdfont.x b/sys/gio/imdkern/imdfont.x new file mode 100644 index 00000000..3117258b --- /dev/null +++ b/sys/gio/imdkern/imdfont.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +# IMD_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set IMD_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure imd_font (font) + +int font # code for font to be set +int pk2, width +include "imd.com" + +begin + width = IMD_WIDTH(g_kt) + pk2 = GKI_PACKREAL(2.0) + + if (font == GT_BOLD) { + if (width != pk2) { + call idk_linewidth (g_out, 2) + width = pk2 + } + } else + call idk_linewidth (g_out, nint (GKI_UNPACKREAL(width))) + + IMD_WIDTH(g_kt) = width +end diff --git a/sys/gio/imdkern/imdgcell.x b/sys/gio/imdkern/imdgcell.x new file mode 100644 index 00000000..0c384d70 --- /dev/null +++ b/sys/gio/imdkern/imdgcell.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMD_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure imd_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. +end diff --git a/sys/gio/imdkern/imdinit.x b/sys/gio/imdkern/imdinit.x new file mode 100644 index 00000000..ceed3948 --- /dev/null +++ b/sys/gio/imdkern/imdinit.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" + +# IMD_INIT -- Initialize the gkt data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine IMD_RESET initializes the attribute +# packets when the frame is flushed. + +procedure imd_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "imd.com" + +begin + # Allocate the gkt descriptor and the string buffer. + if (g_kt == NULL) { + call calloc (g_kt, LEN_IMD, TY_STRUCT) + call malloc (IMD_SBUF(g_kt), SZ_SBUF, TY_CHAR) + } + + # Get the maximum frame count and the flags controlling frame advance + # at start and end of metafile. + + g_maxframes = ttygeti (tty, "MF") + if (g_maxframes == 0) + g_maxframes = DEF_MAXFRAMES + IMD_STARTFRAME(g_kt) = btoi (ttygetb (tty, "FS")) + IMD_ENDFRAME(g_kt) = btoi (ttygetb (tty, "FE")) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + IMD_SZSBUF(g_kt) = SZ_SBUF + IMD_NEXTCH(g_kt) = IMD_SBUF(g_kt) + 1 + Memc[IMD_SBUF(g_kt)] = EOS + + # Get the device resolution from the graphcap entry. + + g_xres = ttygeti (tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_yres = ttygeti (tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + IMD_NCHARSIZES(g_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = IMD_NEXTCH(g_kt) + + if (IMD_NCHARSIZES(g_kt) <= 0) { + IMD_NCHARSIZES(g_kt) = 1 + IMD_CHARSIZE(g_kt,1) = 1.0 + IMD_CHARHEIGHT(g_kt,1) = char_height + IMD_CHARWIDTH(g_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= IMD_NCHARSIZES(g_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + IMD_CHARSIZE(g_kt,i) = char_size + IMD_CHARHEIGHT(g_kt,i) = char_height * char_size + IMD_CHARWIDTH(g_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the gkt + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + IMD_POLYLINE(g_kt) = btoi (ttygetb (tty, "pl")) + IMD_POLYMARKER(g_kt) = btoi (ttygetb (tty, "pm")) + IMD_FILLAREA(g_kt) = btoi (ttygetb (tty, "fa")) + IMD_FILLSTYLE(g_kt) = ttygeti (tty, "fs") + IMD_ROAM(g_kt) = btoi (ttygetb (tty, "ro")) + IMD_ZOOM(g_kt) = btoi (ttygetb (tty, "zo")) + IMD_XRES(g_kt) = ttygeti (tty, "xr") + IMD_YRES(g_kt) = ttygeti (tty, "yr") + IMD_ZRES(g_kt) = ttygeti (tty, "zr") + IMD_CELLARRAY(g_kt) = btoi (ttygetb (tty, "ca")) + IMD_SELERASE(g_kt) = btoi (ttygetb (tty, "se")) + IMD_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + IMD_CURSOR(g_kt) = 1 + + # Save the device string in the descriptor. + nextch = IMD_NEXTCH(g_kt) + IMD_DEVNAME(g_kt) = nextch + maxch = IMD_SBUF(g_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + IMD_NEXTCH(g_kt) = nextch +end + + +# IMD_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure imd_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "imd.com" + +begin + nextch = IMD_NEXTCH(g_kt) + maxch = IMD_SBUF(g_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = IMD_SBUF(g_kt) + + IMD_NEXTCH(g_kt) = nextch + return (strp) +end diff --git a/sys/gio/imdkern/imdline.x b/sys/gio/imdkern/imdline.x new file mode 100644 index 00000000..86f32c0a --- /dev/null +++ b/sys/gio/imdkern/imdline.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_LINETYPE -- Set the line type option. + +procedure imd_linetype (index) + +int index # index for line type switch statement + +int linetype +include "imd.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 2 + case GL_DOTTED: + linetype = 3 + case GL_DOTDASH: + linetype = 4 + default: + linetype = 1 # solid + } + + # This will be done in software in a future version of the IMD kernel. + # call idk_linetype (g_out, linetype) +end diff --git a/sys/gio/imdkern/imdopen.x b/sys/gio/imdkern/imdopen.x new file mode 100644 index 00000000..2a563360 --- /dev/null +++ b/sys/gio/imdkern/imdopen.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_OPENDEV -- Install the IMD kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure imd_opendev (devname, frame, color, dd) + +char devname[ARB] # nonnull for forced output to a device +int frame # display frame buffer number +int color # graphics overlay color index +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern imd_openws(), imd_closews(), imd_clear(), imd_cancel() +extern imd_flush(), imd_polyline(), imd_polymarker(), imd_text() +extern imd_fillarea(), imd_putcellarray(), imd_plset() +extern imd_pmset(), imd_txset(), imd_faset() +extern imd_escape() +include "imd.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_kt = NULL + g_nframes = 0 + g_ndraw = 0 + g_frame = frame + g_color = color + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (imd_openws) + dd[GKI_CLOSEWS] = locpr (imd_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (imd_clear) + dd[GKI_CANCEL] = locpr (imd_cancel) + dd[GKI_FLUSH] = locpr (imd_flush) + dd[GKI_POLYLINE] = locpr (imd_polyline) + dd[GKI_POLYMARKER] = locpr (imd_polymarker) + dd[GKI_TEXT] = locpr (imd_text) + dd[GKI_FILLAREA] = locpr (imd_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (imd_putcellarray) + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (imd_plset) + dd[GKI_PMSET] = locpr (imd_pmset) + dd[GKI_TXSET] = locpr (imd_txset) + dd[GKI_FASET] = locpr (imd_faset) + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (imd_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call imd_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/imdkern/imdopenws.x b/sys/gio/imdkern/imdopenws.x new file mode 100644 index 00000000..cdfaeee0 --- /dev/null +++ b/sys/gio/imdkern/imdopenws.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" + +# IMD_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure imd_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +int idk_open() +bool need_open, same_dev +include "imd.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_kt != NULL) { + same_dev = (streq (Memc[IMD_DEVNAME(g_kt)], Memc[buf])) + if (!same_dev) { + # Does this device require a frame advance at end of metafile? + if (IMD_ENDFRAME(g_kt) == YES) + call idk_frame (g_out) + call idk_close (g_out) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if (!same_dev) { + if (g_kt != NULL) + call ttycdes (g_tty) + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + + # Initialize data structures if we had to open a new device. + call imd_init (g_tty, Memc[buf]) + call imd_reset() + } + + # Open the output file. Metacode output to the device will be + # spooled and then disposed of to the device at CLOSEWS time. + + iferr (g_out = idk_open (g_frame, g_color, g_tty)) { + call ttycdes (g_tty) + call erract (EA_ERROR) + } else { + # Does this device require a frame advance at start of metafile? + if (IMD_STARTFRAME(g_kt) == YES) + call idk_frame (g_out) + g_nframes = 0 + g_ndraw = 0 + } + } + + # Clear the screen if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will clear + # the screen if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call imd_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/imdkern/imdpcell.x b/sys/gio/imdkern/imdpcell.x new file mode 100644 index 00000000..deb61d18 --- /dev/null +++ b/sys/gio/imdkern/imdpcell.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +define DEF_YRES 8192 # default height of device pixel in GKI units +define ZSTEP 4 # bit to be tested (step function width) + + +# IMD_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). The algorithm used here maps 8 bits in into 1 bit +# out, using a step function lookup table. The result is a band-contoured +# image, where the spacing and width of the contour bands decreases as the +# rate of change of intensity in the input cell array increases. + +procedure imd_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +bool ttygetb() +include "imd.com" + +begin + if (ttygetb (g_tty, "BI")) + call imd_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + else + call imd_mcell (m, nx, ny, ax1,ay1, ax2,ay2) +end + + +# IMD_BCELL -- Put cell array, optimized for a bitmap device. In this case, +# to get the maximum resolution at maximum efficiency it is desirable for the +# main loop to be over device pixels, mapping the device pixel into the +# nearest line of the input cell array. + +procedure imd_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int my, i1, i2, v, i, j, k +include "imd.com" +int and() + +begin + # Count drawing instruction, set polyline width to 1 for max y-res. + g_ndraw = g_ndraw + 1 + call idk_linewidth (g_out, 1) + IMD_WIDTH(g_kt) = 0 + + # Determine the width of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + + # Determine the height of a device pixel in GKI units. + if (IMD_YRES(g_kt) <= 0) + dy = GKI_MAXNDC / DEF_YRES + else + dy = max (1.0, real(GKI_MAXNDC) / real(IMD_YRES(g_kt))) + + # Process the cell array. The outer loop runs over device pixels in Y; + # each iteration writes one line of the output raster. The inner loop + # runs down a line of the cell array. + + k = 0 + for (my = ay1 + dy/2; my < ay2; my = k * dy + ay1) { + j = max(1, min(ny, int (real(my-ay1) / real(ay2-ay1) * (ny-1)) + 1)) + my = min (my, int (ay2 - dy/2)) + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i1 + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call idk_move (g_out, int ((i1-1) * dx + ax1), my) + call idk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + + k = k + 1 + } +end + + +# IMD_MCELL -- Put cell array, optimized for a metafile device. In this case, +# it is prohibitively expensive to draw into each resolvable line of the +# output device. It is better to set the linewidth to the width of a cell +# array pixel, output the minimum number of drawing instructions, and let the +# metafile device widen the lines. + +procedure imd_mcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int yres, my, i1, i2, v, i, j +include "imd.com" +int and() + +begin + # Count drawing instruction, clobber saved polyline width. + g_ndraw = g_ndraw + 1 + IMD_WIDTH(g_kt) = 0 + + # Determine the width and height of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + dy = real (ay2 - ay1) / ny + + # Set the IDK line width to the height of a pixel in the cell array. + yres = IMD_YRES(g_kt) + if (yres <= 0) + yres = DEF_YRES + call idk_linewidth (g_out, + max (1, nint (dy / (real(GKI_MAXNDC) / real(yres))))) + + # Process the cell array. The outer loop runs over lines of the input + # cell array; each iteration writes only one line of the output raster, + # but the width of the line is adjusted to the height of a pixel in + # the cell array (the resolution of the cell array should not exceed + # that of the device). + + for (j=1; j <= ny; j=j+1) { + my = int ((j - 0.5) * dy) + ay1 + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call idk_move (g_out, int ((i1-1) * dx + ax1), my) + call idk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + } +end diff --git a/sys/gio/imdkern/imdpl.x b/sys/gio/imdkern/imdpl.x new file mode 100644 index 00000000..7c94f7d2 --- /dev/null +++ b/sys/gio/imdkern/imdpl.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +define MAX_LTYPES 3 # max software line type patterns (excl. solid) +define MAX_LSEGMENTS 4 # max line segments per pattern +define LT_OFFSET 1 # offset to be subtracted from ltype code + + +# IMD_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure imd_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int x, y +int len_p, i +include "imd.com" + +begin + if (npts < 2) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = IMD_PLAP(g_kt) + + if (IMD_WIDTH(g_kt) != PL_WIDTH(pl)) { + call idk_linewidth (g_out, nint (GKI_UNPACKREAL(PL_WIDTH(pl)))) + IMD_WIDTH(g_kt) = PL_WIDTH(pl) + } + if (IMD_COLOR(g_kt) != PL_COLOR(pl)) { + call imd_color (PL_COLOR(pl)) + IMD_COLOR(g_kt) = PL_COLOR(pl) + } + + if (PL_LTYPE(pl) == GL_CLEAR) { + # Ignore clear (erase) polylines. + ; + + } else if (PL_LTYPE(pl) != GL_SOLID) { + # Draw a dashed or dotted polyline of the indicated type. + call imd_dashline (g_out, p, npts, PL_LTYPE(pl)) + + } else { + # Draw a solid polyline (usual case, optimized). + + # Move to the first point. + x = p[1] + y = p[2] + call idk_move (g_out, x, y) + + # Draw the polyline. + for (i=3; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call idk_draw (g_out, x, y) + } + } +end + + +# IMD_DASHLINE -- Draw a dashed or dotted polyline using the indicated line +# style. + +procedure imd_dashline (g_out, p, npts, ltype) + +int g_out # output file +short p[ARB] # the polyline points +int npts # number of points, i.e., (x,y) pairs +int ltype # desired line type + +bool penup +int len_p, i +real vlen, vpos, seglen, dx, dy +int oldx, oldy, newx, newy, penx, peny +int imd_getseg() + +begin + len_p = npts * 2 + + oldx = p[1]; oldy = p[2] + call idk_move (g_out, oldx, oldy) + + # Process each line segment in the polyline. + do i = 3, len_p, 2 { + newx = p[i] + newy = p[i+1] + + # Compute VLEN, the length of the polyline line segment to be + # drawn, VPOS, the relative position along the line segment, + # and DX and DY, the scale factors to be applied to VPOS to get + # the x and y coordinates of a point along the line segment. + + dx = newx - oldx + dy = newy - oldy + vlen = sqrt (dx*dx + dy*dy) + if (vlen < 1.0) # GKI units + next + + dx = dx / vlen + dy = dy / vlen + vpos = 0.0 + + # For each line segment, get segments of the line type pattern + # until all of the current line segment has been drawn. The pattern + # wraps around indefinitely, following the polyline around the + # vertices with concern only for the total length traversed. + + while (vlen - vpos >= 1.0) { + seglen = imd_getseg (int (vlen - vpos), penup, ltype) + if (seglen < 1.0) + break + + vpos = vpos + seglen + penx = oldx + vpos * dx + peny = oldy + vpos * dy + + if (penup) + call idk_move (g_out, penx, peny) + else + call idk_draw (g_out, penx, peny) + } + + oldx = newx + oldy = newy + } +end + + +# IMD_GETSEG -- Get a segment of a line style pattern. The segment extends +# from the current position in the pattern to either the next penup/pendown +# breakpoint in the pattern, or to the point MAXLEN units further along in +# the pattern. When the end of the pattern is reached wrap around and +# duplicate the pattern indefinitely. + +int procedure imd_getseg (maxlen, penup, ltype) + +int maxlen # max length segment to be returned +bool penup # [out] pen up or pen down type segment? +int ltype # line type code + +int seglen, seg, lt +int p_seg[MAX_LTYPES] +int p_nseg[MAX_LTYPES] +int p_segleft[MAX_LTYPES] +bool p_penup[MAX_LTYPES,MAX_LSEGMENTS] +int p_seglen[MAX_LTYPES,MAX_LSEGMENTS] +include "ltype.dat" + +begin + lt = max (1, min (MAX_LTYPES, ltype - LT_OFFSET)) + seg = p_seg[lt] + penup = p_penup[lt,seg] + + repeat { + if (maxlen < p_segleft[lt]) { + seglen = maxlen + p_segleft[lt] = p_segleft[lt] - seglen + } else { + seglen = p_segleft[lt] + seg = seg + 1 + if (seg > p_nseg[lt]) + seg = 1 + p_seg[lt] = seg + p_segleft[lt] = p_seglen[lt,seg] + } + } until (seglen > 0) + + return (seglen) +end diff --git a/sys/gio/imdkern/imdplset.x b/sys/gio/imdkern/imdplset.x new file mode 100644 index 00000000..22743178 --- /dev/null +++ b/sys/gio/imdkern/imdplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure imd_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "imd.com" + +begin + pl = IMD_PLAP(g_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/imdkern/imdpm.x b/sys/gio/imdkern/imdpm.x new file mode 100644 index 00000000..d7bcddac --- /dev/null +++ b/sys/gio/imdkern/imdpm.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure imd_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int x, y, oldx, oldy +include "imd.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = IMD_PMAP(g_kt) + + if (IMD_TYPE(g_kt) != PM_LTYPE(pm)) { + call imd_linetype (PM_LTYPE(pm)) + IMD_TYPE(g_kt) = PM_LTYPE(pm) + } + if (IMD_WIDTH(g_kt) != PM_WIDTH(pm)) { + call idk_linewidth (g_out, nint (GKI_UNPACKREAL(PM_WIDTH(pm)))) + IMD_WIDTH(g_kt) = PM_WIDTH(pm) + } + if (IMD_COLOR(g_kt) != PM_COLOR(pm)) { + call imd_color (PM_COLOR(pm)) + IMD_COLOR(g_kt) = PM_COLOR(pm) + } + + # Draw the polymarker. + oldx = 0; oldy = 0 + for (i=1; i <= len_p; i=i+2) { + x = p[i]; y = p[i+1] + if (x != oldx || y != oldy) { + call idk_move (g_out, x, y) + call idk_draw (g_out, x, y) + } + oldx = x; oldy = y + } +end diff --git a/sys/gio/imdkern/imdpmset.x b/sys/gio/imdkern/imdpmset.x new file mode 100644 index 00000000..6912ef97 --- /dev/null +++ b/sys/gio/imdkern/imdpmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_PMSET -- Set the polymarker attributes. + +procedure imd_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "imd.com" + +begin + pm = IMD_PMAP(g_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/imdkern/imdreset.x b/sys/gio/imdkern/imdreset.x new file mode 100644 index 00000000..fa830e4d --- /dev/null +++ b/sys/gio/imdkern/imdreset.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +# IMD_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure imd_reset() + +pointer pl, pm, fa, tx +include "imd.com" + +begin + # Set pointers to attribute substructures. + pl = IMD_PLAP(g_kt) + pm = IMD_PMAP(g_kt) + fa = IMD_FAAP(g_kt) + tx = IMD_TXAP(g_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + IMD_TYPE(g_kt) = -1 + IMD_WIDTH(g_kt) = -1 + IMD_COLOR(g_kt) = -1 + IMD_TXSIZE(g_kt) = -1 + IMD_TXFONT(g_kt) = -1 +end diff --git a/sys/gio/imdkern/imdtx.x b/sys/gio/imdkern/imdtx.x new file mode 100644 index 00000000..afe6c50c --- /dev/null +++ b/sys/gio/imdkern/imdtx.x @@ -0,0 +1,430 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# IMD_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure imd_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen +pointer sp, seg, ip, op, tx, first +int stx_segment() +include "imd.com" + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = IMD_TXAP(g_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by imd_txset, and is just a scaling factor. + + IMD_TXSIZE(g_kt) = TX_SIZE(tx) + if (TX_COLOR(tx) != IMD_COLOR(g_kt)) { + call imd_color (TX_COLOR(tx)) + IMD_COLOR(g_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line. + if (IMD_TYPE(g_kt) != GL_SOLID) { + call imd_linetype (GL_SOLID) + IMD_TYPE(g_kt) = GL_SOLID + } + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, gki_dx,gki_dy, polytext, + orien) + + # No discreet character sizes, so just scale the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = IMD_CHARHEIGHT(g_kt,1) * tsz + cw = IMD_CHARWIDTH(g_kt,1) * tsz + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call imd_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "imd.com" + +begin + tx = IMD_TXAP(g_kt) + + # Get character sizes in GKI coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = IMD_CHARHEIGHT(g_kt,1) * sz + cw = IMD_CHARWIDTH(g_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/imdkern/imdtxset.x b/sys/gio/imdkern/imdtxset.x new file mode 100644 index 00000000..9479fbdd --- /dev/null +++ b/sys/gio/imdkern/imdtxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +# IMD_TXSET -- Set the text drawing attributes. + +procedure imd_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "imd.com" + +begin + tx = IMD_TXAP(g_kt) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/imdkern/ltype.dat b/sys/gio/imdkern/ltype.dat new file mode 100644 index 00000000..caae0c18 --- /dev/null +++ b/sys/gio/imdkern/ltype.dat @@ -0,0 +1,28 @@ +# LTYPE.DAT -- Initialize the builtin line types for the IMD kernel. Data +# is given in GKI units (1.0 = 32768 units). A segment of 32 GKI units is +# resolved on a device with 1024 resolved pixels. + +data p_seg /1, 1, 1/ +data p_segleft /320, 32, 512/ + +data p_nseg[1] /2/ # PL_DASHED +data p_penup[1,1] /false/ +data p_penup[1,2] /true/ +data p_seglen[1,1] /320/ +data p_seglen[1,2] /128/ + +data p_nseg[2] /2/ # PL_DOTTED +data p_penup[2,1] /false/ +data p_penup[2,2] /true/ +data p_seglen[2,1] /32/ +data p_seglen[2,2] /128/ + +data p_nseg[3] /4/ # PL_DOTDASH +data p_penup[3,1] /false/ +data p_penup[3,2] /true/ +data p_penup[3,3] /false/ +data p_penup[3,4] /true/ +data p_seglen[3,1] /512/ +data p_seglen[3,2] /128/ +data p_seglen[3,3] /32/ +data p_seglen[3,4] /128/ diff --git a/sys/gio/imdkern/mkpkg b/sys/gio/imdkern/mkpkg new file mode 100644 index 00000000..03581bff --- /dev/null +++ b/sys/gio/imdkern/mkpkg @@ -0,0 +1,50 @@ +# Make the GIO/IMDKERN image display device graphics kernel. + +$checkout libimd.a lib$ +$update libimd.a +$checkin libimd.a lib$ +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $omake x_imdkern.x + $link x_imdkern.o -limd -lds -lstg -o xx_imdkern.e + ; + +install: + $move xx_imdkern.e bin$x_imdkern.e + ; + +libimd.a: + idk.x idk.com + imdcancel.x imd.com imd.h + imdclear.x imd.com imd.h + imdclose.x imd.com imd.h + imdclws.x imd.h imd.com + imdcolor.x imd.com imd.h + imddrawch.x font.com font.h imd.com imd.h + imdescape.x + imdfa.x imd.com imd.h + imdfaset.x imd.com imd.h + imdflush.x imd.com imd.h + imdfont.x imd.com imd.h + imdgcell.x + imdinit.x imd.com imd.h + imdline.x imd.com imd.h + imdopen.x imd.com imd.h + imdopenws.x imd.com imd.h + imdpcell.x imd.com imd.h + imdpl.x imd.com imd.h ltype.dat + imdplset.x imd.com imd.h + imdpm.x imd.com imd.h + imdpmset.x imd.com imd.h + imdreset.x imd.com imd.h + imdtx.x imd.com imd.h + imdtxset.x imd.com imd.h + t_imdkern.x + ; diff --git a/sys/gio/imdkern/t_imdkern.x b/sys/gio/imdkern/t_imdkern.x new file mode 100644 index 00000000..ebca44bf --- /dev/null +++ b/sys/gio/imdkern/t_imdkern.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMDKERN -- Graphics kernel for an image display frame buffer using the +# data stream interface. The package is based on the SGI kernel. + +procedure t_imdkern() + +int fd, list, dbfd +pointer gki, sp, fname, devname, dbfname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +int color, frame + +bool clgetb() +int clgeti(), envfind() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (dbfname, SZ_PATHNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Set parameter defaults. + debug = NO + verbose = NO + gkiunits = NO + frame = -1 + color = -1 + + # Check for global kernel debug flag. + if (envfind ("idkdebug", Memc[dbfname], SZ_PATHNAME) > 0) + iferr (dbfd = open (Memc[dbfname], APPEND, TEXT_FILE)) { + debug = NO + dbfd = 0 + } else + debug = YES + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (!clgetb ("generic")) { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + frame = clgeti ("frame") + color = clgeti ("color") + } + + if (debug == YES && dbfd == 0) + dbfd = STDERR + + # Open the graphics kernel. + call imd_opendev (Memc[devname], frame, color, dev) + call gkp_install (deb, dbfd, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) { + call gki_execute (Mems[gki], deb) + call flush (dbfd) + } + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call imd_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/imdkern/x_imdkern.x b/sys/gio/imdkern/x_imdkern.x new file mode 100644 index 00000000..3cc14388 --- /dev/null +++ b/sys/gio/imdkern/x_imdkern.x @@ -0,0 +1,3 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task imdkern = t_imdkern diff --git a/sys/gio/markers.inc b/sys/gio/markers.inc new file mode 100644 index 00000000..ef3a540f --- /dev/null +++ b/sys/gio/markers.inc @@ -0,0 +1,71 @@ +# Data declarations for the standard markers. + +real mpx[86], mpy[86] # marker polyline points +int moff[9] # offsets of the markers in mpx and mpy +int mnpts[9] # number of points in each polyline +int k # implied do-loop dummy index + +# Box. +data (mpx(k),k=01,05) /0.0, 1.0, 1.0, 0.0, 0.0/ +data (mpy(k),k=01,05) /0.0, 0.0, 1.0, 1.0, 0.0/ +data moff[1] /1/, mnpts[1] /5/ + +# Plus. +data (mpx(k),k=06,10) /0.5, 0.5, 0.5, 0.0, 1.0/ +data (mpy(k),k=06,10) /0.0, 1.0, 0.5, 0.5, 0.5/ +data moff[2] /6/, mnpts[2] /5/ + +# Cross. +data (mpx(k),k=11,15) /0.0, 1.0, 0.5, 0.0, 1.0/ +data (mpy(k),k=11,15) /0.0, 1.0, 0.5, 1.0, 0.0/ +data moff[3] /11/, mnpts[3] /5/ + +# Diamond. +data (mpx(k),k=16,20) /0.5, 1.0, 0.5, 0.0, 0.5/ +data (mpy(k),k=16,20) /0.0, 0.5, 1.0, 0.5, 0.0/ +data moff[4] /16/, mnpts[4] /5/ + +# Horizonal line. +data (mpx(k),k=21,22) /0.0, 1.0/ +data (mpy(k),k=21,22) /0.5, 0.5/ +data moff[5] /21/, mnpts[5] /2/ + +# Vertical line. +data (mpx(k),k=23,24) /0.5, 0.5/ +data (mpy(k),k=23,24) /0.0, 1.0/ +data moff[6] /23/, mnpts[6] /2/ + +# Horizontal error bar. +data (mpx(k),k=25,30) /0.0, 0.0, 0.0, 1.0, 1.0, 1.0/ +data (mpy(k),k=25,30) /0.0, 1.0, 0.5, 0.5, 1.0, 0.0/ +data moff[7] /25/, mnpts[7] /6/ + +# Vertical error bar. +data (mpx(k),k=31,36) /0.0, 1.0, 0.5, 0.5, 1.0, 0.0/ +data (mpy(k),k=31,36) /0.0, 0.0, 0.0, 1.0, 1.0, 1.0/ +data moff[8] /31/, mnpts[8] /6/ + +# Circle. +data (mpx(k),k=37,41) /1.000, 0.996, 0.984, 0.963, 0.936/ # X +data (mpx(k),k=42,46) /0.901, 0.859, 0.812, 0.759, 0.702/ +data (mpx(k),k=47,51) /0.642, 0.580, 0.516, 0.452, 0.389/ +data (mpx(k),k=52,56) /0.327, 0.269, 0.214, 0.164, 0.119/ +data (mpx(k),k=57,61) /0.081, 0.050, 0.025, 0.009, 0.001/ +data (mpx(k),k=62,66) /0.001, 0.009, 0.025, 0.050, 0.081/ +data (mpx(k),k=67,71) /0.119, 0.164, 0.214, 0.269, 0.327/ +data (mpx(k),k=72,76) /0.389, 0.452, 0.516, 0.580, 0.642/ +data (mpx(k),k=77,81) /0.702, 0.759, 0.812, 0.859, 0.901/ +data (mpx(k),k=82,86) /0.936, 0.963, 0.984, 0.996, 1.000/ + +data (mpy(k),k=37,41) /0.500, 0.564, 0.627, 0.688, 0.745/ # Y +data (mpy(k),k=42,46) /0.799, 0.848, 0.891, 0.928, 0.957/ +data (mpy(k),k=47,51) /0.979, 0.994, 1.000, 0.998, 0.987/ +data (mpy(k),k=52,56) /0.969, 0.943, 0.910, 0.870, 0.824/ +data (mpy(k),k=57,61) /0.773, 0.717, 0.658, 0.596, 0.532/ +data (mpy(k),k=62,66) /0.468, 0.404, 0.342, 0.283, 0.227/ +data (mpy(k),k=67,71) /0.176, 0.130, 0.090, 0.057, 0.031/ +data (mpy(k),k=72,76) /0.013, 0.002, 0.000, 0.006, 0.021/ +data (mpy(k),k=77,81) /0.043, 0.072, 0.109, 0.152, 0.201/ +data (mpy(k),k=82,86) /0.255, 0.312, 0.373, 0.436, 0.500/ + +data moff[9] /37/, mnpts[9] /50/ diff --git a/sys/gio/mkpkg b/sys/gio/mkpkg new file mode 100644 index 00000000..b09ae3cd --- /dev/null +++ b/sys/gio/mkpkg @@ -0,0 +1,140 @@ +# Make the GIO package. + +$checkout libex.a lib$ # default: update libex.a +$update libex.a +$checkin libex.a lib$ +$exit + +# UPDATE -- Relink and install all graphics kernels. + +update: + @stdgraph + @sgikern + @imdkern + $ifeq (USE_NSPP, yes) @nsppkern $endif + $ifeq (USE_CALCOMP, yes) @calcomp $endif + ; + + +# The following redirect sys$mkpkg to the appropriate subdirectories to +# update the libraries therein. + +libcur.a: + @cursor + ; +libgks.a: + @gks + ; +libncar.a: + @ncarutil + ; +libnspp.a: + @nspp + ; +libstg.a: + @stdgraph + ; +libsgi.a: + @sgikern + ; +libimd.a: + @imdkern + ; +libgkt.a: + @nsppkern + ; +libccp.a: + @calcomp + ; + + +# GIO portion of LIBEX. + +libex.a: + $ifeq (USE_GENERIC, yes) + $ifolder (gtickr.x, gtick.gx) + $generic -k -t r gtick.gx + $endif + $endif + + @glabax + @gki + @gim + + aelogd.x + aelogr.x + elogd.x + elogr.x + fpequald.x + fpequalr.x + fpfixd.x + fpfixr.x + fpndgr.x + fpnormd.x + fpnormr.x + gactivate.x + gadraw.x gpl.com + gamove.x gpl.com + gascale.x + gcancel.x + gclear.x + gclose.x + gctran.x + gcurpos.x gpl.com + gdeact.x + gescape.x + gfill.x + gflush.x + gframe.x + gfrinit.x + ggcell.x gpl.com + ggcur.x + ggetb.x + ggeti.x + ggetr.x + ggets.x + ggscale.x + ggview.x + ggwind.x + gline.x + gmark.x markers.inc + gmftitle.x + gmprintf.x + gmsg.x + gopen.x + gpagefile.x + gpcell.x gpl.com + gplcache.x gpl.com + gplcancel.x gpl.com + gplflush.x gpl.com + gpline.x + gploto.x + gplotv.x + gplreset.x gpl.com + gplstype.x gpl.com + gpmark.x + gqverify.x + grdraw.x + grdwcs.x + greact.x + greset.x + grmove.x + grscale.x + gscan.x + gscur.x + gseti.x + gsetr.x + gsets.x + gstati.x + gstatr.x + gstats.x + gsview.x + gswind.x + gtext.x + gtickr.x + gtxset.x + gumark.x + gvline.x + gvmark.x + wcstogki.x gpl.com + ; diff --git a/sys/gio/ncarutil/README b/sys/gio/ncarutil/README new file mode 100644 index 00000000..6ae35023 --- /dev/null +++ b/sys/gio/ncarutil/README @@ -0,0 +1,219 @@ +Directory gio$ncarutil, with subdirectories conlib, autograph and sysint, +contains the source code for the GKS based NCAR plotting utilities library. +The first public release of this software was installed in IRAF 10SEP86. +(The 3 previous installations of the NCAR Utilities were the result of NOAO +serving as a Beta release test site.) What follows is the Notes files from +the installation : + +****************************************************************************** +Notes for installation of the NCAR GKS based plotting utilities. This +release marks the end of NCAR's beta testing and is the first public release +of the new software. The changes made at NOAO have been merged into the +new source code; these changes have are marked with "+/- NOAO." The IRAF +installed NCAR library differs from the version released on tape as documented +below. Installation was begun September 2, 1986. (S. Hammond) + +Subdirectory AUTOGRAPH -- + +autograph/agback.f: + Calls blockdata agdflt as run time subroutine. +autograph/agcurv.f: + Calls blockdata agdflt as run time subroutine. +autograph/agdflt.f: + This is the block data, which has been completely rewritten as + initialization statements instead of data statements. +autograph/agexax.f: + A ftn write statement has been commented out. +autograph/agppid.f: + A string is written with f77upk/pstr instead of a ftn write statement. +autograph/agrstr.f: + Binary read, completely commented out. +autograph/agsave.f: + Binary write (opposite of agrstr.f), completely commented out. +autograph/agscan.f: + Calls blockdata agdflt as run time subroutine. + A ftn write statement has been commented out. +autograph/agsetp.f: + Calls blockdata agdflt as run time subroutine. +autograph/agstup.f: + Calls blockdata agdflt as run time subroutine. +autograph/ezmxy.f, ezmy.f, ezxy.f, ezy.f: + These four subroutines require identical changes: + Call blockdata agdflt as run time subroutine upon entering; + Call subroutine initag before returning. +autograph/idiot.f: + Call blockdata adgflt as run time subroutine. + Call plotit and initut to reinitialize before returning. +autograph/pstr.x: + This file is not on the distribution tape, it was written to + output strings that have been unpacked by f77upk. + +Subdirectory CONLIB -- + +conlib/conecd.f: + Character variables IT and CHTMP are not used and so are commented out. + The FTN internal writes are rewritten as calls to encode. +conlib/congen.f: + FTN internal write replaced with call to encode. +conlib/conop1.f,conop2.f,conop3.f,conop4.f: + These four routines now call blockdata conbdn as run time initialization. +conlib/conout.f, conot2.f: + Both these routines are no-ops in IRAF. All statements have been commented + out. +conlib/conpdv.f: + FTN internal write replaced with a call to encode. +conlib/conssd.f: + FTN write and format statement commented out. +conlib/contng.f: + FTN internal writes rewritten as calls to encode. + + +Directory NCARUTIL -- + +conran.f: + Changed values of iabove, ibelow and ibel2 to improve label placement. + Blockdata condbn rewritten as run time initialization. (conbdn.f) + Internal writes rewritten as calls to encode. + +conrec.f: + Value of NCRT changed from 4 to 2. + The contour plot labelling has been improved, with the titles being + centered in the current viewport, and the large spaces between + fields eliminated. This change involves: + 1. common block noaolb added; also used in spp calling routine. + 2. Values of LNGTHS array modified. + 3. Character*25 variable string[5] added. + 4. Default plot position is centered on current viewport. + All internal writes have been replaced with calls to encode. + Error message concerning "overflow in STLINE" is now written only + to stderr, not to stdgraph as well. + EZCNTR no longer calls frame. + Block data CONBD deleted from conrec.f source, rewritten as conbd.f + +dashsmth.f: + In two places, the blockdata DASHBD is called as an initializing subroutine. + Subroutines kurv1s and kurv2s are used for both the dashsmth and + isosrf utilities. The code is duplicated in the two fortran files. I + have put it in a separate file (kurv.f) and deleted it from both original + locations. + +gridal.f: + In two places, blockdata GRIDT is called as an initializing subroutine. + All internal FTN writes changed to calls to encode. + FTN write and format statements for error reporting deleted - used seter. + Blockdata deleted from gridal.f; rewritten in gridt.f. + +hafton.f: + Blockdata hfinit rewritten and called as run time initializing subroutine. + One internal write rewritten as call to encode. + Call to FRAME removed from EZHFTN. + +isosrf.f: + Call to FRAME removed from EZISOS + Blockdata isosrb was rewritten as run time initialization isosrb.f + Source for subroutines kurv1s and kurv2s has been deleted from isosrf.f. + (It is shared with the dashsmth utility, and has been moved to kurv.f.) + +pwrity.f: + Blockdata PWRYBD rewritten as subroutine. + FTN writes and format statements commented out. + +pwrzs.f: + Common block noaovp added, so user can control viewport. Calls to + plotit and set had to be changed because they assumed the full + viewport [1-1024] was being used for srface plots. + +srface.f: + Because user changes viewport when labelling is selected, mods had + to be made. Common block noaovp has been added, and calls to set + and plotit no longer assume the full viewport [1-1024] is being used. + Blockdata SRFABD has been rewritten as a run time initialization. + +strmln.f: + The value of uvmsg changed from 1.0E+36 to 1.0E+16 in an attempt + to make this routine run on a VAX. + +threed.f: + Blockdata threbd rewritten as run time initialization. + Subroutine pwrz completely commented out. + +velvct.f: + Blockdata veldat rewritten as run time initialization. + FTN internal write rewritten as call to encode. + + +Subdirectory SYSINT (system interface) -- + +sysint/support.f: + 1. The character size calculated by WTSTR is doubled to be readable + with the IRAF font. + 2. Subroutines SETER and E9RIN both used FTN write statements to + output information. This is now handled by passing the error + message to ULIBER, where the string gets unpacked with f77upk + and written to stderr. + 3. Blockdata UERRBD was rewritten as a run time initialization. + 4. Block data UTILBD was rewritten as a run time initialization. + A logical flag (first) was added to insure that the internal + parameters were initialized only once per load; subroutine + utilbd can be called at several points. An entry point 'utinit' + was added to reset the 'first' flag to true. + 5. In an attempt to mimic the organization of the release tape, file + support.f contains the following fortran subroutines: + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) + SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL) + SUBROUTINE ENTSR(IROLD,IRNEW) + SUBROUTINE RETSR(IROLD) + SUBROUTINE ERROF + SUBROUTINE SETER(MESSG,NERR,IOPT) + SUBROUTINE EPRIN + SUBROUTINE E9RIN(MESSG,NERR,SAVE) + SUBROUTINE FDUM + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) + INTEGER FUNCTION NERRO(NERR) + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) + SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC) + subroutine uerrbd + subroutine uliber (errcode, pkerrmsg, msglen) + +sysint/spps.f: + 1. Subroutine FLUSH has been renamed MCFLSH because of a name conflict. + 2. FRAME calls initut to initialize the 'first' flag in utilbd. + 3. Subroutines OPNGKS and CLSGKS have been commented out. + 4. In PLOTIT and PLOTIF the block data utilbd is called as a run time + initialization subroutine. + +**************************************************************************** + +gio$ncarutil/conrec.f Dec 23, 1986 S. Hammond + Moved the call to gsplci that set up major contours. This + statement was not being executed until after the first major line + had been drawn, resulting in the first major line not being bold. + + +*************************************************************************** +On June 1, 1987 the following copywright notice was inserted into all +FORTRAN files in the ncarutil directory tree. + +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +February 12, 1988. During Steve Rooke's port of IRAF to the HP RISC computer +several Fortran errors were caught by the HP compiler. These have been +fixed as shown: +sys/gio/ncarutil/conbdn.f + The data statement at line 244 had not been commented out. It is now. + +June 10, 1988. Made a mod to conbd.f (and in the comments to conrec.f) that +resets the point at which contour decides an image aspect ratio is "extreme". +Previously if the image axes ratio exceeded 1:4 the contour plot was square. +This limit was too restrictive and has been changed to 1:16. See related +change in pkg$plot.vport.x. diff --git a/sys/gio/ncarutil/autograph/README b/sys/gio/ncarutil/autograph/README new file mode 100644 index 00000000..befb5e42 --- /dev/null +++ b/sys/gio/ncarutil/autograph/README @@ -0,0 +1,46 @@ +AUTOGRAPH -- This directory contains the contents of the NCAR file +autograph.f, unpacked one subroutine per file. Here is the revision file +supplied by NCAR for the autograph package. For NOAO specific enhancements, +see gio$ncarutil/README. + + Revision history: + + February, 1979 Added a revision history and enhanced machine + independency. + + September, 1979 Fixed a couple of problems which caused the code to + bomb when core was pre-set to indefinites and the + 1st graph drawn was peculiar in some way and another + which caused it to set the default dashed-line-speci- + fier length wrong. Added new documentation. + + October, 1979 Changed the way IDIOT behaves when NPTS is negative. + + March, 1980 Fixed a couple of small errors, one which prevented + an error exit in AGSETP from ever being reached and + another which caused AUTOGRAPH to blow up when given + a zero or negative on a logarithmic axis. Changed + the way in which NBPF is computed by AGSTR1. + + August, 1981 Removed all calls setting the plotter intensity and + made the computation of the variable SMRL portable. + + April, 1984 Made the code strictly FORTRAN-77 compatible, taking + out all dependency on support routines (such as LOC). + This required some changes in the user interface. + + February, 1985 Put code in AGSETP to reclaim character-store space + used by character-string dash patterns when they are + redefined using binary patterns. Also changed AGGTCH + to return a single blank for a non-existent string. + + August, 1985 Put code in AGGETP so that the label-name identifier + is now returned properly. Among other things, this + cures a problem which caused the character-storage + space to be eaten up. + + December, 1985 Fixed AGSETP to zero the current-line pointer when + the current-label pointer is changed. + + January, 1986 Fixed AGAXIS to respond properly to the zeroing of + NCIM by AGCHNL. diff --git a/sys/gio/ncarutil/autograph/agaxis.f b/sys/gio/ncarutil/autograph/agaxis.f new file mode 100644 index 00000000..4c3bec73 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agaxis.f @@ -0,0 +1,1851 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C A B R I E F D E S C R I P T I O N O F A U T O G R A P H +C --------------------------------------------------------------------- +C +C Following is a brief description of the AUTOGRAPH package. For a +C complete write-up, see the document "AUTOGRAPH - THE UNABRIDGED +C WRITE-UP". +C +C +C PACKAGE AUTOGRAPH +C +C LATEST REVISION January, 1986 +C +C PURPOSE To draw graphs, each with a labelled background +C and each displaying one or more curves. +C +C ACCESS (ON THE CRAY) To use AUTOGRAPH routines on the Cray, simply +C call them; they are in the binary library +C $NCARLB, which is automatically searched. +C +C To get smoother curves, drawn using spline +C interpolation, compile DASHSMTH, from ULIB, +C to replace DASHCHAR, from $NCARLB: +C +C GETSRC,LIB=ULIB,FILE=DASHSMTH,L=DSMTH. +C CFT,I=DSMTH,L=0. +C +C AUTOGRAPH contains a routine AGPWRT, which it +C calls to draw labels. This routine just passes +C its arguments on to the system-plot-package +C routine PWRIT. To use one of the fancier +C character-drawers, like PWRITX or PWRITY, +C just compile a routine AGPWRT to replace the +C default version; it has the same arguments as +C PWRIT and may either draw the character string +C itself, or just pass the arguments on to a +C desired character-drawer. The AUTOGRAPH +C specialist has some "standard" versions of +C AGPWRT and should be consulted for help in +C avoiding pitfalls. One standard version, +C which calls PWRITX, may be obtained using the +C following JCL: +C +C GETSRC,LIB=XLIB,FILE=AGUPWRITX,L=UPWRTX. +C CFT,I=UPWRTX,L=0. +C +C USAGE Following this indented preamble are given two +C lists: one describing the AUTOGRAPH routines +C and another describing the arguments of those +C routines. +C +C "AUTOGRAPH - THE UNABRIDGED WRITE-UP" gives +C a complete write-up of AUTOGRAPH, in great +C detail and with a set of helpful examples. +C +C ENTRY POINTS Except for seven routines which are included +C in the package for historical reasons (EZY, +C EZXY, EZMY, EZMXY, IDIOT, ANOTAT, and DISPLA), +C the AUTOGRAPH routines have six-character names +C beginning with the characters 'AG'. An alpha- +C betized list follows: +C +C AGAXIS AGBACK AGBNCH AGCHAX AGCHCU AGCHIL +C AGCHNL AGCTCS AGCTKO AGCURV AGDASH AGDFLT +C AGDLCH AGDSHN AGEXAX AGEXUS AGEZSU AGFPBN +C AGFTOL AGGETC AGGETF AGGETI AGGETP AGGTCH +C AGINIT AGKURV AGLBLS AGMAXI AGMINI AGNUMB +C AGPPID AGPWRT AGQURV AGRPCH AGRSTR AGSAVE +C AGSCAN AGSETC AGSETF AGSETI AGSETP AGSRCH +C AGSTCH AGSTUP AGUTOL +C +C NOTE: The "routine" AGDFLT is a block-data +C routine specifying the default values of +C AUTOGRAPH control parameters. +C +C SPECIAL CONDITIONS Under certain conditions, AUTOGRAPH may print +C an error message (via the routine SETER) and +C stop. Each error message includes the name of +C the routine which issued it. A description of +C the condition which caused the error may be +C found in the AUTOGRAPH write-up in the NCAR +C graphics manual; look in the write-up of the +C routine which issued the error message, under +C the heading 'SPECIAL CONDITIONS'. +C +C For error messages issued by the routine +C AGNUMB, see the write-up of the routine AGSTUP. +C +C If you get an error in the routine ALOG10, it +C probably means that you are using a logarithmic +C axis and some of the coordinate data along that +C axis are zero or negative. +C +C COMMON BLOCKS The AUTOGRAPH common blocks are AGCONP, AGORIP, +C AGOCHP, AGCHR1, and AGCHR2. AGCONP contains +C the AUTOGRAPH "control parameters", primary and +C secondary, all of which are real, AGORIP other +C real and/or integer parameters, AGOCHP other +C character parameters, AGCHR1 and AGCHR2 the +C variables implementing the character-storage- +C and-retrieval scheme of AUTOGRAPH. +C +C I/O Lower-level plotting routines are called to +C produce graphical output and, when errors +C occur, error messages may be written to the +C system error file, as defined by I1MACH(4), +C either directly or by way of a call to SETER. +C +C REQUIRED ULIB AUTOGRAPH uses the software dashed-line package +C ROUTINES DASHCHAR. Of course, either of the packages +C DASHSMTH or DASHSUPR may be used instead, to +C get smoother curves. +C +C SPECIALIST Dave Kennison, Scientific Computing Division, +C National Center for Atmospheric Research +C +C LANGUAGE FORTRAN +C +C HISTORY Dave Robertson wrote the original routine +C IDIOT, which was intended to provide a simple, +C quick-and-dirty, x-y graph-drawing capability. +C In time, as it became obvious that many users +C were adapting IDIOT to more sophisticated +C tasks, Dan Anderson wrote the first AUTOGRAPH +C package, based on IDIOT. It allowed the user +C to put more than one curve on a graph, to use +C more sophisticated backgrounds, to specify +C coordinate data in a variety of ways, and to +C more easily control the scaling and positioning +C of graphs. Eventually, this package, too, was +C found wanting. In 1977, Dave Kennison entirely +C re-wrote AUTOGRAPH, with the following goals: +C to maintain the ease of use for simple graphs +C which had been the principal virtue of the +C package, to provide the user with as much +C control as possible, to incorporate desirable +C new features, and to make the package as +C portable as possible. In 1984, the package +C was again worked over by Dave Kennison, to +C make it compatible with FORTRAN-77 and +C to remove any dependency on the LOC function, +C which had proved to cause difficulties on +C certain machines. The user interface was +C changed somewhat and some new features were +C added. A GKS-compatible version was written. +C +C SPACE REQUIRED AUTOGRAPH is big; one pays a price for its +C capabilities. On the Cray, it occupies a +C little under 30000 (octal) locations. The +C required plot package routines take about +C another 7000 (octal), the (modified) PORT +C support routines about another 1000 (octal), +C and system routines (math, I/O, miscellany) +C another 30000 (octal). +C +C PORTABILITY AUTOGRAPH may be ported with few modifications +C to most systems having a FORTRAN-77 compiler. +C +C The labelled common blocks may have to be +C declared in a part of the user program which +C is always core-resident so that variables +C in them will maintain their values from one +C AUTOGRAPH-routine call to the next. Such a +C problem may arise when AUTOGRAPH is placed in +C an overlay or when some sort of memory-paging +C scheme is used. +C +C REQUIRED RESIDENT AUTOGRAPH uses the DASHCHAR routines DASHDB, +C ROUTINES DASHDC, FRSTD, LASTD, LINED, AND VECTD, the +C system-plot-package routines FRAME, GETSET, +C GETSI, LINE, PWRIT, and SET, the support +C routines ISHIFT and IOR, the (modified) +C PORT utilities SETER and I1MACH, and the +C FORTRAN-library routines ALOG10, ATAN2, COS, +C SIN, AND SQRT. +C +C --------------------------------------------------------------------- +C U S E R - C A L L A B L E A U T O G R A P H R O U T I N E S +C --------------------------------------------------------------------- +C +C Following is a list of AUTOGRAPH routines to be called by the user +C (organized by function). Each routine is described briefly. The +C arguments of the routines are described in the next section. +C +C Each of the following routines draws a complete graph with one call. +C Each is implemented by a set of calls to the lower-level AUTOGRAPH +C routines AGSTUP, AGCURV, and AGBACK (which see, below). +C +C -- EZY (YDRA,NPTS,GLAB) - draws a graph of the curve defined by the +C data points ((I,YDRA(I)),I=1,NPTS), with a graph label specified +C by GLAB. +C +C -- EZXY (XDRA,YDRA,NPTS,GLAB) - draws a graph of the curve defined by +C the data points ((XDRA(I),YDRA(I)),I=1,NPTS), with a graph label +C specified by GLAB. +C +C -- EZMY (YDRA,IDXY,MANY,NPTS,GLAB) - draws a graph of the family of +C curves defined by data points (((I,YDRA(I,J)),I=1,NPTS),J=1,MANY), +C with a graph label specified by GLAB. The order of the subscripts +C of YDRA may be reversed - see the routine DISPLA, argument LROW. +C +C -- EZMXY (XDRA,YDRA,IDXY,MANY,NPTS,GLAB) - draws a graph of the +C family of curves defined by the data points (((XDRA(I),YDRA(I,J)), +C I=1,NPTS),J=1,MANY), with a graph label specified by GLAB. XDRA +C may be doubly-subscripted and the order of the subscripts of XDRA +C and YDRA may be reversed - see the routine DISPLA, argument LROW. +C +C -- IDIOT (XDRA,YDRA,NPTS,LTYP,LDSH,LABX,LABY,LABG,LFRA) - implements +C the routine from which AUTOGRAPH grew - not recommended - provided +C for antique lovers. +C +C The following routines provide user access to the AUTOGRAPH control +C parameters (in the labelled common block AGCONP). +C +C -- ANOTAT (XLAB,YLAB,LBAC,LSET,NDSH,DSHL) - may be used to change the +C x- and y-axis (non-numeric) labels, the background type, the way +C in which graphs are positioned and scaled, and the type of dash +C patterns to be used in drawing curves. +C +C -- DISPLA (LFRA,LROW,LTYP) - may be used to specify when, if ever, +C the EZ... routines do a frame advance, how input arrays for EZMY +C and EZMXY are dimensioned, and the linear/log nature of graphs. +C +C -- AGSETP (TPGN,FURA,LURA) - a general-purpose parameter-setting +C routine, used to set the group of parameters specified by TPGN, +C using values obtained from the array (FURA(I),I=1,LURA). +C +C -- AGSETF (TPGN,FUSR) - used to set the single parameter specified by +C TPGN, giving it the floating-point value FUSR. +C +C -- AGSETI (TPGN,IUSR) - used to set the single parameter specified by +C TPGN, giving it the floating-point value FLOAT(IUSR). +C +C -- AGSETC (TPGN,CUSR) - the character string CUSR is stashed in an +C array inside AUTOGRAPH and the floating-point equivalent of an +C identifier which may be used for later retrieval of the string is +C stored as the value of the single parameter specified by TPGN. The +C single parameter must be a label name, a dash pattern, the text of +C a label line, or the line-terminator character. +C +C -- AGGETP (TPGN,FURA,LURA) - a general-purpose parameter-getting +C routine, used to get the group of parameters specified by TPGN, +C putting the result in the array (FURA(I),I=1,LURA). +C +C -- AGGETF (TPGN,FUSR) - used to get, in FUSR, the floating-point +C value of the single parameter specified by TPGN. +C +C -- AGGETI (TPGN,IUSR) - used to get, in IUSR, the integer equivalent +C of the value of the single parameter specified by TPGN. +C +C -- AGGETC (TPGN,CUSR) - used to get, in CUSR, the character string +C whose identifier is specified by the integer equivalent of the +C single parameter specified by TPGN. The single parameter must +C be a label name, a dash pattern, the text of a label line, or the +C line-terminator character. +C +C The following are lower-level routines, which may be used to draw +C graphs of many different kinds. The EZ... routines call these. They +C are intended to be called by user programs, as well. +C +C -- AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX,YDRA,NVIY,IIVY,NEVY,IIEY) - this +C routine must be called prior to the first call to either of the +C two routines AGBACK and AGCURV, to force the set-up of secondary +C parameters controlling the behavior of those routines. After any +C parameter-setting call, AGSTUP must be called again before calling +C either AGBACK or AGCURV again. AGSTUP calls the routine "SET", in +C the plot package, so that user x/y coordinates in subsequent calls +C will map properly into the plotter space. +C +C -- AGBACK - draws the background defined by the current state of the +C AUTOGRAPH control parameters. +C +C -- AGCURV (XVEC,IIEX,YVEC,IIEY,NEXY,KDSH) - draws the curve defined +C by the arguments, positioning it as specified by the current state +C of the AUTOGRAPH control parameters. +C +C The following utility routines are called by the user. +C +C -- AGSAVE (IFNO) - used to save the current state of AUTOGRAPH by +C writing the appropriate information to a specified file. Most +C commonly used to save the default state for later restoration. +C This routine should be used instead of AGGETP when the object +C is to save the whole state of AUTOGRAPH, since it saves not only +C the primary control parameters, but all of the character strings +C pointed to by the primary control parameters. It is the user's +C responsibility to position the file before calling AGSAVE. +C +C -- AGRSTR (IFNO) - used to restore a saved state of AUTOGRAPH by +C reading the appropriate information from a specified file. Most +C commonly used to restore AUTOGRAPH to its default state. It is +C the user's responsibility to position the file before calling +C AGRSTR. +C +C -- AGBNCH (IDSH) - a function, of type CHARACTER*16 (it must be +C declared as such in a user routine referencing it), whose value, +C given a 16-bit binary dash pattern, is the equivalent character +C dash pattern. +C +C -- AGDSHN (IDSH) - a function, of type CHARACTER*16 (it must be +C declared as such in a user routine referencing it), whose value, +C given an integer "n" (typically between 1 and 26) is the character +C string 'DASH/ARRAY/nnnn.', which is the name of the nth dash +C pattern parameter. To set the 13th dash pattern, for example, +C one might use "CALL AGSETC (AGDSHN(13),'$$$$$$CURVE 13$$$$$$')". +C +C The following utility routines are called by AUTOGRAPH. The versions +C included in AUTOGRAPH itself are dummies; they do nothing but RETURN. +C The user may replace one or more of these routines with versions to +C accomplish specific purposes. +C +C -- AGUTOL (IAXS,FUNS,IDMA,VINP,VOTP) - called by AUTOGRAPH to perform +C the mapping from user-system values along an axis to label-system +C values along the axis and vice-versa. This routine may be replaced +C by the user to create a desired graph. +C +C -- AGCHAX (IFLG,IAXS,IPRT,VILS) - called by AUTOGRAPH just before and +C just after the various parts of the axes are drawn. +C +C -- AGCHCU (IFLG,KDSH) - called by AUTOGRAPH just before and just after +C each curve is drawn. +C +C -- AGCHIL (IFLG,LBNM,LNNO) - called by AUTOGRAPH just before and just +C after each line of an informational label is drawn. +C +C -- AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) - called by +C AUTOGRAPH just after the character strings defining a numeric label +C have been generated. +C +C --------------------------------------------------------------------- +C D E S C R I P T I O N S O F A R G U M E N T S +C --------------------------------------------------------------------- +C +C In calls to the routines EZY, EZXY, EZMY, and EZMXY: +C +C -- XDRA is an array of x coordinates, dimensioned as implied by the +C current value of the AUTOGRAPH control parameter 'ROW.' (see the +C description of the argument LROW, below). The value of the +C AUTOGRAPH parameter 'NULL/1.' (1.E36, by default) when used as an +C x coordinate, implies a missing data point; the curve segments +C on either side of such a point are not drawn. +C +C -- YDRA is an array of y coordinates, dimensioned as implied by the +C current value of the AUTOGRAPH control parameter 'ROW.' (see the +C description of the argument LROW, below). The value of the +C AUTOGRAPH parameter 'NULL/1.' (1.E36, by default) when used as a +C y coordinate, implies a missing data point; the curve segments +C on either side of such a point are not drawn. +C +C -- IDXY is the first dimension of the arrays XDRA (if it has two +C dimensions) and YDRA. +C +C -- MANY is the number of curves to be drawn by the call to EZ... - +C normally, the second dimension of XDRA (if it has two dimensions) +C and YDRA. +C +C -- NPTS is the number of points defining each curve to be drawn by +C the routine EZ... - normally, the first (or only) dimension of +C XDRA and YDRA. +C +C -- GLAB is a character constant or a character variable, defining a +C label to be placed at the top of the graph. The string may not be +C more than 40 characters long - if it is fewer than 40 characters +C long, its last character must be a dollar sign. (The dollar sign +C is not a part of the label - it is stripped off.) The character +C string "CHAR(0)" may be used to indicate that the previous label, +C whatever it was, should continue to be used. The initial graph +C label consists of blanks. +C +C In calls to the routine ANOTAT: +C +C -- XLAB and YLAB resemble GLAB (see above) and define labels for the +C x and y axes. The default x-axis label is the single character +C X, the default y-axis label the single character Y. Note that one +C may use the string "CHAR(0)" to indicate that the x-axis (y-axis) +C label is not to be changed from what it was previously. +C +C -- LBAC, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'BACKGROUND.', as follows: +C +C 1 - a perimeter background +C +C 2 - a grid background +C +C 3 - an axis background +C +C 4 - no background +C +C The default value of 'BACKGROUND.' is 1. +C +C -- LSET, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'SET.'. This parameter may be negated to suspend the +C drawing of curves by the EZ... routines, so that a call to one of +C them will produce only a background. The absolute value of 'SET.' +C affects the way in which AUTOGRAPH determines the position and +C shape of the graph and the scaling of the axes, as follows: +C +C 1 - Restores the default values of the AUTOGRAPH parameters +C in question. AUTOGRAPH will set up an appropriate call +C to the plot-package routine "SET", over-riding any prior +C call to that routine. +C +C 2 - Tells AUTOGRAPH to use arguments 1-4 and 9 of the last +C "SET" call. Arguments 1-4 specify where the graph should +C fall on the plotter frame, argument 9 whether the graph +C is linear/linear, linear/log, etc. +C +C 3 - Tells AUTOGRAPH to use arguments 5-8 and 9 of the last +C "SET" call. Arguments 5-8 specify the scaling of the +C axes, argument 9 whether the graph is linear/linear, +C linear/log, etc. +C +C 4 - A combination of 2 and 3. Arguments 1-4 of the last "SET" +C call specify the position, arguments 5-8 the scaling, and +C argument 9 the linear/log nature, of the graph. +C +C (The plot-package routine "SET" is described in the NCAR Graphics +C Manual; it is not a part of AUTOGRAPH.) +C +C If the routine DISPLA is called with its argument LTYP non-zero, +C the linear/log nature of the graph will be that specified by LTYP, +C not that specified by the last "SET" call, no matter what the value +C of the control parameter 'SET.'. +C +C The default value of 'SET.' is 1. +C +C -- NDSH, if non-zero, specifies a new value of the AUTOGRAPH control +C parameter 'DASH/SELECTOR.' (and therefore a new set of dashed-line +C patterns), as described below. Note: The default value of the +C dashed-line parameters is such that all curves will be drawn using +C solid lines; if that is what you want, use a zero for NDSH. +C +C If the value of 'DASH/SELECTOR.' is negative, curves produced +C by subsequent calls to EZMY or EZMXY will be drawn using a +C set of alphabetic dashed-line patterns. The first curve drawn +C by a given call will be labelled 'A', the second 'B', ..., the +C twenty-sixth 'Z', the twenty-seventh 'A' again, and so on. +C Curves drawn by calls to EZY and EZXY will be unaffected. +C +C If the value of 'DASH/SELECTOR.' is positive, it must be less +C than or equal to 26. The next argument, DSHL, is an array +C containing NDSH dashed-line patterns. All curves produced by +C subsequent calls to EZY, EZXY, EZMY, and EZMXY will be drawn +C using the dashed-line patterns in (DSHL(I),I=1,NDSH) - the +C first curve produced by a given call will have the pattern +C specified by DSHL(1), the second that specified by DSHL(2), +C the third that specified by DSHL(3), . . . the NDSH+1st that +C specified by DSHL(1), . . . etc. Each element of DSHL must +C be a character string, in which a dollar sign stands for a +C solid-line segment, a quote stands for a gap, and other +C characters stand for themselves. See the write-up of the +C package "DASHCHAR". Binary dashed-line patterns may not be +C defined by means of a call to ANOTAT, only by means of calls +C to lower-level routines. +C +C -- DSHL (if NDSH is greater than zero) is an array of dashed-line +C patterns, as described above. +C +C In calls to the routine DISPLA: +C +C -- LFRA, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'FRAME.'. Possible values are as follows: +C +C 1 - The EZ... routines do a frame advance after drawing. +C +C 2 - No frame advance is done by the EZ... routines. +C +C 3 - The EZ... routines do a frame advance before drawing. +C +C The default value of 'FRAME.' is 1. +C +C -- LROW, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'ROW.'. This parameter tells AUTOGRAPH how the argument +C arrays XDRA and YDRA, in calls to the routines EZMY and EZMXY, are +C subscripted, as follows: +C +C If 'ROW.' is positive, this implies that the first subscript +C of YDRA is a point number and the second subscript is a curve +C number. If 'ROW.' is negative, the order is reversed. +C +C If the absolute value of 'ROW.' is 1, this implies that XDRA +C is singly-subscripted, by point number only. If the absolute +C value of 'ROW.' is 2 or greater, this implies that XDRA is +C doubly-subscripted, just like YDRA. +C +C The default value of 'ROW.' is 1, spicifying that XDRA is singly- +C subscripted and that YDRA is doubly-subscripted by point number +C and curve number, in that order. +C +C -- LTYP, if non-zero, specifies new values for the AUTOGRAPH control +C parameters 'X/LOGARITHMIC.' and 'Y/LOGARITHMIC.', which determine +C whether the X and Y axes are linear or logarithmic. Possible +C values are as follows: +C +C 1 - x axis linear, y axis linear +C +C 2 - x axis linear, y axis logarithmic +C +C 3 - x axis logarithmic, y axis linear +C +C 4 - x axis logarithmic, y axis logarithmic +C +C The default values of these parameters make both axes linear. +C +C If the parameters 'X/LOGARITHMIC.' and 'Y/LOGARITHMIC.' are reset +C by the routine DISPLA, they are given values which make them +C immune to being reset when 'SET.' = 2, 3, or 4 (see the discussion +C of the argument LSET, above). +C +C In calls to the routines AGSETP, AGSETF, AGSETI AGSETC, AGGETP, +C AGGETF, AGGETI, and AGGETC: +C +C -- TPGN is a character string identifying a group of AUTOGRAPH +C control parameters. It is of the form 'K1/K2/K3/ . . . /Kn.'. +C Each Ki is a keyword. The keyword K1 specifies a group of control +C parameters, K2 a subgroup of that group, K3 a subgroup of that +C subgroup, etc. See the AUTOGRAPH write-up in the graphics manual +C for a more complete description of these parameter-group names and +C the ways in which they may be abbreviated. +C +C -- FURA is an array, from which control-parameter values are to be +C taken (the routine AGSETP) or into which they are to be stored +C (the routine AGGETP). Note that the array is real; all of the +C AUTOGRAPH parameters are stored internally as reals. +C +C -- LURA is the length of the user array FURA. +C +C -- FUSR is a variable, from which a single control parameter value is +C to be taken (the routine AGSETF) or in which it is to be returned +C (the routine AGGETF). Note that the variable is real. +C +C -- IUSR is a variable, from which a single-control parameter value is +C to be taken (the routine AGSETI) or in which it is to be returned +C (the routine AGGETI). Note that, since the control parameters are +C stored internally as reals, each of the routines AGSETI and AGGETI +C does a conversion - from integer to real or vice-versa. Note also +C that AGSETI and AGGETI should only be used for parameters which +C have intrinsically integral values. +C +C -- CUSR is a character variable from which a character string is to +C be taken (the routine AGSETC) or into which it is to be retrieved +C (the routine AGGETC). The control parameter affected by the call +C contains the floating-point equivalent of an integer identifier +C returned by the routine which stashes the character string and +C tendered to the routine which retrieves it (sort of the automated +C equivalent of a hat check). Note that AGSETC and AGGETC should +C only be used for parameters which intrinsically represent character +C strings. +C +C In calls to the routine AGSTUP: +C +C -- XDRA is an array of x coordinates of user data - usually, but not +C necessarily, the same data which will later be used in calls to +C the routine AGCURV. +C +C -- NVIX is the number of vectors of data in XDRA - if XDRA is doubly- +C dimensioned, NVIX would normally have the value of its second +C dimension, if XDRA is singly-dimensioned, a 1. +C +C -- IIVX is the index increment between vectors in XDRA - if XDRA is +C doubly-dimensioned, IIVX would normally have the value of its +C first dimension, if XDRA is singly-dimensioned, a dummy value. +C +C -- NEVX is the number of elements in each data vector in XDRA - if +C XDRA is doubly-dimensioned, NEVX would normally have the value of +C its first dimension, if XDRA is singly-dimensioned, the value of +C that single dimension. +C +C -- IIEX is the index increment between elements of a data vector in +C XDRA - normally a 1. +C +C -- YDRA, NVIY, IIVY, NEVY, and IIEY are analogous to XDRA, NVIX, +C IIVX, NEVX, and IIEX, but define y-coordinate data. +C +C In calls to the routine AGCURV: +C +C -- XVEC is a vector of x coordinate data. +C +C -- IIEX is the index increment between elements in XVEC. AGCURV will +C use XVEC(1), XVEC(1+IIEX), XVEC(1+2*IIEX), etc. +C +C -- YVEC is a vector of y coordinate data. +C +C -- IIEY is the index increment between elements in YVEC. AGCURV will +C use YVEC(1), YVEC(1+IIEY), YVEC(1+2*IIEY), etc. +C +C -- NEXY is the number of points defining the curve to be drawn. +C +C -- KDSH is a dashed-line selector. Possible values are as follows: +C +C If KDSH is zero, AUTOGRAPH will assume that the user has +C called the routine DASHD (in the DASHCHAR package, which see) +C to define the dashed-line pattern to be used. +C +C If KDSH is less than zero and has absolute value M, AUTOGRAPH +C will use the Mth (modulo 26) alphabetic dashed-line pattern. +C Each of these patterns defines a solid line interrupted every +C so often by a letter of the alphabet. +C +C If KDSH is greater than zero and has the value M, AUTOGRAPH +C will use the Mth (modulo N) dashed-line pattern in the group +C of N dashed-line patterns defined by the AUTOGRAPH control +C parameters in the group named 'DASH/PATTERNS.'. The default +C values of these parameters specify solid lines. +C +C In calls to the routines AGSAVE and AGRSTR: +C +C -- IFNO is the unit number associated with a file to which a single +C unformatted logical record of data is to be written, or from which +C such a record is to be read, by AUTOGRAPH. The file is not rewound +C before being written or read; positioning it properly is the user's +C responsibility. +C +C In calls to the function AGBNCH: +C +C -- IDSH is a 16-bit binary dash pattern, the character equivalent of +C which is to be returned as the value of AGBNCH. +C +C In calls to the function AGDSHN: +C +C -- IDSH is the number of the dash pattern parameter whose name is to +C be returned as the value of the function AGDSHN. +C +C In calls to the routine AGUTOL: +C +C -- IAXS is the number of the axis. The values 1, 2, 3, and 4 imply +C the left, right, bottom, and top axes, respectively. +C +C -- FUNS is the value of the parameter 'AXIS/s/FUNCTION.' which may be +C used to select the desired mapping function for axis IAXS. It is +C recommended that the default value (zero) be used to specify the +C identity mapping. A non-zero value may be integral (1., 2., etc.) +C and serve purely to select the code to be executed or it may be the +C value of a real parameter in the equations defining the mapping. +C +C -- IDMA specifies the direction of the mapping. A value greater than +C zero indicates that VINP is a value in the user system and that +C VOTP is to be a value in the label system, a value less than zero +C the opposite. +C +C -- VINP is an input value in one coordinate system along the axis. +C +C -- VOTP is an output value in the other coordinate system along the +C axis. +C +C In calls to the routine AGCHAX: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- IAXS is the number of the axis being drawn. The values 1, 2, 3, +C and 4 indicate the left, right, bottom, and top axes, respectively. +C +C -- IPRT indicates the part of the axis being drawn. Possible values +C are as follows: +C +C -- 1 implies the line of the axis. +C +C -- 2 implies a major tick. +C +C -- 3 implies a minor tick. +C +C -- 4 implies the mantissa of a numeric label. +C +C -- 5 implies the exponent of a numeric label. +C +C -- VILS is the value in the label system at the point where the part +C is being drawn. For IPRT = 1, VILS is zero. +C +C In calls to the routine AGCHCU: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- KDSH is the value with which AGCURV was called, as follows: +C +C AGCURV called by Value of KDSH +C ---------------- ---------------------------------------- +C EZY 1 +C EZXY 1 +C EZMY "n" or "-n", where n is the curve number +C EZMXY "n" or "-n", where n is the curve number +C the user program the user value +C +C In calls to the routine AGCHIL: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- LBNM is a character variable containing the name of the label being +C drawn. +C +C -- LNNO is the number of the line being drawn. +C +C In calls to the routine AGCHNL: +C +C -- IAXS is the number of the axis being drawn. The values 1, 2, 3, +C and 4 imply the left, right, bottom, and top axes, respectively. +C +C -- VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C -- CHRM, on entry, is a character string containing the mantissa of +C the numeric label, as it will appear if AGCHNL makes no changes. +C If the numeric label includes a "times" symbol, it is represented +C by a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C -- MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C -- NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C -- IPXM, on entry, is zero if there is no "times" symbol in CHRM; if +C it is non-zero, it is the index of a character position in CHRM. +C If AGCHNL changes the position of the "times" symbol in CHRM, +C removes it, or adds it, the value of IPXM must be changed. +C +C -- CHRE, on entry, is a character string containing the exponent of +C the numeric label, as it will appear if AGCHNL makes no changes. +C CHRE may be modified. +C +C -- MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C -- NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C --------------------------------------------------------------------- +C T H E A U T O G R A P H C O D E +C --------------------------------------------------------------------- +C +C Following is the AUTOGRAPH code. Routines appear in alphabetic order. +C + SUBROUTINE AGAXIS (IAXS,QTST,QSPA,WCWP,HCWP,XBGA,YBGA,XNDA,YNDA, + + QLUA,UBGA,UNDA,FUNS,QBTP,BASE,QJDP,WMJL,WMJR, + + QMNT,QNDP,WMNL,WMNR,QLTP,QLEX,QLFL,QLOF,QLOS, + + DNLA,WCLM,WCLE,RFNL,QCIM,QCIE,WNLL,WNLR,WNLB, + + WNLE) +C +C The routine AGAXIS is used to draw, tick-mark, and label an axis or, +C if ITST is non-zero, to pre-compute the amount of space which will be +C required for numeric labels when the axis is actually drawn. AGAXIS +C assumes that the last call to the plot-package routine SET was as +C follows (or the equivalent thereof): +C +C CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1) +C +C where XLCW, XRCW, YBCW, and YTCW are the coordinates of the left, +C right, bottom, and top edges of the curve window, stated as fractions +C of the appropriate edge of the plotter frame. +C +C The arguments of AGAXIS are as follows: +C +C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4, meaning +C the left, right, bottom, and top axes, respectively. +C +C -- ITST is an integer specifying what the caller wishes AGAXIS to do, +C as follows: +C +C -- If ITST .LT. 0, AGAXIS is to draw only the axis, nothing else. +C +C -- If ITST .EQ. 0, AGAXIS is to draw, tick, and label the axis. +C +C -- If ITST .GT. 0, AGAXIS is to pre-compute the amount of space +C which will be required for numeric labels. If the labels will +C not fit in the space provided, AGAXIS is instructed to take +C action as follows: +C +C -- ITST .EQ. 1 - no action. +C +C -- ITST .EQ. 2 - shrink the labels. +C +C -- ITST .EQ. 3 - re-orient the labels. +C +C -- ITST .EQ. 4 - shrink and/or re-orient the labels. +C +C -- ISPA is a 0 or a 1, specifying whether or not the axis itself is +C to be drawn. If ISPA .NE. 0, the axis is suppressed. Tick marks +C and/or labels may still be drawn. +C +C -- WCWP is the width of the curve window, in plotter units. +C +C -- HCWP is the height of the curve window, in plotter units. +C +C -- XBGA, YBGA, XNDA, and YNDA are the x and y coordinates of the ends +C of the axis. X coordinates are stated as fractions of the width, +C y coordinates as fractions of the height, of the curve window. The +C axis to be drawn must be either horizontal or vertical (at an angle +C of 0, 90, 180, or 270 degrees). The left side, right side, begin- +C ning, and end of the axis are defined from the viewpoint of a demon +C standing at (XBGA,YBGA) and staring balefully toward (XNDA,YNDA). +C +C -- LLUA, UBGA, and UNDA define the mapping of the "user" coordinate +C system (used for data-point coordinates) onto the axis. If LLUA +C is zero, the mapping is linear; if LLUA is non-zero, the mapping +C is logarithmic. UBGA is the user-system value at the beginning of +C the axis, UNDA the value at the end of the axis. The subroutine +C AGFTOL, which needs these parameters, is actually passed LLUA, +C UBEG=F(UBGA), and UDIF=F(UNDA)-F(UBGA), where F is the function +C F(X)=X or the function F(X)=ALOG10(X), depending on LLUA. +C +C -- FUNS is a function-selector, to be used in calls to AGUTOL, which +C defines the mappings from the user system to the label system and +C vice-versa for each of the four axes. The functions defined must +C be continuous, monotonic, and bounded within the user-system range +C (UBGA,UNDA) and a little bit outside that range. The positions +C of numeric labels and tick marks are chosen in the label system, +C mapped to the user system, and then onto the axis. +C +C -- NBTP and BASE specify how major ticks are to be positioned in the +C label coordinate system. See the routine AGNUMB (arguments NBTP, +C SBSE, and EXMU) for a description of these arguments. Note that +C NBTP .EQ. 0 or BASE .EQ. 0. suppresses both major tick marks and +C their labels. Note: SBSE .EQ. +BASE or -BASE, as needed. +C +C -- QJDP is the major-tick-mark dash pattern (0. .LE. QJDP .LE. 65535.) +C QJDP .LE. 0 suppresses major ticks. +C +C -- WMJL and WMJR are the distances to the left and right ends of the +C major tick marks, stated as fractions of the shortest side of the +C curve window. Values .EQ. 0 may be used to suppress one or both +C portions. Values .GE. 1 may be used to extend a given portion all +C the way to the edge of the curve window. (See routine AGCTKO.) +C +C -- NMNT is the number of minor tick marks to be placed between each +C pair of consecutive major tick marks. NMNT .EQ. 0 suppresses them. +C +C -- QNDP, WMNL, and WMNR are analogous to QJDP, WMJL, and WMJR, but +C specify minor-tick-mark characteristics. +C +C -- NLTP, NLEX, and NLFL specify the graphic form of numeric labels, as +C described in the routine AGNUMB (which see). Note that NLTP .LE. 0 +C suppresses numeric labels. +C +C -- NLOF and NLOS are first and second choices for the numeric label +C orientation. Both must be multiples of 90, specifying an angle +C measured in degrees counter-clockwise from a vector running from +C left to right in the curve window. If ITST .EQ. 0, AGAXIS uses +C NLOF if it is .GE. 0, NLOS otherwise, for the label orientation. +C If ITST .NE. 0, AGAXIS initially makes both NLOF and NLOS positive. +C Then, if ITST .GE. 3, NLOF may or may not be made negative. (To +C set the sign of NLOF or NLOS, AGAXIS adds or subtracts 360*K.) +C +C -- DNLA is the desired distance of numeric labels from the axis, +C positive to the left, negative to the right, of the axis. The +C magnitude of DNLA is the size of the gap between the axis and the +C nearest edge of a label, expressed as a fraction of the smaller +C dimension of the curve window. See also RFNL, below. +C +C -- WCLM and WCLE are the desired widths of characters in the mantissa +C or the exponent, respectively, of numeric labels, expressed as a +C fraction of the smaller dimension of the curve window. See also +C RFNL, below. +C +C -- RFNL is a reduction factor, used as a multiplier for DNLA, WCLM, +C and WCLE. If ITST .NE. 0, RFNL is initially set to 1. - then, if +C ITST .EQ. 2 or 4, it is reset as necessary to shrink the labels. +C +C -- MCIM and MCIE specify the maximum number of characters in the +C mantissa and exponent, respectively, of a numeric label. These +C are input parameters if ITST .EQ. 0, output parameters otherwise. +C +C -- WNLL, WNLR, WNLB, and WNLE are the widths of numeric-label strips +C on the left side, on the right side, at the beginning, and at the +C end, of the axis. These are both input and output parameters of +C AGAXIS. On input, they specify the amount of space available for +C numeric labels - on output, they specify the amount of space used +C (if ITST .EQ. 0) or required (if ITST .NE. 0). Each is stated as +C a fraction of either the width or the height of the curve window, +C depending on the orientation of the axis in the curve window. +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only ones +C actually used here are ISLD, MWCM, MWCE, and MDLA. ISLD is a solid- +C line dash pattern (sixteen one bits). MWCM, MWCE, and MDLA specify +C the minimum allowed values of the width of a character in a label +C mantissa, the width of a character in a label exponent, and the +C distance of a label from the axis. All are in plotter coordinate +C units. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The AUTOGRAPH function AGFPBN is of type integer. +C + INTEGER AGFPBN +C +C Local data required are as follows: +C +C BFRM is a buffer in which the routine AGNUMB returns the characters of +C a label mantissa. CTMP holds a sub-string from an AGPWRT call. +C + CHARACTER*40 BFRM + CHARACTER*40 CTMP +C +C BFRE is a buffer in which the routine AGNUMB returns the characters of +C a label exponent. +C + CHARACTER*5 BFRE +C +C XMJT, YMJT, XMNT, and YMNT are used to hold x and y offsets to the +C endpoints of left-of-label and right-of-label portions of major and +C minor tick marks. +C + DIMENSION XMJT(4),YMJT(4),XMNT(4),YMNT(4) +C +C SMJP is the minimum distance allowed between major tick marks, in +C plotter coordinate units. +C + DATA SMJP / 4. / +C +C FBGM, FBGP, FNDM, and FNDP are the coordinates of points a little on +C either side of the beginning and end of the axis, as fractions of the +C distance along the axis. +C + DATA FBGM / -0.000001 / + DATA FBGP / +0.000001 / + DATA FNDM / +0.999999 / + DATA FNDP / +1.000001 / +C +C HCFW is an arithmetic statement function specifying the height of a +C character as a function of its width (not counting "white space"). +C The value of the multiplier was determined heuristically, by trying +C various values and seeing which gave the best results. +C + HCFW(WDTH)=1.25*WDTH +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the initialization section of AGAXIS. +C +C Unpack integer values from floating-point arguments. +C + ITST=IFIX(QTST) + ISPA=IFIX(QSPA) + LLUA=IFIX(QLUA) + NBTP=IFIX(QBTP) + NMNT=IFIX(QMNT) + NLTP=IFIX(QLTP) + NLEX=IFIX(QLEX) + NLFL=IFIX(QLFL) + NLOF=IFIX(QLOF) + NLOS=IFIX(QLOS) + MCIM=IFIX(QCIM) + MCIE=IFIX(QCIE) +C +C Initialize the local flags which specify what entities to draw, using +C values appropriate for the following quick exit. +C + LDAX=1-ISPA + LDNL=0 + LDMN=0 +C +C If AGAXIS is to draw only the axis, exit immediately. +C + IF (ITST.LT.0) GO TO 800 +C +C If either NBTP or BASE is zeroed, exit immediately. +C + IF (NBTP.EQ.0.OR.BASE.EQ.0.) GO TO 800 +C +C Re-initialize the flag controlling the drawing of numeric labels. +C + IF (NLTP.NE.0) LDNL=1 +C +C If this is not a test run, skip. +C + IF (ITST.EQ.0) GO TO 101 +C +C This is a test run - exit if there are no numeric labels. +C + IF (LDNL.EQ.0) GO TO 800 +C +C This is a test run and the axis is to have numeric labels - initialize +C the numeric-label orientation and sizing parameters. Clobber drawing. +C + NLOF=MOD(NLOF+3600,360) + NLOS=MOD(NLOS+3600,360) + RFNL=1. + MCIM=0 + MCIE=0 + LDMJ=0 + LDMN=0 +C +C The main body of the initialization follows. +C +C Compute the length of the smaller side of the curve window, in the +C plotter coordinate system. +C + 101 SCWP=AMIN1(WCWP,HCWP) +C +C Compute a set of direction numbers for the axis, in the curve-window +C coordinate system (the change in x and y from the beginning to the +C end of the axis). +C + XDNA=XNDA-XBGA + YDNA=YNDA-YBGA +C +C Compute the length of the axis in the plotter coordinate system and +C its direction cosines. +C + XDNP=XDNA*WCWP + YDNP=YDNA*HCWP + AXLP=SQRT(XDNP*XDNP+YDNP*YDNP) + XDCA=XDNP/AXLP + YDCA=YDNP/AXLP +C +C Compute the axis orientation angle, in degrees counter-clockwise. +C + IAOR=MOD(IFIX(57.2957795130823*ATAN2(YDCA,XDCA)+3600.5),360) +C +C Compute the multiplicative constants required to convert a fraction of +C the axis length to a fraction of the width or height of the curve +C window (a distance in x or y). +C + CFAX=AXLP/WCWP + CFAY=AXLP/HCWP +C +C Compute the multiplicative constants required to convert a fraction of +C the axis length to a fraction of the along-axis and perpendicular-to- +C axis sides of the curve window. +C + CFAA=ABS(XDCA*CFAX+YDCA*CFAY) + CFAP=ABS(XDCA*CFAY+YDCA*CFAX) +C +C Compute the quantities (UBEG) and (UDIF) for AGFTOL. +C + IF (LLUA.NE.0) GO TO 102 +C + UBEG=UBGA + UDIF=UNDA-UBGA + GO TO 103 +C + 102 UBEG=ALOG10(UBGA) + UDIF=ALOG10(UNDA)-UBEG +C +C SMJT and SMNT are fractions of the axis length and specify the minimum +C space which must be available between two major ticks before the major +C ticks themselves or the minor ticks between them, respectively, may be +C drawn. +C + 103 SMJT=SMJP/AXLP + SMNT=SMJT*FLOAT(NMNT+1) +C +C Initialize the fractional numeric-label character heights. +C + FHCM=0. + FHCE=0. +C +C If the axis has no numeric labels, skip the following code. +C + IF (LDNL.EQ.0) GO TO 104 +C +C Zero the numeric-label offset. +C + FNLO=0. +C +C The numeric-label parameters are computed by an internal procedure +C (which see, below). +C + ASSIGN 104 TO JMP3 + GO TO 500 +C +C If this is a test run, skip the following code. +C + 104 IF (ITST.NE.0) GO TO 200 +C +C This is not a test run. First, set up the tick-mark parameters. +C +C Compute the multiplicative constant required to convert a fraction of +C the smaller dimension of the grid to a fraction of the axis length. +C + CSFA=SCWP/AXLP +C +C Compute the widths of the left and right portions of the numeric-label +C space as fractions of the axis length, affixing an appropriate sign. +C + FNLL=-WNLL/CFAP + FNLR=+WNLR/CFAP +C +C Compute a jump parameter to sort out the axis orientations. +C + JAOR=1+IAOR/90 +C +C The routine AGCTKO is used to compute the rest of the tick parameters. +C + CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR, 1,QJDP, + + WMJL,WMJR,FNLL,FNLR,MJ12,MJ34,XMJT,YMJT) +C + CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMNT,QNDP, + + WMNL,WMNR,FNLL,FNLR,MN12,MN34,XMNT,YMNT) +C +C Set the flags controlling the drawing of tick marks. +C + LDMJ=MJ12+MJ34 + LDMN=MN12+MN34 + LDLR=-(LDMJ+LDMN) +C +C If no numeric labels are to be drawn, skip the following code. +C + IF (LDNL.EQ.0) GO TO 117 +C +C Numeric labels are to be drawn. Precompute parameters which will be +C used to position labels relative to the axis. +C +C Compute the widths and heights of the longest possible label mantissa +C and exponent, as fractions of the length of the axis. +C + FWLM=FLOAT(MCIM)*FWCM + FWLE=FLOAT(MCIE)*FWCE + FHLM=FHCM + FHLE=FHCE + IF (MCIE.EQ.0) FHLE=0. +C +C Jump on the label-to-axis orientation. +C + GO TO (105,106,107,108) , JLAO +C +C Label is at a 0-degree angle to the axis. +C + 105 FBLP=-FHLM + GO TO 109 +C +C Label is at a 90-degree angle to the axis. +C + 106 FBLA=0. + FBLQ=-FWLM-FWLE + GO TO 110 +C +C Label is at a 180-degree angle to the axis. +C + 107 FBLP=FHLM+FHLE + GO TO 109 +C +C Label is at a 270-degree angle to the axis. +C + 108 FBLA=0. + FBLQ=FWLM+FWLE + GO TO 110 +C +C Label is parallel to the axis. +C + 109 FNLW=FHLM+.5*FHLE + FBLQ=0. + GO TO 111 +C +C Label is perpendicular to the axis. +C + 110 FNLW=FWLM+FWLE + FBLP=0. +C +C If the labels will not fit in the space provided, clobber them. +C + 111 IF (.999999*FNLW.LT.FNLR-FNLL) GO TO 112 +C + LDNL=0 + GO TO 117 +C +C Jump on the signed value of the numeric-label distance from the axis. +C + 112 IF (DNLA) 113,114,115 +C +C Labels are to the right of the axis. +C + 113 FNLC=FDLA+.5*FNLW + FBLP=FDLA+.5*ABS(FBLP-FHLE) + FBLQ=FDLA+.5*ABS(FBLQ+FWLM-FWLE) + GO TO 116 +C +C Labels are centered on the axis. +C + 114 FNLC=0. + FBLP=0. + FBLQ=0. + GO TO 116 +C +C Labels are to the left of the axis. +C + 115 FNLC=-(FDLA+.5*FNLW) + FBLP=-(FDLA+.5*ABS(FBLP)) + FBLQ=-(FDLA+.5*ABS(FBLQ-FWLM+FWLE)) +C + 116 FNLO=.5*(FNLL+FNLR)-FNLC +C +C If the axis would pass through the offset labels, clobber it. +C + IF (FNLL*FNLR.LT.0.) LDAX=0 +C +C Jump to draw numeric labels and/or tick marks. +C + GO TO 200 +C +C No numeric labels are to be drawn. If no tick marks are to be drawn +C either, exit. +C + 117 IF (LDLR.EQ.0) GO TO 800 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following code directs the process of tick-marking and labelling +C the axis, using the internal procedures which follow it. If the +C label-coordinate-system value 0 maps onto the axis, tick-marking and +C labelling are done in two passes, one starting at 0 and proceeding +C in a positive direction and the other starting at 0 and proceeding +C in a negative direction. If the label-coordinate-system value 0 does +C not map onto the axis, only one pass is required. +C +C First, determine the label-coordinate-system values VBGM and VNDP at +C the points FBGM and FNDP, a little beyond the ends of the axis. +C + 200 CALL AGFTOL (IAXS,1,FBGM,VBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) + CALL AGFTOL (IAXS,1,FNDP,VNDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) +C +C If zero falls on the axis, jump to the two-pass section of the code. +C + IF (VBGM*VNDP.LE.0.) GO TO 201 +C +C We may tick-mark and label the axis in a single pass. Compute an +C appropriate starting value for the exponent/multiplier EXMU. +C + SBSE=SIGN(BASE,VBGM) + CALL AGFTOL (IAXS,2,FBGM,EBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + CALL AGFTOL (IAXS,2,FNDP,ENDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + EXMU=AMIN1(EBGM,ENDP) + EXMU=EXMU-AMOD(EXMU,1.)+.5+SIGN(.5,EXMU) +C +C Set the numeric-label-space limits for the beginning and end of the +C axis. +C + FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE) + FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE) +C +C Jump to an internal procedure to tick-mark and label the axis. Return +C from there to the termination section of AGAXIS. +C + ASSIGN 800 TO JMP1 + GO TO 300 +C +C Tick marks and labels must be done in two passes. First, draw the +C tick mark and/or label at the zero position in the label system, using +C an internal procedure below. A number of parameters must be preset. +C + 201 CALL AGFTOL (IAXS,-1,0.,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) +C +C Determine whether label is to be drawn or not. +C + LDLB=0 + IF (LDNL.EQ.0) GO TO 202 + LDLB=1 +C +C The mantissa portion of the label consists of the single character 0. +C + BFRM(1:1)='0' + NCIM=1 + IPXM=0 +C +C The label has no exponent portion. +C + NCIE=0 +C +C Allow the user to change the numeric label. +C + CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE) +C +C Compute the length of the mantissa, the exponent, and the whole label. +C + FLLM=FLOAT(NCIM)*FWCM + FLLE=FLOAT(NCIE)*FWCE + FLLB=FLLM+FLLE +C +C The numeric-label space begins and ends at impossible values. +C + FNLB=-10. + FNLE=+10. +C +C Force the labeler to update FNLB, rather than FNLE. +C + FDIR=1. +C +C Jump to an internal procedure to draw the label and/or the tick mark. +C + 202 ASSIGN 203 TO JMP2 + GO TO 400 +C +C Save the position of the zero-point (FRAX, expressed as a fraction of +C the axis length) and preset the parameter DZRT, which is the minimum +C distance from the zero-point at which a major tick mark could occur, +C and the parameter DZRL, which is the minimum distance from the zero- +C point at which a label could occur. Set the label-space limit FNLE. +C Preset the internal-procedure exit parameter JMP1. +C + 203 ASSIGN 205 TO JMP1 + FZRO=FRAX + DZRT=AMAX1(SMJT,1.6*FLOAT(LDNL)*FHCM) + IF (LDNL.EQ.0) GO TO 204 + DZRL=FNLB-FZRO + FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE) +C +C Do the portion of the axis lying in the direction specified by DZRT. +C If it is too short, skip it entirely. +C + 204 FRAX=FZRO+DZRT + IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO JMP1 , (205,800) +C +C Find out whether BASE must be negated for this portion. +C + CALL AGFTOL (IAXS,1,FRAX,VLCS,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) + SBSE=SIGN(BASE,VLCS) +C +C Compute a starting value of the exponent/multiplier EXMU. +C + CALL AGFTOL (IAXS,2,FRAX,EXMU,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + EXMU=EXMU-AMOD(EXMU,1.)+.5+SIGN(.5,EXMU) +C +C Jump to an internal procedure to draw the tick marks and/or labels. +C + GO TO 300 +C +C Set up to do the second portion of the axis, then go do it. +C + 205 ASSIGN 800 TO JMP1 + DZRT=-DZRT + IF (LDNL.EQ.0) GO TO 204 + FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE) + FNLE=FZRO-DZRL + GO TO 204 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP1. Its purpose is to tick-mark and label a portion of the +C axis (perhaps the entire axis) at positions determined by consecutive +C values of the parameter EXMU. It prevents tick marks from piling up +C or passing through the label space and prevents overlapping of labels. +C Tick marks are drawn alternately from left to right or vice-versa. +C +C The caller has provided an initial value of EXMU, but we must consider +C possible minor tick marks in the interval (EXMU-1.,EXMU). +C + 300 EXMU=EXMU-1. +C +C Compute FRAX, which is the fractional distance along the axis, and +C VLCS, which is the value in the label coordinate system corresponding +C to the current value of EXMU. +C + CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) +C +C Move the current values of EXMU, FRAX, and VLCS to ELST, FLST, and +C VLST, specifying the last values of these parameters. Then increment +C EXMU by 1. and recompute FRAX and VLCS. (The loop through consecutive +C values of EXMU begins here.) +C + 301 ELST=EXMU + FLST=FRAX + VLST=VLCS +C + EXMU=EXMU+1. + CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) +C +C FDIR indicates the direction, FDST the magnitude, of step along axis. +C + FDIR=FRAX-FLST + FDST=ABS(FDIR) +C +C Draw minor tick marks, if any, in the interval (FLST,FRAX). +C + IF (LDMN.EQ.0.OR.FDST.LT.SMNT) GO TO 304 +C +C Use the dashed-line pattern for minor tick marks. +C + CALL DASHDB (AGFPBN(QNDP)) +C +C Minor tick marks are equally spaced in the label-coordinate system. +C + VINC=(VLCS-VLST)/FLOAT(NMNT+1) +C + DO 303 I=1,NMNT + VMNT=VLST+VINC*FLOAT(I) + CALL AGFTOL (IAXS,-1,VMNT,FMNT,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP, + + SBSE) + IF (FMNT.LT.FBGP.OR.FMNT.GT.FNDM) GO TO 303 + XPAX=XBGA+FMNT*XDNA + YPAX=YBGA+FMNT*YDNA + LDLR=-LDLR + IF (LDLR.LT.0) GO TO 302 + CALL AGCHAX (0,IAXS,3,VMNT) + IF (MN12.NE.0) CALL LINED (XPAX+XMNT(1),YPAX+YMNT(1), + + XPAX+XMNT(2),YPAX+YMNT(2)) + IF (MN34.NE.0) CALL LINED (XPAX+XMNT(3),YPAX+YMNT(3), + + XPAX+XMNT(4),YPAX+YMNT(4)) + CALL AGCHAX (1,IAXS,3,VMNT) + GO TO 303 + 302 CALL AGCHAX (0,IAXS,3,VMNT) + IF (MN34.NE.0) CALL LINED (XPAX+XMNT(4),YPAX+YMNT(4), + + XPAX+XMNT(3),YPAX+YMNT(3)) + IF (MN12.NE.0) CALL LINED (XPAX+XMNT(2),YPAX+YMNT(2), + + XPAX+XMNT(1),YPAX+YMNT(1)) + CALL AGCHAX (1,IAXS,3,VMNT) + 303 CONTINUE +C +C If the end of the axis has been reached, return to caller. +C + 304 IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO JMP1 , (205,800) +C +C Draw the major tick mark and/or the numeric label at FRAX. +C + IF (FDST.LT.SMJT) GO TO 301 + LDLB=0 + IF (LDNL.EQ.0) GO TO 305 + CALL AGNUMB (NBTP,SBSE,EXMU,NLTP,NLEX,NLFL,BFRM,40,NCIM,IPXM,BFRE, + + 5,NCIE) + CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE) +C +C If this is not a test run, mantissa and exponent length are checked. +C + IF (ITST.EQ.0.AND.(NCIM.GT.MCIM.OR.NCIE.GT.MCIE)) GO TO 305 + LDLB=1 + FLLM=FLOAT(NCIM)*FWCM + FLLE=FLOAT(NCIE)*FWCE + FLLB=FLLM+FLLE +C +C Use the next internal procedure to draw the major tick and/or label. +C + 305 ASSIGN 301 TO JMP2 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP2. Its purpose is to draw the major tick mark and/or the +C numeric label at a specified point on the axis or, if ITST is .NE. 0, +C to predict the amount of space which will be required for such items. +C +C Jump if no label is to be drawn. +C + 400 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 410 +C +C See if the label will fit without overlapping another label. To do +C this, first compute its fractional length along the axis (FLAA). +C + GO TO (401,402,401,402) , JLAO +C +C Label is parallel to the axis. Allow for inter-label spacing. +C + 401 FLAA=FLLB+FWCM + GO TO 403 +C +C Label is perpendicular to the axis. Ignore exponent portion. +C + 402 FLAA=1.6*FHCM +C +C Compute the fractional coordinates of the endpoints of the label +C (along the axis) and see if it will fit in the available label space. +C + 403 FLBB=FRAX-.5*FLAA + FLBE=FRAX+.5*FLAA +C + IF (FLBB.GE.FNLB.AND.FLBE.LE.FNLE) GO TO 407 +C +C Label will not fit. Omit it or, if this is a test run, see if any +C remedial action is to be taken. +C + LDLB=0 + IF (ITST.EQ.0) GO TO 411 +C +C This is a test run and we have two consecutive labels which overlap. +C See what can be done about it. +C + GO TO (424,404,406,404) , ITST +C +C We are allowed to shrink the labels. See if they are minimum-size +C already. If so, the only other possibility is to re-orient them. +C + 404 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 405 +C +C If not, shrink them by an amount based on the extent of the overlap, +C reset the parameters affected, and start from square one. +C + RFNL=AMIN1(.9,FDST/(FDST+AMAX1(FNLB-FLBB,FLBE-FNLE)))*RFNL + MCIM=0 + MCIE=0 + ASSIGN 200 TO JMP3 + GO TO 500 +C +C If labels have already been shrunk to minimum size, see if we can +C re-orient them. If not, at least continue with finding the maximum +C mantissa and exponent lengths. +C + 405 IF (ITST.NE.4) GO TO 424 +C +C Try re-orienting the labels. If this has already been tried, or it it +C would be pointless, skip it, but continue with finding the maximum +C mantissa and exponent lengths. +C + 406 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.2.OR.JLAO.EQ.4) GO TO 424 +C +C If re-orienting makes sense, reset the appropriate parameters and +C start from square one. +C + NLOF=NLOF-360 + RFNL=1. + MCIM=0 + MCIE=0 + ASSIGN 200 TO JMP3 + GO TO 500 +C +C Label will fit. Update the label space limits for next time. +C + 407 IF (FDIR.GE.0.) GO TO 408 + FNLE=FLBB + GO TO 409 + 408 FNLB=FLBE +C +C If this is not just a test shot, go off and draw the tick mark/label. +C + 409 IF (ITST.EQ.0) GO TO 411 +C +C If this is a test shot, update the maximum mantissa and exponent +C lengths being generated and exit from this internal procedure. +C + MCIM=MAX0(MCIM,NCIM) + MCIE=MAX0(MCIE,NCIE) + GO TO 424 +C +C No label is to be drawn. If this is a test shot, exit from this +C internal procedure without drawing the tick mark. +C + 410 IF (ITST.NE.0) GO TO 424 +C +C Compute x and y coordinates of current axis point. +C + 411 XPAX=XBGA+FRAX*XDNA + YPAX=YBGA+FRAX*YDNA +C +C Jump if no major tick-mark is to be drawn. Otherwise, set up the +C dash pattern for major tick-marks. +C + IF (LDMJ.EQ.0) GO TO 414 + CALL DASHDB (AGFPBN(QJDP)) +C +C Flip the left-to-right/right-to-left direction flag. +C + LDLR=-LDLR +C +C Draw the first portion of the tick mark. +C + IF (LDLR) 413,414,412 +C + 412 IF (MJ12.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(1),YPAX+YMJT(1),XPAX+XMJT(2),YPAX+YMJT(2)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF + GO TO 414 +C + 413 IF (MJ34.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(4),YPAX+YMJT(4),XPAX+XMJT(3),YPAX+YMJT(3)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF +C +C Draw the label, if any. +C + 414 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 421 +C +C Compute the distances from (XPAX,YPAX) to the beginning of the label - +C along the axis (FBLA) and perpendicular to the axis (FBLP). Each is a +C directed distance whose magnitude represents a fraction of the length +C of the axis. The values depend on the label/axis orientation and the +C distance of the label from the axis. In some cases, these quantities, +C or portions of them, have already been computed. +C + GO TO (415,416,417,418) , JLAO +C +C Label is at a 0-degree angle to the axis. +C + 415 FBLA=-.5*FLLB + GO TO 419 +C +C Label is at a 90-degree angle to the axis. +C + 416 FBLP=FBLQ+FLLM + IF (DNLA.EQ.0.) FBLP=.5*FLLB + GO TO 419 +C +C Label is at a 180-degree angle to the axis. +C + 417 FBLA=.5*FLLB + GO TO 419 +C +C Label is at a 270-degree angle to the axis. +C + 418 FBLP=FBLQ-FLLM + IF (DNLA.EQ.0.) FBLP=-.5*FLLB +C +C Draw the mantissa portion of the label (excluding the "X", if any). +C + 419 DEEX=FBLA*XDCA+(FBLP+FNLO)*YDCA + DEEY=FBLA*YDCA-(FBLP+FNLO)*XDCA + CALL AGCHAX (0,IAXS,4,VLCS) + IF (IPXM.EQ.0) THEN + CALL AGPWRT (XPAX+CFAX*DEEX, + + YPAX+CFAY*DEEY,BFRM,NCIM,IWCM,NLOR,-1) + ELSE + CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-3.*FWCM)*XDCL), + + YPAX+CFAY*(DEEY+(FLLM-3.*FWCM)*YDCL), + + BFRM,IPXM-1,IWCM,NLOR,+1) + CTMP=BFRM(IPXM+1:NCIM) + CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-2.*FWCM)*XDCL), + + YPAX+CFAY*(DEEY+(FLLM-2.*FWCM)*YDCL), + + CTMP,NCIM-IPXM,IWCM,NLOR,-1) + END IF + DEEX=DEEX+FLLM*XDCL + DEEY=DEEY+FLLM*YDCL +C +C Draw the "X" portion of the mantissa, if it was left out above. +C + IF (IPXM.EQ.0) GO TO 420 + DEEX=DEEX-2.5*FWCM*XDCL + DEEY=DEEY-2.5*FWCM*YDCL + CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL-YDCL)), + + YPAX+CFAY*(DEEY-.3*FWCM*(YDCL+XDCL)), + + XPAX+CFAX*(DEEX+.3*FWCM*(XDCL-YDCL)), + + YPAX+CFAY*(DEEY+.3*FWCM*(YDCL+XDCL))) + CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL+YDCL)), + + YPAX+CFAY*(DEEY-.3*FWCM*(YDCL-XDCL)), + + XPAX+CFAX*(DEEX+.3*FWCM*(XDCL+YDCL)), + + YPAX+CFAY*(DEEY+.3*FWCM*(YDCL-XDCL))) + DEEX=DEEX+2.5*FWCM*XDCL + DEEY=DEEY+2.5*FWCM*YDCL + 420 CALL AGCHAX (1,IAXS,4,VLCS) +C +C Draw the exponent portion of the label (if it has one). +C + IF (NCIE.EQ.0) GO TO 421 + DEEX=DEEX-.5*FHCM*YDCL + DEEY=DEEY+.5*FHCM*XDCL + CALL AGCHAX (0,IAXS,5,VLCS) + CALL AGPWRT (XPAX+CFAX*DEEX,YPAX+CFAY*DEEY,BFRE,NCIE,IWCE,NLOR,-1) + CALL AGCHAX (1,IAXS,5,VLCS) +C +C Draw the second portion of the tick mark, if any. +C + 421 IF (LDLR) 423,424,422 +C + 422 IF (MJ34.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(3),YPAX+YMJT(3),XPAX+XMJT(4),YPAX+YMJT(4)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF + GO TO 424 +C + 423 IF (MJ12.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(2),YPAX+YMJT(2),XPAX+XMJT(1),YPAX+YMJT(1)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF +C +C Exit from internal procedure. +C + 424 GO TO JMP2 , (203,301) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP3. Its purpose is to compute all numeric-label parameters +C required by AGAXIS. +C +C Compute the desired label orientation and its direction cosines. +C + 500 NLOR=NLOF + IF (NLOR.LT.0) NLOR=NLOS +C + XDCL=COS(.017453292519943*FLOAT(NLOR)) + YDCL=SIN(.017453292519943*FLOAT(NLOR)) +C +C Compute JLAO, which is a computed-go-to jump parameter specifying the +C label-to-axis orientation. +C + JLAO=1+MOD(NLOR-IAOR+3600,360)/90 +C +C Compute the width of a character in the label mantissa, the width of a +C character in the label exponent, and the distance of a label from the +C axis, in the plotter coordinate system. +C + IWCM=MAX0(MWCM,IFIX(RFNL*ABS(WCLM)*SCWP+.5)) + IWCE=MAX0(MWCE,IFIX(RFNL*ABS(WCLE)*SCWP+.5)) + IDLA=MAX0(MDLA,IFIX(RFNL*ABS(DNLA)*SCWP+.5)) +C +C Compute the same quantities as fractions of the axis length. +C + FWCM=FLOAT(IWCM)/AXLP + FWCE=FLOAT(IWCE)/AXLP + FDLA=FLOAT(IDLA)/AXLP +C +C Compute character heights as fractions of the axis length. +C + FHCM=HCFW(FWCM) + FHCE=HCFW(FWCE) +C +C Return to internal-procedure caller. +C + GO TO JMP3 , (104,200,801) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the termination section of AGAXIS. +C +C Update the parameters WNLL and WNLR to reflect the amount of space +C used/needed for numeric labels to the left and right of the axis. +C + 800 IF (LDNL.NE.0) GO TO 801 +C +C No numeric labels occur on the axis. Zero WNLL and WNLR and jump. +C + WNLL=0. + WNLR=0. + GO TO 815 +C +C Numeric labels do occur on the axis. Compute the space required. +C + 801 GO TO (802,803,802,803) , JLAO +C +C Labels are parallel to the axis. +C + 802 FNLW=FHCM + IF (MCIE.NE.0) FNLW=FNLW+.5*FHCE + GO TO 804 +C +C Labels are perpendicular to the axis. +C + 803 FNLW=FLOAT(MCIM)*FWCM+FLOAT(MCIE)*FWCE +C +C Jump on the numeric-label-distance-from-axis parameter DNLA. +C + 804 IF (DNLA) 805,806,807 +C +C Labels are to the right of the axis. +C + 805 FNLL=-FDLA + FNLR=+FDLA+FNLW + GO TO 808 +C +C Labels are centered on the axis. +C + 806 FNLL=+.5*FNLW + FNLR=+.5*FNLW + GO TO 808 +C +C Labels are to the left of the axis. +C + 807 FNLL=+FDLA+FNLW + FNLR=-FDLA +C +C Adjust FNLL and FNLR as implied by the numeric-label offset. +C + 808 FNLL=FNLL-FNLO + FNLR=FNLR+FNLO +C +C If this is not a test run, jump to reset WNLL and WNLR. +C + IF (ITST.EQ.0) GO TO 814 +C +C If this is a test run, see if the labels will fit. Jump if so. +C + IF (CFAP*FNLL.LE.WNLL.AND.CFAP*FNLR.LE.WNLR) GO TO 814 +C +C If the labels will not fit, we have a problem. We may or may not be +C able to do anything about it, depending on ITST. +C + GO TO (814,809,813,809) , ITST +C +C We are allowed to shrink the labels. See if they are minimum-size +C already. If so, the only other possibility is to re-orient them. +C + 809 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 812 +C +C If not, shrink them by an amount based on the extent of the problem, +C reset the parameters affected and see if the problem is solved. +C + IF (WNLR+WNLL.GT.0.) GO TO 810 +C + RFNL=.000001*RFNL + GO TO 811 +C + 810 RFNL=AMIN1(.9,(WNLL+WNLR)/(CFAP*(FNLL+FNLR)))*RFNL +C + 811 ASSIGN 801 TO JMP3 + GO TO 500 +C +C If labels have already been shrunk to minimum size, see if we can +C re-orient them. If not, give up. +C + 812 IF (ITST.NE.3) GO TO 814 +C +C Try re-orienting the labels. If this has already been tried, or if it +C would be pointless, give up. +C + 813 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.1.OR.JLAO.EQ.3) GO TO 814 +C +C If re-orienting makes sense, reset the parameters affected and see if +C the problem is solved. +C + NLOF=NLOF-360 + RFNL=1. + ASSIGN 801 TO JMP3 + GO TO 500 +C +C Reset WNLL and WNLR for caller. +C + 814 WNLL=FNLL*CFAP + WNLR=FNLR*CFAP +C +C If this is a test run, we are now done. +C + 815 IF (ITST.GT.0) GO TO 816 +C +C Draw the axis, if it is to be drawn. +C + IF (LDAX.EQ.0) GO TO 816 +C + CALL DASHDB (ISLD) + CALL AGCHAX (0,IAXS,1,0.) + CALL LINED (XBGA,YBGA,XNDA,YNDA) + CALL AGCHAX (1,IAXS,1,0.) +C +C Pack up integer values which might have been changed into the +C corresponding floating-point arguments. +C + 816 QLOF=FLOAT(NLOF) + QLOS=FLOAT(NLOS) + QCIM=FLOAT(MCIM) + QCIE=FLOAT(MCIE) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agback.f b/sys/gio/ncarutil/autograph/agback.f new file mode 100644 index 00000000..108d2b66 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agback.f @@ -0,0 +1,152 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGBACK +C +C The subroutine AGBACK is used to draw a graph background, as directed +C by the current contents of the parameter list. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Declare the block data routine external to force it to load. +C +C +NOAO - Block data replaced with run time initialization subroutine. +C +C EXTERNAL AGDFLT + call agdflt +C +C -NOAO +C +C Do an appropriate SET call for the following routines. The call is +C equivalent to "CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1)", but +C makes the viewport cover the whole plotter frame, which avoids the +C problems resulting from clipping by GKS. +C + CALL SET (0.,1.,0.,1.,-XLCW/(XRCW-XLCW),(1.-XLCW)/(XRCW-XLCW), + + -YBCW/(YTCW-YBCW),(1.-YBCW)/(YTCW-YBCW),1) +C +C Draw the labels, if any, first. +C + IDLB=IFIX(QDLB) + IF (IDLB.EQ.0) GO TO 101 +C + LBIM=IFIX(QBIM) + CALL AGLBLS (IDLB,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C +C Now draw each of the four axes. +C + 101 I=0 +C + 102 I=I+1 +C + IF (I.EQ.5) GO TO 108 +C + IF (QDAX(I).EQ.0.) GO TO 102 +C + GO TO (103,104,105,106) , I +C +C Y axis - left. +C + 103 WNLB(1)=0.-YBGW + IF (XBGA(1)-WNLL(1).LT.DBOX(3,2).AND. + + XBGA(1)+WNLR(1).GT.DBOX(3,1)) WNLB(1)=0.-DBOX(3,4) +C + WNLE(1)=YTGW-1. + IF (XBGA(1)-WNLL(1).LT.DBOX(4,2).AND. + + XBGA(1)+WNLR(1).GT.DBOX(4,1)) WNLE(1)=DBOX(4,3)-1. +C + GO TO 107 +C +C Y axis - right. +C + 104 WNLB(2)=YTGW-1. + IF (XBGA(2)-WNLR(2).LT.DBOX(4,2).AND. + + XBGA(2)+WNLL(2).GT.DBOX(4,1)) WNLB(2)=DBOX(4,3)-1. +C + WNLE(2)=0.-YBGW + IF (XBGA(2)-WNLR(2).LT.DBOX(3,2).AND. + + XBGA(2)+WNLL(2).GT.DBOX(3,1)) WNLE(2)=0.-DBOX(3,4) +C + GO TO 107 +C +C X axis - bottom. +C + 105 WNLB(3)=XRGW-1. + IF (YBGA(3)-WNLL(3).LT.DBOX(2,4).AND. + + YBGA(3)+WNLR(3).GT.DBOX(2,3)) WNLB(3)=DBOX(2,1)-1. +C + WNLE(3)=0.-XLGW + IF (YBGA(3)-WNLL(3).LT.DBOX(1,4).AND. + + YBGA(3)+WNLR(3).GT.DBOX(1,3)) WNLE(3)=0.-DBOX(1,2) +C + GO TO 107 +C +C X axis - top. +C + 106 WNLB(4)=0.-XLGW + IF (YBGA(4)-WNLR(4).LT.DBOX(1,4).AND. + + YBGA(4)+WNLL(4).GT.DBOX(1,3)) WNLB(4)=0.-DBOX(1,2) +C + WNLE(4)=XRGW-1. + IF (YBGA(4)-WNLR(4).LT.DBOX(2,4).AND. + + YBGA(4)+WNLL(4).GT.DBOX(2,3)) WNLE(4)=DBOX(2,1)-1. +C + 107 Q=AMIN1(0.,QDAX(I)) +C + CALL AGAXIS (I,Q, + + QSPA(I),WCWP,HCWP,XBGA(I),YBGA(I),XNDA(I),YNDA(I), + + QLUA(I),UBGA(I),UNDA(I),FUNS(I),QBTP(I),BASE(I), + + QJDP(I),WMJL(I),WMJR(I),QMNT(I),QNDP(I),WMNL(I), + + WMNR(I),QLTP(I),QLEX(I),QLFL(I),QLOF(I),QLOS(I), + + DNLA(I),WCLM(I),WCLE(I),RFNL(I),QCIM(I),QCIE(I), + + WNLL(I),WNLR(I),WNLB(I),WNLE(I)) +C + GO TO 102 +C +C Do set call for user and return. +C + 108 CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agbnch.f b/sys/gio/ncarutil/autograph/agbnch.f new file mode 100644 index 00000000..4aee636a --- /dev/null +++ b/sys/gio/ncarutil/autograph/agbnch.f @@ -0,0 +1,35 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + CHARACTER*16 FUNCTION AGBNCH (IDSH) +C +C The value of this function is the character-dash-pattern equivalent of +C the integer dash pattern IDSH, a string of quotes and/or dollar signs. +C Note that the support routines IAND and ISHIFT are used. +C + KDSH=IDSH +C + DO 101 I=16,1,-1 + IF (IAND(KDSH,1).EQ.0) THEN + AGBNCH(I:I)='''' + ELSE + AGBNCH(I:I)='$' + END IF + KDSH=ISHIFT(KDSH,-1) + 101 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchax.f b/sys/gio/ncarutil/autograph/agchax.f new file mode 100644 index 00000000..451bce5c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchax.f @@ -0,0 +1,41 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHAX (IFLG,IAXS,IPRT,VILS) +C +C The routine AGCHAX is called by AGAXIS just before and just after each +C of a selected set of objects on the axes are drawn. A user may supply +C a version to change the appearance of these objects. The arguments +C are as follows: +C +C - IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C - IAXS is the number of the axis in question. The values 1, 2, 3, and +C 4 imply the right, left, bottom, and top axes, respectively. +C +C - IPRT is an integer implying which part of the axis is being drawn. +C The value 1 implies the line itself, 2 a major tick, 3 a minor tick, +C 4 the mantissa of a label, and 5 the exponent of a label. +C +C - VILS is the value, in the label coordinate system along the axis, +C associated with the position of the object being drawn. IPRT=1 +C implies VILS=0. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchcu.f b/sys/gio/ncarutil/autograph/agchcu.f new file mode 100644 index 00000000..1364ad28 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchcu.f @@ -0,0 +1,44 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHCU (IFLG,KDSH) +C +C The routine AGCHCU is called by AGCURV just before and just after each +C curve is drawn. The default version does nothing. A user may supply +C a version to change the appearance of the curves. The arguments are +C as follows: +C +C - IFLG is zero if a curve is about to be drawn, non-zero if a curve +C has just been drawn. +C +C - KDSH is the last argument of AGCURV, as follows: +C +C AGCURV called by Value of KDSH +C ---------------- ---------------------------------------- +C EZY 1 +C EZXY 1 +C EZMY "n" or "-n", where n is the curve number +C EZMXY "n" or "-n", where n is the curve number +C the user program the user value +C +C The sign of KDSH, when AGCURV is called by EZMY or EZMXY, indicates +C whether the "user" dash patterns or the "alphabetic" dash patterns +C were selected for use. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchil.f b/sys/gio/ncarutil/autograph/agchil.f new file mode 100644 index 00000000..1952cf68 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchil.f @@ -0,0 +1,36 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHIL (IFLG,LBNM,LNNO) +C + CHARACTER*(*) LBNM +C +C The routine AGCHIL is called by AGLBLS just before and just after each +C informational-label line of text is drawn. The default version does +C nothing. A user may supply a version to change the appearance of the +C text lines. The arguments are as follows: +C +C - IFLG is zero if a text line is about to be drawn, non-zero if one +C has just been drawn. +C +C - LBNM is the name of the label containing the line in question. +C +C - LNNO is the number of the line. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchnl.f b/sys/gio/ncarutil/autograph/agchnl.f new file mode 100644 index 00000000..3b42a5f6 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchnl.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) +C + CHARACTER*(*) CHRM,CHRE +C +C The routine AGCHNL is called by AGAXIS just after it has set up the +C character strings comprising a numeric label along an axis. The +C default version does nothing. A user may supply his own version to +C change the numeric labels. For each numeric label, this routine is +C called twice by AGAXIS - once to determine how much space will be +C required when the label is actually drawn and once just before it +C is actually drawn. The arguments are as follows: +C +C - IAXS is the number of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axes, respectively. +C The value of IAXS must not be altered. +C +C - VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C - CHRM, on entry, is a character string containing the mantissa of the +C numeric label, as it will appear if AGCHNL makes no changes. If the +C numeric label includes a "times" symbol, it will be represented by +C a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C - MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C - NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C - IPXM, on entry, is zero if there is no "times" symbol in CHRM; if it +C is non-zero, it is the index of the appropriate character position +C in CHRM. If AGCHNL changes the position of the "times" symbol in +C CHRM, removes it, or adds it, the value of IPXM must be changed. +C +C - CHRE, on entry, is a character string containing the exponent of the +C numeric label, as it will appear if AGCHNL makes no changes. CHRE +C may be modified. +C +C - MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C - NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agctcs.f b/sys/gio/ncarutil/autograph/agctcs.f new file mode 100644 index 00000000..d9f67d5f --- /dev/null +++ b/sys/gio/ncarutil/autograph/agctcs.f @@ -0,0 +1,79 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCTCS (TPID,ITCS) +C + CHARACTER*(*) TPID +C +C The routine AGCTCS is called by the routines AGGETC and AGSETC to +C check what type of character-string parameter is implied by the +C parameter identifier TPID and return an appropriate value of ITCS, as +C follows: +C +C -- ITCS = 0 implies that the parameter is not intrinsically of type +C character and that AGGETC/AGSETC should not have been called in +C the way that it was. +C +C -- ITCS = 1 implies a dash-pattern parameter. +C +C -- ITCS = 2 implies a label name. +C +C -- ITCS = 3 implies the line-end character. +C +C -- ITCS = 4 implies the text of some line of some label. +C +C Find out where in the parameter list the requested parameter lies. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C See if it's a dash pattern. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.GE.LODP.AND.LOPA.LE.LODP+NIDP-1) THEN + ITCS=1 + RETURN + END IF +C +C See if it's a label name. +C + CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) THEN + ITCS=2 + RETURN + END IF +C +C See if it's the line-end character. +C + CALL AGSCAN ('LINE/END .',LOLE,NILE,IILE) + IF (LOPA.EQ.LOLE) THEN + ITCS=3 + RETURN + END IF +C +C See if it's the text of some label line. +C + CALL AGSCAN ('LINE/BUFF/CONT.',LOLB,NILB,IILB) + IF (LOPA.GE.LOLB.AND.LOPA.LE.LOLB+NILB-1.AND. + + MOD(LOPA-LOLB,6).EQ.3) THEN + ITCS=4 + RETURN + END IF +C +C Error - type not recognizable. +C + ITCS=0 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agctko.f b/sys/gio/ncarutil/autograph/agctko.f new file mode 100644 index 00000000..105438cc --- /dev/null +++ b/sys/gio/ncarutil/autograph/agctko.f @@ -0,0 +1,150 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMMT, + + QMDP,WMML,WMMR,FNLL,FNLR,MM12,MM34,XMMT,YMMT) +C + DIMENSION XMMT(4),YMMT(4) +C +C The routine AGCTKO is used to compute the x and y offsets to the end- +C points of the left-of-label and right-of-label portions of the major +C and minor tick marks. See AGAXIS for definitions of the arguments. +C +C A note about WMML and WMMR: Each is a positive number, of the form +C (E) or (1+E), where E (=EPSILON) is .LT. 1. and is expressed as a +C fraction of the smaller side of the curve window. If the form (E) is +C used, it implies just a tick of length E; if the form (1+E) is used, +C it implies a tick long enough to reach the edge of the curve window, +C plus the length E. +C +C If the tick-mark count NMMT .EQ. 0 or the tick-mark dash pattern QMDP +C .EQ. 0 or both the left-of-axis and right-of-axis tick-mark lengths +C WMML and WMMR .EQ. 0, then no tick marks are to be drawn. +C + IF (NMMT.EQ.0.OR.QMDP.EQ.0..OR.(WMML.EQ.0..AND.WMMR.EQ.0.)) + * GO TO 115 +C +C Compute the distances of the tick mark ends from the axis as fractions +C of the axis length, using only the (EPSILON) portion of WMML and WMMR. +C + FMML=-CSFA*AMOD(WMML,1.) + FMMR=+CSFA*AMOD(WMMR,1.) +C +C If the labels overlap the axis and the (EPSILON) form was used for +C WMML or WMMR, move the tick mark to the end of the label. +C + IF (FNLL*FNLR.GE.0.) GO TO 101 +C + IF (WMML.LT.1.) FMML=FMML+FNLL +C + IF (WMMR.LT.1.) FMMR=FMMR+FNLR +C +C Compute the x and y offsets to the ends of the tick mark. +C + 101 XMML=+CFAX*FMML*YDCA + YMML=-CFAY*FMML*XDCA + XMMR=+CFAX*FMMR*YDCA + YMMR=-CFAY*FMMR*XDCA +C +C If the (1+EPSILON) form was used for WMML or WMMR, adjust XMML, YMML, +C XMMR, and YMMR as implied by the current axis orientation. +C + IF (WMML.LT.1.) GO TO 107 +C + GO TO (102,103,104,105) , JAOR +C +C Axis at 0 degrees (left to right). +C + 102 YMML=YMML+1.-YBGA + GO TO 106 +C +C Axis at 90 degrees (bottom to top). +C + 103 XMML=XMML-XBGA + GO TO 106 +C +C Axis at 180 degrees (right to left). +C + 104 YMML=YMML-YBGA + GO TO 106 +C +C Axis at 270 degrees (top to bottom). +C + 105 XMML=XMML+1.-XBGA +C + 106 FMML=(XMML+YMML)/(CFAX*YDCA-CFAY*XDCA) +C + 107 IF (WMMR.LT.1.) GO TO 113 +C + GO TO (108,109,110,111) , JAOR +C +C Axis at 0 degrees (left to right). +C + 108 YMMR=YMMR-YBGA + GO TO 112 +C +C Axis at 90 degrees (bottom to top). +C + 109 XMMR=XMMR+1.-XBGA + GO TO 112 +C +C Axis at 180 degrees (right to left). +C + 110 YMMR=YMMR+1.-YBGA + GO TO 112 +C +C Axis at 270 degrees (top to bottom). +C + 111 XMMR=XMMR-XBGA +C + 112 FMMR=(XMMR+YMMR)/(CFAX*YDCA-CFAY*XDCA) +C +C Now split the tick mark into two portions - one to the left, and one +C to the right, of the numeric label space. +C + 113 XMMT(1)=XMML + YMMT(1)=YMML + XMMT(2)=XMMR + YMMT(2)=YMMR + MM12=1 + MM34=0 + IF (FMMR.LE.FNLL.OR.FNLL.GE.FNLR) RETURN +C + MM12=0 + IF (FMML.GE.FNLL) GO TO 114 + MM12=1 + XMMT(2)=+CFAX*(FNLL-.005*CSFA)*YDCA + YMMT(2)=-CFAY*(FNLL-.005*CSFA)*XDCA +C + 114 IF (FMMR.LE.FNLR) RETURN +C + MM34=1 + XMMT(4)=XMMR + YMMT(4)=YMMR + XMMT(3)=XMML + YMMT(3)=YMML +C + IF (FMML.GE.FNLR) RETURN + XMMT(3)=+CFAX*(FNLR+.005*CSFA)*YDCA + YMMT(3)=-CFAY*(FNLR+.005*CSFA)*XDCA + RETURN +C +C No ticks to be drawn - zero the flags MM12 and MM34 to indicate this. +C + 115 MM12=0 + MM34=0 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agcurv.f b/sys/gio/ncarutil/autograph/agcurv.f new file mode 100644 index 00000000..47624321 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agcurv.f @@ -0,0 +1,149 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCURV (XVEC,IIEX,YVEC,IIEY,NEXY,KDSH) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGCURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where, if the primary parameter 'INVERT.' is zero, +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If 'INVERT.' is non-zero, the definitions are interchanged, so that +C +C X(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case X(I)=I), and +C Y(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C If the primary parameter 'WINDOW.' is zero, AGKURV is called; it does +C no windowing. If 'WINDOW.' is non-zero, AGQURV is called; it omits +C portions of the curve which fall outside the current curve window. +C +C The argument KDSH specifies the dash pattern to be used. If KDSH is +C negative, the function MOD(IABS(KDSH),26) is used to select a solid +C line interrupted by one of the alphabetic characters. If KDSH is +C zero, the user is assumed to have done his own DASHD call. If KDSH +C is positive, the function MOD(KDSH,NODP) is used to select one of the +C dash patterns in the parameter group 'DASH/PATTERNS.'. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C Declare the block data routine external to force it to load. +C +C +NOAO +C EXTERNAL AGDFLT +C -NOAO +C +C DASH receives alphabetic dash patterns. +C + CHARACTER*10 DASH +C +C ALPH contains an alphabet. +C + CHARACTER*26 ALPH +C + DATA ALPH / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' / +C +C +NOAO - replace blockdata with run time initialization. + call agdflt +C -NOAO +C +C Check for an alphabetic dash pattern. +C + IF (KDSH.LT.0) THEN + IDSH=MOD(-KDSH-1,26)+1 + IPSN=MOD(3*IDSH-1,10)+1 + DASH='$$$$$$$$$$' + DASH(IPSN:IPSN)=ALPH(IDSH:IDSH) + CALL AGSTCH (DASH,10,IDCS) + CALL AGDASH (FLOAT(IDCS),WODQ,WOCD,SCWP) + CALL AGDLCH (IDCS) +C +C Check for a dash pattern from the group "DASH/PATTERNS." +C + ELSE IF (KDSH.GT.0) THEN + IDSH=MOD(KDSH-1,IFIX(QODP))+1 + CALL AGDASH (QDSH(IDSH),WODQ,WOCD,SCWP) +C + END IF +C +C Now that the dash pattern is determined, do the SET call. +C + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C +C Give the user a chance to modify the curve (by changing line style, +C color, etc.). +C + CALL AGCHCU (0,KDSH) +C +C Decide whether AGKURV or AGQURV is to draw the curve. +C + IF (QWND.EQ.0.) THEN +C +C No windowing requested - AGKURV is used. +C + IF (QIXY.EQ.0.) THEN + CALL AGKURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL(1)) + ELSE + CALL AGKURV (YVEC,IIEY,XVEC,IIEX,NEXY,SVAL(1)) + END IF +C + ELSE +C +C Windowing requested - AGQURV is used. +C + IF (QIXY.EQ.0.) THEN + CALL AGQURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL(1)) + ELSE + CALL AGQURV (YVEC,IIEY,XVEC,IIEX,NEXY,SVAL(1)) + END IF +C + END IF +C +C Give the user a chance to change back what he changed above. +C + CALL AGCHCU (1,KDSH) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdash.f b/sys/gio/ncarutil/autograph/agdash.f new file mode 100644 index 00000000..243eb808 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdash.f @@ -0,0 +1,69 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGDASH (DASH,WODQ,WOCD,SCWP) +C +C AGDASH sets up the DASHD call required to establish the dash pattern +C desired for the next curve. The arguments are as follows: +C +C -- DASH specifies the desired dash pattern. A positive value implies +C that a binary dash pattern is to be used, a negative value that a +C character-string dash pattern is to be used. +C +C -- WODQ is the width of the solid-line segment specified by a dollar +C sign and the gap specified by a quote, expressed as a fraction of +C the smaller side of the curve window. +C +C -- WOCD is the width of a character which is to be a part of the dash +C pattern, expressed in the same units as WODQ. +C +C -- SCWP is the length of the smaller side of the curve window, in +C plotter coordinate units. +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only ones +C used here are MWCD and MWDQ - the minimum widths of characters and +C spaces, respectively, in the dash pattern. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C The AUTOGRAPH function AGFPBN is of type integer. +C + INTEGER AGFPBN +C + IWCD=MAX0(MWCD,IFIX(WOCD*SCWP)) + IWDQ=MAX0(MWDQ,IFIX(WODQ*SCWP)) +C + IF (DASH.GE.0.) THEN + CALL DASHDB (AGFPBN(DASH)) + ELSE + CALL AGGTCH (IFIX(DASH),CHS1,LNC1) + CALL DASHDC (CHS1(1:LNC1),IWDQ,IWCD) + END IF +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdflt.bd b/sys/gio/ncarutil/autograph/agdflt.bd new file mode 100644 index 00000000..ddbde9a1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdflt.bd @@ -0,0 +1,414 @@ +C +NOAO +C This block data has been rewritten as a run time initialization +C subroutine (see file agdflt.f). This original block data file +C is retained for reference only. +C -NOAO +C +C --------------------------------------------------------------------- +C + BLOCK DATA AGDFLT +C +C The block data subroutine AGDFLT defines the default values of those +C AUTOGRAPH parameters which can be declared in a DATA statement. See +C AGINIT for code initializing other AUTOGRAPH parameters. +C +C Following are declarations of all the AUTOGRAPH common blocks. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of +C type character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C + CHARACTER*504 CHS1,CHS2 +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C --------------------------------------------------------------------- +C +C Following are declarations of default values of variables in the +C AUTOGRAPH common blocks. +C +C --------------------------------------------------------------------- +C +C QFRA defines the control parameter 'FRAME.', which specifies when, if +C ever, the EZ... routines are to call FRAME to advance to a new frame. +C + DATA QFRA / 1. / +C +C QSET defines the control parameter 'SET.', which determines how the +C last call to the plot-package routine "SET" is to affect AUTOGRAPH. +C + DATA QSET / 1. / +C +C QROW defines the control parameter 'ROW.', which determines how the x +C and y input arrays (in calls to AGSTUP and AGCURV) are to be used. +C + DATA QROW / 1. / +C +C QIXY defines the control parameter 'INVERT.', which, if set non-zero, +C causes the routines AGSTUP and AGCURV to behave as if the arguments +C defining the x and y data had been interchanged. +C + DATA QIXY / 0. / +C +C QWND defines the control parameter 'WINDOW.', which, if set non-zero, +C causes curves drawn to be scissored by the edge of the curve window. +C + DATA QWND / 0. / +C +C QBAC defines the control parameter 'BACKGROUND.', which can be given +C any of four values to set up four specific types of plot background. +C + DATA QBAC / 1. / +C +C SVAL defines the control parameters 'NULL/1.' and 'NULL/2.', which are +C used in various ways by AUTOGRAPH. +C + DATA SVAL(1) / 1E36 / , SVAL(2) / 2E36 / +C +C XLGF, XRGF, YBGF, and YTGF define the parameter-group 'GRAPH.'; they +C specify the position of the graph window within the plotter frame. +C + DATA XLGF / 0. / , XRGF / 1. / , YBGF / 0. / , YTGF / 1. / +C +C XLGD, XRGD, YBGD, and YTGD define the first four parameters in the +C group 'GRID.'; they specify the position of the grid window within +C the graph window. +C + DATA XLGD / .15 / , XRGD / .95 / , YBGD / .15 / , YTGD / .95 / +C +C SOGD defines the control parameter 'GRID/SHAPE.', which defines the +C shape of the grid window. +C + DATA SOGD / 0. / +C +C XMIN and XMAX define the control parameters 'X/MIN.' and 'X/MAX.', +C which determine how minimum and maximum values of x are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C + DATA XMIN / 1E36 / , XMAX / 1E36 / +C +C QLUX defines the control parameter 'X/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C + DATA QLUX / 0. / +C +C QOVX defines the control parameter 'X/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C + DATA QOVX / 0. / +C +C QCEX defines the control parameter 'X/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C + DATA QCEX / -1. / +C +C XLOW and XHGH define the control parameters 'X/SMALLEST.' and +C 'X/LARGEST.'; they come into play only when XMIN and/or XMAX are null +C and they are non-null, in which case they set limits on the range of +C x data to be considered when choosing the minimum and/or maximum. +C + DATA XLOW / 1E36 / , XHGH / 1E36 / +C +C YMIN and YMAX define the control parameters 'Y/MIN.' and 'Y/MAX.', +C which determine how minimum and maximum values of y are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C + DATA YMIN / 1E36 / , YMAX / 1E36 / +C +C QLUY defines the control parameter 'Y/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C + DATA QLUY / 0. / +C +C QOVY defines the control parameter 'Y/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C + DATA QOVY / 0. / +C +C QCEY defines the control parameter 'Y/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C + DATA QCEY / -1. / +C +C YLOW and YHGH define the control parameters 'Y/SMALLEST.' and +C 'Y/LARGEST.'; they come into play only when YMIN and/or YMAX are null +C and they are non-null, in which case they set limits on the range of +C y data to be considered when choosing the minimum and/or maximum. +C + DATA YLOW / 1E36 / , YHGH / 1E36 / +C +C QDAX(i) defines the control parameters 'AXIS/s/CONTROL.' (i=1 implies +C s='LEFT', i=2 implies s='RIGHT', i=3 implies s='BOTTOM', i=4 implies +C s='TOP'). Each of these specifies whether or not a given axis will +C be drawn or not and what liberties may be taken with numeric labels +C on the axis. +C + DATA QDAX(1)/ 4. / , QDAX(2)/ 4. / , QDAX(3)/ 4. / , QDAX(4)/ 4. / +C +C Each QSPA(i) defines a control parameter 'AXIS/s/LINE.', which says +C whether or not the line portion of a particular axis is to be drawn. +C + DATA QSPA(1)/ 0. / , QSPA(2)/ 0. / , QSPA(3)/ 0. / , QSPA(4)/ 0. / +C +C Each PING(i) defines a control parameter 'AXIS/s/INTERSECTION/GRID.', +C which may be used to move a particular axis to a specified position. +C + DATA PING(1)/1E36/ , PING(2)/1E36/ , PING(3)/1E36/ , PING(4)/1E36/ +C +C Each PINU(i) defines a control parameter 'AXIS/s/INTERSECTION/USER.', +C which may be used to move a particular axis to a specified position. +C + DATA PINU(1)/1E36/ , PINU(2)/1E36/ , PINU(3)/1E36/ , PINU(4)/1E36/ +C +C Each FUNS(i) defines a control parameter 'AXIS/s/FUNCTION.', which is +C used within a user-supplied version of AGUTOL to select a particular +C uset-system-to-label-system mapping for a particular axis. The +C default value selects the identity mapping. +C + DATA FUNS(1)/ 0. / , FUNS(2)/ 0. / , FUNS(3)/ 0. / , FUNS(4)/ 0. / +C +C The values of QBTD(i), BASD(i), QMJD(i), QJDP(i), WMJL(i), and WMJR(i) +C together define the control-parameter group 'AXIS/s/TICKS/MAJOR.', +C which determines the positioning and appearance of the major ticks on +C a particular axis. +C + DATA QBTD(1)/1E36/ , QBTD(2)/1E36/ , QBTD(3)/1E36/ , QBTD(4)/1E36/ + DATA BASD(1)/1E36/ , BASD(2)/1E36/ , BASD(3)/1E36/ , BASD(4)/1E36/ + DATA QMJD(1)/ 6. / , QMJD(2)/ 6. / , QMJD(3)/ 6. / , QMJD(4)/ 6. / + DATA QJDP(1)/1E36/ , QJDP(2)/1E36/ , QJDP(3)/1E36/ , QJDP(4)/1E36/ + DATA WMJL(1)/ 0. / , WMJL(2)/ 0. / , WMJL(3)/ 0. / , WMJL(4)/ 0. / + DATA WMJR(1)/.015/ , WMJR(2)/.015/ , WMJR(3)/.015/ , WMJR(4)/.015/ +C +C The values of QMND(i), QNDP(i), WMNL(i), and WMNR(i) together define +C the control-parameter group 'AXIS/s/TICKS/MINOR.', which determines +C the positioning and appearance of the major ticks on a particular +C axis. +C + DATA QMND(1)/1E36/ , QMND(2)/1E36/ , QMND(3)/1E36/ , QMND(4)/1E36/ + DATA QNDP(1)/1E36/ , QNDP(2)/1E36/ , QNDP(3)/1E36/ , QNDP(4)/1E36/ + DATA WMNL(1)/ 0. / , WMNL(2)/ 0. / , WMNL(3)/ 0. / , WMNL(4)/ 0. / + DATA WMNR(1)/.010/ , WMNR(2)/.010/ , WMNR(3)/.010/ , WMNR(4)/.010/ +C +C The values of QLTD(i), QLED(i), QLFD(i), QLOF(i), QLOS(i), DNLA(i), +C WCLM(i), and WCLE(i) together define the control-parameter group +C 'AXIS/s/NUMERIC.', which determines the positioning and appearance of +C the numeric labels on a particular axis. +C + DATA QLTD(1)/1E36/ , QLTD(2)/ 0./ , QLTD(3)/1E36/ , QLTD(4)/ 0./ + DATA QLED(1)/1E36/ , QLED(2)/1E36/ , QLED(3)/1E36/ , QLED(4)/1E36/ + DATA QLFD(1)/1E36/ , QLFD(2)/1E36/ , QLFD(3)/1E36/ , QLFD(4)/1E36/ + DATA QLOF(1)/ 0. / , QLOF(2)/ 0. / , QLOF(3)/ 0. / , QLOF(4)/ 0. / + DATA QLOS(1)/ 90./ , QLOS(2)/ 90./ , QLOS(3)/ 90./ , QLOS(4)/ 90./ + DATA DNLA(1)/.015/ , DNLA(2)/.015/ , DNLA(3)/.015/ , DNLA(4)/.015/ + DATA WCLM(1)/.015/ , WCLM(2)/.015/ , WCLM(3)/.015/ , WCLM(4)/.015/ + DATA WCLE(1)/.010/ , WCLE(2)/.010/ , WCLE(3)/.010/ , WCLE(4)/.010/ +C +C QODP defines the control parameter 'DASH/SELECTOR.', the sign of which +C determines which set of dash patterns is used by EZMY and EZMXY (the +C alphabetic set or the user-specified set); if the user-specified set +C is selected, the magnitude of QODP determines how many of them are to +C be used. +C + DATA QODP / 1. / +C +C QCDP defines the control parameter 'DASH/LENGTH.', which specifies the +C assumed length of dash patterns tendered to AUTOGRAPH. +C + DATA QCDP / 8. / +C +C WOCD and WODQ define the control parameters 'DASH/CHARACTER.' and +C 'DASH/DOLLAR-QUOTE.', which specify the widths of characters used in +C character-string dash patterns. +C + DATA WOCD / .010 / , WODQ / .010 / +C +C QDSH defines the control-parameter group 'DASH/PATTERN.'. Each value, +C if positive, defines a binary dash pattern, and, if negative, serves +C as an identifier in retrieving a character-string dash pattern. +C + DATA QDSH / 26*65535. / +C +C QDLB defines the control parameter 'LABEL/CONTROL.', which specifies +C what may be done with informational labels in response to overlap +C problems. +C + DATA QDLB /2./ +C +C QBIM defines the control parameter 'LABEL/BUFFER/LENGTH.' and must +C be equal to the second dimension of the array FLLB. +C + DATA QBIM / 8. / +C +C QBAN defines the control parameter 'LABEL/NAME.'; its value is really +C a pointer into the label list. The default value, zero, means that +C the pointer has not been set. +C + DATA QBAN / 0. / +C +C QLLN defines the control parameter 'LINE/MAXIMUM.' - the assumed +C maximum length of character strings intended for use as the text of a +C line of a label. +C + DATA QLLN /40./ +C +C TCLN defines the control parameter 'LINE/TERMINATOR.' - which is used +C to mark the end of character strings intended for use as the text of a +C line of a label. It is initialized in AGINIT. +C +C QNIM defines the control parameter 'LINE/BUFFER/LENGTH.' and must be +C equal to the second dimension of FLLN. +C + DATA QNIM / 16. / +C +C QNAN defines the control parameter 'LINE/NUMBER.'; its value is really +C a pointer into the line list. The default value, zero, says that the +C pointer has not been set. +C + DATA QNAN / 0. / +C +C (FLLB(I,1),I=1,10) and (FLLN(I,1),I=1,6) define the label to the left +C of the grid. The name, in FLLB(1,1), and the line text, in FLLN(4,1), +C must be filled in by AGINIT. +C + DATA FLLB( 1,1)/ 0./ , FLLB( 2,1)/ 0./ , FLLB( 3,1)/ 0./ , + + FLLB( 4,1)/ .5/ , FLLB( 5,1)/-.015/ , FLLB( 6,1)/ 0./ , + + FLLB( 7,1)/ 90./ , FLLB( 8,1)/ 0./ , FLLB( 9,1)/ 1./ , + + FLLB(10,1)/ 1./ , FLLN( 1,1)/+100./ , FLLN( 2,1)/ 0./ , + + FLLN( 3,1)/ .015/ , FLLN( 4,1)/ -2./ , FLLN( 5,1)/ 1./ , + + FLLN( 6,1)/ 0./ +C +C (FLLB(I,2),I=1,10) and (FLLN(I,2),I=1,6) define the label to the right +C of the grid. The name, in FLLB(1,2), and the line text, in FLLN(4,2), +C must be filled in by AGINIT. +C + DATA FLLB( 1,2)/ 0./ , FLLB( 2,2)/ 0./ , FLLB( 3,2)/ 1./ , + + FLLB( 4,2)/ .5/ , FLLB( 5,2)/+.015/ , FLLB( 6,2)/ 0./ , + + FLLB( 7,2)/ 90./ , FLLB( 8,2)/ 0./ , FLLB( 9,2)/ 1./ , + + FLLB(10,2)/ 2./ , FLLN( 1,2)/-100./ , FLLN( 2,2)/ 0./ , + + FLLN( 3,2)/ .015/ , FLLN( 4,2)/ -3./ , FLLN( 5,2)/ 0./ , + + FLLN( 6,2)/ 0./ +C +C (FLLB(I,3),I=1,10) and (FLLN(I,3),I=1,6) define the label below the +C grid. The name, in FLLB(1,3), and the line text, in FLLN(4,3), must +C be filled in by AGINIT. +C + DATA FLLB( 1,3)/ 0./ , FLLB( 2,3)/ 0./ , FLLB( 3,3)/ .5/ , + + FLLB( 4,3)/ 0./ , FLLB( 5,3)/ 0./ , FLLB( 6,3)/-.015/ , + + FLLB( 7,3)/ 0./ , FLLB( 8,3)/ 0./ , FLLB( 9,3)/ 1./ , + + FLLB(10,3)/ 3./ , FLLN( 1,3)/-100./ , FLLN( 2,3)/ 0./ , + + FLLN( 3,3)/ .015/ , FLLN( 4,3)/ -1./ , FLLN( 5,3)/ 1./ , + + FLLN( 6,3)/ 0./ +C +C (FLLB(I,4),I=1,10) and (FLLN(I,4),I=1,6) define the label above the +C grid. The name, in FLLB(1,4), and the line text, in FLLN(4,4), must +C be filled in by AGINIT. +C + DATA FLLB( 1,4)/ 0./ , FLLB( 2,4)/ 0./ , FLLB( 3,4)/ .5/ , + + FLLB( 4,4)/ 1./ , FLLB( 5,4)/ 0./ , FLLB( 6,4)/+.020/ , + + FLLB( 7,4)/ 0./ , FLLB( 8,4)/ 0./ , FLLB( 9,4)/ 1./ , + + FLLB(10,4)/ 4./ , FLLN( 1,4)/+100./ , FLLN( 2,4)/ 0./ , + + FLLN( 3,4)/ .020/ , FLLN( 4,4)/ -3./ , FLLN( 5,4)/ 0./ , + + FLLN( 6,4)/ 0./ +C +C Certain secondary parameters must be initialized to prevent bombing. +C + DATA QBTP(1)/ 0./ , QBTP(2)/ 0./ , QBTP(3)/ 0./ , QBTP(4)/ 0./ + DATA BASE(1)/ 0./ , BASE(2)/ 0./ , BASE(3)/ 0./ , BASE(4)/ 0./ + DATA QMNT(1)/ 0./ , QMNT(2)/ 0./ , QMNT(3)/ 0./ , QMNT(4)/ 0./ + DATA QLTP(1)/ 0./ , QLTP(2)/ 0./ , QLTP(3)/ 0./ , QLTP(4)/ 0./ + DATA QLEX(1)/ 0./ , QLEX(2)/ 0./ , QLEX(3)/ 0./ , QLEX(4)/ 0./ + DATA QLFL(1)/ 0./ , QLFL(2)/ 0./ , QLFL(3)/ 0./ , QLFL(4)/ 0./ + DATA QCIM(1)/ 0./ , QCIM(2)/ 0./ , QCIM(3)/ 0./ , QCIM(4)/ 0./ + DATA QCIE(1)/ 0./ , QCIE(2)/ 0./ , QCIE(3)/ 0./ , QCIE(4)/ 0./ + DATA RFNL(1)/ 0./ , RFNL(2)/ 0./ , RFNL(3)/ 0./ , RFNL(4)/ 0./ + DATA QLUA(1)/ 0./ , QLUA(2)/ 0./ , QLUA(3)/ 0./ , QLUA(4)/ 0./ +C +C SMRL and ISLD are set by the routine AGINIT (which see, below). +C +C MWCL, MWCM, MWCE, MDLA, MWCD, and MWDQ are the minimum widths of label +C characters, mantissa characters, exponent characters, label-to-axis +C distances, dash-pattern characters, and dash-pattern spaces, respect- +C ively (in the plotter coordinate system). +C + DATA MWCL /8/, MWCM /8/, MWCE /8/, MDLA /8/, MWCD /8/, MWDQ /8/ +C +C INIF is an initialization flag, set non-zero to indicate that the +C routine AGINIT has been executed to set the values of AUTOGRAPH +C parameters which, for one reason or another, cannot be preset by +C this block data routine. +C + DATA INIF / 0 / +C +C CHS1 and CHS2 are used within AUTOGRAPH when manipulating character +C strings retrieved by calls to AGGTCH. They need not be preset. +C +C LNIC is the second dimension of the array (INCH) which holds an index +C of the character strings stored by AGSTCH. +C + DATA LNIC / 50 / +C +C INCH is an index of character strings currently stored in CHRA. Each +C entry has the following format: +C +C INCH(1,I), if non-zero, is the index, in the array CHRA, of the +C first character of the Ith character string. +C +C INCH(2,I) is the length of the Ith character string. +C + DATA (INCH(1,I),I=1,50) / 50*0 / + DATA (INCH(2,I),I=1,50) / 50*0 / +C +C LNCA is the size of the array (CHRA) in which AGSTCH stores character +C strings. +C + DATA LNCA / 2000 / +C +C INCA is the index of the last character used in CHRA. +C + DATA INCA / 0 / +C +C CHRA holds character strings stored by AGSTCH. It need not be pre-set +C to anything. +C + END diff --git a/sys/gio/ncarutil/autograph/agdflt.f b/sys/gio/ncarutil/autograph/agdflt.f new file mode 100644 index 00000000..87b0ca45 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdflt.f @@ -0,0 +1,690 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C +c +noao: blockdata rewritten to be run time initialization +c BLOCK DATA AGDFLT + subroutine agdflt +C +C The block data subroutine AGDFLT defines the default values of those +C AUTOGRAPH parameters which can be declared in a DATA statement. See +C AGINIT for code initializing other AUTOGRAPH parameters. +C +C Following are declarations of all the AUTOGRAPH common blocks. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of +C type character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +c +noao: logical flag added to prevent "over-initialization" + logical first + data first /.true./ + call utilbd + if (.not. first) return + first = .false. +c -noao +C --------------------------------------------------------------------- +C +C Following are declarations of default values of variables in the +C AUTOGRAPH common blocks. +C +C --------------------------------------------------------------------- +C +C QFRA defines the control parameter 'FRAME.', which specifies when, if +C ever, the EZ... routines are to call FRAME to advance to a new frame. +C +c DATA QFRA / 1. / + QFRA = 1. +C +C QSET defines the control parameter 'SET.', which determines how the +C last call to the plot-package routine "SET" is to affect AUTOGRAPH. +C +c DATA QSET / 1. / + QSET = 1. +C +C QROW defines the control parameter 'ROW.', which determines how the x +C and y input arrays (in calls to AGSTUP and AGCURV) are to be used. +C +c DATA QROW / 1. / + QROW = 1. +C +C QIXY defines the control parameter 'INVERT.', which, if set non-zero, +C causes the routines AGSTUP and AGCURV to behave as if the arguments +C defining the x and y data had been interchanged. +C +c DATA QIXY / 0. / + QIXY = 0. +C +C QWND defines the control parameter 'WINDOW.', which, if set non-zero, +C causes curves drawn to be scissored by the edge of the curve window. +C +c DATA QWND / 0. / + QWND = 0. +C +C QBAC defines the control parameter 'BACKGROUND.', which can be given +C any of four values to set up four specific types of plot background. +C +c DATA QBAC / 1. / + QBAC = 1. +C +C SVAL defines the control parameters 'NULL/1.' and 'NULL/2.', which are +C used in various ways by AUTOGRAPH. +C +c DATA SVAL(1) / 1E36 / , SVAL(2) / 2E36 / + SVAL(1) = 1E36 + SVAL(2) = 2E36 +C +C XLGF, XRGF, YBGF, and YTGF define the parameter-group 'GRAPH.'; they +C specify the position of the graph window within the plotter frame. +C +c DATA XLGF / 0. / , XRGF / 1. / , YBGF / 0. / , YTGF / 1. / + XLGF = 0. + XRGF = 1. + YBGF = 0. + YTGF = 1. +C +C XLGD, XRGD, YBGD, and YTGD define the first four parameters in the +C group 'GRID.'; they specify the position of the grid window within +C the graph window. +C +c DATA XLGD / .15 / , XRGD / .95 / , YBGD / .15 / , YTGD / .95 / + XLGD = .15 + XRGD = .95 + YBGD = .15 + YTGD = .95 +C +C SOGD defines the control parameter 'GRID/SHAPE.', which defines the +C shape of the grid window. +C +c DATA SOGD / 0. / + SOGD = 0. +C +C XMIN and XMAX define the control parameters 'X/MIN.' and 'X/MAX.', +C which determine how minimum and maximum values of x are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C +c DATA XMIN / 1E36 / , XMAX / 1E36 / + XMIN = 1E36 + XMAX = 1E36 +C +C QLUX defines the control parameter 'X/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C +c DATA QLUX / 0. / + QLUX = 0. +C +C QOVX defines the control parameter 'X/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C +c DATA QOVX / 0. / + QOVX = 0. +C +C QCEX defines the control parameter 'X/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C +c DATA QCEX / -1. / + QCEX = -1. +C +C XLOW and XHGH define the control parameters 'X/SMALLEST.' and +C 'X/LARGEST.'; they come into play only when XMIN and/or XMAX are null +C and they are non-null, in which case they set limits on the range of +C x data to be considered when choosing the minimum and/or maximum. +C +c DATA XLOW / 1E36 / , XHGH / 1E36 / + XLOW = 1E36 + XHGH = 1E36 +C +C YMIN and YMAX define the control parameters 'Y/MIN.' and 'Y/MAX.', +C which determine how minimum and maximum values of y are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C +c DATA YMIN / 1E36 / , YMAX / 1E36 / + YMIN = 1E36 + YMAX = 1E36 +C +C QLUY defines the control parameter 'Y/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C +c DATA QLUY / 0. / + QLUY = 0. +C +C QOVY defines the control parameter 'Y/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C +c DATA QOVY / 0. / + QOVY = 0. +C +C QCEY defines the control parameter 'Y/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C +c DATA QCEY / -1. / + QCEY = -1. +C +C YLOW and YHGH define the control parameters 'Y/SMALLEST.' and +C 'Y/LARGEST.'; they come into play only when YMIN and/or YMAX are null +C and they are non-null, in which case they set limits on the range of +C y data to be considered when choosing the minimum and/or maximum. +C +c DATA YLOW / 1E36 / , YHGH / 1E36 / + YLOW = 1E36 + YHGH = 1E36 +C +C QDAX(i) defines the control parameters 'AXIS/s/CONTROL.' (i=1 implies +C s='LEFT', i=2 implies s='RIGHT', i=3 implies s='BOTTOM', i=4 implies +C s='TOP'). Each of these specifies whether or not a given axis will +C be drawn or not and what liberties may be taken with numeric labels +C on the axis. +C +c DATA QDAX(1)/ 4. / , QDAX(2)/ 4. / , QDAX(3)/ 4. / , QDAX(4)/ 4. / + QDAX(1) = 4. + QDAX(2) = 4. + QDAX(3) = 4. + QDAX(4) = 4. +C +C Each QSPA(i) defines a control parameter 'AXIS/s/LINE.', which says +C whether or not the line portion of a particular axis is to be drawn. +C +c DATA QSPA(1)/ 0. / , QSPA(2)/ 0. / , QSPA(3)/ 0. / , QSPA(4)/ 0. / + QSPA(1) = 0. + QSPA(2) = 0. + QSPA(3) = 0. + QSPA(4) = 0. +C +C Each PING(i) defines a control parameter 'AXIS/s/INTERSECTION/GRID.', +C which may be used to move a particular axis to a specified position. +C +c DATA PING(1)/1E36/ , PING(2)/1E36/ , PING(3)/1E36/ , PING(4)/1E36/ + PING(1) = 1E36 + PING(2) = 1E36 + PING(3) = 1E36 + PING(4) = 1E36 +C +C Each PINU(i) defines a control parameter 'AXIS/s/INTERSECTION/USER.', +C which may be used to move a particular axis to a specified position. +C +c DATA PINU(1)/1E36/ , PINU(2)/1E36/ , PINU(3)/1E36/ , PINU(4)/1E36/ + PINU(1) = 1E36 + PINU(2) = 1E36 + PINU(3) = 1E36 + PINU(4) = 1E36 +C +C Each FUNS(i) defines a control parameter 'AXIS/s/FUNCTION.', which is +C used within a user-supplied version of AGUTOL to select a particular +C uset-system-to-label-system mapping for a particular axis. The +C default value selects the identity mapping. +C +c DATA FUNS(1)/ 0. / , FUNS(2)/ 0. / , FUNS(3)/ 0. / , FUNS(4)/ 0. / + FUNS(1) = 0. + FUNS(2) = 0. + FUNS(3) = 0. + FUNS(4) = 0. +C +C The values of QBTD(i), BASD(i), QMJD(i), QJDP(i), WMJL(i), and WMJR(i) +C together define the control-parameter group 'AXIS/s/TICKS/MAJOR.', +C which determines the positioning and appearance of the major ticks on +C a particular axis. +C +c DATA QBTD(1)/1E36/ , QBTD(2)/1E36/ , QBTD(3)/1E36/ , QBTD(4)/1E36/ +c DATA BASD(1)/1E36/ , BASD(2)/1E36/ , BASD(3)/1E36/ , BASD(4)/1E36/ +c DATA QMJD(1)/ 6. / , QMJD(2)/ 6. / , QMJD(3)/ 6. / , QMJD(4)/ 6. / +c DATA QJDP(1)/1E36/ , QJDP(2)/1E36/ , QJDP(3)/1E36/ , QJDP(4)/1E36/ +c DATA WMJL(1)/ 0. / , WMJL(2)/ 0. / , WMJL(3)/ 0. / , WMJL(4)/ 0. / +c DATA WMJR(1)/.015/ , WMJR(2)/.015/ , WMJR(3)/.015/ , WMJR(4)/.015/ + QBTD(1) = 1E36 + QBTD(2) = 1E36 + QBTD(3) = 1E36 + QBTD(4) = 1E36 + BASD(1) = 1E36 + BASD(2) = 1E36 + BASD(3) = 1E36 + BASD(4) = 1E36 + QMJD(1) = 6. + QMJD(2) = 6. + QMJD(3) = 6. + QMJD(4) = 6. + QJDP(1) = 1E36 + QJDP(2) = 1E36 + QJDP(3) = 1E36 + QJDP(4) = 1E36 + WMJL(1) = 0. + WMJL(2) = 0. + WMJL(3) = 0. + WMJL(4) = 0. + WMJR(1) = .015 + WMJR(2) = .015 + WMJR(3) = .015 + WMJR(4) = .015 +C +C The values of QMND(i), QNDP(i), WMNL(i), and WMNR(i) together define +C the control-parameter group 'AXIS/s/TICKS/MINOR.', which determines +C the positioning and appearance of the major ticks on a particular +C axis. +C +c DATA QMND(1)/1E36/ , QMND(2)/1E36/ , QMND(3)/1E36/ , QMND(4)/1E36/ +c DATA QNDP(1)/1E36/ , QNDP(2)/1E36/ , QNDP(3)/1E36/ , QNDP(4)/1E36/ +c DATA WMNL(1)/ 0. / , WMNL(2)/ 0. / , WMNL(3)/ 0. / , WMNL(4)/ 0. / +c DATA WMNR(1)/.010/ , WMNR(2)/.010/ , WMNR(3)/.010/ , WMNR(4)/.010/ + QMND(1) = 1E36 + QMND(2) = 1E36 + QMND(3) = 1E36 + QMND(4) = 1E36 + QNDP(1) = 1E36 + QNDP(2) = 1E36 + QNDP(3) = 1E36 + QNDP(4) = 1E36 + WMNL(1) = 0. + WMNL(2) = 0. + WMNL(3) = 0. + WMNL(4) = 0. + WMNR(1) = .010 + WMNR(2) = .010 + WMNR(3) = .010 + WMNR(4) = .010 +C +C The values of QLTD(i), QLED(i), QLFD(i), QLOF(i), QLOS(i), DNLA(i), +C WCLM(i), and WCLE(i) together define the control-parameter group +C 'AXIS/s/NUMERIC.', which determines the positioning and appearance of +C the numeric labels on a particular axis. +C +c DATA QLTD(1)/1E36/ , QLTD(2)/ 0./ , QLTD(3)/1E36/ , QLTD(4)/ 0./ +c DATA QLED(1)/1E36/ , QLED(2)/1E36/ , QLED(3)/1E36/ , QLED(4)/1E36/ +c DATA QLFD(1)/1E36/ , QLFD(2)/1E36/ , QLFD(3)/1E36/ , QLFD(4)/1E36/ +c DATA QLOF(1)/ 0. / , QLOF(2)/ 0. / , QLOF(3)/ 0. / , QLOF(4)/ 0. / +c DATA QLOS(1)/ 90./ , QLOS(2)/ 90./ , QLOS(3)/ 90./ , QLOS(4)/ 90./ +c DATA DNLA(1)/.015/ , DNLA(2)/.015/ , DNLA(3)/.015/ , DNLA(4)/.015/ +c DATA WCLM(1)/.015/ , WCLM(2)/.015/ , WCLM(3)/.015/ , WCLM(4)/.015/ +c DATA WCLE(1)/.010/ , WCLE(2)/.010/ , WCLE(3)/.010/ , WCLE(4)/.010/ + QLTD(1) = 1E36 + QLTD(2) = 0. + QLTD(3) = 1E36 + QLTD(4) = 0. + QLED(1) = 1E36 + QLED(2) = 1E36 + QLED(3) = 1E36 + QLED(4) = 1E36 + QLFD(1) = 1E36 + QLFD(2) = 1E36 + QLFD(3) = 1E36 + QLFD(4) = 1E36 + QLOF(1) = 0. + QLOF(2) = 0. + QLOF(3) = 0. + QLOF(4) = 0. + QLOS(1) = 90. + QLOS(2) = 90. + QLOS(3) = 90. + QLOS(4) = 90. + DNLA(1) = .015 + DNLA(2) = .015 + DNLA(3) = .015 + DNLA(4) = .015 + WCLM(1) = .015 + WCLM(2) = .015 + WCLM(3) = .015 + WCLM(4) = .015 + WCLE(1) = .010 + WCLE(2) = .010 + WCLE(3) = .010 + WCLE(4) = .010 +C +C QODP defines the control parameter 'DASH/SELECTOR.', the sign of which +C determines which set of dash patterns is used by EZMY and EZMXY (the +C alphabetic set or the user-specified set); if the user-specified set +C is selected, the magnitude of QODP determines how many of them are to +C be used. +C +c DATA QODP / 1. / + QODP = 1. +C +C QCDP defines the control parameter 'DASH/LENGTH.', which specifies the +C assumed length of dash patterns tendered to AUTOGRAPH. +C +c DATA QCDP / 8. / + QCDP = 8. +C +C WOCD and WODQ define the control parameters 'DASH/CHARACTER.' and +C 'DASH/DOLLAR-QUOTE.', which specify the widths of characters used in +C character-string dash patterns. +C +c DATA WOCD / .010 / , WODQ / .010 / + WOCD = .010 + WODQ = .010 +C +C QDSH defines the control-parameter group 'DASH/PATTERN.'. Each value, +C if positive, defines a binary dash pattern, and, if negative, serves +C as an identifier in retrieving a character-string dash pattern. +C +c DATA QDSH / 26*65535. / + do 20, ijk = 1, 26 + 20 QDSH(ijk) = 65535. +C +C QDLB defines the control parameter 'LABEL/CONTROL.', which specifies +C what may be done with informational labels in response to overlap +C problems. +C +c DATA QDLB /2./ + QDLB = 2. +C +C QBIM defines the control parameter 'LABEL/BUFFER/LENGTH.' and must +C be equal to the second dimension of the array FLLB. +C +c DATA QBIM / 8. / + QBIM = 8. +C +C QBAN defines the control parameter 'LABEL/NAME.'; its value is really +C a pointer into the label list. The default value, zero, means that +C the pointer has not been set. +C +c DATA QBAN / 0. / + QBAN = 0. +C +C QLLN defines the control parameter 'LINE/MAXIMUM.' - the assumed +C maximum length of character strings intended for use as the text of a +C line of a label. +C +c DATA QLLN /40./ + QLLN = 40. +C +C TCLN defines the control parameter 'LINE/TERMINATOR.' - which is used +C to mark the end of character strings intended for use as the text of a +C line of a label. It is initialized in AGINIT. +C +C QNIM defines the control parameter 'LINE/BUFFER/LENGTH.' and must be +C equal to the second dimension of FLLN. +C +c DATA QNIM / 16. / + QNIM = 16. +C +C QNAN defines the control parameter 'LINE/NUMBER.'; its value is really +C a pointer into the line list. The default value, zero, says that the +C pointer has not been set. +C +c DATA QNAN / 0. / + QNAN = 0. +C +C (FLLB(I,1),I=1,10) and (FLLN(I,1),I=1,6) define the label to the left +C of the grid. The name, in FLLB(1,1), and the line text, in FLLN(4,1), +C must be filled in by AGINIT. +C +c DATA FLLB( 1,1)/ 0./ , FLLB( 2,1)/ 0./ , FLLB( 3,1)/ 0./ , +c + FLLB( 4,1)/ .5/ , FLLB( 5,1)/-.015/ , FLLB( 6,1)/ 0./ , +c + FLLB( 7,1)/ 90./ , FLLB( 8,1)/ 0./ , FLLB( 9,1)/ 1./ , +c + FLLB(10,1)/ 1./ , FLLN( 1,1)/+100./ , FLLN( 2,1)/ 0./ , +c + FLLN( 3,1)/ .015/ , FLLN( 4,1)/ -2./ , FLLN( 5,1)/ 1./ , +c + FLLN( 6,1)/ 0./ + FLLB( 1,1) = 0. + FLLB( 2,1) = 0. + FLLB( 3,1) = 0. + FLLB( 4,1) = .5 + FLLB( 5,1) = -.015 + FLLB( 6,1) = 0. + FLLB( 7,1) = 90. + FLLB( 8,1) = 0. + FLLB( 9,1) = 1. + FLLB(10,1) = 1. + FLLN( 1,1) = +100. + FLLN( 2,1) = 0. + FLLN( 3,1) = .015 + FLLN( 4,1) = -2. + FLLN( 5,1) = 1. + FLLN( 6,1) = 0. +C +C (FLLB(I,2),I=1,10) and (FLLN(I,2),I=1,6) define the label to the right +C of the grid. The name, in FLLB(1,2), and the line text, in FLLN(4,2), +C must be filled in by AGINIT. +C +c DATA FLLB( 1,2)/ 0./ , FLLB( 2,2)/ 0./ , FLLB( 3,2)/ 1./ , +c + FLLB( 4,2)/ .5/ , FLLB( 5,2)/+.015/ , FLLB( 6,2)/ 0./ , +c + FLLB( 7,2)/ 90./ , FLLB( 8,2)/ 0./ , FLLB( 9,2)/ 1./ , +c + FLLB(10,2)/ 2./ , FLLN( 1,2)/-100./ , FLLN( 2,2)/ 0./ , +c + FLLN( 3,2)/ .015/ , FLLN( 4,2)/ -3./ , FLLN( 5,2)/ 0./ , +c + FLLN( 6,2)/ 0./ + FLLB( 1,2) = 0. + FLLB( 2,2) = 0. + FLLB( 3,2) = 1. + FLLB( 4,2) = .5 + FLLB( 5,2) = +.015 + FLLB( 6,2) = 0. + FLLB( 7,2) = 90. + FLLB( 8,2) = 0. + FLLB( 9,2) = 1. + FLLB(10,2) = 2. + FLLN( 1,2) = -100. + FLLN( 2,2) = 0. + FLLN( 3,2) = .015 + FLLN( 4,2) = -3. + FLLN( 5,2) = 0. + FLLN( 6,2) = 0. +C +C (FLLB(I,3),I=1,10) and (FLLN(I,3),I=1,6) define the label below the +C grid. The name, in FLLB(1,3), and the line text, in FLLN(4,3), must +C be filled in by AGINIT. +C +c DATA FLLB( 1,3)/ 0./ , FLLB( 2,3)/ 0./ , FLLB( 3,3)/ .5/ , +c + FLLB( 4,3)/ 0./ , FLLB( 5,3)/ 0./ , FLLB( 6,3)/-.015/ , +c + FLLB( 7,3)/ 0./ , FLLB( 8,3)/ 0./ , FLLB( 9,3)/ 1./ , +c + FLLB(10,3)/ 3./ , FLLN( 1,3)/-100./ , FLLN( 2,3)/ 0./ , +c + FLLN( 3,3)/ .015/ , FLLN( 4,3)/ -1./ , FLLN( 5,3)/ 1./ , +c + FLLN( 6,3)/ 0./ + FLLB( 1,3) = 0. + FLLB( 2,3) = 0. + FLLB( 3,3) = .5 + FLLB( 4,3) = 0. + FLLB( 5,3) = 0. + FLLB( 6,3) = -.015 + FLLB( 7,3) = 0. + FLLB( 8,3) = 0. + FLLB( 9,3) = 1. + FLLB(10,3) = 3. + FLLN( 1,3) = -100. + FLLN( 2,3) = 0. + FLLN( 3,3) = .015 + FLLN( 4,3) = -1. + FLLN( 5,3) = 1. + FLLN( 6,3) = 0. +C +C (FLLB(I,4),I=1,10) and (FLLN(I,4),I=1,6) define the label above the +C grid. The name, in FLLB(1,4), and the line text, in FLLN(4,4), must +C be filled in by AGINIT. +C +c DATA FLLB( 1,4)/ 0./ , FLLB( 2,4)/ 0./ , FLLB( 3,4)/ .5/ , +c + FLLB( 4,4)/ 1./ , FLLB( 5,4)/ 0./ , FLLB( 6,4)/+.020/ , +c + FLLB( 7,4)/ 0./ , FLLB( 8,4)/ 0./ , FLLB( 9,4)/ 1./ , +c + FLLB(10,4)/ 4./ , FLLN( 1,4)/+100./ , FLLN( 2,4)/ 0./ , +c + FLLN( 3,4)/ .020/ , FLLN( 4,4)/ -3./ , FLLN( 5,4)/ 0./ , +c + FLLN( 6,4)/ 0./ + FLLB( 1,4) = 0. + FLLB( 2,4) = 0. + FLLB( 3,4) = .5 + FLLB( 4,4) = 1. + FLLB( 5,4) = 0. + FLLB( 6,4) = +.020 + FLLB( 7,4) = 0. + FLLB( 8,4) = 0. + FLLB( 9,4) = 1. + FLLB(10,4) = 4. + FLLN( 1,4) = +100. + FLLN( 2,4) = 0. + FLLN( 3,4) = .020 + FLLN( 4,4) = -3. + FLLN( 5,4) = 0. + FLLN( 6,4) = 0. +C +C Certain secondary parameters must be initialized to prevent bombing. +C +c DATA QBTP(1)/ 0./ , QBTP(2)/ 0./ , QBTP(3)/ 0./ , QBTP(4)/ 0./ +c DATA BASE(1)/ 0./ , BASE(2)/ 0./ , BASE(3)/ 0./ , BASE(4)/ 0./ +c DATA QMNT(1)/ 0./ , QMNT(2)/ 0./ , QMNT(3)/ 0./ , QMNT(4)/ 0./ +c DATA QLTP(1)/ 0./ , QLTP(2)/ 0./ , QLTP(3)/ 0./ , QLTP(4)/ 0./ +c DATA QLEX(1)/ 0./ , QLEX(2)/ 0./ , QLEX(3)/ 0./ , QLEX(4)/ 0./ +c DATA QLFL(1)/ 0./ , QLFL(2)/ 0./ , QLFL(3)/ 0./ , QLFL(4)/ 0./ +c DATA QCIM(1)/ 0./ , QCIM(2)/ 0./ , QCIM(3)/ 0./ , QCIM(4)/ 0./ +c DATA QCIE(1)/ 0./ , QCIE(2)/ 0./ , QCIE(3)/ 0./ , QCIE(4)/ 0./ +c DATA RFNL(1)/ 0./ , RFNL(2)/ 0./ , RFNL(3)/ 0./ , RFNL(4)/ 0./ +c DATA QLUA(1)/ 0./ , QLUA(2)/ 0./ , QLUA(3)/ 0./ , QLUA(4)/ 0./ + QBTP(1) = 0. + QBTP(2) = 0. + QBTP(3) = 0. + QBTP(4) = 0. + BASE(1) = 0. + BASE(2) = 0. + BASE(3) = 0. + BASE(4) = 0. + QMNT(1) = 0. + QMNT(2) = 0. + QMNT(3) = 0. + QMNT(4) = 0. + QLTP(1) = 0. + QLTP(2) = 0. + QLTP(3) = 0. + QLTP(4) = 0. + QLEX(1) = 0. + QLEX(2) = 0. + QLEX(3) = 0. + QLEX(4) = 0. + QLFL(1) = 0. + QLFL(2) = 0. + QLFL(3) = 0. + QLFL(4) = 0. + QCIM(1) = 0. + QCIM(2) = 0. + QCIM(3) = 0. + QCIM(4) = 0. + QCIE(1) = 0. + QCIE(2) = 0. + QCIE(3) = 0. + QCIE(4) = 0. + RFNL(1) = 0. + RFNL(2) = 0. + RFNL(3) = 0. + RFNL(4) = 0. + QLUA(1) = 0. + QLUA(2) = 0. + QLUA(3) = 0. + QLUA(4) = 0. +C +C SMRL and ISLD are set by the routine AGINIT (which see, below). +C +C MWCL, MWCM, MWCE, MDLA, MWCD, and MWDQ are the minimum widths of label +C characters, mantissa characters, exponent characters, label-to-axis +C distances, dash-pattern characters, and dash-pattern spaces, respect- +C ively (in the plotter coordinate system). +C +c DATA MWCL /8/, MWCM /8/, MWCE /8/, MDLA /8/, MWCD /8/, MWDQ /8/ + MWCL = 8 + MWCM = 8 + MWCE = 8 + MDLA = 8 + MWCD = 8 + MWDQ = 8 +C +C INIF is an initialization flag, set non-zero to indicate that the +C routine AGINIT has been executed to set the values of AUTOGRAPH +C parameters which, for one reason or another, cannot be preset by +C this block data routine. +C +c DATA INIF / 0 / + INIF = 0 +C +C CHS1 and CHS2 are used within AUTOGRAPH when manipulating character +C strings retrieved by calls to AGGTCH. They need not be preset. +C +C LNIC is the second dimension of the array (INCH) which holds an index +C of the character strings stored by AGSTCH. +C +c DATA LNIC / 50 / + LNIC = 50 +C +C INCH is an index of character strings currently stored in CHRA. Each +C entry has the following format: +C +C INCH(1,I), if non-zero, is the index, in the array CHRA, of the +C first character of the Ith character string. +C +C INCH(2,I) is the length of the Ith character string. +C +c DATA (INCH(1,I),I=1,50) / 50*0 / +c DATA (INCH(2,I),I=1,50) / 50*0 / + do 10, ijk = 1, 50 + inch (1, ijk) = 0 + inch (2, ijk) = 0 + 10 continue +C +C LNCA is the size of the array (CHRA) in which AGSTCH stores character +C strings. +C +c DATA LNCA / 2000 / + LNCA = 2000 +C +C INCA is the index of the last character used in CHRA. +C +c DATA INCA / 0 / + INCA = 0 +C +C CHRA holds character strings stored by AGSTCH. It need not be pre-set +C to anything. +C + return +c + entry initag + first = .true. + END diff --git a/sys/gio/ncarutil/autograph/agdlch.f b/sys/gio/ncarutil/autograph/agdlch.f new file mode 100644 index 00000000..78a96c8f --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdlch.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGDLCH (IDCS) +C +C This routine deletes character strings previously stored by the +C routine AGSTCH (which see). It has the following argument: +C +C -- IDCS is the identifying integer returned by AGSTCH when the string +C was stored. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C Only if the identifier is between -LNIC and -1, inclusive, was the +C string ever stored, so that it needs to be deleted. If the string is +C the last one in CHRA, we can just set INCA to point to the position +C preceding it; otherwise, we zero out the string but don't bother to +C collapse CHRA, which will happen in AGSTCH when the space is needed +C again. In either case, the index entry in INCH is zeroed. +C + IF (IDCS.GE.(-LNIC).AND.IDCS.LE.(-1)) THEN + I=-IDCS + J=INCH(1,I) + IF (J.GT.0) THEN + K=J+INCH(2,I)-1 + IF (K.EQ.INCA) THEN + INCA=J-1 + ELSE + DO 101 L=J,K + CHRA(L)=CHAR(0) + 101 CONTINUE + END IF + INCH(1,I)=0 + END IF + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdshn.f b/sys/gio/ncarutil/autograph/agdshn.f new file mode 100644 index 00000000..a20a5dfd --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdshn.f @@ -0,0 +1,34 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + CHARACTER*16 FUNCTION AGDSHN (IDSH) +C +C The value of this function is the name of the dash pattern numbered +C IDSH - that is to say, the character string 'DASH/PATTERN/n.', where +C n is an integer between 1 and 99, equal to MAX0(1,MIN0(99,IDSH)). +C + AGDSHN='DASH/PATTERN/ .' +C + KDSH=MAX0(1,MIN0(99,IDSH)) +C + DO 101 I=15,14,-1 + AGDSHN(I:I)=CHAR(ICHAR('0')+MOD(KDSH,10)) + IF (KDSH.LE.9) GO TO 102 + KDSH=KDSH/10 + 101 CONTINUE +C + 102 RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agexax.f b/sys/gio/ncarutil/autograph/agexax.f new file mode 100644 index 00000000..b16e2319 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agexax.f @@ -0,0 +1,415 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEXAX (IAXS,SVAL,UMIN,UMAX,NICE,QLUA,FUNS,QBTP,BASD, + + BASE,QMJD,QMND,QMNT,QLTD,QLTP,QLED,QLEX,QLFD, + + QLFL,QMIN,QMAX) +C + DIMENSION SVAL(2) +C +C The routine AGEXAX is used by AGSTUP to examine the parameters which +C determine how a given axis is tick-marked and labelled and to provide +C default values for missing ones. Its arguments are as follows: +C +C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4. +C +C -- SVAL is the array of special values. +C +C -- UMIN and UMAX are the minimum and maximum values along the axis, in +C the user coordinate system. Rounded values of UMIN and UMAX are +C returned in QMIN and QMAX if the following argument (NICE) is zero. +C +C -- NICE is a flag indicating whether rounded values of UMIN and UMAX +C are to be returned (NICE.EQ.0) or not (NICE.NE.0). +C +C -- LLUA and FUNS specify the user-system-to-label-system mapping along +C the axis. See the routine AGAXIS for a discussion of them. +C +C -- NBTP, BASD, BASE, and NMJD are used to determine the positioning of +C major tick marks in the label coordinate system. NBTP and BASE are +C described in the routine AGNUMB. BASD is the desired value of BASE +C supplied by the user. If BASD has a null value, BASE is computed +C by AGEXAX. NMJD is a user-supplied-or-defaulted parameter giving +C the approximate number of major ticks (and therefore the number of +C numeric labels) to be placed on the axis. +C +C -- NMND and NMNT are the desired and actual (to be determined) number +C of minor ticks per major division. See discussion in AGAXIS. +C +C -- NLTD, NLTP, NLED, NLEX, NLFD, and NLFL are desired and actual (to +C be determined) values of the parameters describing the form to be +C used for numeric labels. See discussion in AGNUMB. +C +C -- QMIN and QMAX are rounded values of UMIN and UMAX, returned only if +C NICE.EQ.0. +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The arrays BASP and NMNP specify possible default values for BASE and +C NMNT when NBTP.EQ.1. +C + DIMENSION BASP(5),NMNP(5) +C + DATA BASP(1) / 10. / , NMNP(1) / 1 / , + * BASP(2) / 5. / , NMNP(2) / 4 / , + * BASP(3) / 2. / , NMNP(3) / 1 / , + * BASP(4) / 1. / , NMNP(4) / 1 / , + * BASP(5) / .5 / , NMNP(5) / 4 / +C +C If the parameter NBTP is zero, tick marks and labels are suppressed. +C + NBTP=IFIX(QBTP) + IF (NBTP.EQ.0) RETURN +C +C Unpack integer values from floating-point arguments. +C + LLUA=IFIX(QLUA) + NMJD=IFIX(QMJD) + IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMND=IFIX(QMND) + NMNT=0 + IF (QLTD.NE.SVAL(1).AND.QLTD.NE.SVAL(2)) NLTD=IFIX(QLTD) + NLTP=0 + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) NLED=IFIX(QLED) + NLEX=0 + IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) NLFD=IFIX(QLFD) + NLFL=0 +C +C Compute label-coordinate-system values at the ends of the axis. +C + CALL AGUTOL (IAXS,FUNS,1,UMIN,VMIN) + CALL AGUTOL (IAXS,FUNS,1,UMAX,VMAX) +C +C Error if the label-coordinate-system values are equal. +C + IF (VMIN.EQ.VMAX) GO TO 901 +C +C If a special value is specified for the parameter BASD, AGEXAX must +C pick a value for the parameter BASE. +C + IF (BASD.EQ.SVAL(1).OR.BASD.EQ.SVAL(2)) GO TO 101 +C +C The user has specified a value for the parameter BASE. If that value +C is less than or equal to zero, tick marks and labels are suppressed. +C + BASE=AMAX1(0.,BASD) + IF (BASE.EQ.0.) RETURN + NMNT=0 + GO TO 108 +C +C Pick a value for the parameter BASE, depending on the number type. +C + 101 GO TO (102,105,106) , NBTP +C +C Major ticks and labels are at numbers of the form (-) BASE * EXMU. +C + 102 NMJD=MAX0(0,NMJD) +C +C Compute an approximate value for BASE. +C + FTMP=ABS(VMAX-VMIN)/FLOAT(NMJD+1) +C +C Reduce the approximate value to the form FTMP * 10 ** ITMP. +C + ASSIGN 103 TO JMP1 + GO TO 200 +C +C Pick a reasonable value for BASE (1., 2., OR 5. * 10**ITMP). +C + 103 DO 104 I=1,5 + IF (FTMP.LT.BASP(I)) GO TO 104 + BASE=BASP(I)*SNGL(10.D0**ITMP) + NMNT=NMNP(I) + GO TO 107 + 104 CONTINUE +C +C Major ticks and labels are at numbers of the form (-) BASE * 10**EXMU. +C + 105 BASE=1. + NMNT=8 + GO TO 107 +C +C Major ticks and labels are at numbers of the form (-) BASE**EXMU. +C + 106 BASE=10. + NMNT=8 +C + 107 IF (BASD.EQ.SVAL(2)) BASD=BASE +C + 108 IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMNT=MAX0(0,NMND) + IF (QMND.EQ.SVAL(2)) QMND=FLOAT(NMNT) +C +C If the user wants nice values at the axis ends, reset UMIN and UMAX. +C + IF (NICE.NE.0) GO TO 115 +C + LOOP=0 +C + WMIN=VMIN + WMAX=VMAX +C + GO TO (109,110,112) , NBTP +C + 109 EMIN=VMIN/BASE+.5+SIGN(.5,VMIN-VMAX) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN-VMAX) + WMIN=BASE*(EMIN-AMOD(EMIN,1.)) + EMAX=VMAX/BASE+.5+SIGN(.5,VMAX-VMIN) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX-VMIN) + WMAX=BASE*(EMAX-AMOD(EMAX,1.)) + GO TO 114 +C + 110 IF (VMIN.EQ.0.) GO TO 111 + EMIN=ALOG10(ABS(VMIN)/BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX)) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX)) + WMIN=SIGN(BASE,VMIN)*10.**(EMIN-AMOD(EMIN,1.)) + 111 IF (VMAX.EQ.0.) GO TO 114 + EMAX=ALOG10(ABS(VMAX)/BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN)) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN)) + WMAX=SIGN(BASE,VMAX)*10.**(EMAX-AMOD(EMAX,1.)) + GO TO 114 +C + 112 IF (BASE.EQ.1.) GO TO 115 + IF (VMIN.EQ.0.) GO TO 113 + EMIN=ALOG10(ABS(VMIN))/ALOG10(BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX)) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX)) + WMIN=SIGN(1.,VMIN)*BASE**(EMIN-AMOD(EMIN,1.)) + 113 IF (VMAX.EQ.0.) GO TO 114 + EMAX=ALOG10(ABS(VMAX))/ALOG10(BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN)) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN)) + WMAX=SIGN(1.,VMAX)*BASE**(EMAX-AMOD(EMAX,1.)) +C +C Re-compute the user-coordinate-system minimum and maximum values. +C + 114 CALL AGUTOL (IAXS,FUNS,-1,WMIN,QMIN) + CALL AGUTOL (IAXS,FUNS,-1,WMAX,QMAX) +C +C Test for problems with nice values chosen. +C + IF (QMIN.LT.QMAX) GO TO 140 + IF (QMIN.GT.QMAX) GO TO 901 +C +C We have a pathological case - user values are clustered very close to +C a label position. See what can be done about it. +C + LOOP=LOOP+1 + IF (LOOP.GT.1) GO TO 901 +C + GO TO (137,138,139) , NBTP +C + 137 VMIN=VMIN+SIGN(BASE,VMIN-VMAX) + VMAX=VMAX+SIGN(BASE,VMAX-VMIN) + GO TO 109 +C + 138 VMIN=VMIN*10.**SIGN(1.,VMIN*(VMIN-VMAX)) + VMAX=VMAX*10.**SIGN(1.,VMAX*(VMAX-VMIN)) + GO TO 110 +C + 139 VMIN=VMIN*BASE**SIGN(1.,VMIN*(VMIN-VMAX)) + VMAX=VMAX*BASE**SIGN(1.,VMAX*(VMAX-VMIN)) + GO TO 112 +C + 140 VMIN=WMIN + VMAX=WMAX +C +C Now we examine the parameters defining the appearance of the numeric +C labels. If the numeric-label type is zero, there is no more to do. +C + 115 IF (QLTD.EQ.SVAL(1).OR.QLTD.EQ.SVAL(2)) GO TO 116 + NLTP=MAX0(0,MIN0(3,NLTD)) + IF (NLTP.EQ.0) GO TO 136 +C +C The numeric-label type (NLTP) is specified. If both the numeric-label +C exponent and numeric-label fraction-length are also specified, quit. +C + NLEX=NLED + NLFL=NLFD + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2).AND. + + QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2) ) GO TO 136 + GO TO 117 +C +C We must pick a value for the numeric-label type. Start with the dummy +C value 4 so as to jump to the proper piece of code. +C + 116 NLTP=4 +C +C Reduce the value of BASE to the form RBSE * 10**KBSE, where RBSE is +C in the range (1,10) and KBSE is an integer. +C + 117 FTMP=BASE + ASSIGN 118 TO JMP1 + GO TO 200 +C + 118 RBSE=FTMP + KBSE=ITMP +C +C Compute LBSE = the number of significant digits in RBSE. +C + ASSIGN 119 TO JMP2 + GO TO 300 +C + 119 LBSE=1+ITMP +C +C Jump depending on the value of the numeric-label type. +C + GO TO (120,128,131,132) , NLTP +C +C Scientific notation is to be used. Estimate the number of significant +C digits that are likely to be required, depending on the number type. +C + 120 GO TO (121,123,124) , NBTP +C + 121 FTMP=AMAX1(ABS(VMIN),ABS(VMAX))/BASE + ASSIGN 122 TO JMP1 + GO TO 200 +C + 122 NSIG=MAX0(1,ITMP+1+LBSE) + GO TO 125 +C + 123 NSIG=LBSE + GO TO 125 +C + 124 NSIG=10 +C +C NLEX + NLFL should be equal to NSIG. Make that the case. +C + 125 IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 127 + IF (QLFD.EQ.SVAL(1).OR. QLFD.EQ.SVAL(2)) GO TO 126 + NLEX=NSIG-MAX0(0,NLFL) + GO TO 135 + 126 NLEX=1 + 127 NLFL=NSIG-NLEX + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C Exponential notation is to be used. Compute the exponent NEXP such +C that BASE / 10**NEXP is an integer. +C + 128 NEXP=KBSE-LBSE+1 +C +C NLEX - NLFL should be equal to NEXP. Make that the case. (Note that, +C if NBTP is 3, NLEX is forced to zero.) +C + IF (NBTP.EQ.3) NLEX=0 +C + IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 129 + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 130 + NLFL=-1 + 129 NLEX=MAX0(0,NLFL)+NEXP + GO TO 135 + 130 NLFL=NLEX-NEXP + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C No-exponent notation is to be used. NLFL is the only parameter we +C need to worry about. If it is already set, quit. +C + 131 IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 136 +C +C Set NLFL to the actual number of digits in the fractional portion of +C BASE. +C + NLFL=LBSE-KBSE-1 + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C We must pick a value for the numeric-label type, depending on the +C number type. +C + 132 GO TO (133,134,134) , NBTP +C +C Nunbers are of the form (-) BASE * EXMU. Use labels with no exponent +C unless the use of an exponent would result in shorter labels. +C + 133 IF (MAX0(KBSE+1-LBSE,-KBSE-1).GT.4) GO TO 134 + NLTP=3 + NLFL=LBSE-KBSE-1 + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C Exponential notation is used. +C + 134 NLTP=2 + NLEX=KBSE-LBSE+1 + NLFL=-1 +C +C Back-store the computed parameters, if requested, and return. +C + 135 IF (QLTD.EQ.SVAL(2)) QLTD=FLOAT(NLTP) + IF (QLED.EQ.SVAL(2)) QLED=FLOAT(NLEX) + IF (QLFD.EQ.SVAL(2)) QLFD=FLOAT(NLFL) +C +C Pack up integer values to floating-point arguments and return. +C + 136 QMNT=FLOAT(NMNT) + QLTP=FLOAT(NLTP) + QLEX=FLOAT(NLEX) + QLFL=FLOAT(NLFL) + RETURN +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure reduces the number (FTMP) to the range (1,10), +C returning (FTMP) and (ITMP) such that (FTMP) * 10**(ITMP) is equal to +C the original value of (FTMP). (FTMP) must be positive. +C + 200 FTM1=ALOG10(FTMP+SMRL*FTMP) + IF (FTM1.LT.0.) FTM1=FTM1-1. + ITMP=IFIX(FTM1) + FTMP=AMAX1(1.,FTMP*SNGL(10.D0**(-ITMP))) + GO TO JMP1 , (103,118,122) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure counts the number of digits in the fractional +C portion of (FTMP), returning the count as the value of (ITMP). +C + 300 FTM1=AMOD(FTMP+SMRL*FTMP,1.) + FTM2=10.*SMRL*FTMP + ITMP=0 +C + 301 IF (FTM1.LT.FTM2) GO TO 302 + ITMP=ITMP+1 + IF (ITMP.GE.10) GO TO 302 + FTM1=AMOD(10.*FTM1,1.) + FTM2=10.*FTM2 + GO TO 301 +C + 302 GO TO JMP2 , (119) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C Error exit. +C +C +NOAO - Comment out FTN write and format statement, SETER is okay. +C + 901 CONTINUE +C 901 WRITE (I1MACH(4),9001) IAXS + CALL SETER ('AGEXAX (CALLED BY AGSTUP) - USER-SYSTEM-TO-LABEL-SYST + +EM MAPPING IS NOT MONOTONIC',1,2) +C +C Formats. +C +C9001 FORMAT ('0PROBLEM WITH AXIS NUMBER',I2, +C + ' (1, 2, 3, AND 4 IMPLY LEFT, RIGHT, BOTTOM, AND TOP)') +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agexus.f b/sys/gio/ncarutil/autograph/agexus.f new file mode 100644 index 00000000..7d4a274e --- /dev/null +++ b/sys/gio/ncarutil/autograph/agexus.f @@ -0,0 +1,89 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEXUS (SVAL,ZMIN,ZMAX,ZLOW,ZHGH, + + ZDRA,NVIZ,IIVZ,NEVZ,IIEZ,UMIN,UMAX) +C + DIMENSION SVAL(2),ZDRA(1) +C +C The routine AGEXUS is used by AGSTUP to determine tentative values of +C the user-window edge coordinates. Its arguments are as follows: +C +C -- SVAL is the array of special values. +C +C -- ZMIN and ZMAX are user-supplied minimum and maximum values of the +C data x (or y) coordinates. +C +C -- ZLOW and ZHGH are, respectively, the smallest and largest data +C values to be considered in choosing the minimum and maximum, if +C those values, as given by the user, are null. +C +C -- ZDRA, NVIZ, IIVZ, NEVZ, and IIEZ specify the array of x (or y) +C data coordinates (see AGMAXI or AGMINI for complete description). +C +C -- UMIN and UMAX are returned with tentative minimum and maximum +C values for use at the appropriate user-window edges (left/right +C or bottom/top). +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Assume initially that the user has provided actual values to be used. +C + UMIN=ZMIN + UMAX=ZMAX +C +C If either of the values is null, replace it by a data-based value. +C + IF (UMIN.EQ.SVAL(1).OR.UMIN.EQ.SVAL(2)) + + UMIN=AGMINI(SVAL(1),ZLOW,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) + IF (UMAX.EQ.SVAL(1).OR.UMAX.EQ.SVAL(2)) + + UMAX=AGMAXI(SVAL(1),ZHGH,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C +C Either or both values might still be null (if the user data was null). +C + IF (UMIN.EQ.SVAL(1)) UMIN=UMAX + IF (UMAX.EQ.SVAL(1)) UMAX=UMIN +C +C Check the relative values of UMIN and UMAX for problems. +C + IF (ABS(UMIN-UMAX).LT.50.*SMRL*(ABS(UMIN)+ABS(UMAX))) GO TO 102 + IF (UMAX-UMIN) 101,102,103 + 101 IF (ZMIN.NE.SVAL(1).AND.ZMIN.NE.SVAL(2)) UMAX=UMIN + IF (ZMAX.NE.SVAL(1).AND.ZMAX.NE.SVAL(2)) UMIN=UMAX +C + 102 UMIN=UMIN-.5*ABS(UMIN) + UMAX=UMAX+.5*ABS(UMAX) + IF (UMIN.NE.UMAX) GO TO 103 + UMIN=-1. + UMAX=+1. +C +C If the user wanted these values back-stored, do it. +C + 103 IF (ZMIN.EQ.SVAL(2)) ZMIN=UMIN + IF (ZMAX.EQ.SVAL(2)) ZMAX=UMAX +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agezsu.f b/sys/gio/ncarutil/autograph/agezsu.f new file mode 100644 index 00000000..535e1811 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agezsu.f @@ -0,0 +1,104 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEZSU (ITOC,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX, + + IIVY,IIEY) +C + REAL XDRA(1),YDRA(1) + CHARACTER*(*) LABG +C +C The routine AGEZSU is used by the AUTOGRAPH routines EZY, EZXY, EZMY, +C EZMXY, and IDIOT to examine those parameters which are peculiar to the +C old version of AUTOGRAPH and to do the appropriate call to AGSTUP. +C The arguments are as follows: +C +C -- ITOC indicates which routine is calling AGEZSU, as follows: +C +C -- ITOC .EQ. 1 - call by EZY +C -- ITOC .EQ. 2 - call by EZXY +C -- ITOC .EQ. 3 - call by EZMY +C -- ITOC .EQ. 4 - call by EZMXY +C -- ITOC .EQ. 5 - call by IDIOT +C +C -- XDRA is an array of x-coordinate data. +C +C -- YDRA is an array of y-coordinate data. +C +C -- IDXY is the first dimension of YDRA. +C +C -- MANY is the number of curves defined by XDRA and YDRA. +C +C -- NPTS is the number of points per curve. +C +C -- LABG is a new header label (or the single character CHAR(0), if the +C header label is to be unchanged). +C +C -- IIVX, IIEX, IIVY, and IIEY are indexing controls for the x and y +C data arrays, computed and returned by AGEZSU for use in setting up +C calls to the routine AGCURV. +C +C Examine the frame-advance parameter. Do frame advance as appropriate. +C + CALL AGGETI ('FRAM.',IFRA) + IFRA=MAX0(1,MIN0(3,IFRA)) +C + IF (IFRA.EQ.3) CALL FRAME +C +C Set up the header label. +C + IF (ICHAR(LABG(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'T') + CALL AGSETI ('LINE/NUMB.', 100) + CALL AGSETC ('LINE/TEXT.',LABG) + END IF +C +C Set up the AGSTUP arguments defining the coordinate-data arrays. +C + CALL AGGETI ('ROW .',IROW) + IROW=MAX0(-2,MIN0(+2,IROW)) +C + NVIY=MANY + IIVY=IDXY + NEVY=NPTS + IIEY=1 +C + IF (IROW.LE.0.AND.ITOC.GE.3.AND.ITOC.LE.4) THEN + IIVY=1 + IIEY=IDXY + END IF +C + NVIX=NVIY + IIVX=IIVY + NEVX=NEVY + IIEX=IIEY +C + IF (IABS(IROW).LE.1) THEN + NVIX=1 + IIVX=0 + NEVX=NPTS + IIEX=1 + END IF +C + IF (ITOC.EQ.1.OR.ITOC.EQ.3) IIEX=0 +C +C Do the AGSTUP call. +C + CALL AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX,YDRA,NVIY,IIVY,NEVY,IIEY) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agfpbn.f b/sys/gio/ncarutil/autograph/agfpbn.f new file mode 100644 index 00000000..f4900b60 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agfpbn.f @@ -0,0 +1,37 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + INTEGER FUNCTION AGFPBN (FPDP) +C +C The value of AGFPBN(FPDP) is a binary dash pattern, obtained from the +C floating-point dash pattern FPDP. On machines having a word length +C greater than 16 bits, AGFPBN(FPDP) = IFIX(FPDP). On machines having +C a word length of 16 bits, this is not true. For example, when FPDP = +C 65535. (2 to the 16th minus 1), the equivalent binary dash pattern +C does not have the value 65535, but the value -1 (assuming integers +C are represented in a ones' complement format). So, the functions +C ISHIFT and IOR must be used to generate the dash pattern. +C + TEMP=FPDP + AGFPBN=0 +C + DO 101 I=1,16 + IF (AMOD(TEMP,2.).GE.1.) AGFPBN=IOR(AGFPBN,ISHIFT(1,I-1)) + TEMP=TEMP/2. + 101 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agftol.f b/sys/gio/ncarutil/autograph/agftol.f new file mode 100644 index 00000000..b685f913 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agftol.f @@ -0,0 +1,119 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGFTOL (IAXS,IDMA,VINP,VOTP,VLCS,LLUA,UBEG,UDIF,FUNS, + + NBTP,SBSE) +C +C The routine AGFTOL is used by AGAXIS to map a fractional distance +C along the axis to a value in the label coordinate system or vice- +C versa. Its arguments are as follows: +C +C -- IAXS specifies which axis is being drawn. It is passed to the +C routine AGUTOL. See AGAXIS for a complete description of IAXS. +C +C -- IDMA specifies the direction of the mapping - from the fractional +C system to the label system if IDMA .GT. 0 or from the label system +C to the fractional system if IDMA .LT. 0. IDMA also specifies how +C the label-system value is given to or returned by AGFTOL. +C +C -- If ABSV(IDMA) .EQ. 1, an actual value in the label coordinate +C system (VLCS) is given to or returned by AGFTOL. +C +C -- If ABSV(IDMA) .NE. 1, a value of the exponent/multiplier EXMU +C corresponding to VLCS is given to or returned by AGFTOL. +C +C -- VINP is an input value in one coordinate system. +C +C -- VOTP is an output value in the other coordinate system. +C +C -- VLCS is an output value in the label coordinate system, returned +C no matter what the value of IDMA. +C +C -- LLUA, UBGA, and UDFA specify the mapping from the user coordinate +C system to the fractional system and vice-versa. See the routine +C AGAXIS for a complete description of these parameters. +C +C -- FUNS is a function-selector, to be used in calls to AGUTOL. It +C selects the mapping from the user coordinate system to the label +C coordinate system and vice-versa. See the routine AGAXIS for a +C complete description of this parameter. +C +C -- NBTP and SBSE specify the mapping of label-coordinate-system values +C to exponent/multiplier values and vice-versa. See the routine +C AGNUMB for a complete dexcription of these parameters. +C +C Determine desired direction of mapping. +C + IF (IDMA.GT.0) THEN +C +C Map axis fraction VINP to a label-coordinate-system value VLCS. +C + VUCS=UBEG+VINP*UDIF + IF (LLUA.NE.0) VUCS=10.**VUCS + CALL AGUTOL (IAXS,FUNS,1,VUCS,VLCS) +C +C If IDMA .EQ. 1, caller wants VLCS - otherwise, map VLCS to the +C appropriate exponent/multiplier value EXMU - return value in VOTP. +C + IF (IDMA.EQ.1) THEN + VOTP=VLCS + RETURN + END IF +C + GO TO (101,102,103) , NBTP +C + 101 VOTP=VLCS/SBSE + RETURN +C + 102 VOTP=ALOG10(VLCS/SBSE) + RETURN +C + 103 VOTP=ALOG10(ABS(VLCS))/ALOG10(ABS(SBSE)) + RETURN +C + ELSE +C +C If IDMA .EQ. -1, caller has provided VINP .EQ. VLCS, a value in the +C label coordinate system - otherwise, VINP .EQ. EXMU, the exponent/ +C multiplier needed to generate VLCS. +C + IF (IDMA.EQ.(-1)) THEN + VLCS=VINP + GO TO 107 + END IF +C + GO TO (104,105,106) , NBTP +C + 104 VLCS=SBSE*VINP + GO TO 107 +C + 105 VLCS=SBSE*10.**VINP + GO TO 107 +C + 106 VLCS=SIGN(1.,SBSE)*ABS(SBSE)**VINP +C +C Map label-system value VLCS to a user-system value VUCS. +C + 107 CALL AGUTOL (IAXS,FUNS,-1,VLCS,VUCS) +C +C Map user-system value VUCS to an axis fraction VOTP and return. +C + IF (LLUA.NE.0) VUCS=ALOG10(VUCS) + VOTP=(VUCS-UBEG)/UDIF + RETURN +C + END IF +C + END diff --git a/sys/gio/ncarutil/autograph/aggetc.f b/sys/gio/ncarutil/autograph/aggetc.f new file mode 100644 index 00000000..caf9f357 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetc.f @@ -0,0 +1,51 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETC (TPID,CUSR) +C + CHARACTER*(*) TPID,CUSR +C + DIMENSION FURA(1) +C +C The routine AGGETC is used to get the character strings represented +C by the values of certain individual AUTOGRAPH parameters. TPID is a +C parameter identifier (from the caller). CUSR is a character string +C (returned to the caller). +C +C See what kind of parameter is being gotten. +C + CALL AGCTCS (TPID,ITCS) +C +C If the parameter is not intrinsically of type character, log an error. +C + IF (ITCS.EQ.0) GO TO 901 +C +C Otherwise, get the integer value of the parameter and use that to get +C the desired character string. +C + CALL AGGETP (TPID,FURA,1) + CALL AGGTCH (IFIX(FURA(1)),CUSR,LNCS) +C +C Done. +C + RETURN +C +C Error exit. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGGETC - PARAMETER TO GET IS NOT INTRINSICALLY OF TYP + +E CHARACTER',2,2) +C + END diff --git a/sys/gio/ncarutil/autograph/aggetf.f b/sys/gio/ncarutil/autograph/aggetf.f new file mode 100644 index 00000000..6391222b --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetf.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETF (TPID,FUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETF may be used to get the real (floating-point) value +C of any single AUTOGRAPH control parameter. +C + CALL AGGETP (TPID,FURA,1) + FUSR=FURA(1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggeti.f b/sys/gio/ncarutil/autograph/aggeti.f new file mode 100644 index 00000000..31841826 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggeti.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETI (TPID,IUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETI may be used to get the integer-equivalent value of +C any single AUTOGRAPH control parameter. +C + CALL AGGETP (TPID,FURA,1) + IUSR=IFIX(FURA(1)) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggetp.f b/sys/gio/ncarutil/autograph/aggetp.f new file mode 100644 index 00000000..ac44085e --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetp.f @@ -0,0 +1,104 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETP returns to the user the AUTOGRAPH parameter(s) +C specified by the parameter identifier TPID. The arguments are as +C follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array which is to receive the desired parameter(s) +C specified by TPID. +C +C -- LURA is the length of the user array FURA. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Define the array DUMI, which allows access to the parameter list as +C an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters desired. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of elements to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C Transfer the desired parameters to the user array. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + FURA(IURA)=DUMI(IDMI) + 101 CONTINUE +C +C If the current label name is being gotten, return its identifier. +C + CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN.AND.NIPA.EQ.NILN.AND.QBAN.NE.0.) THEN + LBAN=IFIX(QBAN) + FURA(1)=FLLB(1,LBAN) + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggtch.f b/sys/gio/ncarutil/autograph/aggtch.f new file mode 100644 index 00000000..7591c670 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggtch.f @@ -0,0 +1,78 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGTCH (IDCS,CHST,LNCS) +C + CHARACTER*(*) CHST +C +C This routine gets character strings previously stored by the routine +C AGSTCH (which see). It has the following arguments: +C +C -- IDCS is the identifying integer returned by AGSTCH when the string +C was stored. +C +C -- CHST is the character string returned. +C +C -- LNCS is the length of the character string returned in CHST. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C First, blank-fill the character variable to be returned. +C + CHST=' ' +C +C If the identifier is less than -LNIC, the (one-character) string is +C retrieved from it. +C + IF (IDCS.LT.(-LNIC)) THEN + CHST=CHAR(-IDCS-LNIC-1) + LNCS=1 +C +C If the identifier is between -LNIC and -1, its absolute value is the +C index, in INCH, of the descriptor of the character string stored in +C CHRA. +C + ELSE IF (IDCS.LE.(-1)) THEN + I=-IDCS + J=INCH(1,I)-1 + IF (J.GE.0) THEN + LNCS=MIN0(LEN(CHST),INCH(2,I)) + DO 101 K=1,LNCS + J=J+1 + CHST(K:K)=CHRA(J) + 101 CONTINUE + ELSE + LNCS=0 + END IF +C +C In all other cases, return a single blank. +C + ELSE + LNCS=1 +C + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aginit.f b/sys/gio/ncarutil/autograph/aginit.f new file mode 100644 index 00000000..e863e01f --- /dev/null +++ b/sys/gio/ncarutil/autograph/aginit.f @@ -0,0 +1,113 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGINIT +C +C This routine is called to initialize some machine-dependent constants. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Fill in the names of the four pre-defined labels. +C + CALL AGSTCH ('L',1,IDCS) + FLLB(1,1)=FLOAT(IDCS) + CALL AGSTCH ('R',1,IDCS) + FLLB(1,2)=FLOAT(IDCS) + CALL AGSTCH ('B',1,IDCS) + FLLB(1,3)=FLOAT(IDCS) + CALL AGSTCH ('T',1,IDCS) + FLLB(1,4)=FLOAT(IDCS) +C +C Declare the rest of the label-definition slots to be available. +C + LBIM=IFIX(QBIM) +C + DO 101 J=5,LBIM + FLLB(1,J)=0. + 101 CONTINUE +C +C Fill in the text of the four pre-defined lines. +C + CALL AGSTCH ('Y',1,IDCS) + FLLN(4,1)=FLOAT(IDCS) + CALL AGSTCH (' ',1,IDCS) + FLLN(4,2)=FLOAT(IDCS) + CALL AGSTCH ('X',1,IDCS) + FLLN(4,3)=FLOAT(IDCS) + CALL AGSTCH (' ',1,IDCS) + FLLN(4,4)=FLOAT(IDCS) +C +C Declare the rest of the line-definition slots to be available. +C + LNIM=IFIX(QNIM) +C + DO 102 J=5,LNIM + FLLN(1,J)=SVAL(1) + 102 CONTINUE +C +C Set the value of 'LINE/TERMINATOR.' +C + CALL AGSTCH ('$',1,IDCS) + TCLN=FLOAT(IDCS) +C +C SMRL is used by AUTOGRAPH for rounding operations. +C + SMRL=10.**(3-IFIX(ALOG10(FLOAT(I1MACH(10)))*FLOAT(I1MACH(11)))) +C +C ISLD is an integer containing 16 one bits (right-justified with zero +C fill to the left). It is used to direct the DASHCHAR package to draw +C solid lines. To generate it, we start with a 15-bit mask and then +C add another bit. +C + ISLD = 32767 + ISLD = ISHIFT(ISLD,1) + ISLD = IOR(ISLD,1) +C +C Set the initialization flag to indicate initialization has been done. +C + INIF=1 +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agkurv.f b/sys/gio/ncarutil/autograph/agkurv.f new file mode 100644 index 00000000..d93f0659 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agkurv.f @@ -0,0 +1,145 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGKURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGKURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C No windowing is performed. +C +C Check first whether the number of curve points is properly specified. +C + IF (NEXY.LE.0) GO TO 901 +C +C Initialization. Pretend that the last point was point number zero. +C Set the indices for the x and y vectors accordingly. Clear the line- +C drawn-to-last-point flag. +C + INDP=0 + INDX=1-IIEX + INDY=1-IIEY + LDLP=0 +C +C Initialization. Retrieve the current curve window, user window, and +C x/y linear/logarithmic flags. +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Initialization. Set linear/log flag and linear-window limits for +C x-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.2) THEN + LLUX=0 + XLLW=XLUW + XRLW=XRUW + ELSE + LLUX=1 + XLLW=ALOG10(XLUW) + XRLW=ALOG10(XRUW) + END IF +C +C Initialization. Set linear/log flag and linear-window limits for +C y-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.3) THEN + LLUY=0 + YBLW=YBUW + YTLW=YTUW + ELSE + LLUY=1 + YBLW=ALOG10(YBUW) + YTLW=ALOG10(YTUW) + END IF +C +C Initialization. Call SET, if necessary, to define a linear mapping. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLLW,XRLW,YBLW,YTLW,1) +C +C Beginning of loop through points. Update indices and determine the +C user-space coordinates of the next point. +C + 101 IF (INDP.EQ.NEXY) GO TO 102 + INDP=INDP+1 +C + INDX=INDX+IIEX + XNXT=XVEC(INDX) + IF (IIEX.EQ.0) XNXT=FLOAT(INDP) + IF (LLUX.NE.0.AND.XNXT.LE.0.) XNXT=SVAL +C + INDY=INDY+IIEY + YNXT=YVEC(INDY) + IF (IIEY.EQ.0) YNXT=FLOAT(INDP) + IF (LLUY.NE.0.AND.YNXT.LE.0.) YNXT=SVAL +C +C Check whether (XNXT,YNXT) is a special-value point. Handle that case. +C + IF (XNXT.EQ.SVAL.OR.YNXT.EQ.SVAL) THEN + IF (LDLP.EQ.0) GO TO 101 + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + LDLP=0 + GO TO 101 + END IF +C +C If user space is not linear/linear, modify XNXT and YNXT accordingly. +C + IF (LLUX.NE.0) XNXT=ALOG10(XNXT) + IF (LLUY.NE.0) YNXT=ALOG10(YNXT) +C +C Start or continue line. +C + IF (LDLP.EQ.0) THEN + CALL FRSTD (XNXT,YNXT) + XLST=XNXT + YLST=YNXT + ELSE + CALL VECTD (XNXT,YNXT) + END IF +C + LDLP=LDLP+1 + GO TO 101 +C +C Last point was final point. Finish up. +C + 102 IF (LDLP.NE.0) THEN + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + END IF +C +C Restore logarithmic mapping, if appropriate. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Return to caller. +C + RETURN +C +C Error exit. +C + 901 CALL SETER ('AGKURV - NUMBER OF POINTS IS LESS THAN OR EQUAL TO ZE + +RO',3,2) +C + END diff --git a/sys/gio/ncarutil/autograph/aglbls.f b/sys/gio/ncarutil/autograph/aglbls.f new file mode 100644 index 00000000..d99b038d --- /dev/null +++ b/sys/gio/ncarutil/autograph/aglbls.f @@ -0,0 +1,616 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGLBLS (ITST,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C + DIMENSION FLLB(10,8),FLLN(6,16),DBOX(6,4),SBOX(6,4),RBOX(6) +C +C The routine AGLBLS is used (if ITST .LE. 0) to predict the amount of +C space which will be required for graph labels (excluding the numeric +C labels on the axes, which are handled by AGAXIS) or (if ITST .GT. 0) +C to actually draw the graph labels. +C +C The labels in question are defined by the label list (FLLB array) and +C the line list (FLLN array). Each label is assumed to lie in one of +C five boxes, as follows: +C +C Box 1 is to the left of the curve window. +C Box 2 is to the right of the curve window. +C Box 3 is below the curve window. +C Box 4 is above the curve window. +C Box 5 is the curve window itself. +C Box 6 is the entire plot (graph) window. +C +C A test run of AGLBLS returns two sets of box dimensions to the caller. +C DBOX contains the dimensions required if all labels are to have their +C desired sizes, SBOX the dimensions required if all labels are to have +C their smallest sizes. The caller is expected to use this information +C to determine a final set of box dimensions (stored in DBOX), and then +C call AGLBLS again to actually draw the labels in those boxes. +C +C The arguments of AGLBLS are as follows: +C +C -- ITST specifies whether the call is a test call (ITST .LE. 0) or a +C real call (ITST .GT. 0). If ABSV(ITST) .GT. 1, AGLBLS is allowed +C to shrink the labels if they would not otherwise fit in their box. +C If ABSV(ITST) .EQ. 1, shrinkage of labels is prohibited. If ITST +C .EQ. 0, labels are suppressed. +C +C -- WCWP and HCWP are the width and height of the curve window, in +C plotter-coordinate-system units. AGLBLS assumes that the last call +C to the plot package routine "SET" had arguments XLCW, XRCW, YBCW, +C YTCW, 0., 1., 0., 1., and 1 - defining the most convenient system +C of coordinates for it. +C +C -- FLLB is the array in which the label list is stored. The array is +C doubly-dimensioned. The first subscript specifies one of ten label +C attributes, the second a particular label. The attributes are as +C follows (the name ILLB(M,N) refers to a label attribute which is +C intrinsically an integer, despite being stored as a real): +C +C -- ILLB(1,N) specifies the name of label N. If ILLB(1,N) is zero, +C no label is defined. Otherwise, ILLB(1,N) is an identifier +C returned by AGSTCH when the name of the label (a character +C string) was stored away. +C +C -- ILLB(2,N) may be set non-zero to suppress label N. +C +C -- FLLB(3,N) and FLLB(4,N) are the x and y coordinates of a base- +C point relative to which label N is positioned, as fractions of +C the width and height, respectively, of the curve window. The +C position of the base-point determines the box in which label N +C is considered to lie. +C +C -- FLLB(5,N) and FLLB(6,N) are small offsets (typically about the +C size of a character width), stated as fractions of the smaller +C side of the curve window. They are used to offset the label +C base-point (after the box number is determined). Typically, +C this provides a minimum spacing between the label and one side +C of the curve window. +C +C -- ILLB(7,N) is the orientation angle of the label, in degrees +C counter-clockwise from horizontal. The base-line for label N +C is a vector emanating from the base-point at this angle. The +C specified angle must be a multiple of 90 degrees. +C +C -- ILLB(8,N) is the centering option for the label. It specifies +C how each line of the label is to be positioned relative to a +C line perpendicular to the base-line at the base-point. +C +C -- If ILLB(8,N) .LT. 0, the left edge of each line lies on +C the perpendicular. +C +C -- If ILLB(8,N) .EQ. 0, the center of each line lies on the +C perpendicular. +C +C -- If ILLB(8,N) .GT. 0, the right edge of each line lies on +C the perpendicular. +C +C -- ILLB(9,N) is the number of lines in label N. +C +C -- ILLB(10,N) is the second subscript (in the line list) of the +C first line of label N. +C +C -- LBIM is the maximum number of labels the label list will hold. +C +C -- FLLN is the array in which the line list is stored. The array is +C doubly-dimensioned. The first subscript specifies one of six line +C attributes, the second a particular line. The attributes are as +C follows (the name ILLN(M,N) refers to a line attribute which is +C intrinsically an integer, despite being stored as a real): +C +C -- ILLN(1,N) is the position number of line N. The lines of a +C label are ordered according to their position numbers, the one +C having the largest position number being top-most. Moreover, +C lines having position numbers .GT. 0 are placed above the label +C base-line, those having position numbers .EQ. 0 (of which there +C should be but one) are placed on the label base-line, and those +C having position numbers .LT. 0 are placed below the label base- +C line. The magnitudes of the position numbers have nothing to +C do with inter-line spacing - that is up to AGLBLS to determine. +C +C -- ILLN(2,N) may be set non-zero to suppress line N. +C +C -- FLLN(3,N) is the desired width of characters in the line, as a +C fraction of the smaller side of the curve window. +C +C -- ILLN(4,N) is the identifier of the character string comprising +C the text of the line, as returned by AGSTCH at the time the +C string was stored. +C +C -- ILLN(5,N) is the number of characters in the line. +C +C -- ILLN(6,N) is the index of the next line of the label. The +C lines of a label must be ordered by position number (largest +C to smallest). +C +C -- DBOX and SBOX, dimensioned 6 X 4, contain box dimensions, as dis- +C cussed above. D/SBOX(M,N) is the Nth edge-coordinate of box M, +C where N .EQ. 1 for the left edge, 2 for the right edge, 3 for the +C bottom edge, and 4 for the top edge, of the box. The first two are +C stated as fractions of the width, the second two as fractions of +C the height, of the curve window. +C +C RBOX, dimensioned 6, holds reduction factors for the sizes of the +C characters in labels in each of the six boxes. Each RBOX(M) is +C +C -- negative to specify smallest-size characters, or +C +C -- zero to specify that no reduction factor has been chosen, or +C +C -- positive, between 0. and 1. (an actual reduction factor). +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only one of +C interest here is MWCL, which is the minimum usable character width, +C in plotter units. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C HCFW(WDTH) specifies the height of a character as a function of width. +C + HCFW(WDTH)=2.*WDTH +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the main section of AGLBLS. +C +C Compute the length of the smallest side of the curve window. +C + SCWP=AMIN1(WCWP,HCWP) +C +C Preset certain jumps in the internal procedure which follows. +C + ASSIGN 211 TO JMP1 + ASSIGN 216 TO JMP2 + ASSIGN 221 TO JMP3 +C +C Jump if this is a test run. +C + IF (ITST.LE.0) GO TO 101 +C +C This is not a test run. If the reduction factors for the six boxes +C are already set, jump directly to the plotting section; otherwise, we +C must first compute the coordinates of the six smallest-size boxes. +C + IF (RBOX(1).NE.0.) GO TO 115 + GO TO 105 +C +C This is a test run. Compute the coordinates of the edges of the six +C desired-size boxes. +C + 101 RWCL=1. + NBOX=0 + ASSIGN 102 TO JMP4 + GO TO 200 +C + 102 DBOX(NBOX,1)=XLBX + DBOX(NBOX,2)=XRBX + DBOX(NBOX,3)=YBBX + DBOX(NBOX,4)=YTBX +C + IF (NBOX.LT.6) GO TO 200 +C +C This is a test run. Compute the coordinates of the edges of the six +C smallest-size boxes, in one of two ways. +C + IF (IABS(ITST).GT.1) GO TO 105 +C +C This is a test run. Determine smallest-size boxes (no shrinking). +C + DO 104 J=1,4 + DO 103 I=1,6 + SBOX(I,J)=DBOX(I,J) + 103 CONTINUE + 104 CONTINUE + RETURN +C +C Determine smallest-size boxes (shrinking allowed). +C + 105 RWCL=0. + NBOX=0 + ASSIGN 106 TO JMP4 + GO TO 200 +C + 106 SBOX(NBOX,1)=XLBX + SBOX(NBOX,2)=XRBX + SBOX(NBOX,3)=YBBX + SBOX(NBOX,4)=YTBX +C + IF (NBOX.LT.6) GO TO 200 +C +C If this is not a test run, jump to compute reduction factors for each +C of the six boxes and then plot the labels. Otherwise, return. +C + IF (ITST.GT.0) GO TO 107 + RETURN +C +C This is not a test run. Compute reduction factors for each of the +C six boxes. +C + 107 NBOX=1 + ASSIGN 110 TO JMP4 +C +C (DBOX(NBOX,I),I=1,4) specifies the box in which the labels are to be +C drawn, (SBOX(NBOX,I),I=1,4) the minimum box in which they can be drawn +C if shrunk. Check first whether the latter is contained in the former. +C If so, we have a chance. If not, the best we can do is shrink the +C labels to minimum size and hope for the best. +C + 108 IF (SBOX(NBOX,1).LT.SBOX(NBOX,2).AND. + + DBOX(NBOX,1)-SBOX(NBOX,1).LT..0001.AND. + + SBOX(NBOX,2)-DBOX(NBOX,2).LT..0001.AND. + + DBOX(NBOX,3)-SBOX(NBOX,3).LT..0001.AND. + + SBOX(NBOX,4)-DBOX(NBOX,4).LT..0001 ) GO TO 109 +C + RBOX(NBOX)=-1. + GO TO 114 +C +C Mimimum-size labels will fit. Find the largest value of RBOX(NBOX) +C for which the labels will fit. +C + 109 RWCL=1. + DWCL=.5 + SWCL=0. + GO TO 201 +C +C See if the last value of RBOX(NBOX) gave us labels which would fit or +C not and adjust the value accordingly. +C + 110 IF (DBOX(NBOX,1)-XLBX.LT..0001.AND. + + XRBX-DBOX(NBOX,2).LT..0001.AND. + + DBOX(NBOX,3)-YBBX.LT..0001.AND. + + YTBX-DBOX(NBOX,4).LT..0001 ) GO TO 111 +C +C Labels did not fit. Adjust RBOX(NBOX) downward. +C + RWCL=RWCL-DWCL + DWCL=.5*DWCL + IF (DWCL.LT..001) RWCL=SWCL + GO TO 201 +C +C Labels did fit. Adjust RBOX(NBOX) upward, unless it is equal to 1. +C + 111 IF (RWCL.EQ.1.) GO TO 113 + SWCL=RWCL + RWCL=RWCL+DWCL + DWCL=.5*DWCL + IF (DWCL.GT..001) GO TO 201 +C +C The current value of RBOX(NBOX) is acceptable. Do next box, if any. +C + 113 IF (NBOX.GE.5) GO TO 114 +C +C Return updated box-edge coordinates for boxes 1 through 4. +C + DBOX(NBOX,1)=XLBX + DBOX(NBOX,2)=XRBX + DBOX(NBOX,3)=YBBX + DBOX(NBOX,4)=YTBX +C + 114 NBOX=NBOX+1 + IF (NBOX.LE.6) GO TO 108 +C +C We have done all we can to make the labels fit. Plot them now. +C + 115 NBOX=0 + LBIN=0 + ASSIGN 117 TO JMP3 + ASSIGN 120 TO JMP4 +C +C Get a label to chew on. +C + 116 ASSIGN 211 TO JMP1 + ASSIGN 216 TO JMP2 + GO TO 202 +C +C We have a label. Initialize the re-loop through the lines in it. +C + 117 XPLN=XPLB-DTLB*YDLB/WCWP + YPLN=YPLB+DTLB*XDLB/HCWP + PHCL=0. + LNIN=LNII + ASSIGN 118 TO JMP1 + ASSIGN 116 TO JMP2 + GO TO 210 +C +C Get ready to plot the label line. +C + 118 XPLN=XPLN+.5*(PHCL+FHCL)*YDLB/WCWP + YPLN=YPLN-.5*(PHCL+FHCL)*XDLB/HCWP + PHCL=FHCL + CALL AGGTCH (IFIX(FLLN(4,LNIN)),CHS2,LNC2) +C +C Give the user a chance to change the appearance of the label line. +C + CALL AGCHIL (0,CHS1(1:LNC1),IFIX(FLLN(1,LNIN))) +C +C Plot the label line. +C + CALL AGPWRT (XPLN,YPLN,CHS2,LNC2,IWCL,LBOR,LBCN) +C +C Give the user a chance to undo the changes he made above. +C + CALL AGCHIL (1,CHS1(1:LNC1),IFIX(FLLN(1,LNIN))) +C +C Go get the next line, if any. +C + GO TO 215 +C +C All labels are drawn. Return. +C + 120 RETURN +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure, which may be entered and exited in a number +C of different ways, is used to scan the label list and the line list +C and to return information about the labels and lines defined there. +C +C Entry occurs here to bump the box number, store away a reduction +C factor for the sizes of labels in that box, and then compute the edge +C coordinates of the box required to hold labels of the size implied by +C that reduction factor. +C + 200 NBOX=NBOX+1 +C +C Entry occurs here to do all of the above except the bumping of the box +C number. +C + 201 RBOX(NBOX)=RWCL +C +C Initialize the label-list index and the box-edge parameters. +C + LBIN=0 + XLBX=+1000. + XRBX=-1000. + YBBX=+1000. + YTBX=-1000. + IF (ITST.EQ.0) GO TO 222 +C +C This is the beginning of the loop through the labels. Entry occurs +C here to find the next label in the list and return positioning info. +C +C Increment the label index and test for end of label list. +C + 202 LBIN=LBIN+1 + IF (LBIN.GT.LBIM) GO TO 222 +C +C Skip this label if it is non-existent, suppressed, or empty. +C + IF (FLLB(1,LBIN).EQ.0..OR.FLLB(2,LBIN).NE.0. + + .OR.FLLB(9,LBIN).EQ.0.) GO TO 202 +C +C Unpack the parameters specifying the label-base-point position. +C + XBLB=FLLB(3,LBIN) + YBLB=FLLB(4,LBIN) + XOLB=FLLB(5,LBIN) + YOLB=FLLB(6,LBIN) +C +C Determine in which of five boxes the label lies: +C +C in the box to the left of the curve window. +C + LBBX=1 + IF (XBLB.EQ.0..AND.XOLB.LE.0.) GO TO 203 +C +C in the box to the right of the curve window, +C + LBBX=2 + IF (XBLB.EQ.1..AND.XOLB.GE.0.) GO TO 203 +C +C in the box below the curve window, +C + LBBX=3 + IF (YBLB.EQ.0..AND.YOLB.LE.0.) GO TO 203 +C +C in the box above the curve window, +C + LBBX=4 + IF (YBLB.EQ.1..AND.YOLB.GE.0.) GO TO 203 +C +C in the curve window, +C + LBBX=5 + IF ( (XBLB.EQ.0..AND.XOLB.GT.0.).OR. + + (XBLB.EQ.1..AND.XOLB.LT.0.).OR. + + (YBLB.EQ.0..AND.YOLB.GT.0.).OR. + + (YBLB.EQ.1..AND.YOLB.LT.0.) ) GO TO 203 +C +C or elsewhere. +C + LBBX=6 +C +C If we are interested in a particular box and this label is not in that +C box, skip it. +C + 203 IF (NBOX.NE.0.AND.LBBX.NE.NBOX) GO TO 202 +C +C On a non-test run, get the label name and length for call to AGCHIL. +C + IF (ITST.GT.0) CALL AGGTCH (IFIX(FLLB(1,LBIN)),CHS1,LNC1) +C +C Unpack the label orientation and compute its direction cosines. +C + LBOR=IFIX(FLLB(7,LBIN)) +C + XDLB=COS(.017453292519943*FLLB(7,LBIN)) + YDLB=SIN(.017453292519943*FLLB(7,LBIN)) +C +C Unpack the label-centering option. +C + LBCN=IFIX(FLLB(8,LBIN)) +C +C Unpack the index of the initial line of the label and save it. +C + LNIN=IFIX(FLLB(10,LBIN)) + LNII=LNIN +C +C If this is not a test run, modify the label-base-point position as +C needed to move the label into the actual box in which it must fit. +C + IF (ITST.LE.0) GO TO 209 +C + GO TO (204,205,206,207,208,209) , LBBX +C + 204 XBLB=XBLB+DBOX(1,2) + GO TO 209 +C + 205 XBLB=XBLB+DBOX(2,1)-1. + GO TO 209 +C + 206 YBLB=YBLB+DBOX(3,4) + GO TO 209 +C + 207 YBLB=YBLB+DBOX(4,3)-1. + GO TO 209 +C + 208 IF (XBLB.EQ.0.) XBLB=XBLB+DBOX(5,1) + IF (XBLB.EQ.1.) XBLB=XBLB+DBOX(5,2)-1. + IF (YBLB.EQ.0.) YBLB=YBLB+DBOX(5,3) + IF (YBLB.EQ.1.) YBLB=YBLB+DBOX(5,4)-1. +C +C Compute the final label-base-point position. +C + 209 XPLB=XBLB+XOLB*SCWP/WCWP + YPLB=YBLB+YOLB*SCWP/HCWP +C +C Before entering the loop through the line list, initialize the label- +C dimension parameters. +C + DLLB=0. + DRLB=0. + DBLB=0. + DTLB=0. +C +C This is the beginning of the loop through the lines in a given label. +C Entry may occur here to find the next line and return info about it. +C +C If the line is suppressed or of zero length, skip it. +C + 210 IF (FLLN(2,LNIN).NE.0..OR.FLLN(5,LNIN).LE.0.) GO TO 215 +C +C Unpack the position-number, character-width, and character-count +C parameters for the line. +C + LNPN=IFIX(FLLN(1,LNIN)) + WCLN=FLLN(3,LNIN) + LNCC=IFIX(FLLN(5,LNIN)) +C +C Compute the integer width (IWCL) and the floating-point width and +C height (FWCL and FHCL) of characters in the label. All are expressed +C in plotter-coordinate-system units. +C + IWCL=MAX0(MWCL,IFIX(RBOX(LBBX)*WCLN*SCWP+.5)) + FWCL=FLOAT(IWCL) + FHCL=HCFW(FWCL) +C +C Jump back with line information or drop through, as directed. +C + GO TO JMP1 , (118,211) +C +C Update the label-dimension parameters. +C + 211 DRLB=AMAX1(DRLB,FLOAT(LNCC)*FWCL) +C + IF (LNPN) 212,213,214 +C + 212 DBLB=DBLB+FHCL + GO TO 215 +C + 213 DBLB=DBLB+.5*FHCL + DTLB=DTLB+.5*FHCL + GO TO 215 +C + 214 DTLB=DTLB+FHCL +C +C Go to the next line in the label, if there is one. +C + 215 LNIN=IFIX(FLLN(6,LNIN)) + IF (LNIN.NE.0) GO TO 210 +C +C Jump back on end of lines or drop through, as directed. +C + GO TO JMP2 , (116,216) +C +C If all the lines in the label were either suppressed or of zero +C length, skip this label. +C + 216 IF (DRLB.EQ.0.) GO TO 202 +C +C Complete the computation of the label dimensions. The four parameters +C DLLB, DRLB, DBLB, and DTLB represent the distances from the base-point +C to the left edge, right edge, bottom edge, and top edge of the label, +C in plotter-coordinate-system units, where left, right, etc., are as +C viewed by a reader of the label. +C + IF (LBCN) 217,218,219 +C +C Left edges of lines are aligned. +C + 217 GO TO 220 +C +C Centers of lines are aligned. +C + 218 DLLB=.5*(DLLB+DRLB) + DRLB=DLLB + GO TO 220 +C +C Right edges of lines are aligned. +C + 219 SWAP=DLLB + DLLB=DRLB + DRLB=SWAP +C +C Jump back with label information or drop through, as directed. +C + 220 GO TO JMP3 , (117,221) +C +C Update the x and y coordinates of the label box edges. +C + 221 XLBX=AMIN1(XLBX,XBLB, + + XPLB-AMAX1(+DLLB*XDLB,-DRLB*XDLB,-DBLB*YDLB,+DTLB*YDLB)/WCWP) + XRBX=AMAX1(XRBX,XBLB, + + XPLB+AMAX1(-DLLB*XDLB,+DRLB*XDLB,+DBLB*YDLB,-DTLB*YDLB)/WCWP) + YBBX=AMIN1(YBBX,YBLB, + + YPLB-AMAX1(+DLLB*YDLB,-DRLB*YDLB,+DBLB*XDLB,-DTLB*XDLB)/HCWP) + YTBX=AMAX1(YTBX,YBLB, + + YPLB+AMAX1(-DLLB*YDLB,+DRLB*YDLB,-DBLB*XDLB,+DTLB*XDLB)/HCWP) +C +C Go back for the next label. +C + GO TO 202 +C +C End of label list. Jump as directed. +C + 222 GO TO JMP4 , (102,106,110,120) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C + END diff --git a/sys/gio/ncarutil/autograph/agmaxi.f b/sys/gio/ncarutil/autograph/agmaxi.f new file mode 100644 index 00000000..9c981e0d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agmaxi.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + FUNCTION AGMAXI (SVAL,ZHGH,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C + DIMENSION ZDRA(1) +C +C The routine AGMAXI returns the maximum value of the elements in ZDRA +C specified by NVIZ, IIVZ, NEVZ, and IIEZ, skipping elements having the +C special value SVAL (or more than ZHGH, if ZHGH is not equal to SVAL). +C +C -- NVIZ is the number of vectors of data stored in ZDRA. +C +C -- IIVZ is the index increment from one data vector to the next. +C +C -- NEVZ is the number of elements per vector to be examined. +C +C -- IIEZ is the index increment from one vector element to the next. +C If IIEZ is 0, the array is ignored and NEVZ is returned. +C + AGMAXI=FLOAT(NEVZ) + IF (IIEZ.EQ.0) RETURN +C + AGMAXI=SVAL + INDZ=1-IIEZ +C + DO 103 I=1,NVIZ + IF (ZHGH.EQ.SVAL) THEN + DO 101 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL) GO TO 101 + IF (AGMAXI.EQ.SVAL) AGMAXI=ZDRA(INDZ) + AGMAXI=AMAX1(AGMAXI,ZDRA(INDZ)) + 101 CONTINUE + ELSE + DO 102 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL.OR.ZDRA(INDZ).GT.ZHGH) GO TO 102 + IF (AGMAXI.EQ.SVAL) AGMAXI=ZDRA(INDZ) + AGMAXI=AMAX1(AGMAXI,ZDRA(INDZ)) + 102 CONTINUE + END IF + INDZ=INDZ-NEVZ*IIEZ+IIVZ + 103 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agmini.f b/sys/gio/ncarutil/autograph/agmini.f new file mode 100644 index 00000000..be4b6d2c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agmini.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + FUNCTION AGMINI (SVAL,ZLOW,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C + DIMENSION ZDRA(1) +C +C The routine AGMINI returns the mimimum value of the elements in ZDRA +C specified by NVIZ, IIVZ, NEVZ, and IIEZ, skipping elements having the +C special value SVAL (or less than ZLOW, if ZLOW is not equal to SVAL). +C +C -- NVIZ is the number of vectors of data stored in ZDRA. +C +C -- IIVZ is the index increment from one data vector to the next. +C +C -- NEVZ is the number of elements per vector to be examined. +C +C -- IIEZ is the index increment from one vector element to the next. +C If IIEZ is 0, the array is ignored and 1. is returned. +C + AGMINI=1. + IF (IIEZ.EQ.0) RETURN +C + AGMINI=SVAL + INDZ=1-IIEZ +C + DO 103 I=1,NVIZ + IF (ZLOW.EQ.SVAL) THEN + DO 101 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL) GO TO 101 + IF (AGMINI.EQ.SVAL) AGMINI=ZDRA(INDZ) + AGMINI=AMIN1(AGMINI,ZDRA(INDZ)) + 101 CONTINUE + ELSE + DO 102 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL.OR.ZDRA(INDZ).LT.ZLOW) GO TO 102 + IF (AGMINI.EQ.SVAL) AGMINI=ZDRA(INDZ) + AGMINI=AMIN1(AGMINI,ZDRA(INDZ)) + 102 CONTINUE + END IF + INDZ=INDZ-NEVZ*IIEZ+IIVZ + 103 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agnumb.f b/sys/gio/ncarutil/autograph/agnumb.f new file mode 100644 index 00000000..24469772 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agnumb.f @@ -0,0 +1,491 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGNUMB (NBTP,SBSE,EXMU , NLTP,NLEX,NLFL , + + BFRM,MCIM,NCIM,IPXM , BFRE,MCIE,NCIE) +C + CHARACTER*(*) BFRM,BFRE +C +C The routine AGNUMB converts the number specified by the arguments +C NBTP, SBSE, and EXMU to the label format specified by the arguments +C NLTP, NLEX, and NLFL, returning the characters of the mantissa in the +C buffer BFRM and the characters of the exponent in the buffer BFRE, +C ready for plotting. The arguments of AGNUMB are as follows: +C +C -- NBTP is an integer specifying the type of number to be converted. +C There are three possibilities: +C +C NBTP = 1 - number of the form SBSE * EXMU. +C +C NBTP = 2 - number of the form SBSE * 10**EXMU. +C +C NBTP = 3 - number of the form SIGN(SBSE) * ABSV(SBSE)**EXMU. +C +C -- SBSE is a base value for a set of labels. See NBTP description. +C +C -- EXMU is an exponent or a multiplier for a given label. Although it +C is a floating-point number, its value should be integral, unless +C NBTP equals 1 and/or NLTP equals 1. Using a non-integral EXMU in +C other cases will have undesirable effects. See NBTP description. +C +C -- NLTP is an integer specifying the type of label to be generated. +C There are three possibilities: +C +C -- NLTP = 1 - label is to have an exponent portion and is to be +C expressed in scientific notation. +C +C -- NLTP = 2 - label is to have an exponent portion and is to be +C expressed in a form determined by the number type NBTP. +C +C -- NLTP = 3 - label is to have no exponent portion and is to be +C expressed in a form determined by the number type NBTP. +C +C The possible label types will be described in greater detail below. +C +C -- NLEX (when used) is an integer specifying (in a manner depending on +C the values of other parameters) the value of the exponent portion +C of the label. See the detailed discussion of label types, below. +C +C -- NLFL (when used) is an integer specifying (in a manner depending on +C the values of other parameters) the length of the fractional por- +C tion of the mantissa of the label. See the detailed discussion of +C label types, below. +C +C -- BFRM is a character variable in which the mantissa portion of the +C label is to be returned. +C +C -- MCIM specifies the maximum number of characters BFRM can hold. +C +C -- NCIM is the number of characters returned in BFRM by AGNUMB. +C +C -- IPXM is the position of the character X in the mantissa. If IPXM +C is zero, the character X does not occur in the mantissa. +C +C -- BFRE, MCIE, and NCIE are analogous to BFRM, MCIM, and NCIM, but +C pertain to the exponent portion of the label. +C +C Label types: AGNUMB will produce many different types of labels, as +C directed by the various input parameters. Each of these is described +C below. The general form of a label is +C +C (-) (1/) (I) (.) (F) (X 10) (E) +C +C where the parentheses are used to mark portions which may either be +C present or absent. The minus sign is included only if the label value +C is negative. I is the integer portion of the mantissa, included only +C if its value is non-zero. The decimal point is included if the input +C parameter NLFL does not specifically direct that it should be omitted +C or if the fractional portion of the mantissa (F) is present. F is the +C fractional portion of the mantissa. The "X 10" is included if it is +C appropriate, and is considered to be a part of the mantissa; if it is +C included, a blank is actually returned for the character X, so the +C routine which plots the label should construct this character by +C drawing two short lines. E is the exponent, returned in a separate +C buffer so that it may be plotted in a superscript form. The possible +C label types are, then, as follows: +C +C -- Scientific notation - if the label type NLTP equals 1, the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. NLEX specifies the length of I (thus also specifying the +C value of the exponent E). If NLEX is .LE. 0, I is omitted. If +C NLEX is .LT. 0 and has the absolute value N, the fraction F is +C forced to have N leading zeroes. NLFL specifies the length of F. +C If NLFL is .LE. 0, F is omitted. If NLFL is .LT. 0, the decimal +C point is omitted. If (I.F) has the value 1, (I.F X) is omitted. +C If the entire label has zero value, the character 0 is used. +C +C -- Exponential, but non-scientific notation - if the label type NLTP +C equals 2, the form used depends on the argument NBTP, as follows: +C +C -- If NBTP equals 1 (number of the form SBSE * EXMU), the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. NLEX specifies the value of the exponent E. The +C length of F is specified by NLFL. If NLFL is .LE. 0, F is +C omitted. If NLFL is .LT. 0, the decimal point is omitted. If +C the label value is exactly 0, the character 0 is used. +C +C -- If NBTP equals 2 (number of the form SBSE*10**EXMU), the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. The exponent E has the value NLEX+EXMU. The length +C of F is specified by NLFL. If NLFL is .LE. 0, F is omitted. +C If NLFL is .LT. 0, the decimal point is omitted. If the label +C value is exactly 0, the character 0 is used. If (I.F) has the +C value 1., then (I.F X) is omitted. +C +C -- If NBTP equals 3, specifying that the number is of the form +C SIGN(SBSE) * ABSV(SBSE)**EXMU, the form +C +C (-) (I) (.) (F) (E) +C +C is used. The exponent E has the value EXMU. The length of F +C is specified by NLFL. If NLFL is .LE. 0, F is omitted. If +C NLFL is .LT. 0, the decimal point is omitted. +C +C -- No-exponent notation - if the label type NLTP equals 3, the form +C used depends on the argument NBTP, as follows: +C +C -- If NBTP equals 1 (number of the form SBSE * EXMU), the form +C +C (-) (I) (.) (F) +C +C is used. NLFL specifies the length of F. If NLFL is .LE. 0, +C F is omitted. If NLFL is .LT. 0, the decimal point is omitted. +C If the entire label has zero value, the character 0 is used. +C +C -- If NBTP equals 2 (number of the form SBSE*10**EXMU), the form +C +C (-) (I) (.) (F) +C +C is used. The length of F is specified by the function +C +C MAX(NLFL,0)-EXMU (if EXMU is .LT. MAX(NLFL,0)) +C MIN(NLFL,0) (if EXMU is .GE. MAX(NLFL,0)) +C +C which may appear somewhat formidable, but produces a simple, +C desirable result. Suppose, for example, that SBSE = 3.6, +C NLFL = 1, and EXMU ranges from -3 to +3 - the labels produced +C are as follows: +C +C .0036 .036 .36 3.6 36. 360. 3600. +C +C NLFL may be viewed as specifying the length of F if EXMU is 0. +C If the value of the function is .LE. 0, F is omitted - if its +C value is .LT. 0, the decimal point is omitted. +C +C -- If NBTP equals 3, specifying that the number is of the form +C SIGN(SBSE) * ABSV(SBSE)**EXMU, the form +C +C (-) (I) (.) (F) +C +C is used if EXMU is positive (or zero), and the form +C +C (-) 1 / (I) (.) (F) +C +C is used if EXMU is negative. The length of F is specified by +C the function +C +C NLFL * ABSV(EXMU) (if EXMU is .NE. 0) +C MIN(NLFL,0) (if EXMU is .EQ. 0) +C +C Again, this function produces a simple result. Suppose that +C SBSE = 1.1, NLFL = 1, and EXMU ranges from -3 to +3 - the +C labels produced are as follows: +C +C 1/1.331 1/1.21 1/1.1 1. 1.1 1.21 1.331 +C +C NLFL may be viewed as specifying the length of F if EXMU is 1. +C If the value of the function is .LE. 0, F is omitted - if its +C value is .LT. 0, the decimal point is omitted. As another +C example, suppose that SBSE = 2., NLFL = -1, and EXMU ranges +C from -4 to +4. The labels produced are as follows: +C +C 1/16 1/8 1/4 1/2 1 2 4 8 16 +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C KHAR holds single characters to be stored away in BFRM or BFRE. +C + CHARACTER*1 KHAR +C +C Zero character counters and pointers. +C + NCIM=0 + NCIE=0 + IPXM=0 +C +C Compute a jump parameter to allow a quick sorting-out of the possible +C number-type/label-type combinations below. +C + NTLT=NBTP+3*(NLTP-1) +C +C Compute the value (XMAN) from which the characters of the mantissa +C will be generated. +C + GO TO (101,102,103,101,102,104,101,102,105) , NTLT +C + 101 XMAN=SBSE*EXMU + GO TO 106 +C + 102 XMAN=SBSE*SNGL(10.D0**DBLE(EXMU)) + GO TO 106 +C + 103 XMAN=SIGN(1.,SBSE)*SNGL(DBLE(ABS(SBSE))**DBLE(EXMU)) + GO TO 106 +C + 104 XMAN=SBSE + GO TO 106 +C + 105 XMAN=SIGN(1.,SBSE)*SNGL(DBLE(ABS(SBSE))**DBLE(ABS(EXMU))) +C +C If the mantissa-generator is negative, make it positive and put a +C minus sign in the mantissa buffer. +C + 106 IF (XMAN.LT.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='-' + XMAN=-XMAN + END IF +C +C If the number is zero, put a zero in the mantissa buffer and quit. +C + IF (XMAN.EQ.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='0' + RETURN + END IF +C +C Reduce the mantissa-generator to the range (1.,10.), keeping track of +C the power of 10 required to do it. Round the result, keeping in mind +C that the rounding may kick the value past 10. . +C + IMAN=IFIX(ALOG10(XMAN)) + IF (XMAN.LT.1.) IMAN=IMAN-1 + XMAN=XMAN*SNGL(10.D0**(-IMAN))+SMRL + IF (XMAN.GE.10.) THEN + XMAN=XMAN/10. + IMAN=IMAN+1 + END IF +C +C Jump (depending on the number-type/label-type combination) to set up +C the label-generation control parameters, as follows: +C +C NDPD - number of digits to precede decimal point - if NDPD .LT. 0, +C ABS(NDPD) leading zeroes follow the decimal point, preceding +C the first digit generated from XMAN. +C NDFD - number of digits to follow decimal point - if NDFD .LT. 0, +C the decimal point is suppressed. +C IF10 - flag, set non-zero to force generation of the (X 10) portion +C of the label. +C IFEX - flag, set non-zero to force generation of an exponent. +C IVEX - value of exponent (if any) - always equals (IMAN+1) - NDPD. +C + GO TO (107,107,107,108,109,110,111,112,113) , NTLT +C +C Scientific notation. +C + 107 NDPD=NLEX + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SBSE * EXMU. +C + 108 NDPD=IMAN+1-NLEX + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SBSE * 10**EXMU. +C + 109 NDPD=IMAN+1-(NLEX+IFIX(EXMU+SMRL*EXMU)) + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SIGN(SBSE) * ABSV(SBSE)**EXMU. +C + 110 NDPD=IMAN+1 + IMAN=IMAN+IFIX(EXMU+SMRL*EXMU) + NDFD=NLFL + IF10=0 + IFEX=1 + GO TO 115 +C +C No-exponent notation for SBSE * EXMU. +C + 111 NDPD=IMAN+1 + NDFD=NLFL + IF10=0 + IFEX=0 + GO TO 115 +C +C No-exponent notation for SBSE * 10**EXMU. +C + 112 NDPD=IMAN+1 + NDFD=MAX0(NLFL,0)-IFIX(EXMU+SMRL*EXMU) + IF (NDFD.LE.0) NDFD=MIN0(NLFL,0) + IF10=0 + IFEX=0 + GO TO 115 +C +C No-exponent notation for SIGN(SBSE) * ABSV(SBSE)**EXMU +C + 113 IF (EXMU.LT.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='1' + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='/' + END IF +C + NDPD=IMAN+1 + NDFD=NLFL*IFIX(ABS(EXMU+SMRL*EXMU)) + IF (NDFD.EQ.0) NDFD=MIN0(NLFL,0) + IF10=0 + IFEX=0 + GO TO 115 +C +C If there is an exponent of 10 and the mantissa is precisely 1, omit +C the (I.F X) portion of the mantissa. +C + 114 IF (NDPD.NE.1) GO TO 115 + IF (IFIX(XMAN).NE.1) GO TO 115 + IF (((XMAN-1.)*10.**MAX0(0,NDFD)).GE.1.) GO TO 115 + IVEX=IMAN+1-NDPD + GO TO 123 +C +C Generate the characters of the mantissa (I.F). Check first for zero- +C or-negative-length error. +C + 115 LMAN=MAX0(NDPD,0)+1+MAX0(NDFD,-1) + IF (LMAN.LE.0) GO TO 903 +C +C Make sure the mantissa buffer is big enough to hold (I.F). +C + IF (NCIM+LMAN.GT.MCIM) GO TO 901 +C +C Compute the value of the parameter IVEX before changing NDPD. +C + IVEX=IMAN+1-NDPD +C +C Generate the digits preceding the decimal point, if any. +C + IF (NDPD.LE.0) GO TO 117 +C + ASSIGN 116 TO JUMP + GO TO 121 +C + 116 NDPD=NDPD-1 + IF (NDPD.NE.0) GO TO 121 +C +C Generate the decimal point. +C + 117 KHAR='.' + ASSIGN 118 TO JUMP + GO TO 122 +C +C Generate leading zeroes, if any, after the decimal point. +C + 118 IF (NDPD.EQ.0) GO TO 120 + KHAR='0' + ASSIGN 119 TO JUMP + GO TO 122 +C + 119 NDPD=NDPD+1 + IF (NDPD.NE.0) GO TO 122 +C +C Generate remaining fractional digits. +C + 120 ASSIGN 121 TO JUMP +C +C Generate a digit from the mantissa-generator. It is assumed that, for +C n between 1 and 9, ICHAR('n') = ICHAR('n-1') + 1 . +C + 121 IDGT=IFIX(XMAN) + KHAR=CHAR(ICHAR('0')+IDGT) + XMAN=XMAN-FLOAT(IDGT) + XMAN=XMAN*10. +C +C Store a digit from KHAR into the mantissa buffer. +C + 122 NCIM=NCIM+1 + BFRM(NCIM:NCIM)=KHAR +C +C Check whether (I.F) is complete. +C + LMAN=LMAN-1 + IF (LMAN.NE.0) GO TO JUMP , (116,118,119,121) +C +C If appropriate, leave space in the mantissa buffer for the "X" . +C + IF (IF10.EQ.0) GO TO 124 + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + IPXM=NCIM + BFRM(IPXM:IPXM)=' ' +C +C If appropriate, put a "10" in the mantissa buffer. +C + 123 NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='1' + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='0' +C +C If appropriate, generate an exponent in the exponent buffer. +C + 124 IF (IFEX.EQ.0) RETURN +C + IF (IVEX) 126,125,127 +C + 125 NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 + BFRE(NCIE:NCIE)='0' + RETURN +C + 126 NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 + BFRE(NCIE:NCIE)='-' + IVEX=-IVEX +C + 127 NCIE=NCIE+1 + IF (IVEX.GE.10) NCIE=NCIE+1 + IF (IVEX.GE.100) NCIE=NCIE+1 + IF (IVEX.GE.1000) NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 +C + DO 128 I=1,4 + J=NCIE+1-I + BFRE(J:J)=CHAR(ICHAR('0')+MOD(IVEX,10)) + IVEX=IVEX/10 + IF (IVEX.EQ.0) RETURN + 128 CONTINUE +C + IF (IVEX.NE.0) GO TO 902 +C +C Done. +C + RETURN +C +C Error exits. +C + 901 CALL SETER ('AGNUMB - MANTISSA TOO LONG',4,2) +C + 902 CALL SETER ('AGNUMB - EXPONENT TOO LARGE',5,2) +C + 903 CALL SETER ('AGNUMB - ZERO-LENGTH MANTISSA',6,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agppid.f b/sys/gio/ncarutil/autograph/agppid.f new file mode 100644 index 00000000..145d98d3 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agppid.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGPPID (TPID) +C + CHARACTER*(*) TPID +C +C The object of this routine is to print out a parameter identifier +C which has caused some kind of problem. +C +C Define a character variable to hold the print line. +C + CHARACTER*124 TEMP +C +C +NOAO + integer*2 itemp(124) +C -NOAO +C +C Set up the print line. +C + TEMP='0PARAMETER IDENTIFIER - ' +C +C Transfer characters of the parameter identifier, one at a time, until +C 100 have been transferred or a period is encountered, whichever occurs +C first. This is done so as to allow for old programs on the Cray which +C used Hollerith strings as parameter identifiers. +C + I=24 +C + DO 101 J=1,100 + I=I+1 + TEMP(I:I)=TPID(J:J) + IF (TEMP(I:I).EQ.'.') GO TO 102 + 101 CONTINUE +C +C Print the line. +C +C +NOAO - replace FTN write and format statement. +C 102 WRITE (I1MACH(4),1001) TEMP + 102 CONTINUE + call f77upk (temp, itemp, 125) + call pstr (itemp) +C +C Done. +C + RETURN +C +C Format. +C +C1001 FORMAT (A124) +C -NOAO +C + END diff --git a/sys/gio/ncarutil/autograph/agpwrt.f b/sys/gio/ncarutil/autograph/agpwrt.f new file mode 100644 index 00000000..25cc2e52 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agpwrt.f @@ -0,0 +1,31 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGPWRT (XPOS,YPOS,CHRS,NCHS,ISIZ,IORI,ICEN) +C + CHARACTER*(*) CHRS +C +C This routine just passes its arguments along to the character-drawing +C routine PWRIT, in the system plot package. By substituting his/her +C own version of AGPWRT, the user can cause a fancier character-drawer +C to be used. +C + CALL PWRIT (XPOS,YPOS,CHRS,NCHS,ISIZ,IORI,ICEN) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agqurv.f b/sys/gio/ncarutil/autograph/agqurv.f new file mode 100644 index 00000000..dc70fc43 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agqurv.f @@ -0,0 +1,322 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGQURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGQURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C The curve drawn is windowed. Portions of the curve which would fall +C outside the current curve window, as defined by the last SET call, +C are not drawn. +C +C Check first whether the number of curve points is properly specified. +C + IF (NEXY.LE.0) GO TO 901 +C +C Initialization. Pretend that the last point was point number zero. +C Set the indices for the x and y vectors accordingly. Clear the line- +C drawn-to-last-point and last-point-outside-window flags. +C + INDP=0 + INDX=1-IIEX + INDY=1-IIEY + LDLP=0 + LPOW=0 +C +C Initialization. Retrieve the current curve window, user window, and +C x/y linear/logarithmic flags. +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Initialization. Set linear/log flag and linear-window limits for +C x-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.2) THEN + LLUX=0 + XLLW=XLUW + XRLW=XRUW + ELSE + LLUX=1 + XLLW=ALOG10(XLUW) + XRLW=ALOG10(XRUW) + END IF +C +C Initialization. Set linear/log flag and linear-window limits for +C y-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.3) THEN + LLUY=0 + YBLW=YBUW + YTLW=YTUW + ELSE + LLUY=1 + YBLW=ALOG10(YBUW) + YTLW=ALOG10(YTUW) + END IF +C +C Initialization. Call SET, if necessary, to define a linear mapping. +C (This greatly simplifies the windowing code.) +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLLW,XRLW,YBLW,YTLW,1) +C +C Initialization. Compute mimimum and maximum values of x which are +C slightly outside the linear window. (Note: XLLW and XRLW will not +C be used after this.) +C + IF (XLLW.GT.XRLW) THEN + TEMP=XLLW + XLLW=XRLW + XRLW=TEMP + END IF + XEPS=.000001*(XRLW-XLLW) + XMIN=XLLW-XEPS + XMAX=XRLW+XEPS +C +C Initialization. Compute minimum and maximum values of y which are +C slightly outside the linear window. (Note: YBLW and YTLW will not +C be used after this.) +C + IF (YBLW.GT.YTLW) THEN + TEMP=YBLW + YBLW=YTLW + YTLW=TEMP + END IF + YEPS=.000001*(YTLW-YBLW) + YMIN=YBLW-YEPS + YMAX=YTLW+YEPS +C +C Beginning of loop through points. Update indices and determine the +C user-space coordinates of the next point. +C + 101 IF (INDP.EQ.NEXY) GO TO 120 + INDP=INDP+1 +C + INDX=INDX+IIEX + XNXT=XVEC(INDX) + IF (IIEX.EQ.0) XNXT=FLOAT(INDP) + IF (LLUX.NE.0.AND.XNXT.LE.0.) XNXT=SVAL +C + INDY=INDY+IIEY + YNXT=YVEC(INDY) + IF (IIEY.EQ.0) YNXT=FLOAT(INDP) + IF (LLUY.NE.0.AND.YNXT.LE.0.) YNXT=SVAL +C +C Check whether (XNXT,YNXT) is a special-value point. Handle that case. +C + IF (XNXT.EQ.SVAL.OR.YNXT.EQ.SVAL) THEN + LPOW=0 + IF (LDLP.EQ.0) GO TO 101 + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + LDLP=0 + GO TO 101 + END IF +C +C If user space is not linear/linear, modify XNXT and YNXT accordingly. +C + IF (LLUX.NE.0) XNXT=ALOG10(XNXT) + IF (LLUY.NE.0) YNXT=ALOG10(YNXT) +C +C Set the next-point-outside-window flag to a value between -4 and +4, +C inclusive. A non-zero value indicates that the next point is outside +C the window and indicates which of eight possible areas it falls in. +C + NPOW=IFIX(3.*(SIGN(.51,XNXT-XMIN)+SIGN(.51,XNXT-XMAX))+ + + (SIGN(.51,YNXT-YMIN)+SIGN(.51,YNXT-YMAX))) +C +C There are now various possible cases, depending on whether the line- +C drawn-to-last-point flag is set or not, whether the next point is in +C the window or not, and whether the last point was in the window, not +C in the window, or non-existent (point 0 or a special-value point). +C + IF (LDLP.EQ.0) GO TO 102 + IF (NPOW.NE.0) GO TO 103 +C +C Line drawn to last point, next point inside, last point inside. +C + CALL VECTD (XNXT,YNXT) + LDLP=LDLP+1 + GO TO 119 +C + 102 IF (NPOW.NE.0) GO TO 109 + IF (LPOW.NE.0) GO TO 105 +C +C No line drawn to last point, next point inside, no last point. +C + CALL FRSTD (XNXT,YNXT) + LDLP=1 + GO TO 119 +C +C Line drawn to last point, next point outside, last point inside. +C + 103 XPIW=XLST + YPIW=YLST + XPOW=XNXT + YPOW=YNXT + ASSIGN 104 TO JUMP + GO TO 107 + 104 CALL VECTD (XPEW,YPEW) + CALL LASTD + LDLP=0 + GO TO 119 +C +C No line drawn to last point, next point inside, last point outside. +C + 105 XPIW=XNXT + YPIW=YNXT + XPOW=XLST + YPOW=YLST + ASSIGN 106 TO JUMP + GO TO 107 + 106 CALL FRSTD (XPEW,YPEW) + CALL VECTD (XNXT,YNXT) + LDLP=2 + GO TO 119 +C +C The following local procedure, given a point (XPIW,YPIW) inside the +C window and a point (XPOW,YPOW) outside the window, finds the point of +C intersection (XPEW,YPEW) of a line joining them with the window edge. +C + 107 XPEW=XPIW + YPEW=YPIW + XDIF=XPOW-XPIW + YDIF=YPOW-YPIW +C + IF (ABS(XDIF).GT.XEPS) THEN + XPEW=XMIN + IF (XDIF.GE.0.) XPEW=XMAX + YPEW=YPIW+(XPEW-XPIW)*YDIF/XDIF + IF (YPEW.GE.YMIN.AND.YPEW.LE.YMAX) GO TO 108 + END IF +C + IF (ABS(YDIF).GT.YEPS) THEN + YPEW=YMIN + IF (YDIF.GE.0.) YPEW=YMAX + XPEW=XPIW+(YPEW-YPIW)*XDIF/YDIF + END IF +C + 108 GO TO JUMP , (104,106) +C +C No line drawn to last point, next point outside. Jump if no last +C point. +C + 109 IF (LPOW.EQ.0) GO TO 119 +C +C No line drawn to last point, next point outside, last point outside. +C Check whether a portion of the line joining them lies in the window. +C + MPOW=9*LPOW+NPOW+41 +C + GO TO (119,119,119,119,119,110,119,110,110, + + 119,119,119,111,119,110,111,110,110, + + 119,119,119,111,119,119,111,111,119, + + 119,113,113,119,119,110,119,110,110, + + 119,119,119,119,119,119,119,119,119, + + 112,112,119,112,119,119,111,111,119, + + 119,113,113,119,119,113,119,119,119, + + 112,112,113,112,119,113,119,119,119, + + 112,112,119,112,119,119,119,119,119) , MPOW +C + 110 XPE1=XMIN + YPT1=YMIN + XPE2=XMAX + YPT2=YMAX + GO TO 114 +C + 111 XPE1=XMIN + YPT1=YMAX + XPE2=XMAX + YPT2=YMIN + GO TO 114 +C + 112 XPE1=XMAX + YPT1=YMAX + XPE2=XMIN + YPT2=YMIN + GO TO 114 +C + 113 XPE1=XMAX + YPT1=YMIN + XPE2=XMIN + YPT2=YMAX +C + 114 XDIF=XNXT-XLST + YDIF=YNXT-YLST +C + IF (ABS(XDIF).LE.XEPS) GO TO 116 + YPE1=YLST+(XPE1-XLST)*YDIF/XDIF + YPE2=YLST+(XPE2-XLST)*YDIF/XDIF +C + IF (ABS(YDIF).LE.YEPS) GO TO 118 + IF (YPE1.GE.YMIN.AND.YPE1.LE.YMAX) GO TO 115 + YPE1=YPT1 + XPE1=XLST+(YPE1-YLST)*XDIF/YDIF + IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 119 +C + 115 IF (YPE2.GE.YMIN.AND.YPE2.LE.YMAX) GO TO 118 + GO TO 117 +C + 116 YPE1=YPT1 + XPE1=XLST+(YPE1-YLST)*XDIF/YDIF + IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 119 +C + 117 YPE2=YPT2 + XPE2=XLST+(YPE2-YLST)*XDIF/YDIF + IF (XPE2.LT.XMIN.OR.XPE2.GT.XMAX) GO TO 119 +C + 118 CALL FRSTD (XPE1,YPE1) + CALL VECTD (XPE2,YPE2) + CALL LASTD +C +C Processing of next point is done. It becomes the last point and we +C go back for a new next point. +C + 119 LPOW=NPOW + XLST=XNXT + YLST=YNXT + GO TO 101 +C +C Last point was final point. Finish up. +C + 120 IF (LDLP.NE.0) THEN + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + END IF +C +C Restore logarithmic mapping, if appropriate. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Return to caller. +C + RETURN +C +C Error exit. +C + 901 CALL SETER ('AGQURV - NUMBER OF POINTS IS LESS THAN OR EQUAL TO ZE + +RO',7,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agrpch.f b/sys/gio/ncarutil/autograph/agrpch.f new file mode 100644 index 00000000..c37a7ae4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agrpch.f @@ -0,0 +1,86 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGRPCH (CHST,LNCS,IDCS) +C + CHARACTER*(*) CHST +C +C This routine is used to replace a character string previously stored +C by the routine AGSTCH (which see). This could be done by an AGDLCH +C followed by an AGSTCH, and, in fact, under certain conditions, does +C exactly that. Only when it is easy to do so does AGRPCH operate more +C efficiently. Nevertheless, a user who (for example) repeatedly and +C perhaps redundantly defines x-axis labels of the same length may +C greatly benefit thereby; repeated deletes and stores would lead to +C frequent garbage collection by AGSTCH. +C +C AGRPCH has the following arguments: +C +C -- CHST is the new character string, to replace what was originally +C stored. +C +C -- LNCS is the length of the character string in CHST. +C +C -- IDCS is the identifier returned by AGSTCH when the original string +C was stored. The value of IDCS may be changed by the call. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If the identifier is positive or is negative but less than -LNIC, the +C original string was never stored in CHRA; just treat the replacement +C as a store and return a new value of IDCS. +C + IF (IDCS.GT.(-1).OR.IDCS.LT.(-LNIC)) THEN + CALL AGSTCH (CHST,LNCS,IDCS) +C + ELSE +C +C The absolute value of the identifier is the index, in INCH, of the +C descriptor of the character string stored in CHRA. If the new string +C is shorter than the old one, store it and zero remaining character +C positions. Otherwise, treat the replacement as a delete followed by +C a store. +C + I=-IDCS + IF (LNCS.LE.INCH(2,I)) THEN + J=INCH(1,I)-1 + DO 101 K=1,LNCS + J=J+1 + CHRA(J)=CHST(K:K) + 101 CONTINUE + DO 102 K=LNCS+1,INCH(2,I) + J=J+1 + CHRA(J)=CHAR(0) + 102 CONTINUE + INCH(2,I)=LNCS + ELSE + CALL AGDLCH (IDCS) + CALL AGSTCH (CHST,LNCS,IDCS) + END IF +C + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agrstr.f b/sys/gio/ncarutil/autograph/agrstr.f new file mode 100644 index 00000000..72afc643 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agrstr.f @@ -0,0 +1,88 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +NOAO - this subroutine is a no-op in IRAF. +C --------------------------------------------------------------------- +C + SUBROUTINE AGRSTR (IFNO) +C +C This subroutine is called to restore the current state of AUTOGRAPH by +C reading all of its important variables from a record on the file which +C is associated with the unit number IFNO. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C Read the record. +C +C READ (IFNO,ERR=901,END=902) +C 1 BASD,BASE,DBOX,DNLA,FLLB,FLLN,FUNS,HCWP,PING,PINU,QBAC,QBAN,QBIM, +C 2 QBTD,QBTP,QCDP,QCEX,QCEY,QCIE,QCIM,QDAX,QDLB,QDSH,QFRA,QIXY,QJDP, +C 3 QLED,QLEX,QLFD,QLFL,QLLN,QLOF,QLOS,QLTD,QLTP,QLUA,QLUX,QLUY,QMJD, +C 4 QMND,QMNT,QNAN,QNDP,QNIM,QODP,QOVX,QOVY,QROW,QSET,QSPA,QWND,RBOX, +C 5 RFNL,SBOX,SCWP,SOGD,SVAL,TCLN,UBGA,UNDA,WCLE,WCLM,WCWP,WMJL,WMJR, +C 6 WMNL,WMNR,WNLB,WNLE,WNLL,WNLR,WOCD,WODQ,XBGA,XHGH,XLCW,XLGD,XLGF, +C 7 XLGW,XLOW,XLUW,XMAX,XMIN,XNDA,XRCW,XRGD,XRGF,XRGW,XRUW,YBCW,YBGA, +C 8 YBGD,YBGF,YBGW,YBUW,YHGH,YLOW,YMAX,YMIN,YNDA,YTCW,YTGD,YTGF,YTGW, +C 9 YTUW, +C + INIF,ISLD,MDLA,MWCD,MWCE,MWCL,MWCM,MWDQ,SMRL, +C 1 INCA,INCH,LNCA,LNIC, +C 2 CHRA +C +C Done. +C + RETURN +C +C Error exits. +C +C 901 CALL SETER ('AGRSTR - ERROR ON READ',8,2) +C +C 902 CALL SETER ('AGRSTR - END-OF-FILE ON READ',9,2) +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agsave.f b/sys/gio/ncarutil/autograph/agsave.f new file mode 100644 index 00000000..ef0feb7d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsave.f @@ -0,0 +1,93 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +NOAO - This routine is a no-op in IRAF. +C --------------------------------------------------------------------- +C + SUBROUTINE AGSAVE (IFNO) +C +C This subroutine is called to save the current state of AUTOGRAPH by +C writing all of its important variables as a record on the file which +C is associated with the unit number IFNO. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C Write the record. Variables from each COMMON block are together, in +C alphabetical order. +C +C WRITE (IFNO,ERR=901) +C 1 BASD,BASE,DBOX,DNLA,FLLB,FLLN,FUNS,HCWP,PING,PINU,QBAC,QBAN,QBIM, +C 2 QBTD,QBTP,QCDP,QCEX,QCEY,QCIE,QCIM,QDAX,QDLB,QDSH,QFRA,QIXY,QJDP, +C 3 QLED,QLEX,QLFD,QLFL,QLLN,QLOF,QLOS,QLTD,QLTP,QLUA,QLUX,QLUY,QMJD, +C 4 QMND,QMNT,QNAN,QNDP,QNIM,QODP,QOVX,QOVY,QROW,QSET,QSPA,QWND,RBOX, +C 5 RFNL,SBOX,SCWP,SOGD,SVAL,TCLN,UBGA,UNDA,WCLE,WCLM,WCWP,WMJL,WMJR, +C 6 WMNL,WMNR,WNLB,WNLE,WNLL,WNLR,WOCD,WODQ,XBGA,XHGH,XLCW,XLGD,XLGF, +C 7 XLGW,XLOW,XLUW,XMAX,XMIN,XNDA,XRCW,XRGD,XRGF,XRGW,XRUW,YBCW,YBGA, +C 8 YBGD,YBGF,YBGW,YBUW,YHGH,YLOW,YMAX,YMIN,YNDA,YTCW,YTGD,YTGF,YTGW, +C 9 YTUW, +C + INIF,ISLD,MDLA,MWCD,MWCE,MWCL,MWCM,MWDQ,SMRL, +C 1 INCA,INCH,LNCA,LNIC, +C 2 CHRA +C +C Done. +C + RETURN +C +C Error exit. +C +C 901 CALL SETER ('AGSAVE - ERROR ON WRITE',10,2) +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agscan.f b/sys/gio/ncarutil/autograph/agscan.f new file mode 100644 index 00000000..222db6c4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agscan.f @@ -0,0 +1,628 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSCAN (TPID,LOPA,NIPA,IIPA) +C + CHARACTER*(*) TPID +C +C The routine AGSCAN is used by AGGETP and AGSETP to scan a parameter +C identifier and return a description of the parameter-list items which +C are specified by that parameter identifier. It has the following +C arguments: +C +C -- TPID is the parameter identifier. +C +C -- LOPA is the index of the first parameter-list item specified. +C +C -- NIPA is the number of parameter-list items specified. +C +C -- IIPA is the index increment between one of the parameter-list items +C specified and the next (meaningless if NIPA=1). +C +C +C BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE +C +C Originally, this routine used the function "LOC" to return, in LOPA, +C the base address, in core, of the specified parameter group. To some +C degree, it was thereby insulated from changes in the labelled common +C block AGCONP. With the demise of "LOC", LOPA has been re-defined and +C that insulation no longer exists. In the following code, there are +C integers which represent the indices of desired quantities in common. +C +C BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE +C +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C Declare the block data routine EXTERNAL to force loading of it. +C +C +NOAO - call agdflt as run time initialization +C +C EXTERNAL AGDFLT + call agdflt +C -NOAO +C +C Initialize the parameter-identifier character index. +C + IPID=0 +C +C Initialize the value of the index increment to be returned. +C + IIPA=1 +C +C Find the first keyword in the parameter identifier. +C + CALL AGSRCH (TPID,IPID,IKWL,'PRIMFRAMSET ROW INVEWINDNULLGRAPGRIDX + + Y AXISLEFTRIGHBOTTTOP DASHLABELINESECOBACK') +C + GO TO (101,102,103,104,105,106,107,108,109,110, + + 111,113,114,114,114,114,132,133,147,155,166,901) , IKWL +C +C PRIMARY CONTROL PARAMETERS. +C + 101 LOPA=1 + NIPA=336 + GO TO 203 +C +C FRAME PARAMETER. +C + 102 LOPA=1 + GO TO 202 +C +C SET PARAMETER. +C + 103 LOPA=2 + GO TO 202 +C +C ROW PARAMETER. +C + 104 LOPA=3 + GO TO 202 +C +C X/Y INVERSION PARAMETER. +C + 105 LOPA=4 + GO TO 202 +C +C WINDOWING PARAMETER. +C + 106 LOPA=5 + GO TO 202 +C +C BACKGROUND PARAMETER. +C + 166 LOPA=6 + GO TO 202 +C +C NULL PARAMETER(S). +C + 107 LOPA=7 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'1 2 ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C PLOT (GRAPH) WINDOW PARAMETERS. +C + 108 LOPA=9 + NIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 + GO TO 201 +C +C GRID WINDOW PARAMETERS. +C + 109 LOPA=13 + NIPA=5 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP SHAP') +C + IF (IKWL.EQ.6) GO TO 901 + GO TO 201 +C +C X DATA PARAMETERS. +C + 110 LOPA=18 + GO TO 112 +C +C Y DATA PARAMETERS. +C + 111 LOPA=25 +C +C X OR Y DATA PARAMETERS. +C + 112 NIPA=7 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MINIMAXILOGAORDENICESMALLARG') +C + IF (IKWL.EQ.8) GO TO 901 + GO TO 201 +C +C AXIS PARAMETERS. +C + 113 LOPA=32 + NIPA=92 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 + IKWL=IKWL+12 +C +C LEFT, RIGHT, BOTTOM, OR TOP AXIS PARAMETERS. +C + 114 LOPA=19+IKWL + NIPA=23 + IIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'CONTLINEINTEFUNCTICKMAJOMINONUMETYPEEXPOFRACANGLOFFSWIDT') +C + GO TO (202,201,115,167,116,117,123,126,127,127,127, + + 127,127,127,901) , IKWL +C +C AXIS INTERSECTION PARAMETERS. +C + 115 LOPA=LOPA+8 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'GRIDUSER') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C AXIS MAPPING FUNCTION. +C + 167 LOPA=LOPA+16 + GO TO 202 +C +C AXIS TICK PARAMETERS. +C + 116 LOPA=LOPA+20 + NIPA=10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MAJOMINO') +C + LOPA=LOPA-20 + GO TO (117,123,901) , IKWL +C +C AXIS MAJOR-TICK PARAMETERS. +C + 117 LOPA=LOPA+20 + NIPA=6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'SPACTYPEBASECOUNPATTLENGOUTWINWA') +C + GO TO (118,119,119,119,120,121,122,122,901) , IKWL +C +C AXIS MAJOR-TICK SPACING PARAMETERS. +C + 118 NIPA=3 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'TYPEBASECOUN') +C + IF (IKWL.EQ.4) GO TO 901 +C + GO TO 201 +C + 119 IKWL=IKWL-1 + GO TO 201 +C +C AXIS MAJOR-TICK DASH PATTERN. +C + 120 LOPA=LOPA+12 + GO TO 202 +C +C AXIS MAJOR-TICK LENGTH PARAMETERS. +C + 121 LOPA=LOPA+16 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'OUTWINWA') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C + 122 LOPA=LOPA+16 + IKWL=IKWL-6 + GO TO 201 +C +C AXIS MINOR-TICK PARAMETERS. +C + 123 LOPA=LOPA+44 + NIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'SPACPATTLENGOUTWINWA') +C + GO TO (202,201,124,125,125,901) , IKWL +C +C AXIS MINOR-TICK LENGTH PARAMETERS. +C + 124 LOPA=LOPA+8 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'OUTWINWA') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C + 125 LOPA=LOPA+8 + IKWL=IKWL-3 + GO TO 201 +C +C AXIS NUMERIC-LABEL PARAMETERS. +C + 126 LOPA=LOPA+60 + NIPA=8 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'TYPEEXPOFRACANGLOFFSWIDT') +C + GO TO 128 +C + 127 LOPA=LOPA+60 + IKWL=IKWL-8 +C + 128 GO TO (202,201,201,129,130,131,901) ,IKWL +C +C AXIS NUMERIC-LABEL ORIENTATION ANGLE. +C + 129 LOPA=LOPA+12 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'1ST 2ND ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C AXIS NUMERIC-LABEL OFFSET. +C + 130 LOPA=LOPA+20 + GO TO 202 +C +C AXIS NUMERIC-LABEL WIDTH PARAMETERS. +C + 131 LOPA=LOPA+24 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MANTEXPO') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C DASH-PATTERN PARAMETERS. +C + 132 LOPA=124 + NIPA=30 + IF (TPID(IPID:IPID).EQ.'.') RETURN + JPID=IPID + CALL AGSRCH (TPID,IPID,IKWL,'SELELENGCHARDOLLPATT') + IF (IKWL.EQ.6) THEN + IPID=JPID + GO TO 168 + END IF + IF (IKWL.NE.5) GO TO 201 + 168 LOPA=LOPA+4 + NIPA=26 + IF (TPID(IPID:IPID).EQ.'.') RETURN + CALL AGSRCH (TPID,IPID,IKWL, + +'1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 1 + +7 18 19 20 21 22 23 24 25 26 ') + IF (IKWL.EQ.27) GO TO 901 + GO TO 201 +C +C LABEL PARAMETERS. +C + 133 LBIM=IFIX(QBIM) + LBAN=IFIX(QBAN) +C + LOPA=154 + NIPA=3+LBIM*10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'CONTBUFFNAMEDEFISUPPBASEOFFSANGLCENTLINEINDE') +C + GO TO (202,136,139,140,141,141,141,141,141,141,141,901) , IKWL +C +C LABEL BUFFER PARAMETERS. +C + 136 LOPA=155 + NIPA=1+LBIM*10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LENGCONTNAME') +C + GO TO (202,137,138,901) , IKWL +C +C LABEL BUFFER CONTENTS. +C + 137 LOPA=156 + NIPA=LBIM*10 + GO TO 203 +C +C LABEL BUFFER NAMES. +C + 138 LOPA=156 + NIPA=LBIM + IIPA=10 + GO TO 203 +C +C LABEL NAME. +C + 139 LOPA=236 + GO TO 202 +C +C LABEL DEFINITION. +C + 140 IF (LBAN.LT.1.OR.LBAN.GT.LBIM) GO TO 902 +C + LOPA=157+(LBAN-1)*10 + NIPA=9 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'SUPPBASEOFFSANGLCENTLINEINDE') +C + GO TO 142 +C + 141 IF (LBAN.LT.1.OR.LBAN.GT.LBIM) GO TO 902 +C + LOPA=157+(LBAN-1)*10 + IKWL=IKWL-4 +C + 142 GO TO (202,143,144,146,146,146,146,901) , IKWL +C +C LABEL POSITION. +C + 143 LOPA=LOPA+1 + GO TO 145 +C +C LABEL OFFSET. +C + 144 LOPA=LOPA+3 +C +C LABEL POSITION OR OFFSET. +C + 145 NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'X Y ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C OTHER LABEL ATTRIBUTES. +C + 146 LOPA=LOPA+5 + IKWL=IKWL-3 + GO TO 201 +C +C LINE PARAMETERS. +C + 147 LNIM=IFIX(QNIM) + LNAN=IFIX(QNAN) +C + LOPA=237 + NIPA=4+LNIM*6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'MAXIEND BUFFNUMBDEFISUPPCHARTEXTLENGINDE') +C + GO TO (202,201,150,152,153,154,154,154,154,154,901) , IKWL +C +C LINE BUFFER PARAMETERS. +C + 150 LOPA=239 + NIPA=1+LNIM*6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LENGCONT') +C + GO TO (202,151,901) , IKWL +C +C LINE BUFFER CONTENTS. +C + 151 LOPA=240 + NIPA=LNIM*6 + GO TO 203 +C +C LINE NUMBER. +C + 152 LOPA=336 + GO TO 202 +C +C LINE DEFINITION. +C + 153 IF (LNAN.LT.1.OR.LNAN.GT.LNIM) GO TO 903 +C + LOPA=241+(LNAN-1)*6 + NIPA=5 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'SUPPCHARTEXTLENGINDE') +C + IF (IKWL.EQ.6) GO TO 901 + GO TO 201 +C + 154 IF (LNAN.LT.1.OR.LNAN.GT.LNIM) GO TO 903 + LOPA=241+(LNAN-1)*6 + IKWL=IKWL-5 + GO TO 201 +C +C SECONDARY CONTROL PARAMETERS. +C + 155 LOPA=337 + NIPA=149 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'GRAPUSERCURVDIMEAXISLEFTRIGHBOTTTOP LABE') +C + GO TO (156,157,158,159,160,161,161,161,161,165,901) , IKWL +C +C PLOT (GRAPH) WINDOW EDGES. +C + 156 LOPA=337 + NIPA=4 + GO TO 203 +C +C USER WINDOW PARAMETERS. +C + 157 LOPA=341 + NIPA=4 + GO TO 203 +C +C CURVE WINDOW PARAMETERS. +C + 158 LOPA=345 + NIPA=4 + GO TO 203 +C +C CURVE WINDOW DIMENSIONS. +C + 159 LOPA=349 + NIPA=3 + GO TO 203 +C +C AXIS PARAMETERS. +C + 160 LOPA=352 + NIPA=80 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 +C + IKWL=IKWL+5 +C +C LEFT, RIGHT, BOTTOM, OR TOP AXIS PARAMETERS. +C + 161 LOPA=346+IKWL + NIPA=20 + IIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'POSITICKNUME') +C + GO TO (162,163,164,901) , IKWL +C +C AXIS POSITIONING PARAMETERS. +C + 162 NIPA=6 + GO TO 203 +C +C AXIS TICK PARAMETERS. +C + 163 LOPA=LOPA+24 + NIPA=3 + GO TO 203 +C +C AXIS NUMERIC-LABEL PARAMETERS. +C + 164 LOPA=LOPA+36 + NIPA=11 + GO TO 203 +C +C LABEL BOXES. +C + 165 LOPA=432 + NIPA=54 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP CENTGRAP') +C + IF (IKWL.EQ.7) GO TO 901 +C + LOPA=LOPA+IKWL-1 + NIPA=9 + IIPA=6 + GO TO 203 +C +C Normal exits. +C + 201 LOPA=LOPA+(IKWL-1)*IIPA +C + 202 NIPA=1 +C + 203 IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGPPID (TPID) +C +NOAO - following FTN write and fmt statements commented out, SETER is okay. +C +C WRITE (I1MACH(4),1001) + RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ILLEGAL KEYWORD USED IN PARAMETER + +IDENTIFIER',11,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ATTEMPT TO ACCESS LABEL ATTRIBUTES + + BEFORE SETTING LABEL NAME',12,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ATTEMPT TO ACCESS LINE ATTRIBUTES + +BEFORE SETTING LINE NUMBER',13,2) +C +C Formats. +C +C1001 FORMAT (' WARNING - ABOVE PARAMETER IDENTIFIER HAS TOO MANY KEYWOR +C +DS') +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agsetc.f b/sys/gio/ncarutil/autograph/agsetc.f new file mode 100644 index 00000000..bced8458 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetc.f @@ -0,0 +1,100 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETC (TPID,CUSR) +C + CHARACTER*(*) TPID,CUSR +C + DIMENSION FURA(1) +C +C The routine AGSETC is used to set the values of individual AUTOGRAPH +C parameters which intrinsically represent character strings. TPID is a +C parameter identifier. CUSR is a character string. The situation is +C complicated by the fact that the character string may be either a dash +C pattern, the name of a label, the line-end character, or the text of a +C line, all of which are treated differently. +C +C Define a local variable to hold the "line-end" character. +C + CHARACTER*1 LEND +C +C See what kind of parameter is being set. +C + CALL AGCTCS (TPID,ITCS) +C +C If the parameter is not intrinsically of type character, log an error. +C + IF (ITCS.EQ.0) GO TO 901 +C +C Find the length of the string, which may or may not actually be used. +C (On the Cray, at least, it may be zero if the wrong type of argument +C was used.) +C + ILEN=LEN(CUSR) +C +C Retrieve the current (integer) value of the parameter. +C + CALL AGGETI (TPID,ITMP) +C +C Check for a dash pattern. +C + IF (ITCS.EQ.1) THEN + CALL AGGETI ('DASH/LENG.',NCHR) + IF (ILEN.GT.0.AND.ILEN.LT.NCHR) NCHR=ILEN + CALL AGRPCH (CUSR,NCHR,ITMP) +C +C Check for a label name. +C + ELSE IF (ITCS.EQ.2) THEN + CALL AGRPCH (CUSR,MAX0(1,ILEN),ITMP) +C +C Check for the line-end character. +C + ELSE IF (ITCS.EQ.3) THEN + CALL AGRPCH (CUSR,1,ITMP) +C +C Check for the text of a label. +C + ELSE IF (ITCS.EQ.4) THEN + CALL AGGETI ('LINE/MAXI.',NCHR) + IF (ILEN.GT.0) NCHR=MIN0(NCHR,ILEN) + CALL AGGETC ('LINE/END .',LEND) + DO 101 I=1,NCHR + IF (CUSR(I:I).EQ.LEND) THEN + NCHR=I-1 + GO TO 102 + END IF + 101 CONTINUE +C + 102 CALL AGRPCH (CUSR,NCHR,ITMP) +C + END IF +C +C Transfer the generated value to the list of AUTOGRAPH parameters. +C + FURA(1)=FLOAT(ITMP) + CALL AGSETP (TPID,FURA,1) +C +C Done. +C + RETURN +C +C Error exit. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETC - PARAMETER TO SET IS NOT INTRINSICALLY OF TYP + +E CHARACTER',14,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agsetf.f b/sys/gio/ncarutil/autograph/agsetf.f new file mode 100644 index 00000000..36fca46e --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetf.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETF (TPID,FUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGSETF may be used to set the real (floating-point) value +C of any single AUTOGRAPH control parameter. +C + FURA(1)=FUSR + CALL AGSETP (TPID,FURA,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agseti.f b/sys/gio/ncarutil/autograph/agseti.f new file mode 100644 index 00000000..06e3b3f1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agseti.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETI (TPID,IUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGSETI may be used to set the integer-equivalent value of +C any single AUTOGRAPH control parameter. +C + FURA(1)=FLOAT(IUSR) + CALL AGSETP (TPID,FURA,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agsetp.f b/sys/gio/ncarutil/autograph/agsetp.f new file mode 100644 index 00000000..95e98a6d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetp.f @@ -0,0 +1,447 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(LURA) +C +C The routine AGSETP stores user-provided values of the AUTOGRAPH +C parameters specified by the parameter identifier TPID. The arguments +C are as follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array from which parameter values are to be taken. +C +C -- LURA is the length of the user array. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C Define the array DUMI, which allows access to the control-parameter +C list as an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C +NOAO - Make sure common has been initialized. +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters affected. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of values to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C If character-string dash patterns are being replaced by integer dash +C patterns, reclaim the space used in the character-storage arrays. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.LE.LODP+NIDP-1.AND.LOPA+NURA-1.GE.LODP) THEN + MINI=MAX0(LOPA,LODP)-LOPA+1 + MAXI=MIN0(LOPA+NURA-1,LODP+NIDP-1)-LOPA+1 + DO 100 I=MINI,MAXI + IF (FURA(I).GT.0.) CALL AGDLCH (IFIX(DUMI(LOPA+I-1))) + 100 CONTINUE + END IF +C +C Save the current values of special values 1 and 2. +C + SVL1=SVAL(1) + SVL2=SVAL(2) +C +C Transfer the user-provided values to the parameter list. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + DUMI(IDMI)=FURA(IURA) + 101 CONTINUE +C +C If a specific item was changed, we may have a bit more work to do; +C otherwise, return to the user. +C + IF (NIPA.NE.1) RETURN +C +C If the specific item was special value 1 or 2, scan the primary list +C of parameters for other occurrences of the special value and change +C them to the new value. +C + IF (SVAL(1).NE.SVL1) THEN + SVLO=SVL1 + SVLN=SVAL(1) + GO TO 102 + END IF +C + IF (SVAL(2).NE.SVL2) THEN + SVLO=SVL2 + SVLN=SVAL(2) + GO TO 102 + END IF +C + GO TO 104 +C + 102 CALL AGSCAN ('PRIM.',LOPR,NIPR,IIPR) +C + IDMI=LOPR-IIPR +C + DO 103 I=1,NIPR + IDMI=IDMI+IIPR + IF (DUMI(IDMI).EQ.SVLO) DUMI(IDMI)=SVLN + 103 CONTINUE +C + RETURN +C +C If the specific item was the label control flag and it was set +C negative, delete all labels and lines. +C + 104 CALL AGSCAN ('LABE/CONT.',LOLC,NILC,IILC) + IF (LOPA.NE.LOLC) GO TO 107 + IF (QDLB.GE.0.) RETURN +C + QBAN=0. + QNAN=0. +C + LBIM=IFIX(QBIM) +C + DO 105 I=1,LBIM + IF (FLLB(1,I).NE.0.) THEN + CALL AGDLCH (IFIX(FLLB(1,I))) + FLLB(1,I)=0. + END IF + 105 CONTINUE +C + LNIM=IFIX(QNIM) +C + DO 106 I=1,LNIM + IF (FLLN(1,I).NE.SVAL(1)) THEN + CALL AGDLCH (IFIX(FLLN(4,I))) + FLLN(1,I)=SVAL(1) + END IF + 106 CONTINUE +C + RETURN +C +C If the specific item was the label name, reset it to an appropriate +C index in the label list, providing initial values if appropriate. +C + 107 CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 109 +C + LBAN=0 + LBIM=IFIX(QBIM) + QNAN=0. +C + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) +C + DO 108 I=1,LBIM + IF (LBAN.EQ.0.AND.FLLB(1,I).EQ.0.) LBAN=I + CALL AGGTCH (IFIX(FLLB(1,I)),CHS2,LCS2) + IF (LCS1.NE.LCS2) GO TO 108 + IF (CHS1(1:LCS1).NE.CHS2(1:LCS2)) GO TO 108 + QBAN=FLOAT(I) + RETURN + 108 CONTINUE +C + IF (LBAN.EQ.0) GO TO 901 +C + QBAN=FLOAT(LBAN) +C + FLLB( 1,LBAN)=FURA(1) + FLLB( 2,LBAN)=0. + FLLB( 3,LBAN)=.5 + FLLB( 4,LBAN)=.5 + FLLB( 5,LBAN)=0. + FLLB( 6,LBAN)=0. + FLLB( 7,LBAN)=0. + FLLB( 8,LBAN)=0. + FLLB( 9,LBAN)=0. + FLLB(10,LBAN)=0. +C + RETURN +C +C If the label access name is not set, skip. +C + 109 IF (QBAN.LE.0.) GO TO 122 +C + LBAN=IFIX(QBAN) + LBIM=IFIX(QBIM) + LNAN=IFIX(QNAN) + LNIM=IFIX(QNIM) +C +C If the specific item was the suppression flag for the current label +C and it was set negative, delete the label and/or its lines. +C + CALL AGSCAN ('LABE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 111 + IF (FLLB(2,LBAN).GE.0.) RETURN +C + ITMP=IFIX(FLLB(2,LBAN)) + FLLB(2,LBAN)=0. + FLLB(9,LBAN)=0. + LNIN=IFIX(FLLB(10,LBAN)) + FLLB(10,LBAN)=0. + QNAN=0. + IF (ITMP.EQ.(-1)) GO TO 110 + CALL AGDLCH (IFIX(FLLB(1,LBAN))) + FLLB(1,LBAN)=0. + QBAN=0. +C + 110 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + FLLN(1,LNIN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNIN))) + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 110 +C +C If the specific item was the line number, reset it to an appropriate +C index in the line list, providing initial values if appropriate. +C + 111 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 118 +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 112 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) GO TO 115 + IF (LNAN-IFIX(FLLN(1,LNIN))) 113,114,115 +C + 113 LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 112 +C + 114 QNAN=FLOAT(LNIN) + RETURN +C + 115 DO 116 I=1,LNIM + LNIT=I + IF (FLLN(1,I).EQ.SVAL(1)) GO TO 117 + 116 CONTINUE +C + GO TO 903 +C + 117 CALL AGSTCH (' ',1,ITMP) +C + FLLN(1,LNIT)=FLOAT(LNAN) + FLLN(2,LNIT)=0. + FLLN(3,LNIT)=.015 + FLLN(4,LNIT)=ITMP + FLLN(5,LNIT)=1. + FLLN(6,LNIT)=FLOAT(LNIN) +C + LNAN=LNIT + IF (LNIL.EQ.0) FLLB(10,LBAN)=FLOAT(LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLOAT(LNAN) +C + FLLB(9,LBAN)=FLLB(9,LBAN)+1. +C + QNAN=FLOAT(LNAN) + RETURN +C +C If the line access number is not set, skip. +C + 118 IF (LNAN.LE.0) GO TO 122 +C +C If the specific item was the suppression flag for the current line and +C it was set negative, delete the line. +C + CALL AGSCAN ('LINE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 121 + IF (FLLN(2,LNAN).GE.0.) RETURN +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 119 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + IF (LNAN.EQ.LNIN) GO TO 120 + LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 119 +C + 120 IF (LNIL.EQ.0) FLLB(10,LBAN)=FLLN(6,LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLLN(6,LNAN) + FLLN(1,LNAN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNAN))) + QNAN=0. + RETURN +C +C If the specific item was the text of a line, set the length of the +C line, as well. +C + 121 CALL AGSCAN ('LINE/TEXT.',LOLT,NILT,IILT) + IF (LOPA.NE.LOLT) GO TO 123 + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) + FLLN(5,LNAN)=FLOAT(LCS1) + RETURN +C +C See if the user is trying to get at a line of a non-existent label. +C + 122 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) GO TO 902 +C +C If the specific item was the background parameter, set up the back- +C ground requested by the user. +C + 123 CALL AGSCAN ('BACK.',LOBG,NIBG,IIBG) + IF (LOPA.NE.LOBG) GO TO 130 +C + QBAC=AMAX1(1.,AMIN1(4.,QBAC)) + IBAC=IFIX(QBAC) + GO TO (124,125,126,127) , IBAC +C +C Perimeter background. +C + 124 QLBC=4. + QRTC=4. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C Grid background. +C + 125 QLBC=4. + QRTC=-1. + WMJI=1. + WMNI=1. + GO TO 128 +C +C Half-axis background. +C + 126 QLBC=4. + QRTC=0. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C No background. +C + 127 QLBC=0. + QRTC=0. + WMJI=.015 + WMNI=.010 +C + 128 QDAX(1)=QLBC + QDAX(2)=QRTC + QDAX(3)=QLBC + QDAX(4)=QRTC +C + DO 129 I=1,4 + WMJR(I)=WMJI + WMNR(I)=WMNI + 129 CONTINUE +C + QDLB=FLOAT(2-2*(IBAC/4)) + RETURN +C +C If the specific item was the get-limits-from-last-SET-call parameter, +C do what is necessary. +C + 130 CALL AGSCAN ('SET .',LOSE,NISE,IISE) + IF (LOPA.NE.LOSE) GO TO 131 +C + QSET=SIGN(AMAX1(1.,AMIN1(4.,ABS(QSET))),QSET) +C + XLGD=.15 + XRGD=.95 + YBGD=.15 + YTGD=.95 + SOGD=0. +C + XMIN=SVAL(1) + XMAX=SVAL(1) + QLUX=AMIN1(QLUX,0.) + QOVX=0. + QCEX=-1. + XLOW=SVAL(1) + XHGH=SVAL(1) +C + YMIN=SVAL(1) + YMAX=SVAL(1) + QLUY=AMIN1(QLUY,0.) + QOVY=0. + QCEY=-1. + YLOW=SVAL(1) + YHGH=SVAL(1) +C + RETURN +C +C Return to caller. +C + 131 RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LABEL LIST OVERFLOW - SEE AUTOGRAPH SPECIALI + +ST',15,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGSETP - ATTEMPT TO DEFINE LINE OF NON-EXISTENT LABEL + +',16,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LINE LIST OVERFLOW - SEE AUTOGRAPH SPECIALIS + +T',17,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agsrch.f b/sys/gio/ncarutil/autograph/agsrch.f new file mode 100644 index 00000000..366c46cc --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsrch.f @@ -0,0 +1,96 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSRCH (TPID,IPID,IKWL,TKWL) +C + CHARACTER*(*) TPID,TKWL +C +C The routine AGSRCH is used by AGSCAN to search a parameter identifier +C for the next keyword and return the index of that keyword in a list of +C keywords. It has the following arguments. +C +C -- TPID is the parameter identifier, a character string. +C +C -- IPID is the index of the last character examined in TPID. It is +C updated by AGSRCH to point to the first slash or period following +C the next keyword. +C +C -- IKWL is returned containing the index (in the keyword list) of the +C next keyword in the parameter identifier (list length, plus one, +C if the keyword is not found in the list). +C +C -- TKWL is the keyword list - 4*LKWL characters in all. +C +C ICHR is used to hold up to four characters of a keyword. +C + CHARACTER*4 ICHR +C +C LPID is the assumed maximum length of a parameter identifier. +C + DATA LPID / 100 / +C +C Compute the number of 4-character keywords in the keyword list. +C + LKWL=LEN(TKWL)/4 +C +C Find the next non-blank in the parameter identifier. +C + 101 IPID=IPID+1 + IF (IPID.GT.LPID) GO TO 107 + IF (TPID(IPID:IPID).EQ.' ') GO TO 101 +C +C Pick up at most four characters of the keyword, stopping on the first +C blank, slash, or period encountered. +C + NCHR=0 +C + 102 IF (TPID(IPID:IPID).EQ.' '.OR. + + TPID(IPID:IPID).EQ.'/'.OR. + + TPID(IPID:IPID).EQ.'.') GO TO 103 +C + NCHR=NCHR+1 + ICHR(NCHR:NCHR)=TPID(IPID:IPID) +C + IPID=IPID+1 +C + IF (NCHR.LT.4) GO TO 102 +C +C If the keyword found has zero length, error. +C + 103 IF (NCHR.EQ.0) GO TO 107 +C +C Scan ahead for the next slash or period. +C + 104 IF (TPID(IPID:IPID).EQ.'/'.OR.TPID(IPID:IPID).EQ.'.') GO TO 105 +C + IPID=IPID+1 + IF (IPID.GT.LPID) GO TO 107 + GO TO 104 +C +C Search the keyword list for the keyword found. +C + 105 DO 106 I=1,LKWL + IKWL=I + ISTR=(I-1)*4+1 + IEND=(I-1)*4+NCHR + IF (ICHR(1:NCHR).EQ.TKWL(ISTR:IEND)) RETURN + 106 CONTINUE +C +C Keyword not found - set IKWL to impossible value and return. +C + 107 IKWL=LKWL+1 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agstch.f b/sys/gio/ncarutil/autograph/agstch.f new file mode 100644 index 00000000..2b2906bd --- /dev/null +++ b/sys/gio/ncarutil/autograph/agstch.f @@ -0,0 +1,124 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSTCH (CHST,LNCS,IDCS) +C + CHARACTER*(*) CHST +C +C This routine stores strings of characters for later retrieval and/or +C modification by the routines AGGTCH, AGRPCH, and AGDLCH. It has the +C following arguments: +C +C -- CHST is the character string to be stored. +C +C -- LNCS is the length of the character string in CHST. LNCS must be +C less than or equal to the value of the FORTRAN function LEN(CHST). +C +C -- IDCS is an identifying integer, returned to the caller by AGSTCH +C for later use in calls to AGGTCH, AGRPCH, and AGDLCH. If CHST is +C more than one character long, it is stashed in the array CHRA, and +C the value returned in IDCS is a negative number between -LNIC and +C -1, inclusive, the absolute value of which is the index of an entry +C in the array INCH describing where in the array CHRA the string was +C stored. If CHST is only one character long, IDCS is returned as +C the value of the FORTRAN expression -(LNIC+1+ICHAR(CHST(1:1))). +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If the string is short enough, just embed it in a negative integer +C and return that value to the caller as the identifier of the string. +C + IF (LNCS.LE.1) THEN + IDCS=-(LNIC+1+ICHAR(CHST(1:1))) + RETURN + END IF +C +C Otherwise, the string must be stashed in CHRA and the negative of the +C index, in INCH, of its descriptor returned to the caller. Loop, on I, +C through the index of character strings. +C + DO 104 I=1,LNIC +C +C If the next entry in the index is zeroed, use it for the new string. +C + IF (INCH(1,I).EQ.0) THEN +C +C Zeroed entry found. Return the negative of its index to the user. +C + IDCS=-I +C +C If there isn't enough room for the character string at the end of the +C character-storage array, do some garbage-collecting, eliminating all +C strings of all-zero characters. +C + IF (LNCS.GT.LNCA-INCA) THEN + J=0 + K=0 + DO 102 L=1,INCA + IF (CHRA(L).EQ.CHAR(0)) THEN + IF (J.EQ.0) J=L + ELSE + IF (J.NE.0) THEN + DO 101 M=1,LNIC + IF (INCH(1,M).GT.K) INCH(1,M)=INCH(1,M)+J-L + 101 CONTINUE + J=0 + END IF + K=K+1 + CHRA(K)=CHRA(L) + END IF + 102 CONTINUE + INCA=K + END IF +C +C If there still isn't enough room for the character string at the end +C of the character-storage array, take an error exit. Otherwise, stash +C it and return. All-zero characters are changed to blanks. +C + IF (LNCS.GT.LNCA-INCA) GO TO 901 + INCH(1,I)=INCA+1 + INCH(2,I)=LNCS + DO 103 J=1,LNCS + INCA=INCA+1 + CHRA(INCA)=CHST(J:J) + IF (ICHAR(CHRA(INCA)).EQ.0) CHRA(INCA)=' ' + 103 CONTINUE + RETURN +C + END IF +C + 104 CONTINUE +C +C If no zeroed entry was found in the index of character strings, jump +C to log an error and quit. +C + GO TO 902 +C +C Error exits. +C + 901 CALL SETER ('AGSTCH - CHARACTER-STRING BUFFER OVERFLOW - SEE CONSU + +LTANT',18,2) +C + 902 CALL SETER ('AGSTCH - CHARACTER-STRING INDEX OVERFLOW - SEE CONSUL + +TANT',19,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agstup.f b/sys/gio/ncarutil/autograph/agstup.f new file mode 100644 index 00000000..41a97674 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agstup.f @@ -0,0 +1,543 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX, + + YDRA,NVIY,IIVY,NEVY,IIEY) +C + DIMENSION XDRA(1),YDRA(1) +C +C The routine AGSTUP is called to examine the parameter list, to provide +C default values for missing parameters, and to check for and cope with +C label overlap problems. +C +C The arguments describe the x and y data arrays to be used for the next +C graph. See the routine AGEXUS for a description of them. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Declare the block data routine external to force it to load. +C +C EXTERNAL AGDFLT +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','AGSTUP','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO - Block data replaced with run time initialization +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C Compute the width and height of the plotter frame. +C + CALL GETSI (IWFP,IHFP) + WOFP=2.**IWFP-1. + HOFP=2.**IHFP-1. +C +C Examine the get-limits-from-last-set-call parameter. +C + IF (ABS(QSET).EQ.1.) GO TO 141 +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XMNT,XMXT,YMNT,YMXT,LILO) +C + QLUX=FLOAT((1-LILO)/2) + QLUY=FLOAT(MOD(1-LILO,2)) +C + IF (ABS(QSET).EQ.3.) GO TO 140 +C + XLGD=(XLCW-XLGF)/(XRGF-XLGF) + XRGD=(XRCW-XLGF)/(XRGF-XLGF) + YBGD=(YBCW-YBGF)/(YTGF-YBGF) + YTGD=(YTCW-YBGF)/(YTGF-YBGF) + SOGD=0. +C + IF (ABS(QSET).EQ.2.) GO TO 141 +C + 140 XMIN=AMIN1(XMNT,XMXT) + XMAX=AMAX1(XMNT,XMXT) + QOVX=0. + IF (XMNT.GT.XMXT) QOVX=1. + QCEX=0. +C + YMIN=AMIN1(YMNT,YMXT) + YMAX=AMAX1(YMNT,YMXT) + QOVY=0. + IF (YMNT.GT.YMXT) QOVY=1. + QCEY=0. +C + 141 CONTINUE +C +C Examine the graph-window parameters. +C + XLGF=AMAX1(0.,AMIN1(1.,XLGF)) + XRGF=AMAX1(0.,AMIN1(1.,XRGF)) + YBGF=AMAX1(0.,AMIN1(1.,YBGF)) + YTGF=AMAX1(0.,AMIN1(1.,YTGF)) +C + IF (XLGF.GE.XRGF.OR.YBGF.GE.YTGF) GO TO 901 +C +C Examine the grid-window parameters. +C + XLGD=AMAX1(0.,AMIN1(1.,XLGD)) + XRGD=AMAX1(0.,AMIN1(1.,XRGD)) + YBGD=AMAX1(0.,AMIN1(1.,YBGD)) + YTGD=AMAX1(0.,AMIN1(1.,YTGD)) +C + IF (XLGD.GE.XRGD.OR.YBGD.GE.YTGD) GO TO 902 +C +C Examine the user-window minima and maxima for special values. Compute +C tentative values of the user-window edge parameters. +C + QIXY=AMAX1(0.,AMIN1(1.,QIXY)) +C + IF (QIXY.NE.0.) GO TO 142 +C + CALL AGEXUS (SVAL,XMIN,XMAX,XLOW,XHGH, + + XDRA,NVIX,IIVX,NEVX,IIEX,XLUW,XRUW) + CALL AGEXUS (SVAL,YMIN,YMAX,YLOW,YHGH, + + YDRA,NVIY,IIVY,NEVY,IIEY,YBUW,YTUW) + GO TO 143 +C + 142 CALL AGEXUS (SVAL,XMIN,XMAX,XLOW,XHGH, + + YDRA,NVIY,IIVY,NEVY,IIEY,XLUW,XRUW) + CALL AGEXUS (SVAL,YMIN,YMAX,YLOW,YHGH, + + XDRA,NVIX,IIVX,NEVX,IIEX,YBUW,YTUW) +C + 143 CONTINUE +C +C Examine the user-window nice-value-at-ends parameters. INAX and INAY +C specify which axis has the nice values (if any). +C + QCEX=AMAX1(-1.,AMIN1(+1.,QCEX)) + INAX=IFIX(QCEX) + IF (INAX.NE.0) INAX=(INAX+7)/2 +C + QCEY=AMAX1(-1.,AMIN1(+1.,QCEY)) + INAY=IFIX(QCEY) + IF (INAY.NE.0) INAY=(INAY+3)/2 +C +C Examine the user-window linear-log flags. +C + QLUX=AMAX1(-1.,AMIN1(1.,QLUX)) + QLUY=AMAX1(-1.,AMIN1(1.,QLUY)) +C +C Examine the axis parameters. +C + QLUD=ABS(QLUY) + INAD=INAY + UMIN=YBUW + UMAX=YTUW + QMIN=YBUW + QMAX=YTUW +C + I=0 +C + 101 I=I+1 + IF (I.EQ.5) GO TO 104 +C + IF (I.EQ.3) THEN + QLUD=ABS(QLUX) + INAD=INAX + UMIN=XLUW + UMAX=XRUW + QMIN=XLUW + QMAX=XRUW + END IF +C + QDAX(I)=AMAX1(-1.,AMIN1(4.,QDAX(I))) + IF (QDAX(I).LE.0.) GO TO 102 + QLUA(I)=QLUD + QBTP(I)=QBTD(I) + IF (QBTD(I).EQ.SVAL(1).OR.QBTD(I).EQ.SVAL(2)) QBTP(I)=1.+QLUD + QBTP(I)=AMAX1(0.,AMIN1(3.,QBTP(I))) + IF (QBTD(I).EQ.SVAL(2)) QBTD(I)=QBTP(I) +C + CALL AGEXAX (I,SVAL,UMIN,UMAX,INAD-I,QLUD,FUNS(I),QBTP(I),BASD(I), + + BASE(I),QMJD(I),QMND(I),QMNT(I),QLTD(I),QLTP(I), + + QLED(I),QLEX(I),QLFD(I),QLFL(I),QMIN,QMAX) +C + QSPA(I)=AMAX1(0.,AMIN1(1.,QSPA(I))) + IF (QJDP(I).EQ.SVAL(1).OR.QJDP(I).EQ.SVAL(2)) QJDP(I)=65535. + IF (QNDP(I).EQ.SVAL(1).OR.QNDP(I).EQ.SVAL(2)) QNDP(I)=65535. +C + 102 IF (I.EQ.2) THEN + YBUW=QMIN + YTUW=QMAX + ELSE IF (I.EQ.4) THEN + XLUW=QMIN + XRUW=QMAX + END IF +C + GO TO 101 +C +C Examine the user-window min-max/max-min ordering parameters. Compute +C final values of the user-window edge parameters. +C + 104 QOVX=AMAX1(0.,AMIN1(1.,QOVX)) + IF (QOVX.EQ.0.) GO TO 105 + TEMP=XLUW + XLUW=XRUW + XRUW=TEMP +C + 105 QOVY=AMAX1(0.,AMIN1(1.,QOVY)) + IF (QOVY.EQ.0.) GO TO 106 + TEMP=YBUW + YBUW=YTUW + YTUW=TEMP +C +C Determine the exact size and shape of the curve window. +C + 106 XLGW=XLGF*WOFP + XRGW=XRGF*WOFP + YBGW=YBGF*HOFP + YTGW=YTGF*HOFP +C + XLCW=XLGW+XLGD*(XRGW-XLGW) + XRCW=XLGW+XRGD*(XRGW-XLGW) + YBCW=YBGW+YBGD*(YTGW-YBGW) + YTCW=YBGW+YTGD*(YTGW-YBGW) +C + WCWP=XRCW-XLCW + HCWP=YTCW-YBCW +C + ARWH=WCWP/HCWP +C + IF (SOGD) 107,115,108 +C + 107 DRWH=ABS(SOGD) + GO TO 111 +C + 108 DRWH=ABS((XRUW-XLUW)/(YTUW-YBUW)) + IF (SOGD-1.) 109,110,110 +C + 109 IF (DRWH.LT.SOGD.OR.(1./DRWH).LT.SOGD) GO TO 115 + GO TO 111 +C + 110 IF (DRWH.GT.SOGD.OR.(1./DRWH).GT.SOGD) DRWH=1. +C + 111 IF (DRWH-ARWH) 112,115,113 +C + 112 XLCW=XLCW+.5*(WCWP-HCWP*DRWH) + XRCW=XRCW-.5*(WCWP-HCWP*DRWH) + GO TO 114 +C + 113 YBCW=YBCW+.5*(HCWP-WCWP/DRWH) + YTCW=YTCW-.5*(HCWP-WCWP/DRWH) +C + 114 WCWP=XRCW-XLCW + HCWP=YTCW-YBCW +C + 115 SCWP=AMIN1(WCWP,HCWP) +C + XLGW=(XLGW-XLCW)/WCWP + XRGW=(XRGW-XLCW)/WCWP + YBGW=(YBGW-YBCW)/HCWP + YTGW=(YTGW-YBCW)/HCWP +C + XLCW=XLCW/WOFP + XRCW=XRCW/WOFP + YBCW=YBCW/HOFP + YTCW=YTCW/HOFP +C +C Make sure the number of dash patterns is in range. +C + QODP=AMAX1(-26.,AMIN1(+26.,QODP)) + IF (QODP.EQ.0.) QODP=-1. +C +C Examine the windowing parameter. +C + QWND=AMAX1(0.,AMIN1(1.,QWND)) +C +C Do a test run of the routine AGLBLS to find out how much space will be +C required for labels in each of the six label boxes. +C + QDLB=AMAX1(0.,AMIN1(2.,QDLB)) + IDLB=IFIX(QDLB) + LBIM=IFIX(QBIM) +C + CALL AGLBLS (-IDLB,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C +C Compute the desired and smallest-possible widths of the labels in +C boxes 1 and 2. +C + DWB1=AMAX1(0.,DBOX(1,2)-DBOX(1,1)) + SWB1=AMAX1(0.,SBOX(1,2)-SBOX(1,1)) + DWB2=AMAX1(0.,DBOX(2,2)-DBOX(2,1)) + SWB2=AMAX1(0.,SBOX(2,2)-SBOX(2,1)) +C +C Compute the desired and smallest-possible heights of the labels in +C boxes 3 and 4. +C + DHB3=AMAX1(0.,DBOX(3,4)-DBOX(3,3)) + SHB3=AMAX1(0.,SBOX(3,4)-SBOX(3,3)) + DHB4=AMAX1(0.,DBOX(4,4)-DBOX(4,3)) + SHB4=AMAX1(0.,SBOX(4,4)-SBOX(4,3)) +C +C Do test runs of AGAXIS for each of the four axes to see how much space +C will be required for numeric labels. +C + I=0 +C + 118 I=I+1 + IF (I.EQ.5) GO TO 128 +C + XYPI=FLOAT(1-MOD(I,2)) + IF (QDAX(I).EQ.0.) GO TO 121 + IF (PING(I).NE.SVAL(1)) XYPI=PING(I) +C + IF (I.GE.3) GO TO 119 +C + XYMN=XLGW + XYMX=XRGW + IF (PINU(I).EQ.SVAL(1)) GO TO 120 + XYPI=(PINU(I)-XLUW)/(XRUW-XLUW) + IF (QLUX.NE.0.) XYPI=(ALOG10(PINU(I))-ALOG10(XLUW))/ + + (ALOG10(XRUW)-ALOG10(XLUW)) + GO TO 120 +C + 119 XYMN=YBGW + XYMX=YTGW + IF (PINU(I).EQ.SVAL(1)) GO TO 120 + XYPI=(PINU(I)-YBUW)/(YTUW-YBUW) + IF (QLUY.NE.0.) XYPI=(ALOG10(PINU(I))-ALOG10(YBUW))/ + + (ALOG10(YTUW)-ALOG10(YBUW)) +C + 120 XYPI=AMAX1(XYMN,AMIN1(XYMX,XYPI)) +C + 121 GO TO (122,123,124,125) , I +C +C Left y axis. +C + 122 XBGA(1)=XYPI + YBGA(1)=0. + UBGA(1)=YBUW + XNDA(1)=XYPI + YNDA(1)=1. + UNDA(1)=YTUW + WNLL(1)=XYPI-XLGW-DWB1 + WNLR(1)=XRGW-XYPI-DWB2 + GO TO 126 +C +C Right y axis. +C + 123 XBGA(2)=XYPI + YBGA(2)=1. + UBGA(2)=YTUW + XNDA(2)=XYPI + YNDA(2)=0. + UNDA(2)=YBUW + WNLL(2)=XRGW-XYPI-DWB2 + WNLR(2)=XYPI-XLGW-DWB1 + GO TO 126 +C +C Bottom x axis. +C + 124 XBGA(3)=1. + YBGA(3)=XYPI + UBGA(3)=XRUW + XNDA(3)=0. + YNDA(3)=XYPI + UNDA(3)=XLUW + WNLL(3)=XYPI-YBGW-DHB3 + WNLR(3)=YTGW-XYPI-DHB4 + GO TO 126 +C +C Top x axis. +C + 125 XBGA(4)=0. + YBGA(4)=XYPI + UBGA(4)=XLUW + XNDA(4)=1. + YNDA(4)=XYPI + UNDA(4)=XRUW + WNLL(4)=YTGW-XYPI-DHB4 + WNLR(4)=XYPI-YBGW-DHB3 +C + 126 IF (QDAX(I).GT.0.) THEN + CALL AGAXIS (I,QDAX(I),QSPA(I),WCWP,HCWP,XBGA(I),YBGA(I), + + XNDA(I),YNDA(I),QLUA(I),UBGA(I),UNDA(I),FUNS(I), + + QBTP(I),BASE(I),QJDP(I),WMJL(I),WMJR(I),QMNT(I), + + QNDP(I),WMNL(I),WMNR(I),QLTP(I),QLEX(I),QLFL(I), + + QLOF(I),QLOS(I),DNLA(I),WCLM(I),WCLE(I),RFNL(I), + + QCIM(I),QCIE(I),WNLL(I),WNLR(I),10.,11.) + ELSE + WNLL(I)=0. + WNLR(I)=0. + END IF + GO TO 118 +C +C If no labels are to be drawn, AGSTUP is now done. +C + 128 IF (IDLB.EQ.0) GO TO 138 +C +C Check the label boxes, moving and/or shrinking them to prevent the +C labels in them from overlapping any portion of any axis. The labels +C on an axis may have to be moved, as well. +C +C Box 1 - to the left of the curve window. +C + IF (DBOX(1,2).GT.0.) GO TO 903 + DBOX(1,2)=AMIN1(0.,XBGA(1)-WNLL(1),XBGA(2)-WNLR(2)) + DBOX(1,1)=DBOX(1,2)-DWB1 + IF (DBOX(1,1).LT.XLGW) DBOX(1,1)=AMIN1(DBOX(1,2)-SWB1,XLGW) + IF (DBOX(1,1).GE.XLGW) GO TO 130 + DBOX(1,1)=XLGW + DBOX(1,2)=XLGW+SWB1 + TEMP=XBGA(1)-WNLL(1)-DBOX(1,2) + IF (TEMP.GE.0.) GO TO 129 + WNLL(1)=WNLL(1)+TEMP + WNLR(1)=WNLR(1)-TEMP + 129 TEMP=XBGA(2)-WNLR(2)-DBOX(1,2) + IF (TEMP.GE.0.) GO TO 130 + WNLL(2)=WNLL(2)-TEMP + WNLR(2)=WNLR(2)+TEMP +C +C Box 2 - to the right of the curve window. +C + 130 IF (DBOX(2,1).LT.1.) GO TO 904 + DBOX(2,1)=AMAX1(1.,XBGA(1)+WNLR(1),XBGA(2)+WNLL(2)) + DBOX(2,2)=DBOX(2,1)+DWB2 + IF (DBOX(2,2).GT.XRGW) DBOX(2,2)=AMAX1(DBOX(2,1)+SWB2,XRGW) + IF (DBOX(2,2).LE.XRGW) GO TO 132 + DBOX(2,1)=XRGW-SWB2 + DBOX(2,2)=XRGW + TEMP=XBGA(1)+WNLR(1)-DBOX(2,1) + IF (TEMP.LE.0.) GO TO 131 + WNLL(1)=WNLL(1)+TEMP + WNLR(1)=WNLR(1)-TEMP + 131 TEMP=XBGA(2)+WNLL(2)-DBOX(2,1) + IF (TEMP.LE.0.) GO TO 132 + WNLL(2)=WNLL(2)-TEMP + WNLR(2)=WNLR(2)+TEMP +C +C Box 3 - below the curve window. +C + 132 IF (DBOX(3,4).GT.0.) GO TO 905 + DBOX(3,4)=AMIN1(0.,YBGA(3)-WNLL(3),YBGA(4)-WNLR(4)) + DBOX(3,3)=DBOX(3,4)-DHB3 + IF (DBOX(3,3).LT.YBGW) DBOX(3,3)=AMIN1(DBOX(3,4)-SHB3,YBGW) + IF (DBOX(3,3).GE.YBGW) GO TO 134 + DBOX(3,3)=YBGW + DBOX(3,4)=YBGW+SHB3 + TEMP=YBGA(3)-WNLL(3)-DBOX(3,4) + IF (TEMP.GE.0.) GO TO 133 + WNLL(3)=WNLL(3)+TEMP + WNLR(3)=WNLR(3)-TEMP + 133 TEMP=YBGA(4)-WNLR(4)-DBOX(3,4) + IF (TEMP.GE.0.) GO TO 134 + WNLL(4)=WNLL(4)-TEMP + WNLR(4)=WNLR(4)+TEMP +C +C Box 4 - above the curve window. +C + 134 IF (DBOX(4,3).LT.1.) GO TO 906 + DBOX(4,3)=AMAX1(1.,YBGA(3)+WNLR(3),YBGA(4)+WNLL(4)) + DBOX(4,4)=DBOX(4,3)+DHB4 + IF (DBOX(4,4).GT.YTGW) DBOX(4,4)=AMAX1(DBOX(4,3)+SHB4,YTGW) + IF (DBOX(4,4).LE.YTGW) GO TO 136 + DBOX(4,3)=YTGW-SHB4 + DBOX(4,4)=YTGW + TEMP=YBGA(3)+WNLR(3)-DBOX(4,3) + IF (TEMP.LE.0.) GO TO 135 + WNLL(3)=WNLL(3)+TEMP + WNLR(3)=WNLR(3)-TEMP + 135 TEMP=YBGA(4)+WNLL(4)-DBOX(4,3) + IF (TEMP.LE.0.) GO TO 136 + WNLL(4)=WNLL(4)-TEMP + WNLR(4)=WNLR(4)+TEMP +C +C Box 5 - the curve window itself. +C + 136 IF (DBOX(5,1).LT.0..OR.DBOX(5,2).GT.1..OR. + + DBOX(5,3).LT.0..OR.DBOX(5,4).GT.1.) GO TO 907 +C + DBOX(5,1)=AMAX1(XLGW,XBGA(1)+WNLR(1)) + DBOX(5,2)=AMIN1(XRGW,XBGA(2)-WNLR(2)) + DBOX(5,3)=AMAX1(YBGW,YBGA(3)+WNLR(3)) + DBOX(5,4)=AMIN1(YTGW,YBGA(4)-WNLR(4)) +C +C Do a final check on all boxes for labels running outside the graph +C window. +C + DO 137 NBOX=1,6 + DBOX(NBOX,1)=AMAX1(XLGW,DBOX(NBOX,1)) + DBOX(NBOX,2)=AMIN1(XRGW,DBOX(NBOX,2)) + DBOX(NBOX,3)=AMAX1(YBGW,DBOX(NBOX,3)) + DBOX(NBOX,4)=AMIN1(YTGW,DBOX(NBOX,4)) + 137 CONTINUE +C +C Do a "SET" call for the user and return. +C + 138 CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C + RETURN +C +C Error exits. +C + 901 CALL SETER ('AGSTUP - GRAPH WINDOW IMPROPERLY SPECIFIED',20,2) +C + 902 CALL SETER ('AGSTUP - GRID WINDOW IMPROPERLY SPECIFIED',21,2) +C + 903 CALL SETER ('AGSTUP - LEFT LABELS IMPROPERLY SPECIFIED',22,2) +C + 904 CALL SETER ('AGSTUP - RIGHT LABELS IMPROPERLY SPECIFIED',23,2) +C + 905 CALL SETER ('AGSTUP - BOTTOM LABELS IMPROPERLY SPECIFIED',24,2) +C + 906 CALL SETER ('AGSTUP - TOP LABELS IMPROPERLY SPECIFIED',25,2) +C + 907 CALL SETER ('AGSTUP - INTERIOR LABELS IMPROPERLY SPECIFIED',26,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agutol.f b/sys/gio/ncarutil/autograph/agutol.f new file mode 100644 index 00000000..02dbf64c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agutol.f @@ -0,0 +1,49 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGUTOL (IAXS,FUNS,IDMA,VINP,VOTP) +C +C This routine is called to perform the mapping from the "user system" +C along an axis to the "label system" along that axis or vice-versa. It +C may be replaced by the user in order to create a desired graph. The +C arguments are as follows: +C +C -- IAXS is the index of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axis, respectively. +C +C -- FUNS is the value of the parameter 'AXIS/s/FUNCTION.', which may be +C used to select the desired mapping function for axis IAXS. It is +C recommended that the default value (zero) be used to specify the +C identity mapping. A non-zero value may be integral (1., 2., etc.) +C and serve purely to select the code to be executed or it may be the +C value of a real parameter in the equations defining the mapping. +C +C -- IDMA specifies the direction of the mapping. A value greater than +C zero indicates that VINP is a value in the user system and that +C VOTP is to be a value in the label system, a value less than zero +C the opposite. +C +C -- VINP is an input value in one coordinate system along the axis. +C +C -- VOTP is an output value in the other coordinate system along the +C axis. +C +C The default routine simply defines the identity mapping for all axes. +C + VOTP=VINP +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/anotat.f b/sys/gio/ncarutil/autograph/anotat.f new file mode 100644 index 00000000..ed46025b --- /dev/null +++ b/sys/gio/ncarutil/autograph/anotat.f @@ -0,0 +1,63 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE ANOTAT (LABX,LABY,LBAC,LSET,NDSH,DSHL) +C + CHARACTER*(*) LABX,LABY,DSHL(*) +C +C The routine ANOTAT resets background annotation. +C +C Declare the type of the dash-pattern-parameter-name generator. +C + CHARACTER*16 AGDSHN +C +C Set up the x-axis label. +C + IF (ICHAR(LABX(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'B') + CALL AGSETI ('LINE/NUMB.',-100) + CALL AGSETC ('LINE/TEXT.',LABX) + END IF +C +C Set up the y-axis label. +C + IF (ICHAR(LABY(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'L') + CALL AGSETI ('LINE/NUMB.', 100) + CALL AGSETC ('LINE/TEXT.',LABY) + END IF +C +C Set up the background the user wants. +C + IF (LBAC.GT.0) CALL AGSETI ('BACK.',LBAC) +C +C Set the parameter ISET. +C + IF (LSET.NE.0) CALL AGSETI ('SET .',LSET) +C +C Set up the dash patterns the user wants. +C + IF (NDSH.NE.0) THEN + IDSH=MIN0(26,NDSH) + CALL AGSETI ('DASH/SELE.',IDSH) + IF (IDSH.LT.0) RETURN + DO 101 I=1,IDSH + CALL AGSETC (AGDSHN(I),DSHL(I)) + 101 CONTINUE + END IF +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/displa.f b/sys/gio/ncarutil/autograph/displa.f new file mode 100644 index 00000000..0749b29b --- /dev/null +++ b/sys/gio/ncarutil/autograph/displa.f @@ -0,0 +1,33 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE DISPLA (LFRA,LROW,LTYP) +C +C The subroutine DISPLA resets the parameters IFRA, IROW, and/or LLUX +C and LLUY. +C + IF (LFRA.NE.0) CALL AGSETI ('FRAM.', MAX0(1,MIN0(3,LFRA))) +C + IF (LROW.NE.0) CALL AGSETI ('ROW .',LROW) +C + IF (LTYP.EQ.0) RETURN +C + ITYP=MAX0(1,MIN0(4,LTYP)) + CALL AGSETI ('X/LOGA.', (1-ITYP)/2) + CALL AGSETI ('Y/LOGA.',MOD(1-ITYP,2)) +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezmxy.f b/sys/gio/ncarutil/autograph/ezmxy.f new file mode 100644 index 00000000..bc8f6352 --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezmxy.f @@ -0,0 +1,67 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZMXY (XDRA,YDRA,IDXY,MANY,NPTS,LABG) +C + REAL XDRA(*),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZMXY draws many curves, each of them defined by points of +C the form (XDRA(I,J),YDRA(I,J)) or (XDRA(J,I),YDRA(J,I)) or, possibly, +C (XDRA(I),YDRA(I,J)) or (XDRA(I),YDRA(J,I)), for I = 1, 2, ... NPTS and +C for J = 1, 2, ... MANY. (YDRA is actually dimensioned IDXY by * .) +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZMXY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) + CALL AGGETI ('DASH/SELE.',IDSH) +C + CALL AGEZSU (4,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.LT.0) GO TO 102 +C + DO 101 I=1,MANY + INXD=1+(I-1)*IIVX + INYD=1+(I-1)*IIVY + KDSH=ISIGN(I,IDSH) + CALL AGCURV (XDRA(INXD),IIEX,YDRA(INYD),IIEY,NPTS,KDSH) + 101 CONTINUE +C + 102 IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezmy.f b/sys/gio/ncarutil/autograph/ezmy.f new file mode 100644 index 00000000..e406465b --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezmy.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZMY (YDRA,IDXY,MANY,NPTS,LABG) +C + REAL XDRA(1),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZMY draws many curves, each of them defined by points of +C the form (I,YDRA(I,J)) or (I,YDRA(J,I)), for I = 1, 2, ... NPTS and +C for J = 1, 2, ... MANY. (YDRA is actually dimensioned IDXY by * .) +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZMY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) + CALL AGGETI ('DASH/SELE.',IDSH) +C + CALL AGEZSU (3,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.LT.0) GO TO 102 +C + DO 101 I=1,MANY + INYD=1+(I-1)*IIVY + KDSH=ISIGN(I,IDSH) + CALL AGCURV (XDRA,0,YDRA(INYD),IIEY,NPTS,KDSH) + 101 CONTINUE +C + 102 IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezxy.f b/sys/gio/ncarutil/autograph/ezxy.f new file mode 100644 index 00000000..e6ef3b5e --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezxy.f @@ -0,0 +1,57 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZXY (XDRA,YDRA,NPTS,LABG) +C + REAL XDRA(*),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZXY draws one curve through the points (XDRA(I),YDRA(I)), +C for I = 1, 2, ... NPTS. +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZXY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) +C + CALL AGEZSU (2,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.GE.0) CALL AGCURV (XDRA,1,YDRA,1,NPTS,1) +C + IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezy.f b/sys/gio/ncarutil/autograph/ezy.f new file mode 100644 index 00000000..3be54a03 --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezy.f @@ -0,0 +1,57 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZY (YDRA,NPTS,LABG) +C + REAL XDRA(1),YDRA(*) +C + CHARACTER*(*) LABG +C +C The subroutine EZY draws one curve through the points (I,YDRA(I)), for +C I = 1, 2, ... NPTS. +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) +C + CALL AGEZSU (1,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.GE.0) CALL AGCURV (XDRA,0,YDRA,1,NPTS,1) +C + IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/idiot.f b/sys/gio/ncarutil/autograph/idiot.f new file mode 100644 index 00000000..0e2ce5e5 --- /dev/null +++ b/sys/gio/ncarutil/autograph/idiot.f @@ -0,0 +1,64 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE IDIOT (XDRA,YDRA,NPTS,LTYP,LDSH,LABX,LABY,LABG,LFRA) +C + REAL XDRA(*),YDRA(*) +C + INTEGER LDSH(*) +C + CHARACTER*(*) LABX,LABY,LABG +C + CHARACTER*16 AGBNCH +C +C This is an implementation of the routine from which AUTOGRAPH grew. +C It should work pretty much as the original did (if you can figure out +C what that was). +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','IDIOT','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL ANOTAT (LABX,LABY,1,2-ISIGN(1,NPTS),1,AGBNCH(LDSH)) +C + CALL DISPLA (2-MAX0(-1,MIN0(1,LFRA)),1,LTYP) +C + CALL AGEZSU (5,XDRA,YDRA,IABS(NPTS),1,IABS(NPTS),LABG,IIVX,IIEX, + + IIVY,IIEY) + CALL AGBACK +C + CALL AGCURV (XDRA,1,YDRA,1,IABS(NPTS),1) +C + IF (LFRA.GT.0) CALL FRAME +C +C +NOAO +C + call plotit (0, 0, 2) + call initut +C +C -NOAO + RETURN + END diff --git a/sys/gio/ncarutil/autograph/mkpkg b/sys/gio/ncarutil/autograph/mkpkg new file mode 100644 index 00000000..8af0a0d4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/mkpkg @@ -0,0 +1,62 @@ +# Make the NCAR AUTOGRAPH library. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + agdflt.f + agaxis.f + agback.f + agbnch.f + agchax.f + agchcu.f + agchil.f + agchnl.f + agctcs.f + agctko.f + agcurv.f + agdash.f + agdlch.f + agdshn.f + agexax.f + agexus.f + agezsu.f + agfpbn.f + agftol.f + aggetc.f + aggetf.f + aggeti.f + aggetp.f + aggtch.f + aginit.f + agkurv.f + aglbls.f + agmaxi.f + agmini.f + agnumb.f + agppid.f + agpwrt.f + agqurv.f + agrpch.f + agrstr.f + agsave.f + agscan.f + agsetc.f + agsetf.f + agseti.f + agsetp.f + agsrch.f + agstch.f + agstup.f + agutol.f + anotat.f + displa.f + ezmxy.f + ezmy.f + ezxy.f + ezy.f + idiot.f + pstr.x + ; diff --git a/sys/gio/ncarutil/autograph/pstr.x b/sys/gio/ncarutil/autograph/pstr.x new file mode 100644 index 00000000..a40c9fc1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/pstr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PSTR -- Print a character string from a fortran program. The string is +# passed as an unpacked spp string, the result of f77upk in the calling +# program. PSTR is called by agppid.f in the autograph package. + +procedure pstr (spp_string) + +char spp_string[ARB] + +begin + call eprintf ("%s\n") + call pargstr (spp_string) +end diff --git a/sys/gio/ncarutil/conbd.f b/sys/gio/ncarutil/conbd.f new file mode 100644 index 00000000..eaaf2df5 --- /dev/null +++ b/sys/gio/ncarutil/conbd.f @@ -0,0 +1,111 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C BLOCKDATA CONBD + subroutine conbd + integer first, temp + common /conflg/ first + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c +noao: dimension of stline ir array increased from 20000 to 80000 6-93 + COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP, + 1 NCRT ,ILAB ,NULBLL ,IOFFD, + 2 EXT ,IOFFM ,ISOLID ,NLA, + 3 NLM ,XLT ,YBT ,SIDE + COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX +C + SAVE +C +C DATA IOFFP,SPVAL/0,0.0/ + data temp /1/ + first = temp + IOFFP = 0 + SPVAL = 0.0 +C DATA ISIZEL,ISIZEM,ISIZEP,NLA,NLM,XLT,YBT,SIDE,ISOLID,NREP,NCRT/ +C 1 1, 2, 0, 16, 40,.05,.05, .9, 1023, 6, 4 / + if (first .ne. 1) then + return + endif + + temp = 0 + +c ISIZEL = 1 +c noao: size of contour labels seemed too large. Changed from 1 to 0 + isizel = 0 + ISIZEM = 2 + ISIZEP = 0 + NLA = 16 + NLM = 40 + XLT = .05 + YBT = .05 + SIDE = .9 + ISOLID = 1023 + NREP = 4 + NCRT = 2 +C DATA EXT,IOFFD,NULBLL,IOFFM,ILAB/.25,0,3,0,1/ +C +noao value of "extreme" axes ratios changed from 1/4 to 1/16 (ShJ 6-10-88) +C EXT = .25 + EXT = .0625 +C -noao + IOFFD = 0 + NULBLL = 3 + IOFFM = 0 + ILAB = 1 +C DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ +C 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + INX(1) = -1 + INX(2) = -1 + INX(3) = 0 + INX(4) = 1 + INX(5) = 1 + INX(6) = 1 + INX(7) = 0 + INX(8) = -1 +C DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ +C 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + INY(1) = 0 + INY(2) = 1 + INY(3) = 1 + INY(4) = 1 + INY(5) = 0 + INY(6) = -1 + INY(7) = -1 + INY(8) = -1 +C DATA NR/500/ +c +noao: dimension of stline array increased from 500 to 5000 6March87 +c +noao: dimension of stline array increased from 5000 to 20000 Jan90 +c +noao: dimension of stline array increased from 20000 to 80000 6-93 + NR = 80000 +C DATA IRECMJ,IRECMN,IRECTX/ 1 , 1 , 1/ +c +noao: value of irecmj changed so major divisions are high intensity + IRECMJ = 2 + IRECMN = 1 + IRECTX = 1 +C +C - noao +C +C REVISION HISTORY--- +C +C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +C +C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +C DOCUMENTATION CLARIFIED AND CORRECTED. +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +C------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/conbdn.f b/sys/gio/ncarutil/conbdn.f new file mode 100644 index 00000000..cd7ca00d --- /dev/null +++ b/sys/gio/ncarutil/conbdn.f @@ -0,0 +1,342 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data conbdn changed to run time initialization +c BLOCKDATA CONBDN + subroutine conbdn +C +C +C +C COMMON DATA +C +C NOTE THE COMMON BLOCKS LISTED INCLUDE ALL THE COMMON USED BY +C THE ENTIRE CONRAN FAMILY, NOT ALL MEMBERS WILL USE ALL +C THE COMMON DATA. +C +C CONRA1 +C CL-ARRAY OF CONTOUR LEVELS +C NCL-NUMBER OF CONTOUR LEVELS +C OLDZ-Z VALUE OF LEFT NEIGHBOR TO CURRENT LOCATION +C PV-ARRAY OF PREVIOUS ROW VALUES +C HI-LARGEST CONTOUR PLOTTED +C FLO-LOWEST CONTOUR PLOTTED +C FINC-INCREMENT LEVEL BETWEEN EQUALLY SPACED CONTOURS +C CONRA2 +C REPEAT-FLAG TO TRIANGULATE AND DRAW OR JUST DRAW +C EXTRAP-PLOT DATA OUTSIDE OF CONVEX DATA HULL +C PER-PUT PERIMETER ARROUND PLOT +C MESS-FLAG TO INDICATE MESSAGE OUTPUT +C ISCALE-SCALING SWITCH +C LOOK-PLOT TRIANGLES FLAG +C PLDVLS-PLOT THE DATA VALUES FLAG +C GRD-PLOT GRID FLAG +C CON-USER SET OR PROGRAM SET CONTOURS FLAG +C CINC-USER OR PROGRAM SET INCREMENT FLAG +C CHILO-USER OR PROGRAM SET HI LOW CONTOURS +C LABON-FLAG TO CONTROL LABELING OF CONTOURS +C PMIMX-FLAG TO CONTROL THE PLOTTING OF MIN"S +C AND MAX"S +C SCALE-THE SCALE FACTOR FOR CONTOUR LINE VALUES +C AND MIN , MAX PLOTTED VALUES +C FRADV-ADVANCE FRAME BEFORE PLOTTING TRIANGUALTION +C EXTRI-ONLY PLOT TRIANGULATION +C BPSIZ-BREAKPOINT SIZE FOR DASHPATTERNS +C LISTOP-LIST OPTIONS ON UNIT6 FLAG +C CONRA3 +C IREC-PORT RECOVERABLE ERROR FLAG +C CONRA4 +C NCP-NUMBER OF DATA POINTS USED AT EACH POINT FOR +C POLYNOMIAL CONSTRUCTION. +C NCPSZ-MAX SIZE ALLOWED FOR NCP +C CONRA5 +C NIT-FLAG TO INDICATE STATUS OF SEARCH DATA BASE +C ITIPV-LAST TRIANGLE INTERPOLATION OCCURRED IN +C CONRA6 +C XST-X COORDINATE START POINT FOR CONTOURING +C YST-Y COORDINATE START POINT FOR CONTOURING +C XED-X COORDINATE END POINT FOR CONTOURING +C YED-Y COORDINATE END POINT FOR CONTOURING +C STPSZ-STEP SIZE FOR X,Y CHANGE WHEN CONTOURING +C IGRAD-NUMBER OF GRADUATIONS FOR CONTOURING(STEP SIZE) +C IG-RESET VALUE FOR IGRAD +C XRG-X RANGE OF COORDINATES +C YRG-Y RANGE OF COORDINATES +C BORD-PERCENT OF FRAME USED FOR CONTOUR PLOT +C PXST-X PLOTTER START ADDRESS FOR CONTOURS +C PYST-Y PLOTTER START ADDRESS FOR CONTOURS +C PXED-X PLOTTER END ADDRESS FOR CONTOURS +C PYED-Y PLOTTER END ADDRESS FOR CONTOURS +C ITICK-NUMBER OF TICK MARKS FOR GRIDS AND PERIMETERS +C CONRA7 +C TITLE-SWITCH TO INDICATE IF TITLE OPTION ON OR OFF +C ISTRNG-CHARACTER STRING OF TITLE +C ICNT-CHARACTER COUNT OF ISTRNG +C ITLSIZ-SIZE OF TITLE IN PWRIT UNITS +C CONRA8 +C IHIGH-DEFAULT COLOR (INTENSITY) INDEX SETTING +C INMAJ-CONTOUR LEVEL COLOR (INTENSITY) INDEX FOR MAJOR LINES +C INMIN-CONTOUR LEVEL COLOR (INTENSITY) INDEX FOR MINOR LINES +C INLAB-TITLE AND MESSAGE COLOR (INTENSITY) INDEX +C INDAT-DATA VALUE COLOR (INTENSITY) INDEX +C FORM-THE FORMAT FOR PLOTTING THE DATA VALUES +C LEN-THE NUMBER OF CHARACTERS IN THE FORMAT +C IFMT-SIZE OF THE FORMAT FIELD +C LEND-DEFAULT FORMAT LENGTH +C IFMTD-DEFAULT FORMAT FIELD SIZE +C ISIZEP-SIZE OF THE PLOTTED DATA VALUES +C CONRA9 +C X-ARRAY OF X COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C Y-ARRAY OF Y COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C NP-COUNT IN X AND Y +C MXXY-SIZE OF X AND Y +C TR-TOP RIGHT CORNER VALUE OF CURRENT CELL +C BR-BOTTOM RIGHT CORNER VALUE OF CURRENT CELL +C TL-TOP LEFT CORNER VALUE OF CURRENT CELL +C BL-BOTTOM LEFT CORNER VALUE OF CURRENT CELL +C CONV-CURRENT CONTOUR VALUE +C XN-X POSITION WHERE CONTOUR IS BEING DRAWN +C YN-Y POSITION WHERE CONTOUR IS BEING DRAWN +C ITLL-TRIANGLE WHERE TOP LEFT CORNER OF CURRENT CELL LIES +C IBLL-TRIANGLE OF BOTTOM LEFT CORNER +C ITRL-TRIANGLE OF TOP RIGHT CORNER +C IBRL-TRIANGLE OF BOTTOM LEFT CORNER +C XC-X COORDINATE OF CURRENT CELL +C YC-Y CORRDINATE OF CURRENT CELL +C ITLOC-IN CONJUNCTION WITH PV STORES THE TRIANGLE WHERE PV +C VALUE CAME FROM +C CONR10 +C NT-NUMBER OF TRIANGLES GENERATED +C NL-NUMBER OF LINE SEGMENTS +C NTNL-NT+NL +C JWIPT-POINTER INTO IWK WHERE WHERE TRIANGLE POINT NUMBERS +C ARE STORED +C JWIWL-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIWP-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIPL-IN IWK THE LOCATION OF END POINTS FOR BORDER LINE +C SEGMENTS +C IPR-IN WK THE LOCATION OF THE PARTIAL DERIVITIVES AT EACH +C DATA POINT +C ITPV-THE TRIANGLE WHERE THE PREVIOUS VALUE CAME FROM +C CONR11 +C NREP-NUMBER OF REPETITIONS OF DASH PATTERN BEFORE A LABEL +C NCRT-NUMBER OF CRT UNITS FOR A DASH MARK OR BLANK +C ISIZEL-SIZE OF CONTOUR LINE LABELS +C NDASH-ARRAY CONTAINING THE NEGATIVE VALUED CONTOUR DASH +C PATTERN +C MINGAP-NUMBER OF UNLABELED LINES BETWEEN EACH LABELED ONE +C IDASH-POSITIVE VALUED CONTOUR DASH PATTERN +C ISIZEM-SIZE OF PLOTTED MINIMUMS AND MAXIMUMS +C EDASH-EQUAL VALUED CONTOUR DASH PATTERN +C TENS-DEFAULT TENSION SETTING FOR SMOOTHING +C CONR12 +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C CONR13 +C XVS-ARRAY OF THE X COORD FOR SHIELDING +C YVS-ARRAY OF THE Y COORD FOR SHIELDING +C IXVST-POINTER (VIA LOC) TO THE USERS X ARRAY FOR SHIELDING +C IYVST-POINTER (VIA LOC) TO THE USERS Y ARRAY FOR SHIELDING +C ICOUNT-COUNT OF THE SHIELD ELEMENTS +C SPVAL-SPECIAL VALUE USED TO HALT CONTOURING AT THE SHIELD +C BOUNDRY +C SHIELD-LOGICAL FLAG TO SIGNAL STATUS OF SHIELDING +C SLDPLT-LOGICAL FLAG TO INDICTE STATUS OF SHIEDL PLOTTING +C CONR14 +C LINEAR-C1 LINAER INTERPOLATIN FLAG +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210), + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS, + 1 ISCALE ,LOOK ,PLDVLS ,GRD, + 2 CINC ,CHILO ,CON ,LABON, + 3 PMIMX ,SCALE ,FRADV ,EXTRI, + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED, + 1 STPSZ ,IGRAD ,IG ,XRG, + 2 YRG ,BORD ,PXST ,PYST, + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT, + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR, + 1 BR ,TL ,BL ,CONV, + 2 XN ,YN ,ITLL ,IBLL, + 3 ITRL ,IBRL ,XC ,YC, + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT, + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS, + 1 LOOK ,PLDVLS ,GRD ,LABON, + 2 PMIMX ,FRADV ,EXTRI ,CINC, + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + logical first + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C + SAVE +C +C +c +noao: parameter added to avoid clobbering initialization done +c by conop[1-4]. + data first /.true./ + if (.not. first) return + first = .false. +c -noao +C +c DATA ICOUNT,SHIELD,SLDPLT,LINEAR/0,.FALSE.,.FALSE.,.FALSE./ + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. + LINEAR = .FALSE. +c +c DATA REPEAT,EXTRAP,PER/.FALSE.,.FALSE.,.TRUE./ + REPEAT = .FALSE. + EXTRAP = .FALSE. + PER = .TRUE. +c +c DATA FRADV,EXTRI,BPSIZ/.TRUE.,.FALSE.,0.0/ + FRADV = .TRUE. + EXTRI = .FALSE. + BPSIZ = 0.0 +c +c DATA TITLE,MESS,LOOK/.FALSE.,.TRUE.,.FALSE./ + TITLE = .FALSE. + MESS = .TRUE. + LOOK = .FALSE. +c +c DATA PLDVLS,GRD/.FALSE.,.FALSE./ + PLDVLS = .FALSE. + GRD = .FALSE. +c +c DATA CON,CINC,CHILO/.FALSE.,.FALSE.,.FALSE./ + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. +c +c DATA SCALE,PMIMX/1.,.FALSE./ + SCALE = 1. + PMIMX = .FALSE. +c +c DATA ISIZEP,ISIZEM,TENS/8,15,2.5/ + ISIZEP = 8 + ISIZEM = 15 + TENS = 2.5 +c +c DATA INMAJ,INMIN,INLAB,INDAT/1, 1, 1, 1/ + INMAJ = 2 + INMIN = 1 + INLAB = 2 + INDAT = 1 +c +c DATA IRANMJ, IRANMN, IRANTX /1, 1, 1/ + IRANMJ = 2 + IRANMN = 1 + IRANTX = 1 +c +c DATA IRASMJ, IRASMN, IRASTX /1, 1, 1/ + IRASMJ = 2 + IRASMN = 1 + IRASTX = 1 +c +c DATA IRAQMJ, IRAQMN, IRAQTX /1, 1, 1/ + IRAQMJ = 2 + IRAQMN = 1 + IRAQTX = 1 +c +c DATA LABON/.TRUE./,LISTOP/.FALSE./ + LABON = .TRUE. + LISTOP = .FALSE. +c +c DATA BORD,ITICK/.9,10/ + BORD = .9 + ITICK = 10 +c +c DATA ISCALE,ITLSIZ/0,16/ + ISCALE = 0 + ITLSIZ = 16 +c +c DATA ITIPV,NIT,NCL/0,0,0/ + ITIPV = 0 + NIT = 0 + NCL = 0 +c +c DATA NCPSZ/25/ + NCPSZ = 25 +c +c DATA IHIGH/255/ + IHIGH = 255 +c +c DATA NCP /4/ + NCP = 4 +c +c DATA IREC /1/ + IREC = 1 +c +c DATA LEN,IFMT,LEND,IFMTD/0,0,7,10/ + LEN = 0 + IFMT = 0 + LEND = 7 + IFMTD = 10 +c +c DATA IGRAD,IG/40,40/ + IGRAD = 40 + IG = 40 +c +c DATA NREP,NCRT,ISIZEL,MXXY,MINGAP/6,3,9,500,3/ + NREP = 6 + NCRT = 3 + ISIZEL = 9 + MXXY = 500 + MINGAP = 3 +c +c DATA IDASH(1:1)/' '/ + IDASH(1:1) = ' ' +c +c DATA NDASH(1:1)/' '/ + NDASH(1:1) = ' ' +c +c DATA EDASH(1:1)/' '/ + EDASH(1:1) = ' ' +c +c DATA ISHFCT/9/ + ISHFCT = 9 +c +c - noao + END diff --git a/sys/gio/ncarutil/conlib/README b/sys/gio/ncarutil/conlib/README new file mode 100644 index 00000000..69f73877 --- /dev/null +++ b/sys/gio/ncarutil/conlib/README @@ -0,0 +1,3 @@ +CONLIB -- This directory contains the contents of the NCAR files concom.f and +conterp.f, unpacked one subroutine per file. The unpacking operation is +necessary to permit topological ordering of the library. diff --git a/sys/gio/ncarutil/conlib/concal.f b/sys/gio/ncarutil/conlib/concal.f new file mode 100644 index 00000000..e021fa30 --- /dev/null +++ b/sys/gio/ncarutil/conlib/concal.f @@ -0,0 +1,340 @@ + SUBROUTINE CONCAL (XD,YD,ZD,NT,IPT,NL,IPL,PDD,ITI,XII,YII,ZII, + 1 ITPV) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE PERFORMS PUNCTUAL INTERPOLATION OR EXTRAPO- +C LATION, I.E., DETERMINES THE Z VALUE AT A POINT. +C THE INPUT PARAMETERS ARE +C +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z +C COORDINATES OF DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE END POINTS OF THE BORDER LINE SEGMENTS AND +C THEIR RESPECTIVE TRIANGLE NUMBERS, +C PDD = ARRAY CONTAINING THE PARTIAL DERIVATIVES AT +C THE DATA POINTS, +C ITI = TRIANGLE NUMBER OF THE TRIANGLE IN WHICH LIES +C THE POINT FOR WHICH INTERPOLATION IS TO BE +C PERFORMED, +C XII,YII = X AND Y COORDINATES OF THE POINT FOR WHICH +C INTERPOLATION IS TO BE PERFORMED. +C THE OUTPUT PARAMETER IS +C +C ZII = INTERPOLATED Z VALUE. +C +C DECLARATION STATEMENTS +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,IPT(1) , + 1 IPL(1) ,PDD(1) + DIMENSION X(3) ,Y(3) ,Z(3) ,PD(15) , + 1 ZU(3) ,ZV(3) ,ZUU(3) ,ZUV(3) , + 2 ZVV(3) + REAL LU ,LV + EQUIVALENCE (P5,P50) +C + SAVE +C +C PRELIMINARY PROCESSING +C + IT0 = ITI + NTL = NT+NL + IF (IT0 .LE. NTL) GO TO 100 + IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IF (IL1 .EQ. IL2) GO TO 150 + GO TO 200 +C +C CALCULATION OF ZII BY INTERPOLATION. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 100 IF (IT0 .EQ. ITPV) GO TO 140 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE +C IPI 102 VERTEXES. +C IPI 103 +C + JIPT = 3*(IT0-1) + JPD = 0 + DO 120 I=1,3 + JIPT = JIPT+1 + IDP = IPT(JIPT) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 110 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 110 CONTINUE + 120 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = X(2)-X0 + B = X(3)-X0 + C = Y(2)-Y0 + D = Y(3)-Y0 + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -C/DLT + DP = A/DLT +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE VERTEXES OF THE +C TRIANGLE FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 130 I=1,3 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 130 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P10-P20 + H2 = ZU(2)-P10-ZUU(1) + H3 = ZUU(2)-ZUU(1) + P30 = 10.0*H1-4.0*H2+0.5*H3 + P40 = -15.0*H1+7.0*H2-H3 + P50 = 6.0*H1-3.0*H2+0.5*H3 + H1 = Z(3)-P00-P01-P02 + H2 = ZV(3)-P01-ZVV(1) + H3 = ZVV(3)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + LU = SQRT(AA+CC) + LV = SQRT(BB+DD) + THXU = ATAN2(C,A) + THUV = ATAN2(D,B)-THXU + CSUV = COS(THUV) + P41 = 5.0*LV*CSUV/LU*P50 + P14 = 5.0*LU*CSUV/LV*P05 + H1 = ZV(2)-P01-P11-P41 + H2 = ZUV(2)-P11-4.0*P41 + P21 = 3.0*H1-H2 + P31 = -2.0*H1+H2 + H1 = ZU(3)-P10-P11-P14 + H2 = ZUV(3)-P11-4.0*P14 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + THUS = ATAN2(D-C,B-A)-THXU + THSV = THUV-THUS + AA = SIN(THSV)/LU + BB = -COS(THSV)/LU + CC = SIN(THUS)/LV + DD = COS(THUS)/LV + AC = AA*CC + AD = AA*DD + BC = BB*CC + G1 = AA*AC*(3.0*BC+2.0*AD) + G2 = CC*AC*(3.0*AD+2.0*BC) + H1 = -AA*AA*AA*(5.0*AA*BB*P50+(4.0*BC+AD)*P41)- + 1 CC*CC*CC*(5.0*CC*DD*P05+(4.0*AD+BC)*P14) + H2 = 0.5*ZVV(2)-P02-P12 + H3 = 0.5*ZUU(3)-P20-P21 + P22 = (G1*H2+G2*H3-H1)/(G1+G2) + P32 = H2-P22 + P23 = H3-P22 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 140 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*(P13+V*P14))) + P2 = P20+V*(P21+V*(P22+V*P23)) + P3 = P30+V*(P31+V*P32) + P4 = P40+V*P41 + ZII = P0+U*(P1+U*(P2+U*(P3+U*(P4+U*P5)))) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE RECTANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 150 IF (IT0 .EQ. ITPV) GO TO 190 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE END +C POINTS OF THE BORDER LINE SEGMENT. +C + JIPL = 3*(IL1-1) + JPD = 0 + DO 170 I=1,2 + JIPL = JIPL+1 + IDP = IPL(JIPL) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 160 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 160 CONTINUE + 170 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = Y(2)-Y(1) + B = X(2)-X(1) + C = -B + D = A + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -BP + DP = AP +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE END POINTS OF THE +C BORDER LINE SEGMENT FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 180 I=1,2 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 180 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P01-P02 + H2 = ZV(2)-P01-ZVV(1) + H3 = ZVV(2)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + H1 = ZU(2)-P10-P11 + H2 = ZUV(2)-P11 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + P21 = 0.0 + P23 = -ZUU(2)+ZUU(1) + P22 = -1.5*P23 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 190 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*P13)) + P2 = P20+V*(P21+V*(P22+V*P23)) + ZII = P0+U*(P1+U*P2) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE TRIANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 200 IF (IT0 .EQ. ITPV) GO TO 220 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE VERTEX +C OF THE TRIANGLE. +C + JIPL = 3*IL2-2 + IDP = IPL(JIPL) + X(1) = XD(IDP) + Y(1) = YD(IDP) + Z(1) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 210 KPD=1,5 + JPDD = JPDD+1 + PD(KPD) = PDD(JPDD) + 210 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = PD(1) + P01 = PD(2) + P20 = 0.5*PD(3) + P11 = PD(4) + P02 = 0.5*PD(5) + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 220 U = XII-X(1) + V = YII-Y(1) +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*P02) + P1 = P10+V*P11 + ZII = P0+U*(P1+U*P20) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concld.f b/sys/gio/ncarutil/conlib/concld.f new file mode 100644 index 00000000..6829d5fe --- /dev/null +++ b/sys/gio/ncarutil/conlib/concld.f @@ -0,0 +1,314 @@ + SUBROUTINE CONCLD (ICASE,IOOP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + INTEGER GOOP +C + SAVE + DATA GOOP/0/ +C +C STATEMENT FUNCTIONS FOR CONTOUR PLACEMENT WITHIN CELLS +C + CX(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + CY(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + IC = ICASE + ICASE = 0 +C +C SPECIAL PROCESSING IF SHIELDING ACTIVATED +C + IF (.NOT.SHIELD) GO TO 1 +C +C CHECK IF ANY CELL CORNER CONTAINS A SPECIAL VALUE +C IF SO THEN FLAG AND RETURN +C + IF (TR.NE.SPVAL.AND.BR.NE.SPVAL.AND.TL.NE.SPVAL.AND.BL.NE.SPVAL) + 1 GO TO 1 +C +C SPECIAL VALUE IN CELL FLAG AND RETURN +C + ICASE = -1 + RETURN +C +C IF CURRENT BR VALUE LESS THAN CONTOUR THEN NEIGHBOR WILL BE WHERE +C CONTOUR IS DRAWN. +C + 1 CONTINUE +C + IF (BR.LT.CONV) GO TO 90 +C +C CURRENT LOCATION IS WHERE CONTOUR WILL BE DRAWN +C +C TEST FOR VERTICAL CONTOUR BREAK +C + IF (BL.GE.CONV) GO TO 60 +C +C VERTICAL CONTOUR BREAK +C +C CASE 1 LEFT NEIGHBOR LESS THAN CONTOUR LEVEL AND CURRENT +C LOCATION GE CONTOUR VALUE +C + IF (TR.GE.CONV) GO TO 40 +C +C CASE 1A CONTOUR LOWER RIGHT +C +C +C CONTOUR FROM UPPER RIGHT +C + XO = XC-CX(BR,TR) + YO = YC + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 4 + IF (IC.NE.3) GO TO 10 + ICASE = IOC + XN = XO + YN = YO + RETURN + 10 IF (IOOP.NE.GOOP) GO TO 20 + IF (IC.NE.2) GO TO 30 + 20 ICASE = NC + RETURN +C +C CASE 1B CONTOR UPPER LEFT +C + 30 XN = XC-STPSZ + YN = YC-STPSZ+CY(TL,TR) + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + IOC = 2 + NC = 3 + GO TO 180 +C +C CONTOURS FROM ABOVE AND UPPER LEFT +C + 40 IF (TL.LT.CONV) GO TO 50 +C +C CASE 1C CONTOUR LOWER LEFT +C + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 2 + GO TO 180 +C +C CASE 1D CONTOUR FROM ABOVE +C + 50 XO = XC-STPSZ + YO = YC-CY(TR,TL) + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C +C TEST FOR HORIZONTAL CONTOUR BREAK +C + 60 IF (TR.LT.CONV) GO TO 70 + IF (TL.GE.CONV) GO TO 200 +C +C CASE 2A CONTOUR UPPER LEFT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-CX(BL,TL) + YN = YC-STPSZ + NC = 2 + IOC = 3 + GO TO 180 +C + 70 IF (TL.LT.CONV) GO TO 80 +C +C CASE 2B CONTOUR FROM UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 2C CONTOUR FROM LEFT TO RIGHT +C + 80 XO = XC-CX(BL,TL) + YO = YC-STPSZ + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 2 + GO TO 180 +C +C +C CURRENT BR VALUE LESS THAN CONTOUR +C +C + 90 IF (BL.LT.CONV) GO TO 150 +C +C VERTICAL CONTOUR BREAK +C +C CASE 3 CURRENT SPACE LESS THAN CONTOUR LEVEL AND LEFT +C NEIGHBOR GE CONTOUR LEVEL +C + IF (TL.GE.CONV) GO TO 130 +C +C CASE 3A CONTOUR LOWER LEFT +C + XO = XC-CX(BL,TL) + YO = YC-STPSZ + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 2 + IF (IC.NE.3) GO TO 100 + ICASE = IOC + XN = XO + YN = YO + RETURN + 100 IF (IOOP.NE.GOOP) GO TO 110 + IF (IC.NE.4) GO TO 120 + 110 ICASE = NC + RETURN +C +C CASE 3B CONTOUR UPPERRIGHT +C + 120 XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C + 130 IF (TR.GE.CONV) GO TO 140 +C +C CASE 3C CONTOUR FROM ABOVE +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C CASE 3D CONTOUR LOWER RIGHT +C + 140 XO = XC-STPSZ+CX(TR,BR) + YO = YC + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 4 + GO TO 180 +C +C +C +C TEST FOR HORIZONTAL BREAK POINT +C + 150 IF (TR.GE.CONV) GO TO 160 +C + IF (TL.LT.CONV) GO TO 200 +C +C CASE 4A CONTOUR UPPER LEFT +C + XN = XC-STPSZ+CX(TL,BL) + YN = YC-STPSZ + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + NC = 2 + IOC = 3 + GO TO 180 +C + 160 IF (TL.GE.CONV) GO TO 170 +C +C CASE 4B CONTOUR UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 4C CONTOUR FROM LEFT TO RIGHT +C + 170 YO = YC-STPSZ + XO = XC-STPSZ+CX(TL,BL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 2 +C +C DRAW THE CONTOUR LINES NOT ALREADY TAKEN CARE OF +C + 180 IF (IABS(IC-NC).NE.2) GO TO 190 + ICASE = IOC + XN = XO + YN = YO + RETURN + 190 ICASE = NC + 200 RETURN + END diff --git a/sys/gio/ncarutil/conlib/concls.f b/sys/gio/ncarutil/conlib/concls.f new file mode 100644 index 00000000..02d97a4d --- /dev/null +++ b/sys/gio/ncarutil/conlib/concls.f @@ -0,0 +1,177 @@ + SUBROUTINE CONCLS (ZD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C GENERATE CONTOUR LEVELS BASED ON THE INPUT DATA +C + DIMENSION ZD(1) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C IF NOT USER SET COMPUTE CONTOUR LEVELS +C + IF (.NOT.CON) GO TO 150 +C +C OTHERWISE GET HI AND LOW CONTOURS FOR MESSAGE +C + HI = CL(1) + FLO = CL(1) + DO 110 I=1,NCL + IF (HI .GE. CL(I)) GO TO 100 + HI = CL(I) + GO TO 110 + 100 IF (FLO .LE. CL(I)) GO TO 110 + FLO = CL(I) + 110 CONTINUE +C +C GET INCREMENT IF EQUAL SPACED CONTOURS +C + IF (NCL .NE. 1) GO TO 120 + FINC = 0. + RETURN + 120 FINC = ABS(CL(1)-CL(2)) + IF (NCL .EQ. 2) RETURN + DO 130 I=3,NCL + IF (FINC .NE. ABS(CL(I-1)-CL(I))) GO TO 140 + 130 CONTINUE + RETURN + 140 FINC = -1. + RETURN +C +C FIND HIGHEST AND LOWEST INPUT VALUES +C + 150 IF (CHILO) GO TO 180 + FLO = ZD(1) + HI = ZD(1) + DO 170 I=2,NDP + IF (FLO .LE. ZD(I)) GO TO 160 + FLO = ZD(I) + GO TO 170 + 160 IF (HI .GE. ZD(I)) GO TO 170 + HI = ZD(I) + 170 CONTINUE +C +C CALCULATE THE CONTOUR LEVEL INTERVAL +C + 180 IF (CINC) GO TO 200 + FINC = (HI-FLO)/15. + IF (FINC .NE. 0.) GO TO 190 + CALL SETER (' CONCLS - CONSTANT INPUT FIELD',1,1) + RETURN +C +C ROUND FINC TO NICE NUMBER +C + 190 P = 10.**(IFIX(ALOG10(FINC)+500.)-500) + FINC = AINT(FINC/P+0.1)*P +C +C ROUND THE LOW VALUE TO START AT A NICE NUMBER +C + 200 IF (CHILO) GO TO 210 + FLO = AINT(FLO/FINC)*FINC +C +C COMPUTE THE CONTOUR LEVELS +C +C TEST IF BREAK POINT WITHIN RANGE OF HI TO FLO +C + 210 IF (BPSIZ.GE.FLO .AND. BPSIZ.LE.HI) GO TO 240 +C +C BREAK POINT OUT OF RANGE SO GENERATE CONTOURS BASED ON FLO +C + DO 220 I=1,30 + CV = FLO+FLOAT(I-1)*FINC + ICUR = I + CL(I) = CV + IF (CV .GE. HI) GO TO 230 + 220 CONTINUE + 230 NCL = ICUR + HI = CV + RETURN +C +C BREAK POINT WITHIN RANGE SO BASE CONTOURS ON IT +C + 240 DO 250 I=1,30 + CV = BPSIZ-FLOAT(I-1)*FINC + IND = (30-I)+1 + CL(IND) = CV + ICUR = I + IF (CV .LE. FLO) GO TO 260 + 250 CONTINUE +C +C PUT THE CONTOURS IN THE CORRECT ORDER +C + 260 DO 270 I=1,ICUR + IND = (30-ICUR)+I + CL(I) = CL(IND) + 270 CONTINUE +C +C ADD THE GREATER THAN BREAK POINT CONTOURS +C + IEND = 30-ICUR + ISAV = ICUR+1 + DO 280 I=1,IEND + CV = BPSIZ+FLOAT(I)*FINC + CL(ISAV) = CV + ISAV = ISAV+1 + IF (CV .GE. HI) GO TO 290 + 280 CONTINUE +C +C SET NUMBER OF CONTOUR LEVELS AND UPDATE THE HIGH VALUE +C + 290 NCL = ISAV-1 + HI = CV + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concom.f b/sys/gio/ncarutil/conlib/concom.f new file mode 100644 index 00000000..8a5041df --- /dev/null +++ b/sys/gio/ncarutil/conlib/concom.f @@ -0,0 +1,78 @@ + FUNCTION CONCOM (XQ,YQ,XD,YD,ZD,NDP,WK,IWK,LOC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C INTERPOLATE A GIVEN X,Y PAIR AND RETURN ITS LOCATION +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,WK(1) , + 1 IWK(1) +C + SAVE +C +C LOCATE PROPER TRIANGLE +C + CALL CONLOC (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),XQ,YQ,LOC, + 1 IWK(JWIWL),WK) +C +C INTERPOLATE THE LOCATION +C + CALL CONCAL (XD,YD,ZD,NT,IWK(JWIPT),NL,IWK(JWIPL),WK(IPR),LOC,XQ, + 1 YQ,TEMP,ITPV) + CONCOM = TEMP + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condet.f b/sys/gio/ncarutil/conlib/condet.f new file mode 100644 index 00000000..6b3a3077 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condet.f @@ -0,0 +1,128 @@ + SUBROUTINE CONDET (NDP,XD,YD,NCP,IPC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN , CONRAQ AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C THIS SUBROUTINE SELECTS SEVERAL DATA POINTS THAT ARE CLOSEST +C TO EACH OF THE DATA POINT. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS CONTAINING THE X AND Y COORDINATES +C OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS CLOSEST TO EACH DATA +C POINTS. +C THE OUTPUT PARAMETER IS +C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP, WHERE THE +C POINT NUMBERS OF NCP DATA POINTS CLOSEST TO +C EACH OF THE NDP DATA POINTS ARE TO BE STORED. +C THIS SUBROUTINE ARBITRARILY SETS A RESTRICTION THAT NCP MUST +C NOT EXCEED 25 WITHOUT MODIFICATION TO THE ARRAYS DSQ0 AND IPC0. +C DECLARATION STATEMENTS +C + COMMON /CONRA3/ IREC + DIMENSION XD(NDP) ,YD(NDP) ,IPC(1) + DIMENSION DSQ0(25) ,IPC0(25) +C + SAVE +C +C STATEMENT FUNCTION +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 +C +C CALCULATION +C + DO 220 IP1=1,NDP +C +C - SELECTS NCP POINTS. +C + X1 = XD(IP1) + Y1 = YD(IP1) + J1 = 0 + DSQMX = 0.0 + DO 110 IP2=1,NDP + IF (IP2 .EQ. IP1) GO TO 110 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + J1 = J1+1 + DSQ0(J1) = DSQI + IPC0(J1) = IP2 + IF (DSQI .LE. DSQMX) GO TO 100 + DSQMX = DSQI + JMX = J1 + 100 IF (J1 .GE. NCP) GO TO 120 + 110 CONTINUE + 120 IP2MN = IP2+1 + IF (IP2MN .GT. NDP) GO TO 150 + DO 140 IP2=IP2MN,NDP + IF (IP2 .EQ. IP1) GO TO 140 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .GE. DSQMX) GO TO 140 + DSQ0(JMX) = DSQI + IPC0(JMX) = IP2 + DSQMX = 0.0 + DO 130 J1=1,NCP + IF (DSQ0(J1) .LE. DSQMX) GO TO 130 + DSQMX = DSQ0(J1) + JMX = J1 + 130 CONTINUE + 140 CONTINUE +C +C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR. +C + 150 IP2 = IPC0(1) + DX12 = XD(IP2)-X1 + DY12 = YD(IP2)-Y1 + DO 160 J3=2,NCP + IP3 = IPC0(J3) + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .NE. 0.0) GO TO 200 + 160 CONTINUE +C +C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT. +C + NCLPT = 0 + DO 190 IP3=1,NDP + IF (IP3 .EQ. IP1) GO TO 190 + DO 170 J4=1,NCP + IF (IP3 .EQ. IPC0(J4)) GO TO 190 + 170 CONTINUE + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .EQ. 0.0) GO TO 190 + DSQI = DSQF(X1,Y1,XD(IP3),YD(IP3)) + IF (NCLPT .EQ. 0) GO TO 180 + IF (DSQI .GE. DSQMN) GO TO 190 + 180 NCLPT = 1 + DSQMN = DSQI + IP3MN = IP3 + 190 CONTINUE + DSQMX = DSQMN + IPC0(JMX) = IP3MN +C +C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY. +C + 200 J1 = (IP1-1)*NCP + DO 210 J2=1,NCP + J1 = J1+1 + IPC(J1) = IPC0(J2) + 210 CONTINUE + 220 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condrw.f b/sys/gio/ncarutil/conlib/condrw.f new file mode 100644 index 00000000..df47eae9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condrw.f @@ -0,0 +1,253 @@ + SUBROUTINE CONDRW (SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW ALL CONTOURS AT THIS LEVEL +C IF NOT EXTRAPOLATING +C SEARCH CONVEX HULL FOR CONTOURS INTERSECTING IT AND DRAW THEM +C SEARCH INTERIOR AND DRAW ALL REMAINING UNDRAWN CONTOURS +C +C IF EXTRAPOLATING +C SEARCH FROM X START TO X END AND Y START TO Y END FOR ALL +C CONTOURS AT THIS LEVEL +C +C INPUT +C SCRARR SCRATCH ARRAY USED FOR FAST CONTOURING +C VIA COMMON BLOCKS BELOW +C CONV-THE CURRENT CONTOUR LEVEL +C ITLOC-THE CONVEX HULL BOUNDRIES RELATIVE TO THE SCRATCH +C ARRAY, SCRARR +C PV-REAL Y COOORDINATES OF THE CONVEX HULL RELATIVE TO THE +C USERS COORDINATE SPACE +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C +C OUTPUT +C CONTOUR LINES OUTPUT TO PLOTTER FILE +C +C NOTE +C THIS ROUTINE WILL DETECT AND CORRECT FOR CONRAN ERROR 9 +C + DIMENSION SCRARR(1) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C +C FLAGS TO ALLOW COMPRESSION OF CONTOUR STORAGE IF IT IS EXAUSTED +C + DATA ICOMP,NOCOMP/1,0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C CLEAR THE CONTOUR STORAGE LIST +C + NP = 0 +C +C SCAN X BOARDERS FOR INTERSECTIONS +C + JX = 2 + ICASE = 1 + X = XST+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 10 IF (.NOT.EXTRAP) GO TO 20 + JY = 2 + JYE = IYMAX + Y = YST+STPSZ + GO TO 30 +C +C NOT EXTRAPOLATING +C + 20 JY = ITLOC(JX*2-1) + IF (JY.EQ.0) GO TO 60 + JYE = ITLOC(JX*2)+1 + IF (JYE.GT.IYMAX) JYE = IYMAX + Y = PV(JX*2-1) + IF (JY.GE.2) GO TO 30 + JY = 2 + Y = YST+STPSZ + 30 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 40 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 50 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 50 TL = TR + BL = BR + JY = JY+1 + Y = Y+STPSZ + IF (JY.LE.JYE) GO TO 40 + 60 IF (JX.EQ.IXMAX) GO TO 70 + JX = IXMAX + ICASE = 3 + X = XMAX + GO TO 10 +C +C SCAN Y BOARDERS +C + 70 IPOS = 1 + ICASE = 4 + 80 JX = 3 + X = XST+STPSZ+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 90 IF (.NOT.EXTRAP) GO TO 100 + JY = 2 + Y = YST+STPSZ + IF (IPOS.NE.0) GO TO 110 + JY = IYMAX + Y = YED + GO TO 110 +C +C NOT EXTRAPOLATING +C + 100 JY = ITLOC(JX*2 - IPOS ) + IF (JY.EQ.0) GO TO 120 + JY = JY + IPOS + Y = PV(JX*2 - IPOS) + STPSZ*(1*IPOS) + 110 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 120 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 120 JX = JX+1 + X = X+STPSZ + IF (JX.LE.IXMAX-1) GO TO 90 + IF (IPOS.EQ.0) GO TO 130 + IPOS = 0 + ICASE = 2 + GO TO 80 +C +C BOARDER SEARCH DONE CONTOUR INTERIOR +C +C INITIALIZE THE SEARCH +C + 130 JX = 3 + ICASE = 0 + X = XST+STPSZ+STPSZ + JXE = IXMAX-1 +C +C IF EXTRAPOLATING GO FROM BORDER TO BORDER +C + 140 IF (.NOT.EXTRAP) GO TO 150 + JY = 3 + JYE = IYMAX-1 + Y = YST+STPSZ+STPSZ + GO TO 160 +C +C NOT EXTRAPOLATING STAY IN HULL +C + 150 JY = ITLOC(JX*2 - 1)+2 + IF (JY.EQ.2) GO TO 190 + JYE = ITLOC(JX*2)-1 + Y = PV(JX*2 - 1)+STPSZ+STPSZ +C + 160 IF (JY.GT.JYE) GO TO 190 + TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 170 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,ICOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 180 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 180 JY = JY+1 + Y = Y+STPSZ + TL = TR + BL = BR + IF (JY.LE.JYE) GO TO 170 +C +C PROCESS EACH ROW OF INTERIOR +C + 190 X = X+STPSZ + JX = JX+1 + IF (JX.LE.JXE) GO TO 140 +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condsd.f b/sys/gio/ncarutil/conlib/condsd.f new file mode 100644 index 00000000..0ea5fb43 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condsd.f @@ -0,0 +1,54 @@ + SUBROUTINE CONDSD +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW THE OUTLINE OF THE SHIELD ON THE PLOT +C + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C GET THE START POINT +C + XS = XVS(1) + YS = YVS(1) +C +C MOVE TO THE START OF THE OUTLINE +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,0) +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 2,ICOUNT +C +C DRAW THE OUTLINE OF THE SHIELD +C + CALL FL2INT(XVS(IC),YVS(IC),IX,IY) + CALL PLOTIT(IX,IY,1) +C + 100 CONTINUE +C +C DRAW TO THE START +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conecd.f b/sys/gio/ncarutil/conlib/conecd.f new file mode 100644 index 00000000..56d8a934 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conecd.f @@ -0,0 +1,178 @@ + SUBROUTINE CONECD (VAL,IOUT,NUSED) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C ENCODE A NUMBER IN THE LEAST AMOUNT OF SPACE +C ON INPUT +C VAL THE NUMBER TO BE ENCODED +C ON OUTPUT +C IOUT CHARACTER STRING FILLED WITH THE ENCODED RESULT, MUST BE ABLE TO +C HOLD UP TO 9 CHARACTERS. +C +C NUSED NUMBER OF CHARACTERS IN IOUT +C +C VALUE INPUT WILL BE SCALED BY SCALE IN CONRA2 +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + CHARACTER*(*) IOUT + CHARACTER*6 IFMT1 +C +C +NOAO - Variables CHTMP and IT are not used. +C +C CHARACTER*9 CHTMP +C CHARACTER*1 IT +C +C -NOAO +C + SAVE +C + V = VAL +C +C IF VAL EQUALS ZERO EASY PROCESSING +C + IF (V.NE.0.) GO TO 20 + IOUT = '0.0' + NUSED = 3 + RETURN +C +C SCALE VALUE +C + 20 V = V*SCALE +C +C GET SIZE OF NUMBER +C + LOG = IFIX(ALOG10(ABS(V))+.1) + IF (IABS(LOG).GT.4) GO TO 60 +C +C COMPUTE FLOATING POINT FIELD +C + NS = IABS(LOG)+3 + ND = 1 + IF (LOG.GT.0) GO TO 40 +C +C LOG = 0 TEST FOR FRACTIONAL PART ONLY +C + IF (ALOG10( ABS(V) ).GE.0.) GO TO 30 +C +C NUMBER LT 1 BUT GREATER THAN ZERO IN ABSOLUTE VALUE +C + NS = 4 + ND = 1 + GO TO 40 +C +C NUMBER LESS THAN 10 BUT GE 1 +C + 30 ND = 1 + NS = 4 +C +C BUILD THE FORMAT +C + 40 IF (V.LT.0) NS = NS+1 + IFMT1 = '(F . )' +C +C INSERT THE FLOATING POINT FORMAT SIZE +C +C +NOAO - Scheme for creating format has been modified because it uses +C FTN internal writes. NOAO mods are written in lower case. +C +C WRITE(IT,'(I1)')NS +C IFMT1(3:3) = IT +C WRITE(IT,'(I1)')ND +C IFMT1(5:5) = IT +C + ifmt1(1:6) = '(f . )' + ifmt1(3:3) = char (ns + ichar ('0') + 1) + ifmt1(5:5) = char (nd + ichar ('0')) +C +C ENCODE THE DESIRED NUMBER +C +C WRITE(CHTMP,IFMT1)V +C IOUT = CHTMP +C + call encode (ns, ifmt1, iout, v) + + NUSED = NS + RETURN +C +C DATA LARGER THAN A NICE SIZE FORCE IT TO BE ENCODED +C +C 60 WRITE(CHTMP,'(E8.3)')V +C IOUT = CHTMP +C + 60 call encode (8, '(E8.3)', iout, v) +C +C -NOAO + NUSED = 8 + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONCOM TO ULIB * +C* AUGUST 1980 FIXED BOARDER CONTOUR DETECTION * +C* DECEMBER 1980 FIXED ERROR TRAP, CONTOUR REORDERING ALGORITHM * +C* AND ERROR MESSAGE 10 * +C* AUGUST 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED (MACHINE DEPENDENT) FUNCTION LOC; CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/congen.f b/sys/gio/ncarutil/conlib/congen.f new file mode 100644 index 00000000..c70cfe05 --- /dev/null +++ b/sys/gio/ncarutil/conlib/congen.f @@ -0,0 +1,454 @@ + SUBROUTINE CONGEN (XI,YI,IPACK,SCRARR,ICA) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW A CONTOUR AT THE CURRENT LEVEL +C +C INPUT +C XI YI LOWER RIGHT CORNER OF CELL +C IPACK-FLAG TO ALLOW REDUCTION OF COORDINATE PAIR STORAGE +C IF REQUIRED +C SCRARR-SCRATCH ARRAY OF CONTOUR VALUES +C ICA-ENTERING CASE CONDITIONS IF ANY REQUIRED +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(1) ,IXMOV(2) ,IYMOV(2) + CHARACTER*64 IHOLD + CHARACTER*23 IVOUT + INTEGER GOOP +C + SAVE + DATA NOOP,GOOP/1,0/ +C +C STATEMENT FUNCTIONS FOR MAPPING GRAPHICS OUTPUT +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C DRAW AN ENTIRE CONTOUR LINE WHEN A POTENTIAL START POINT IS +C PROVIDED +C +C SAVE STARTING CELL +C + XCS = XI + YCS = YI +C +C TEST IF VALID START POINT +C + ICASE = ICA + XC = XI + YC = YI + CALL CONCLD (ICASE,NOOP) +C +C IF NO CONTOUR RETURN +C + IF (ICASE.EQ.-1) RETURN + IF (ICASE.EQ.0) RETURN +C +C IF CONTOUR ALREADY DRAWN RETURN +C + ILOC = IOR(ISHIFT(JX,ISHFCT),JY) + IF (NP.EQ.0) GO TO 20 +C +C TEST IF CONTOUR FOUND +C + DO 10 I=1,NP + IF (ILOC.NE.ICOORD(I)) GO TO 10 + RETURN + 10 CONTINUE +C +C GET CORRECT OLD CASE +C + 20 IC = IOC + IF (ICASE.EQ.IOC) IC = NC +C +C SET UP STRUCTURE TO START IN OTHER DIRECTION FROM HERE IF CONTOUR +C UNEXPECTLY ENDS IN THIS DIRECTION +C + IFCASE = IC + IFOCSE = ICASE + FXO = XO + FYO = YO + LOOP = 1 +C +C SET UP IC TO SIMULATE EXIT FROM A PREVIOUS CELL +C + IC = MOD(IC+2,4) +C +C IF EXTRAPOLATING PASS ON +C + IF (EXTRAP) GO TO 60 +C +C TEST IF CONTOUR EXCEEDED BORDER LIMITS +C NOTE THAT ICASER CANNOT EQUAL 3 AT THIS POINT +C + GO TO ( 30, 40, 30, 50),ICASE +C +C EXIT FROM BOTTOM +C + 30 IF (JX.GE.IXMAX) RETURN + GO TO 60 +C +C EXIT FROM LEFT +C + 40 IF (JY.LE.ITLOC(JX*2 - 1)) RETURN + GO TO 60 +C +C EXIT FROM RIGHT +C + 50 IF (JY.GE.ITLOC(JX*2 - 1)) RETURN +C +C SAVE CELL INFO IF COMMING BACK +C + 60 TRT = TR + BRT = BR + TLT = TL + BLT = BL + IX = JX + IY = JY +C +C VALID CONTOUR START FOUND +C + XX = FX(XO,YO) + CALL FRSTD (XX,FY(XO,YO)) +C +C DRAW CONTOUR IN THIS CELL +C + 70 XX = FX(XN,YN) + CALL VECTD (XX,FY(XN,YN)) + XCSTOR = XC + YCSTOR = YC + IXSTOR = IX + IYSTOR = IY + IOLDC = IC + IC = ICASE +C +C ENTER COORDINATE PAIR OF CONTOUR IN LIST +C + NP = NP+1 + IF (NP.GT.MXXY) GO TO 180 + ICOORD(NP) = ILOC +C +C BRANCH TO APPROPIATE CODE DEPENDING ON CONTOUR EXIT FROM THE CELL +C + 80 GO TO ( 90, 110, 130, 150),IC +C +C EXIT FORM BOTTOM +C END CONTOUR IF ON CONVEX HULL +C + 90 IF (EXTRAP) GO TO 100 + IF (IY.LT.ITLOC(IX*2 - 1) .OR. IY-1.GT.ITLOC(IX*2)) GO TO 360 + 100 TR = BR + TL = BL + XC = XC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IX = IX+1 + IF (IX.GT.IXMAX) GO TO 360 + BR = SCRTCH(IX,IY) + BL = SCRTCH(IX,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM LEFT SIDE +C TEST IF IN CONVEX HULL +C + 110 IF (EXTRAP) GO TO 120 + IF (IY-1.LT.ITLOC( (IX-1)*2 - 1 ) .AND. IY-1.LT.ITLOC(IX*2 - 1)) + 1 GO TO 360 + 120 TR = TL + BR = BL + YC = YC-STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY-1 + IF (IY.LT.2) GO TO 360 + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM TOP +C END CONTOUR IF OUT OF CONVEX HULL +C + 130 IF (EXTRAP) GO TO 140 + IF (IY.LT.ITLOC( (IX-1)*2 - 1 ) .OR. IY-1.GT.ITLOC( (IX-1)*2 )) + 1 GO TO 360 + 140 BR = TR + BL = TL + XC = XC-STPSZ +C +C END CONTOUR IF OUTSIDE OF BORDER +C + IX = IX-1 + IF (IX.LT.2) GO TO 360 + TR = SCRTCH(IX-1,IY) + TL = SCRTCH(IX-1,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM RIGHT SIDE +C TEST IF ON CONVEX HULL +C + 150 IF (EXTRAP) GO TO 160 + IF (IY.GT.ITLOC( (IX-1)*2 ) .AND. IY.GT.ITLOC(IX*2)) GO TO 360 + 160 TL = TR + BL = BR + YC = YC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY+1 + IF (IY.GT.IYMAX) GO TO 360 + TR = SCRTCH(IX-1,IY) + BR = SCRTCH(IX,IY) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C END THE CONTOUR +C + 170 CALL LASTD + TR = TRT + BR = BRT + TL = TLT + BL = BLT + RETURN +C +C CONTOUR STORAGE EXCEEDED TRY PACKING +C + 180 IF (IPACK.EQ.0) GO TO 200 + NP = 0 + ITEST = IOR(ISHIFT(JX,ISHFCT),JY) + DO 190 K=1,MXXY + IF (ICOORD(K).LE.ITEST) GO TO 190 + NP = NP+1 + ICOORD(NP) = ICOORD(K) + 190 CONTINUE + IF (NP.LT.MXXY) GO TO 80 +C +C FAILURE NO MORE SPACE ABORT THIS CONTOUR LEVEL +C + 200 IHOLD(1:39) = ' CONDRW-CONTOUR STORAGE EXAUSTED LEVEL=' +C +C BLANK FILL THE ENCODE ARRAY +C + IVOUT = ' ' +C +NOAO - FTN internal write rewritten as encode for IRAF. +C +C WRITE(IVOUT,'(G13.5)')CONV + call encode (13, '(g13.5)', ivout, conv) +C +C -NOAO + IHOLD(40:62) = IVOUT + CALL SETER (IHOLD,10,IREC) + RETURN +C +C BAD TIME THE CONTOUR EXITED A CORNER OF THE CELL MUST SEARCH FOR +C NEW CELL +C + 230 IXSTP = IXSTOR + IYSTP = IYSTOR + GO TO ( 240, 250, 260, 270),IOLDC +C +C PREVIOUS CELL BOTTOM EXIT +C + 240 IXSTP = IXSTP-1 + GO TO 280 +C +C PREVIOUS CELL LEFT EXIT +C + 250 IYSTP = IYSTP+1 + GO TO 280 +C +C PREVIOUS CELL TOP EXIT +C + 260 IXSTP = IXSTP+1 + GO TO 280 +C +C PREVIOUS CELL RIGHT EXIT +C + 270 IYSTP = IYSTP-1 +C +C BRANCH TO CURRENT CELL CASE +C + 280 GO TO ( 290, 300, 310, 320),IC +C +C APPARENT BOTTOM EXIT +C + 290 IXMOV(1) = 0 + IXMOV(2) = 1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT LEFT EXIT +C + 300 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = -1 + GO TO 330 +C +C APPARENT TOP EXIT +C + 310 IXMOV(1) = 0 + IXMOV(2) = -1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT RIGHT EXIT +C + 320 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = 1 +C +C SEARCH THE POSSIBLE CELLS +C + 330 DO 350 K=1,2 + DO 340 L=1,2 + XC = XCSTOR + STPSZ*FLOAT( IXMOV(K) ) + YC = YCSTOR + STPSZ*FLOAT( IYMOV(L) ) + IX = IXSTOR+IXMOV(K) + IY = IYSTOR+IYMOV(L) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C IF BACK TO START END CONTOUR +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 +C +C IF AT PREVIOUS CELL SKIP PROCESSING +C + IF (IX.EQ.IXSTP .AND. IY.EQ.IYSTP) GO TO 340 +C +C COMPUTE CELL VALUES +C + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) + TR = SCRTCH(IX-1,IY) + BL = SCRTCH(IX,IY) + ICASE = IC + CALL CONCLD (ICASE,NOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 +C +C FAILURE TRY AGAIN +C + 340 CONTINUE + 350 CONTINUE +C +C NO MORE CONTOUR TRY OTHER END OF LINE +C + 360 IF (LOOP.EQ.0) GO TO 170 + LOOP = 0 + IX = JX + IY = JY + TR = TRT + TL = TLT + BR = BRT + BL = BLT + IC = IFCASE + ICASE = IC + IOLDC = IFOCSE + XC = XI + YC = YI + IXSTOR = IX + IYSTOR = IY + YCSTOR = YI + XCSTOR = XI + XX = FX(FXO,FYO) + CALL LASTD + CALL FRSTD (XX,FY(FXO,FYO)) + GO TO ( 90, 110, 130, 150),IC + END diff --git a/sys/gio/ncarutil/conlib/conint.f b/sys/gio/ncarutil/conlib/conint.f new file mode 100644 index 00000000..84a1be82 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conint.f @@ -0,0 +1,147 @@ + SUBROUTINE CONINT (NDP,XD,YD,ZD,NCP,IPC,PD) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE ESTIMATES PARTIAL DERIVATIVES OF THE FIRST AND +C SECOND ORDER AT THE DATA POINTS. +C THE INPUT PARAMETERS ARE +C +C NDP = NUMBER OF DATA POINTS, +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z COORDI- +C NATES OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS TO BE USED FOR ESTIMATION +C OF PARTIAL DERIVATIVES AT EACH DATA POINT, +C IPC = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C NCP DATA POINTS CLOSEST TO EACH OF THE NDP DATA +C POINT. +C THE OUTPUT PARAMETER IS +C +C PD = ARRAY OF DIMENSION 5*NDP, WHERE THE ESTIMATED +C +C ZX, ZY, ZXX, ZXY, AND ZYY VALUES AT THE DATA +C POINTS ARE TO BE STORED. +C DECLARATION STATEMENTS +C +C + DIMENSION XD(NDP) ,YD(NDP) ,ZD(NDP) ,IPC(1) , + 1 PD(1) + REAL NMX ,NMY ,NMZ ,NMXX , + 1 NMXY ,NMYX ,NMYY +C + SAVE +C +C PRELIMINARY PROCESSING +C +C + NCPM1 = NCP-1 +C +C ESTIMATION OF ZX AND ZY +C +C + DO 130 IP0=1,NDP + X0 = XD(IP0) + Y0 = YD(IP0) + Z0 = ZD(IP0) + NMX = 0.0 + NMY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 120 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + DZ1 = ZD(IPI)-Z0 + IC2MN = IC1+1 + DO 110 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 110 + DZ2 = ZD(IPI)-Z0 + DNMX = DY1*DZ2-DZ1*DY2 + DNMY = DZ1*DX2-DX1*DZ2 + IF (DNMZ .GE. 0.0) GO TO 100 + DNMX = -DNMX + DNMY = -DNMY + DNMZ = -DNMZ + 100 NMX = NMX+DNMX + NMY = NMY+DNMY + NMZ = NMZ+DNMZ + 110 CONTINUE + 120 CONTINUE + JPD0 = 5*IP0 + PD(JPD0-4) = -NMX/NMZ + PD(JPD0-3) = -NMY/NMZ + 130 CONTINUE +C +C ESTIMATION OF ZXX, ZXY, AND ZYY +C +C + DO 170 IP0=1,NDP + JPD0 = JPD0+5 + X0 = XD(IP0) + JPD0 = 5*IP0 + Y0 = YD(IP0) + ZX0 = PD(JPD0-4) + ZY0 = PD(JPD0-3) + NMXX = 0.0 + NMXY = 0.0 + NMYX = 0.0 + NMYY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 160 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + JPD = 5*IPI + DZX1 = PD(JPD-4)-ZX0 + DZY1 = PD(JPD-3)-ZY0 + IC2MN = IC1+1 + DO 150 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 150 + JPD = 5*IPI + DZX2 = PD(JPD-4)-ZX0 + DZY2 = PD(JPD-3)-ZY0 + DNMXX = DY1*DZX2-DZX1*DY2 + DNMXY = DZX1*DX2-DX1*DZX2 + DNMYX = DY1*DZY2-DZY1*DY2 + DNMYY = DZY1*DX2-DX1*DZY2 + IF (DNMZ .GE. 0.0) GO TO 140 + DNMXX = -DNMXX + DNMXY = -DNMXY + DNMYX = -DNMYX + DNMYY = -DNMYY + DNMZ = -DNMZ + 140 NMXX = NMXX+DNMXX + NMXY = NMXY+DNMXY + NMYX = NMYX+DNMYX + NMYY = NMYY+DNMYY + NMZ = NMZ+DNMZ + 150 CONTINUE + 160 CONTINUE + PD(JPD0-2) = -NMXX/NMZ + PD(JPD0-1) = -(NMXY+NMYX)/(2.0*NMZ) + PD(JPD0) = -NMYY/NMZ + 170 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlcm.f b/sys/gio/ncarutil/conlib/conlcm.f new file mode 100644 index 00000000..80791d49 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlcm.f @@ -0,0 +1,65 @@ + FUNCTION CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,LOC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C COMPUTE A Z VALUE FOR A GIVEN X,Y VALUE +C NOTE THAT X,Y MUST BE INSIDE THE CONVEX HULL OF THE INPUT DATA +C INORDER FOR THIS FUNCTION TO WORK. +C +C INPUT +C X-X COORDINATE OF REQUESTED POINT +C Y-Y COORDINATE OF REQUESTED POINT +C WK-LIST OF COEFICENTS FOR LINEAR INTERPOLATION FUNCTIONS +C LOCATED BY A = WK((TRI-1)*3+1) +C B = WK((TRI-2)*3+1) +C C = WK((TRI-3)*3+1) +C +C OUTPUT +C LOC-TRIANGLE NUMBER OF REQUESTED POINT +C Z VALUE AS FUNCTION RESULT +C + DIMENSION WK(1),IWK(1),XD(1),YD(1),ZD(1) +C + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV +C + SAVE +C +C LOCATE THE TRIANGLE +C + CALL CONLOC(NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),X,Y,LOC, + 1 IWK(JWIWL),WK) +C +C IF OUTSIDE CONVEX HULL THEN DON'T COMPUTE A VALUE +C + IF (LOC.GT.NT) RETURN +C +C GET THE VECTOR 1 VALUES FOR THE TRIANGLE +C + IVEC = (LOC-1)*3 + JWIPT + IV = IWK(IVEC) + X1 = X - XD(IV) + Y1 = Y - YD(IV) + Z1 = ZD(IV) +C +C COMPUT THE Z VALUE +C + IPOINT = (LOC-1)*3 + IPR +C + Z = (WK(IPOINT)*X1+WK(IPOINT+1)*Y1)/WK(IPOINT+2) + Z1 +C + CONLCM = Z +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlin.f b/sys/gio/ncarutil/conlib/conlin.f new file mode 100644 index 00000000..f940d48c --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlin.f @@ -0,0 +1,68 @@ + SUBROUTINE CONLIN(XD,YD,ZD,NT,IWK,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE GENERATES THE COORDINATES USED IN A LINEAR INTERPOLATION +C OF THE TRIANGLES CREATED FROM IRREGULARLY DISTRIBUTED DATA. +C +C INPUT +C XD-X INPUT COORDINATES] +C YD-Y INPUT COORDINATES +C ZD-Z VALUE AT INPUT X,Y +C NT-NUMBER OF TRIANGLES GENERATED +C IWK-LIST OF TRIANGLE POINTS, RELATIVE TO XD,YD +C GROUPED 3 PER TRIANGLE I.E. TRIANGLE 1 IWK(1,2,3), +C TRIANGLE 2 IWK(4,5,6) ETC. +C +C OUTPUT +C WK ARRAY OF COEFICENTS FOR LINEATION FORMUALS +C GROUPED 3 PER TRIANGLE +C POINTS ARE (TRI-1)*3 + 1,2,3 +C + DIMENSION IWK(1),WK(1),XD(1),YD(1),ZD(1) +C + SAVE +C +C LOOP FOR ALL TRIANGLES +C + DO 1000 ITRI = 1,NT +C +C GET THE POINTS OF THE TRIANGLE +C + IPOINT = (ITRI-1)*3 + IP1 = IWK(IPOINT+1) + IP2 = IWK(IPOINT+2) + IP3 = IWK(IPOINT+3) +C +C GET THE VALUES AT THE TRIANBGLE POINTS +C + X1 = XD(IP1) + Y1 = YD(IP1) + Z1 = ZD(IP1) + X2 = XD(IP2) + Y2 = YD(IP2) + Z2 = ZD(IP2) + X3 = XD(IP3) + Y3 = YD(IP3) + Z3 = ZD(IP3) +C +C COMPUTE THE INTERPLOATING COEFICIENTS +C + WK(IPOINT+1) = (Y2-Y1)*(Z3-Z1)-(Y3-Y1)*(Z2-Z1) + WK(IPOINT+2) = (X3-X1)*(Z2-Z1)-(X2-X1)*(Z3-Z1) + WK(IPOINT+3) = (X3-X1)*(Y2-Y1)-(X2-X1)*(Y3-Y1) +C + 1000 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conloc.f b/sys/gio/ncarutil/conlib/conloc.f new file mode 100644 index 00000000..5907c9df --- /dev/null +++ b/sys/gio/ncarutil/conlib/conloc.f @@ -0,0 +1,256 @@ + SUBROUTINE CONLOC (NDP,XD,YD,NT,IPT,NL,IPL,XII,YII,ITI,IWK,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE LOCATES A POINT, I.E., DETERMINES TO WHAT TRI- +C ANGLE A GIVEN POINT (XII,YII) BELONGS. WHEN THE GIVEN POINT +C DOES NOT LIE INSIDE THE DATA AREA, THIS SUBROUTINE DETERMINES +C THE BORDER LINE SEGMENT WHEN THE POINT LIES IN AN OUTSIDE +C RECTANGULAR AREA, AND TWO BORDER LINE SEGMENTS WHEN THE POINT +C LIES IN AN OUTSIDE TRIANGULAR AREA. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y +C COORDINATES OF THE DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE +C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE +C POINT NUMBERS OF THE END POINTS OF THE BORDER +C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE +C NUMBERS, +C XII,YII = X AND Y COORDINATES OF THE POINT TO BE +C LOCATED. +C THE OUTPUT PARAMETER IS +C ITI = TRIANGLE NUMBER, WHEN THE POINT IS INSIDE THE +C DATA AREA, OR +C TWO BORDER LINE SEGMENT NUMBERS, IL1 AND IL2, +C CODED TO IL1*(NT+NL)+IL2, WHEN THE POINT IS +C OUTSIDE THE DATA AREA. +C THE OTHER PARAMETERS ARE +C IWK = INTEGER ARRAY OF DIMENSION 18*NDP USED INTER- +C NALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + DIMENSION XD(1) ,YD(1) ,IPT(1) ,IPL(1) , + 1 IWK(1) ,WK(1) +C +C +C + DIMENSION NTSC(9) ,IDSC(9) + COMMON /CONRA5/ NIT ,ITIPV +C + SAVE +C +C STATEMENT FUNCTIONS +C + SIDE(U1,V1,U2,V2,U3,V3) = (U1-U3)*(V2-V3)-(V1-V3)*(U2-U3) + SPDT(U1,V1,U2,V2,U3,V3) = (U1-U2)*(U3-U2)+(V1-V2)*(V3-V2) +C +C PRELIMINARY PROCESSING +C + NT0 = NT + NL0 = NL + NTL = NT0+NL0 + X0 = XII + Y0 = YII +C +C PROCESSING FOR A NEW SET OF DATA POINTS +C + IF (NIT .NE. 0) GO TO 170 + NIT = 1 +C +C - DIVIDES THE X-Y PLANE INTO NINE RECTANGULAR SECTIONS. +C + XMN = XD(1) + XMX = XMN + YMN = YD(1) + YMX = YMN + DO 100 IDP=2,NDP + XI = XD(IDP) + YI = YD(IDP) + XMN = AMIN1(XI,XMN) + XMX = AMAX1(XI,XMX) + YMN = AMIN1(YI,YMN) + YMX = AMAX1(YI,YMX) + 100 CONTINUE + XS1 = (XMN+XMN+XMX)/3.0 + XS2 = (XMN+XMX+XMX)/3.0 + YS1 = (YMN+YMN+YMX)/3.0 + YS2 = (YMN+YMX+YMX)/3.0 +C +C - DETERMINES AND STORES IN THE IWK ARRAY TRIANGLE NUMBERS OF +C - THE TRIANGLES ASSOCIATED WITH EACH OF THE NINE SECTIONS. +C + DO 110 ISC=1,9 + NTSC(ISC) = 0 + IDSC(ISC) = 0 + 110 CONTINUE + IT0T3 = 0 + JWK = 0 + DO 160 IT0=1,NT0 + IT0T3 = IT0T3+3 + I1 = IPT(IT0T3-2) + I2 = IPT(IT0T3-1) + I3 = IPT(IT0T3) + XMN = AMIN1(XD(I1),XD(I2),XD(I3)) + XMX = AMAX1(XD(I1),XD(I2),XD(I3)) + YMN = AMIN1(YD(I1),YD(I2),YD(I3)) + YMX = AMAX1(YD(I1),YD(I2),YD(I3)) + IF (YMN .GT. YS1) GO TO 120 + IF (XMN .LE. XS1) IDSC(1) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(2) = 1 + IF (XMX .GE. XS2) IDSC(3) = 1 + 120 IF (YMX.LT.YS1 .OR. YMN.GT.YS2) GO TO 130 + IF (XMN .LE. XS1) IDSC(4) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(5) = 1 + IF (XMX .GE. XS2) IDSC(6) = 1 + 130 IF (YMX .LT. YS2) GO TO 140 + IF (XMN .LE. XS1) IDSC(7) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(8) = 1 + IF (XMX .GE. XS2) IDSC(9) = 1 + 140 DO 150 ISC=1,9 + IF (IDSC(ISC) .EQ. 0) GO TO 150 + JIWK = 9*NTSC(ISC)+ISC + IWK(JIWK) = IT0 + NTSC(ISC) = NTSC(ISC)+1 + IDSC(ISC) = 0 + 150 CONTINUE +C +C - STORES IN THE WK ARRAY THE MINIMUM AND MAXIMUM OF THE X AND +C - Y COORDINATE VALUES FOR EACH OF THE TRIANGLE. +C + JWK = JWK+4 + WK(JWK-3) = XMN + WK(JWK-2) = XMX + WK(JWK-1) = YMN + WK(JWK) = YMX + 160 CONTINUE + GO TO 200 +C +C CHECKS IF IN THE SAME TRIANGLE AS PREVIOUS. +C + 170 IT0 = ITIPV + IF (IT0 .GT. NT0) GO TO 180 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF ON THE SAME BORDER LINE SEGMENT. +C + 180 IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (IL2 .NE. IL1) GO TO 190 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF BETWEEN THE SAME TWO BORDER LINE SEGMENTS. +C + 190 IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 260 +C +C LOCATES INSIDE THE DATA AREA. +C - DETERMINES THE SECTION IN WHICH THE POINT IN QUESTION LIES. +C + 200 ISC = 1 + IF (X0 .GE. XS1) ISC = ISC+1 + IF (X0 .GE. XS2) ISC = ISC+1 + IF (Y0 .GE. YS1) ISC = ISC+3 + IF (Y0 .GE. YS2) ISC = ISC+3 +C +C - SEARCHES THROUGH THE TRIANGLES ASSOCIATED WITH THE SECTION. +C + NTSCI = NTSC(ISC) + IF (NTSCI .LE. 0) GO TO 220 + JIWK = -9+ISC + DO 210 ITSC=1,NTSCI + JIWK = JIWK+9 + IT0 = IWK(JIWK) + JWK = IT0*4 + IF (X0 .LT. WK(JWK-3)) GO TO 210 + IF (X0 .GT. WK(JWK-2)) GO TO 210 + IF (Y0 .LT. WK(JWK-1)) GO TO 210 + IF (Y0 .GT. WK(JWK)) GO TO 210 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 210 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 210 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 210 + GO TO 260 + 210 CONTINUE +C +C LOCATES OUTSIDE THE DATA AREA. +C + 220 DO 240 IL1=1,NL0 + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 240 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 230 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 240 + IL2 = IL1 + GO TO 250 + 230 IL2 = MOD(IL1,NL0)+1 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 250 + 240 CONTINUE + IT0 = 1 + GO TO 260 + 250 IT0 = IL1*NTL+IL2 +C +C NORMAL EXIT +C + 260 ITI = IT0 + ITIPV = IT0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlod.f b/sys/gio/ncarutil/conlib/conlod.f new file mode 100644 index 00000000..d7fc3804 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlod.f @@ -0,0 +1,194 @@ + SUBROUTINE CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION SCRARR(1) +C + SAVE +C +C IFR - FLAG TO REGISTER FIRST PASS IN Y DIRECTION +C +C LOAD THE SCRATCH SPACE AND CONVEX HULL POINTERS +C ITLOC IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO THE SCARTCH +C SPACE. +C PV IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO USER COORDINATES +C +C INITALIZE THE SPECIAL VALUE FEATURE +C + X = (XED-XST)/2. + XST + Y = (YED-YST)/2. + YST + IF(LINEAR) GO TO 1 + SPVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 2 + 1 SPVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 2 CONTINUE +C +C INITIALIZE THE SEARCH +C + IYMAX = 0 + IFR = 1 + JX = 1 + X = XST + 10 JY = 1 + Y = YST +C +C SET HULL POINTERS FOR THIS COLUMN TO NULL +C + ITLOC(JX*2-1) = 0 + ITLOC(JX*2) = 0 +C +C FLAG START OF COLUMN +C + LOOP = 1 +C +C GET INTERPOLATED VALUE +C + 20 IF (LINEAR) GO TO 3 + RVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 4 + 3 RVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 4 CONTINUE + SCRARR(JY+(JX-1)*IYMAX) = RVAL + IF (RVAL.GT.SPVAL) SPVAL = RVAL +C +C IF OUTSIDE CONVEX HULL BRANCH +C + IF (IT.GT.NTNL) GO TO 30 +C +C IF OUTSIDE TRIANGLES AND USING LINEAR INTERPLOATION THEN BRANCH +C + IF(LINEAR.AND.IT.GT.NT) GO TO 30 +C +C IF FIRST OF COLUMN IN HULL CONTINUE THROUGH +C + IF (LOOP.NE.1) GO TO 40 +C +C SET HULL POINTERS +C + PV(JX*2-1) = Y + ITLOC(JX*2-1) = JY +C +C SET FLAG TO LOOK FOR END OF HULL IN COLUMN +C + LOOP = 2 +C +C GO FOR NEXT ENTRY +C + GO TO 40 +C +C TEST FOR END OF CONVEX HULL ON THIS ROW +C + 30 IF (LOOP.NE.2) GO TO 40 +C +C END OF HULL SET POINTERS FOR END OF HULL AND FLAG IT VIA LOOP +C + LOOP = 0 + ITLOC(JX*2) = JY-1 + PV(JX*2) = Y-STPSZ +C +C GET NEXT ELEMENT IN ROW IF NOT OUTSIDE ENCLOSING RECTANGULAR +C BOARDER +C + 40 Y = Y+STPSZ + JY = JY+1 + IF (Y.LE.YED) GO TO 20 +C +C TEST FOR FIRST COLUMN +C + IF (IFR.NE.1) GO TO 50 +C +C FIRST COLUMN OVER SET MAX Y VALUES +C + IYMAX = JY-1 + YMAX = Y-STPSZ + IFR = 0 +C +C IF HULL WENT TO EDGE OF RECTANGULAR BOARDER SET HULL POINTERS HERE +C + 50 IF (LOOP.NE.2) GO TO 60 + PV(JX*2) = Y-STPSZ + ITLOC(JX*2) = JY-1 +C +C END OF COLUMN GET NEXT ONE +C + 60 X = X+STPSZ + JX = JX+1 +C +C IF NOT END OF WORK CONTINUE WITH NEXT COLUMN +C + IF (X.LE.XED) GO TO 10 +C +C END OF WORK SET MAX X VALUES +C + IXMAX = JX-1 + XMAX = X-STPSZ + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop1.f b/sys/gio/ncarutil/conlib/conop1.f new file mode 100644 index 00000000..fc61872d --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop1.f @@ -0,0 +1,465 @@ + SUBROUTINE CONOP1 (IOPT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +c +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE OPTION AND ITS VALUE +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C REP FOUND CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'RE') THEN +C +C SWITCH = ON CONTOUR SAME DATA +C + IF (OPT .EQ. 'ON') THEN + REPEAT = .TRUE. + RETURN +C +C SWITCH = OFF CONTOUR NEW DATA +C + ELSEIF (OPT .EQ. 'OF') THEN + REPEAT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXTRAPOLATION FLAG +C + ELSEIF (TAG .EQ. 'EX') THEN +C +C SWITCH = ON EXTRAPOLATE WHEN CONTOURING +C + IF (OPT .EQ. 'ON') THEN + EXTRAP = .TRUE. + RETURN +C +C SWITCH = OFF INTERPOLATE ONLY +C + ELSEIF (OPT .EQ. 'OF') THEN + EXTRAP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PER FOUND SET PERIMETER +C + ELSEIF (TAG .EQ. 'PE') THEN +C +C SWITCH = ON DRAW PERIMETERS +C + IF (OPT .EQ. 'ON') THEN + PER = .TRUE. +C +C TURN GRID OFF, USER WANTS PERIMETER +C + GRD = .FALSE. + RETURN +C +C SWITCH = OFF DO NOT DRAW PERIMETERS +C + ELSEIF (OPT .EQ. 'OF') THEN + PER = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C DEF FOUND SET ALL OPTIONS TO DEFAULT (NO SWITCHES) +C + ELSEIF (TAG .EQ. 'DE') THEN + PER = .TRUE. + LISTOP = .FALSE. + PMIMX = .FALSE. + SCALE = 1. + TENSN = TENS + EXTRAP = .FALSE. + TITLE = .FALSE. + ITLSIZ = 16 + REPEAT = .FALSE. + MESS = .TRUE. + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. + IGRAD = IG + ISCALE = 0 + NCP = 4 + LOOK = .FALSE. + GRD = .FALSE. + PLDVLS = .FALSE. + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + BPSIZ = 0. + LABON = .TRUE. + ISIZEL = 9 + ISIZEP = 8 + ISIZEM = 15 + FRADV = .TRUE. + EXTRI = .FALSE. + MINGAP = 3 + LINEAR = .FALSE. + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. +C +C SET DEFAULT DASH PATTERN +C + IDASH = '$$$$$$$$$$' + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' +C +C SET DEFAULT FORMAT +C + FORM = '(G10.3)' + RETURN +C +C MES FOUND TEST VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'ME') THEN +C +C ACTIVATE CONRAN MESSAGE +C + IF (OPT .EQ. 'ON') THEN + MESS = .TRUE. + RETURN +C +C TURN OFF CONRAN MESSAGE +C + ELSEIF (OPT .EQ. 'OF') THEN + MESS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALING OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'SC') THEN +C +C SET VALUE OF SCALE FLAG +C + IF (OPT .EQ. 'ON') THEN + ISCALE = 0 + RETURN + ELSEIF (OPT .EQ. 'OF') THEN + ISCALE = 1 + RETURN + ELSEIF (OPT .EQ. 'PR') THEN + ISCALE = 2 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TRIANGLE FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'TR') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + LOOK = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + LOOK = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT DATA VALUES FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'PD') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + PLDVLS = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + PLDVLS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C GRID OPTION ACTIVATED GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'GR') THEN +C +C SWITCH ON SET GRID FLAG +C + IF (OPT .EQ. 'ON') THEN + GRD = .TRUE. +C +C TURN PER OFF USER WANTS GRID +C + PER = .FALSE. + RETURN +C +C SWITCH OFF CLEAR GRID FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + GRD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL PLOTTING FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LA') THEN +C +C SWITCH ON LABEL CONTOURS +C + IF (OPT .EQ. 'ON') THEN + LABON = .TRUE. + RETURN +C +C SWITCH OFF DON"T LABEL CONTOURS +C + ELSEIF (OPT .EQ. 'OF') THEN + LABON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT THE RELATIVE MIN"S AND MAX"S +C + ELSEIF (TAG .EQ. 'PM') THEN +C +C SWTICH ON PLOT THE INFO +C + IF (OPT .EQ. 'ON') THEN + PMIMX = .TRUE. + RETURN +C +C SWTICH OFF DO NOT PLOT THE INFO +C + ELSEIF (OPT .EQ. 'OF') THEN + PMIMX = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C ADVANCE FRAME BEFORE TRIANGULATION PLOT +C + ELSEIF (TAG .EQ. 'TF') THEN +C +C SWITCH ON ADVANCE FRAME +C + IF (OPT .EQ. 'ON') THEN + FRADV = .TRUE. + RETURN +C +C SWITCH OFF DO NOT ADVANCE FRAME +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXIT AFTER TRIANGULATION +C + ELSEIF (TAG .EQ. 'TO') THEN +C +C SWITCH ON EXIT AFTER TRIANGULATION +C + IF (OPT .EQ. 'ON') THEN + EXTRI = .TRUE. + LOOK = .TRUE. + FRADV = .FALSE. + RETURN +C +C SWITCH OFF DO NOT EXIT AFTER TRIANGULATION +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .TRUE. + LOOK = .FALSE. + EXTRI = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LIST OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LO') THEN +C +C ON SET LIST OPTIONS FLAG +C + IF (OPT .EQ. 'ON') THEN + LISTOP = .TRUE. + RETURN +C +C TURN OFF LIST OPTIONS FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + LISTOP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE INTERPOLATION SCHEME +C + ELSEIF (TAG .EQ. 'IT') THEN +C +C SET TO C1 SURFACE +C + IF (OPT .EQ. 'C1') THEN + LINEAR = .FALSE. + RETURN +C +C SET TO LINEAR INTERPOLATION +C + ELSEIF (OPT .EQ. 'LI') THEN + LINEAR = .TRUE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE SHIELD PLOT FLAG +C + ELSEIF (TAG .EQ. 'PS') THEN +C +C TURN ON SHIELD PLOT +C + IF (OPT .EQ. 'ON') THEN + SLDPLT = .TRUE. + RETURN +C +C TURN OFF SHIELD PLOT +C + ELSEIF (OPT .EQ. 'OF') THEN + SLDPLT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP1 -- UNDEFINED OPTION',1,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conop2.f b/sys/gio/ncarutil/conlib/conop2.f new file mode 100644 index 00000000..41dc27c3 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop2.f @@ -0,0 +1,316 @@ + SUBROUTINE CONOP2 (IOPT,ISIZE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ISIZE- INTEGER INPUT +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C SET RESOLUTION OF VIRTUAL GRID +C + IF (TAG .EQ. 'SS') THEN +C +C SWITCH = ON SET RESOLUTION OF VIRTUAL GRID +C + IF (OPT .EQ. 'ON') THEN + IGRAD = ISIZE + RETURN +C +C SWITCH = OFF RESET RESOLUTION TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + IGRAD = IG + RETURN + ELSE + GOTO 120 + ENDIF +C +C NCP OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'NC') THEN +C +C SWITCH ON GET VALUE FOR NUMBER OF SURROUNDING DATA POINTS TO USE +C + IF (OPT .EQ. 'ON') THEN + NCP = ISIZE + RETURN +C +C SWITCH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + NCP = 4 + RETURN + ELSE + GOTO 120 + ENDIF +C +C INTENSITY OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'IN') THEN +C +C SWITCH OFF SET DEFAULT VALUES +C + IF (OPT .EQ. 'OF') THEN + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + RETURN +C +C SET PLOTTED DATA INTENSITY +C + ELSEIF (OPT .EQ. 'DA') THEN + INDAT = ISIZE + RETURN +C +C SET TITLE AND MESSAGE INTENSITY +C + ELSEIF (OPT .EQ. 'LA') THEN + INLAB = ISIZE + IRANTX = ISIZE + IRASTX = ISIZE + IRAQTX = ISIZE + RETURN +C +C SET ALL INTENSITIES TO THE SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IRANMJ = ISIZE + IRANMN = ISIZE + IRANTX = ISIZE + IRASMJ = ISIZE + IRASMN = ISIZE + IRASTX = ISIZE + IRAQMJ = ISIZE + IRAQMN = ISIZE + IRAQTX = ISIZE + INMAJ = ISIZE + INMIN = ISIZE + INLAB = ISIZE + INDAT = ISIZE + RETURN +C +C SET MAJOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MA') THEN + IRANMJ = ISIZE + IRASMJ = ISIZE + IRAQMJ = ISIZE + INMAJ = ISIZE + RETURN +C +C SET MINOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MI') THEN + IRANMN = ISIZE + IRASMN = ISIZE + IRAQMN = ISIZE + INMIN = ISIZE + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL SIZE OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LS') THEN +C +C SWITCH ON GET USER LABEL SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEL = ISIZE + RETURN +C +C SWITCH OFF SET LABEL SIZE TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEL = 9 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZES OF MINIMUM AND MAXIMUM LABELS +C + ELSEIF (TAG .EQ. 'SM') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEM = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEM = 15 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZE OF THE PLOTTED DATA +C + ELSEIF (TAG .EQ. 'SP') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEP = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEP = 8 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TITLE SIZE SWITCH +C + ELSEIF (TAG .EQ. 'ST') THEN +C +C SWITCH ON SET THE TITLE SIZE +C + IF (OPT .EQ. 'ON') THEN + ITLSIZ = ISIZE + RETURN +C +C SWITCH OFF SET TITLE SIZE TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ITLSIZ = 16 + RETURN + ELSE + GOTO 120 + ENDIF +C +C MINOR LINE COUNT OPTION +C + ELSEIF (TAG .EQ. 'MI') THEN +C +C SET MINOR LINE COUNT +C + IF (OPT .EQ. 'ON') THEN + MINGAP = ISIZE+1 + RETURN +C +C SET MINOR LINE COUNT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + MINGAP = 3 + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP2 - UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop3.f b/sys/gio/ncarutil/conlib/conop3.f new file mode 100644 index 00000000..e4632478 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop3.f @@ -0,0 +1,266 @@ + SUBROUTINE CONOP3 (IOPT,ARRAY,ISIZE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ARRAY- REAL ARRAY OF DIMENSION ISIZE +C ISIZE- SIZE OF ARRAY +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + DIMENSION ARRAY(ISIZE) + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C CON CONTOUR LEVELS CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'CO') THEN +C +C SWITCH = ON SET CONTOUR LEVELS +C + IF (OPT .EQ. 'ON') THEN + IF (CHILO .OR. CINC) GOTO 140 +C +C TEST IF NUMBER OF CONTOURS IS ACCEPTABLE +C + IF (ISIZE .GT. 30) + 1 CALL SETER (' CONOP3-NUMBER OF CONTOUR LEVELS EXCEEDS 30', + 2 1,1) + DO 200 I=1,ISIZE + CL(I) = ARRAY(I) + 200 CONTINUE + CON = .TRUE. + NCL = ISIZE + RETURN +C +C SWITCH = OFF CLEAR CONTOUR LEVEL ARRAY (PROGRAM SELECTS) +C + ELSEIF (OPT .EQ. 'OF') THEN + CON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR HI LO OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CH') THEN +C +C SWITCH ON SET HI AND FLO +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + HI = ARRAY(1) + FLO = ARRAY(2) + CHILO = .TRUE. + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CHILO = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR INCREMENT OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CI') THEN +C +C SWITCH ON SET INCREMENT +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + CINC = .TRUE. + FINC = ARRAY(1) + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CINC = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALE THE DATA PLOTTED ON THE CONTOURS AND MIN MAX POINTS +C + ELSEIF (TAG .EQ. 'SD') THEN +C +C SWTICH ON GET SCALE FACTOR +C + IF (OPT .EQ. 'ON') THEN + SCALE = ARRAY(1) + RETURN +C +C SWTICH OFF SET FOR NO SCALING +C + ELSEIF (OPT .EQ. 'OF') THEN + SCALE = 1. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE TENSION VALUE FOR SMOOTHING +C + ELSEIF (TAG .EQ. 'TE') THEN +C +C SWTICH ON SET TENSION FACTOR +C + IF (OPT .EQ. 'ON') THEN + TENSN = ARRAY(1) + RETURN +C +C SWTICH OFF SET TO DEFAULT TENSION +C + ELSEIF (OPT .EQ. 'OF') THEN + TENSN = TENS + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN BREAK POINT SWITCH +C + ELSEIF (TAG .EQ. 'DB') THEN +C +C SWITCH ON GET USERS BREAKPOINT +C + IF (OPT .EQ. 'ON') THEN + BPSIZ = ARRAY(1) + RETURN +C +C SWITCH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + BPSIZ = 0. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SHIELD OPTION +C + ELSEIF (TAG .EQ. 'SL') THEN +C +C TURN SHIELDING ON AND SET THE SHIELD COORD POINTERS +C + IF (OPT .EQ. 'ON') THEN + NISIZE = ISIZE/2 + CALL CONSSD(ARRAY(1),ARRAY(NISIZE+1),NISIZE) + RETURN +C +C DEACTIVATE SHIELDING +C + ELSEIF (OPT .EQ. 'OF') THEN + ICOUNT = 0 + SHIELD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP3-UNDEFINED OPTION',1,1) + RETURN +C +C ILLEGAL USE OF CON WITH CIL OR CHL +C + 140 CALL SETER + 1('CONOP3-ILLEGAL USE OF CON OPTION WITH CIL OR CHL OPTION', + 2 1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop4.f b/sys/gio/ncarutil/conlib/conop4.f new file mode 100644 index 00000000..f963dcf9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop4.f @@ -0,0 +1,197 @@ + SUBROUTINE CONOP4 (IOPT,ARRAY,ISIZE,IFORT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT -- CHARACTER STRING OF OPTION VALUE +C ARRAY -- CHARACTER INPUT DATA +C ISIZE -- INTEGER INPUT +C IFORT -- INTEGER. THIS VALUE IS USED ONLY WHEN IOPT IS +C "FMT=ON". IN THIS CASE, IFORT IS THE TOTAL NUMBER +C OF CHARACTERS TO BE PROCESSED BY THE FORMAT +C STATEMENT. FOR EXAMPLE, FOR THE FORMAT "F10.3", +C IFORT SHOULD BE SET TO 10. +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*(*) ARRAY + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C TITLE OPTION GET VALUE OF SWITCH +C + IF (TAG .EQ. 'TL') THEN +C +C SWITCH ON GET TITLE AND COUNT FROM INPUT +C + IF (OPT .EQ. 'ON') THEN + TITLE = .TRUE. + ISTRNG = ARRAY + ICNT = ISIZE + RETURN +C +C SWITCH OFF OPTION DEACTIVATED +C + ELSEIF (OPT .EQ. 'OF') THEN + TITLE = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CHANGE DATA VALUE FORMAT +C + ELSEIF (TAG .EQ. 'FM') THEN +C +C SWITCH ON GET USER FORMAT +C + IF (OPT .EQ. 'ON') THEN + FORM = ARRAY + LEN = ISIZE + IFMT = IFORT + RETURN +C +C SWITCH OFF SET FORMAT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'DA') THEN +C +C SWITCH OFF DEFAULT PATTERNS +C + IF (OPT .EQ. 'OF') THEN + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' + IDASH = '$$$$$$$$$$' + RETURN +C +C SWITCH ALL SET GTR,LSS,AND EQU TO SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IDASH = ARRAY + EDASH = ARRAY + NDASH = ARRAY + RETURN +C +C SWITCH SET TO POS CHANGE POS DASH PATTERN +C + ELSEIF (OPT .EQ. 'GT') THEN + IDASH = ARRAY + RETURN +C +C SWITCH SET TO NEG SET NEG DASH PATTERN +C + ELSEIF (OPT .EQ. 'LS') THEN + NDASH = ARRAY + RETURN +C +C SWITCH SET TO EQU SET EQUAL DASH PATTERN +C + ELSEIF (OPT .EQ. 'EQ') THEN + EDASH = ARRAY + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP4-UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conot2.f b/sys/gio/ncarutil/conlib/conot2.f new file mode 100644 index 00000000..f2bc6aed --- /dev/null +++ b/sys/gio/ncarutil/conlib/conot2.f @@ -0,0 +1,178 @@ + SUBROUTINE CONOT2 (IVER,IUNIT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C OUTPUT THE OPTION VALUES TO THE LINE PRINTER +C +C CONTINUE FOR CONRAN AND CONRAS +C +C +C +C COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , +C 1 FINC ,HI ,FLO +C COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , +C 1 ISCALE ,LOOK ,PLDVLS ,GRD , +C 2 CINC ,CHILO ,CON ,LABON , +C 3 PMIMX ,SCALE ,FRADV ,EXTRI , +C 4 BPSIZ ,LISTOP +C COMMON /CONRA3/ IREC +C COMMON /CONRA4/ NCP ,NCPSZ +C COMMON /CONRA5/ NIT ,ITIPV +C COMMON /CONRA6/ XST ,YST ,XED ,YED , +C 1 STPSZ ,IGRAD ,IG ,XRG , +C 2 YRG ,BORD ,PXST ,PYST , +C 3 PXED ,PYED ,ITICK +C COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ +C COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , +C 1 LEN ,IFMT ,LEND , +C 2 IFMTD ,ISIZEP ,INMIN +C COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , +C 1 BR ,TL ,BL ,CONV , +C 2 XN ,YN ,ITLL ,IBLL , +C 3 ITRL ,IBRL ,XC ,YC , +C 4 ITLOC(210) ,JX ,JY ,ILOC , +C 5 ISHFCT ,XO ,YO ,IOC ,NC +C COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , +C 1 JWIWL ,JWIWP ,JWIPL ,IPR , +C 2 ITPV +C COMMON /CONR11/ NREP ,NCRT ,ISIZEL , +C 1 MINGAP ,ISIZEM , +C 2 TENS +C COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX +C LOGICAL REPEAT ,EXTRAP ,PER ,MESS , +C 1 LOOK ,PLDVLS ,GRD ,LABON , +C 2 PMIMX ,FRADV ,EXTRI ,CINC , +C 3 TITLE ,LISTOP ,CHILO ,CON +C COMMON /CONR15/ ISTRNG +C CHARACTER*64 ISTRNG +C COMMON /CONR16/ FORM +C CHARACTER*10 FORM +C COMMON /CONR17/ NDASH, IDASH, EDASH +C CHARACTER*10 NDASH, IDASH, EDASH +C +C +C SAVE +C +C LABEL THE CONTOURS +C +C WRITE (IUNIT,1001) +C IF (LABON) GO TO 100 +C WRITE (IUNIT,1002) +C GO TO 110 +C 100 WRITE (IUNIT,1003) +C +C LABEL SIZE +C +C 110 WRITE (IUNIT,1004) ISIZEL +C +C SCALE DATA ON CONTOURS +C +C WRITE (IUNIT,1005) +C IF (SCALE .NE. 1.) GO TO 120 +C WRITE (IUNIT,1006) +C GO TO 130 +C 120 WRITE (IUNIT,1007) SCALE +C +C TENSION FACTOR +C +C 130 WRITE (IUNIT,1008) TENS +C +C PLOT RELATIVE MINS AND MAXS +C +C WRITE (IUNIT,1009) +C IF (PMIMX) GO TO 140 +C WRITE (IUNIT,1010) +C GO TO 150 +C 140 WRITE (IUNIT,1011) +C +C SIZE OF MINIMUM AND MAXIMUM LABELS +C +C 150 WRITE (IUNIT,1012) ISIZEM +C +C DASH PATTERN +C +C WRITE (IUNIT,1013) +C IF (IDASH(1:1) .EQ. ' ') GO TO 170 +C WRITE (IUNIT,1014) IDASH +C GO TO 180 +C 170 WRITE (IUNIT,1015) +C 180 IF (EDASH(1:1) .EQ. ' ') GO TO 200 +C WRITE (IUNIT,1016) EDASH +C GO TO 210 +C 200 WRITE (IUNIT,1017) +C 210 IF (NDASH(1:1) .EQ. ' ') GO TO 230 +C WRITE (IUNIT,1018) NDASH +C GO TO 240 +C 230 WRITE (IUNIT,1019) +C +C DASH PATTERN BREAK POINT +C +C 240 WRITE (IUNIT,1020) BPSIZ +C +C PRINT MINOR LINE GAP +C +C ITT = MINGAP-1 +C WRITE (IUNIT,1021) ITT +C RETURN +C +C 1001 FORMAT (5X,'LABEL THE CONTOURS, LAB=') +C 1002 FORMAT ('+',28X,'OFF') +C 1003 FORMAT ('+',28X,'ON') +C 1004 FORMAT (5X,'CONTOUR LABEL SIZE IN PWRIT UNITS, LSZ=',I4) +C 1005 FORMAT (5X,'SCALE THE DATA ON CONTOUR LINES, SDC=') +C 1006 FORMAT ('+',41X,'OFF') +C 1007 FORMAT ('+','ON, SCALE FACTOR=',G10.3) +C 1008 FORMAT (5X,'TENSION FACTOR (USED FOR SMOOTH AND SUPER), TEN=', +C 1 F6.2) +C 1009 FORMAT (5X,'PLOT RELATIVE MINIMUMS AND MAXIMUMS, PMM=') +C 1010 FORMAT ('+',45X,'OFF') +C 1011 FORMAT ('+',45X,'ON') +C 1012 FORMAT (5X,'SIZE OF MIN AND MAX LABELS IN PWRIT UNITS SML=', +C 1 I4) +C 1013 FORMAT (5X,'DASH PATTERN GTR=GREATER, EQU=EQUAL, LSS=LESS') +C 1014 FORMAT (10X,'GTR=',A10) +C 1015 FORMAT (10X,'GTR=$$$$$$$$$$') +C 1016 FORMAT (10X,'EQU=',A10) +C 1017 FORMAT (10X,'EQU=$$$$$$$$$$') +C 1018 FORMAT (10X,'LSS=',A10) +C 1019 FORMAT (10X,'LSS=$$$$$$$$$$') +C 1020 FORMAT (5X,'DASH PATTERN BREAK POINT, DBP=',G10.3) +C 1021 FORMAT (5X,'MINOR LINE COUNT=',I3) +C +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONTERP TO ULIB * +C* AUGUST 1980 FIXED THE FOLLOWING PROBLEMS * +C* 1.PLOTTING OF INPUT DATA VALUES * +C* 2.SETTING OF MINIMUM INTENSITY IN ALL OPTION * +C* 3.SETTING OF EQU FLAG IN CONTOUR DASH PATTERN * +C* 4.TURNING OFF OF SIZE OF PLOTTED DATA OPTION * +C* DECEMBER 1980 FIXED CONTOUR SELECTION ALGORITHM AND MOVED IN * +C* DASH PACKAGE COMMON BLOCK INTPR +C* MARCH 1981 FIXED NON-PORTABLE STATEMENT ORDERING IN CONSET * +C* APRIL 1981 FIXED OPTION LISTING ROUTINE * +C* ADDED MINOR LINE COUNT OPTION * +C* JULY 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED LOC (MACHINE DEPENDENT FUNCTION), CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/conout.f b/sys/gio/ncarutil/conlib/conout.f new file mode 100644 index 00000000..c2684de9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conout.f @@ -0,0 +1,350 @@ + SUBROUTINE CONOUT (IVER) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C LIST OUT ALL THE CONRAN OPTION VALUES ON THE LINE PRINTER +C +C THE VALUE OF IVER DETERMINES WHICH ENTRY POINT CALLED THIS ROUTINE +C +C 1. CONRAQ +C 2. CONRAN +C 3. CONRAS +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C +C GET THE STANDARD OUTPUT UNIT TO WRITE THE OPTION VALUE LIST +C + IUNIT = I1MACH(2) +C +C PRINT OUT HEADER AND ALL OPTIONS WHICH APPLY TO CALLING VERSION +C +C GO TO ( 100, 110, 120),IVER +C 100 WRITE (IUNIT,1001) +C GO TO 130 +C 110 WRITE (IUNIT,1002) +C GO TO 130 +C 120 WRITE (IUNIT,1003) +C 130 WRITE (IUNIT,1004) +C +C PERIMETER +C +C WRITE (IUNIT,1005) +C IF (PER) GO TO 140 +C WRITE (IUNIT,1006) +C GO TO 150 +C 140 WRITE (IUNIT,1007) +C +C GRID +C +C 150 WRITE (IUNIT,1008) +C IF (GRD) GO TO 160 +C WRITE (IUNIT,1009) +C GO TO 170 +C 160 WRITE (IUNIT,1010) +C +C SCALING OF DATA ON FRAME +C +C 170 WRITE (IUNIT,1011) +C GO TO ( 180, 190, 200),ISCALE+1 +C 180 WRITE (IUNIT,1012) +C GO TO 210 +C 190 WRITE (IUNIT,1013) +C GO TO 210 +C 200 WRITE (IUNIT,1014) +C +C SAME DATA ANOTHER PLOT +C +C 210 WRITE (IUNIT,1015) +C IF (REPEAT) GO TO 220 +C WRITE (IUNIT,1016) +C GO TO 230 +C 220 WRITE (IUNIT,1017) +C +C SHIELDING +C +C 230 WRITE(IUNIT,2000) +C IF (SHIELD) GO TO 231 +C WRITE(IUNIT,2001) +C GO TO 232 +C 231 WRITE(IUNIT,2002) +C +C INTERPOLATION +C +C 232 WRITE(IUNIT,2003) +C IF (LINEAR) GO TO 233 +C WRITE(IUNIT,2004) +C GO TO 234 +C 233 WRITE(IUNIT,2005) +C +C PLOT THE SHIELD +C +C 234 WRITE(IUNIT,2006) +C IF (SLDPLT) GO TO 235 +C WRITE(IUNIT,2007) +C GO TO 236 +C 235 WRITE(IUNIT,2008) +C +C EXTRAPOLATION +C +C 236 WRITE (IUNIT,1018) +C IF (EXTRAP) GO TO 240 +C WRITE (IUNIT,1019) +C GO TO 250 +C 240 WRITE (IUNIT,1020) +C +C STEP SIZE OR RESOLUTION OF THE GRID +C +C 250 WRITE (IUNIT,1021) IGRAD +C +C MESSAGE AT BOTTOM OF PLOT +C +C WRITE (IUNIT,1022) +C IF (MESS) GO TO 260 +C WRITE (IUNIT,1023) +C GO TO 270 +C 260 WRITE (IUNIT,1024) +C +C TITLE AT TOP OF PLOT +C +C 270 WRITE (IUNIT,1025) +C IF (TITLE) GO TO 280 +C WRITE (IUNIT,1026) +C GO TO 290 +C 280 WRITE (IUNIT,1027) +C +C SIZE OF TITLE +C +C 290 WRITE (IUNIT,1028) ITLSIZ +C +C PRINT TITLE +C +C IF (ICNT.EQ.0 .OR. .NOT.TITLE) GO TO 310 +C ICC = 100 +C IF (ICC .GT. ICNT) ICC = ICNT +C WRITE (IUNIT,1029) ISTRNG +C +C DATA POINTS USED FOR PARTIAL DERIVATIVE ESTIMATION +C +C 310 WRITE (IUNIT,1030) NCP +C +C LOOK AT TRIANGLES SWITCH +C +C WRITE (IUNIT,1031) +C IF (LOOK) GO TO 320 +C WRITE (IUNIT,1032) +C GO TO 330 +C 320 WRITE (IUNIT,1033) +C +C ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C +C 330 WRITE (IUNIT,1034) +C IF (FRADV) GO TO 340 +C WRITE (IUNIT,1035) +C GO TO 350 +C 340 WRITE (IUNIT,1036) +C +C TRIANGLES ONLY PLOT +C +C 350 WRITE (IUNIT,1037) +C IF (EXTRI) GO TO 360 +C WRITE (IUNIT,1038) +C GO TO 370 +C 360 WRITE (IUNIT,1039) +C +C PLOT THE INPUT DATA VALUES +C +C 370 WRITE (IUNIT,1040) +C IF (PLDVLS) GO TO 380 +C WRITE (IUNIT,1041) +C GO TO 390 +C 380 WRITE (IUNIT,1042) +C +C FORMAT OF THE PLOTTED INPUT DATA +C +C 390 WRITE (IUNIT,1043) +C IF (LEN .NE. 0) GO TO 400 +C WRITE (IUNIT,1044) +C GO TO 420 +C 400 WRITE (IUNIT,1045) FORM +C +C SIZE OF THE PLOTTED DATA VALUES +C +C 420 WRITE (IUNIT,1046) ISIZEP +C +C INTENSITY SETTINGS +C +C WRITE (IUNIT,1047) +C WRITE (IUNIT,1048) INMAJ,INMIN,INLAB,INDAT +C +C DISTLAY CONTOUR SETTING +C +C WRITE (IUNIT,1049) +C IF (CON) GO TO 430 +C WRITE (IUNIT,1050) +C GO TO 440 +C 430 WRITE (IUNIT,1051) NCL,(CL(I),I=1,NCL) +C +C CONTOUR INCREMENT +C +C 440 WRITE (IUNIT,1052) +C IF (CINC) GO TO 450 +C WRITE (IUNIT,1053) +C GO TO 460 +C 450 WRITE (IUNIT,1054) FINC +C +C CONTOUR HIGH AND LOW VALUES +C +C 460 WRITE (IUNIT,1055) +C IF (CHILO) GO TO 470 +C WRITE (IUNIT,1056) +C GO TO 480 +C 470 WRITE (IUNIT,1057) HI,FLO +C +C CALL CONOT2 IF NOT QUICK VERSION +C +C 480 IF (IVER .NE. 1) CALL CONOT2 (IVER,IUNIT) +C +C THE ROUTINE CONOT2 WAS GENERATED TO ELIMINATE COMPILER ERRORS +C RESULTING FROM TOO MANY FORMAT STATEMENTS IN ONE SUBROUTINE +C +C RETURN +C +C +C1001 FORMAT (1X,'CONRAQ') +C1002 FORMAT (1X,'CONRAN') +C1003 FORMAT (1X,'CONRAS') +C1004 FORMAT ('+',6X,'-OPTION VALUE SETTINGS',/ +C 1 ,7X,'ALL NON-PWRIT VALUES APPLY TO THE UNSCALED DATA') +C1005 FORMAT (5X,'PERIMETER, PER=') +C1006 FORMAT ('+',19X,'OFF') +C1007 FORMAT ('+',19X,'ON') +C1008 FORMAT (5X,'GRID, GRD=') +C1009 FORMAT ('+',14X,'OFF') +C1010 FORMAT ('+',14X,'ON') +C1011 FORMAT (5X,'SCALING OF PLOT ON FRAME, SCA=') +C1012 FORMAT ('+',34X,'ON') +C1013 FORMAT ('+',34X,'OFF') +C1014 FORMAT ('+',34X,'PRI') +C1015 FORMAT (5X,'SAME DATA FOR ANOTHER PLOT, REP=') +C1016 FORMAT ('+',36X,'OFF') +C1017 FORMAT ('+',36X,'ON') +C1018 FORMAT (5X,'EXTRAPOLATION, EXT=') +C1019 FORMAT ('+',23X,'OFF') +C1020 FORMAT ('+',23X,'ON') +C1021 FORMAT (5X,'RESOLUTION, SSZ=',I4) +C1022 FORMAT (5X,'MESSAGE, MES=') +C1023 FORMAT ('+',17X,'OFF') +C1024 FORMAT ('+',17X,'ON') +C1025 FORMAT (5X,'TITLE, TLE=') +C1026 FORMAT ('+',15X,'OFF') +C1027 FORMAT ('+',15X,'ON') +C1028 FORMAT (5X,'TITLE SIZE IN PWRIT UNITS, STL=',I4) +C1029 FORMAT (5X,'TITLE=',A64) +C1030 FORMAT (5X,'DATA POINTS USED FOR PARTIAL DERIVATIVE', +C 1' ESTIMATION, NCP=',I4) +C1031 FORMAT (5X,'LOOK AT TRIANGLES, TRI=') +C1032 FORMAT ('+',27X,'OFF') +C1033 FORMAT ('+',27X,'ON') +C1034 FORMAT (5X,'ADVANCE FRAME BEFORE PLOTTING TRIANGULATION,', +C 1' TFR=') +C1035 FORMAT ('+',53X,'OFF') +C1036 FORMAT ('+',53X,'ON') +C1037 FORMAT (5X,'TRIANGULATION ONLY PLOT, TOP=') +C1038 FORMAT ('+',33X,'OFF') +C1039 FORMAT ('+',33X,'ON') +C1040 FORMAT (5X,'PLOT THE INPUT DATA VALUES, PDV=') +C1041 FORMAT ('+',36X,'OFF') +C1042 FORMAT ('+',36X,'ON') +C1043 FORMAT (5X,'FORMAT OF THE PLOTTED INPUT DATA, FMT=') +C1044 FORMAT ('+',42X,'(G10.3)') +C1045 FORMAT ('+',42X,A10) +C1046 FORMAT (5X,'SIZE OF THE PLOTTED DATA VALUES IN PWRIT', +C 1' UNITS, SPD=',I4) +C1047 FORMAT (5X,'COLOR (INTENSITY) INDICES FOLLOW.', +C 1' FOR CONRAQ MAJOR CONTOURS ARE ONLY USED') +C1048 FORMAT (10X,'MAJOR CONTOUR LINES, MAJ=',I4,/ +C 1 ,10X,'MINOR CONTOUR LINES, MIN=',I4,/ +C 2 ,10X,'TITLE AND MESSAGE, LAB=',I4,/ +C 3 ,10X,'PLOTTED DATA VALUES, DAT=',I4) +C1049 FORMAT (5X,'CONTOUR LEVELS, CON=') +C1050 FORMAT ('+',25X,'OFF') +C1051 FORMAT ('+',25X,'ON, NCL=',I4,' ARRAY='/(10(2X,F10.3))) +C1052 FORMAT (5X,'CONTOUR INCREMENT, CIL=') +C1053 FORMAT ('+',27X,'OFF') +C 1054 FORMAT ('+',27X,'ON, INCREMENT=',G10.3) +C 1055 FORMAT (5X,'CONTOUR HIGH AND LOW VALUES, CHL=') +C 1056 FORMAT ('+',37X,'OFF') +C 1057 FORMAT ('+',37X,'ON, HI=',G10.3,' FLO=',G10.3) +C 2000 FORMAT (5X,'SHIELDING, SLD=') +C 2001 FORMAT ('+',19X,'OFF') +C 2002 FORMAT ('+',19X,'ON') +C 2003 FORMAT (5X,'INTERPOLATION, ITP=') +C 2004 FORMAT ('+',23X,'C1 SURFACE') +C 2005 FORMAT ('+',23X,'LINEAR') +C 2006 FORMAT (5X,'PLOT THE SHIELD, SPT=') +C 2007 FORMAT ('+',25X,'OFF') +C 2008 FORMAT ('+',25X,'ON') +C + END diff --git a/sys/gio/ncarutil/conlib/conpdv.f b/sys/gio/ncarutil/conlib/conpdv.f new file mode 100644 index 00000000..49c1f61f --- /dev/null +++ b/sys/gio/ncarutil/conlib/conpdv.f @@ -0,0 +1,118 @@ + SUBROUTINE CONPDV (XD,YD,ZD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C PLOT THE DATA VALUES ON THE CONTOUR MAP +C CURRENTLY UP TO 10 CHARACTERS FOR EACH VALUE ARE DISPLAYED +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C + CHARACTER*10 ISTR + DIMENSION XD(1) ,YD(1) ,ZD(1) +C + SAVE +C +C DATA TO CONVERT 0-32767 COORIDNATES TO 1-1024 VALUES +C + DATA TRANS/32./ +C +C SET INTENSITY +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C SET FORMAT IF NONE SPECIFIED +C + IF (LEN .NE. 0) GO TO 110 + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD +C +C LOOP AND PLOT ALL VALUES +C + 110 DO 120 K=1,NDP + CALL FL2INT (XD(K),YD(K),MX,MY) + MX = IFIX(FLOAT(MX)/TRANS)+1 + MY = IFIX(FLOAT(MY)/TRANS)+1 +C +C + NOAO - FTN internal write rewritten as call to encode for IRAF +C +C WRITE(ISTR,FORM)ZD(K) + call encode (len, form, istr, zd(k)) +C +C - NOAO +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) +C + CALL WTSTR(XC,YC,ISTR,ISIZEP,0,0) + CALL GSELNT(ICN) + 120 CONTINUE + IF (INDAT .NE. 1) THEN + CALL GSTXCI (IRANTX) + ENDIF + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conreo.f b/sys/gio/ncarutil/conlib/conreo.f new file mode 100644 index 00000000..c029c0bb --- /dev/null +++ b/sys/gio/ncarutil/conlib/conreo.f @@ -0,0 +1,129 @@ + SUBROUTINE CONREO (MAJLNS) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MAJLNS. PV IS USED AS A WORK SPACE. MINGAP IS +C THE NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS +C BETWEEN MAJOR LEVELS). +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C + NL = NCL + IF (NL.LE.4 .OR. MINGAP.LE.1) GO TO 160 + NML = MINGAP-1 + IF (NL.LE.10) NML = 1 +C +C CHECK FOR BREAK POINT IN THE LIST OF CONTOURS FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 10 I=1,NL + ISAVE = I + IF (CL(I).EQ.BPSIZ) GO TO 40 + 10 CONTINUE +C +C NO BREAKPOINT FOUND SO TRY FOR A NICE NUMBER +C + L = NL/2 + L = ALOG10( ABS( CL(L) ) )+1. + Q = 10.**L + DO 30 J=1,3 + Q = Q/10. + DO 20 I=1,NL + ISAVE = I + IF (AMOD( ABS( CL(I) + 1.E-9*CL(I) )/Q,FLOAT(NMLP1) ).LE. + 1 .0001) GO TO 40 + 20 CONTINUE + 30 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN PV +C + 40 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART.EQ.0) ISTART = NMLP1 + NMAJL = 0 + DO 50 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + PV(NMAJL) = CL(I) + 50 CONTINUE + MAJLNS = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN PV +C + IC = NML/2 + 1 + L = MAJLNS+1 + DO 100 LOOP=1,NML + IC1 = IC + DO 90 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 60 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + IF (IC1.GE.NMLP1) GO TO 90 + IF (IC1.LE.0) GO TO 90 + 60 DO 70 K=ISTART,NL,NMLP1 + IND = K+IC1 + IF (IND.GT.NL) GO TO 80 + PV(L) = CL(IND) + L = L+1 + 70 CONTINUE + 80 IF (LOOP.EQ.1) GO TO 100 + 90 CONTINUE + 100 CONTINUE +C +C IF MAJOR LINES DID NOT START ON THE FIRST ENTRY PICK UP THE MISSING +C LEVELS +C + IF (ISTART.EQ.1) GO TO 140 + DO 130 LOOP=1,NML + IC1 = IC + DO 120 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 110 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + 110 IF (IC1.GE.ISTART) GO TO 120 + IF (IC1.LE.0) GO TO 120 + PV(L) = CL(IC1) + L = L+1 + IF (LOOP.EQ.1) GO TO 130 + 120 CONTINUE + 130 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 140 DO 150 I=1,NL + CL(I) = PV(I) + 150 CONTINUE + RETURN + 160 MAJLNS = NL + RETURN + END diff --git a/sys/gio/ncarutil/conlib/consld.f b/sys/gio/ncarutil/conlib/consld.f new file mode 100644 index 00000000..fd40e10d --- /dev/null +++ b/sys/gio/ncarutil/conlib/consld.f @@ -0,0 +1,165 @@ + SUBROUTINE CONSLD (SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE IS USED TO GENERATE A SHIELD WHERE CONTOUR +C DRAWING IS ALLOWED. +C +C THE ROUTINE TAKES THE SILHOUETTE INFORMATION FROM COMMON BLOCK +C CONR13 AND TRANSFORMS THIS INTO A SHIELD TO BE USED IN THE +C SCRATCH ARRAY PASSED IN BY THE USER (THE SCRATCH ARRAY HOLDS THE +C GRIDED DATA FROM THE INTERPOLATION). +C +C INPUT +C SCRARR-THE SCRATCH ARRAY HOLDING THE INTERPOLATED DATA +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C +C INCREASE THE RESOLUTION OF THE SHIELD PROFILE +C + DIMENSION SCRARR(1) +C + SAVE + DATA RESINC/8.0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C +C +NOAO +C These statement functions are never called. +C SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C IARVL(IXX,IYY) = IYY+(IXX-1)*IYMAX +C -NOAO + IGADDR(XXX,YYY) = + 1 IFIX((YYY-YST)/STPSZ+.5)+(IFIX((XXX-XST)/STPSZ+.5))*IYMAX +C +C SET THE SPECIAL VALUE +C + SPVAL = SPVAL * 2. +C +C SET THE USER ARRAY LOCATIONS TO TEMPORARY POINTERS +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 1,ICOUNT +C +C ASSIGN LINE SEGMENT END POINTS +C + X1 = XVS(IC) + Y1 = YVS(IC) + IF (IC .EQ. ICOUNT) GO TO 10 + X2 = XVS(IC+1) + Y2 = YVS(IC+1) + GO TO 15 + 10 CONTINUE + X2 = XVS(1) + Y2 = YVS(1) + 15 CONTINUE +C +C INSURE THAT ALL POINTS ARE IN THE CONVEX HULL +C + IF (X1.GT.XED) X1 = XED + IF (X1.LT.XST) X1 = XST + IF (X2.GT.XED) X2 = XED + IF (X2.LT.XST) X2 = XST + IF (Y1.GT.YED) Y1 = YED + IF (Y1.LT.YST) Y1 = YST + IF (Y2.GT.YED) Y2 = YED + IF (Y2.LT.YST) Y2 = YST +C +C SET THE START OF THE LINE SEGMENT SCRATCH LOCATION TO +C THE SPECIAL VALUE +C + II = IGADDR(X1,Y1) + SCRARR(II) = SPVAL +C +C FIND THE LENGTH OF THE LINE SEGMENT +C + DIST = SQRT(((X2-X1)**2)+((Y2-Y1)**2)) +C +C IF LENGTH SHORTER THAN STEP SIZE THEN THERE IS NOTHING TO DO +C + IF (DIST .LE. STPSZ) GO TO 100 +C +C SET UP LOOP TO SET ALL CELLS ON THE LINE SEGMENT +C + NSTPS = (DIST/STPSZ)*RESINC + XSTP = (X2-X1)/FLOAT(NSTPS) + YSTP = (Y2-Y1)/FLOAT(NSTPS) + X = X1 + Y = Y1 + DO 20 K = 1,NSTPS + X = X + XSTP + Y = Y + YSTP + II = IGADDR(X,Y) + SCRARR(II) = SPVAL + 20 CONTINUE +C + 100 CONTINUE +C +C FILL THE SHIELDED AREAS +C FOR EACH COLUMN THE ELEMENTS ARE SET TO SPVAL IF FILL IS TRUE. +C THE VALUE OF FILL IS NEGATED EVERY TIME A SPVAL IS ENCOUNTERED, +C AND THAT CELL REMAINS UNCHANGED. +C +C LOOP THROUGH THE GRID +C + DO 39 I = 1,IXMAX +C +C GET THE START AND END FOR THE COLUMN +C + IYS = (I-1)*IYMAX+1 + IYE = I*IYMAX +C +C ADVANCE IN THE FORWARD DIRECTION +C + DO 32 J = IYS,IYE +C +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(J).EQ.SPVAL) GO TO 33 + SCRARR(J) = SPVAL + 32 CONTINUE + GO TO 39 +C +C ADVANCE IN THE BACKWARD DIRECTION +C + 33 CONTINUE + DO 34 J = 1,IYMAX + NJ =IYE+1-J +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(NJ).EQ.SPVAL) GO TO 39 + SCRARR(NJ) = SPVAL + 34 CONTINUE + 39 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conssd.f b/sys/gio/ncarutil/conlib/conssd.f new file mode 100644 index 00000000..26ac20d1 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conssd.f @@ -0,0 +1,61 @@ + SUBROUTINE CONSSD(X,Y,IC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE SETS THE SHIELDING FLAG AND CONNECTS THE +C USERS SHIELD ARRAYS TO SOME INTERNAL POINTERS +C +C INPUT +C X-X COORDINATE STRING +C Y-Y COORDINATE STRING +C IC-NUMBER OF COORDINATES +C +C NOTE THE USERS ARRAYS CANNOT BE MUCKED WITH DURING EXECUTION +C THOSE ARRAYS ARE USED DURING CONRAN EXECUTION +C + DIMENSION X(1),Y(1) + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C SET COUNTER +C + ICOUNT = IC +C +C CHECK THE DIMENSION OF SHIELD ARRAYS +C + IERUNT = I1MACH(4) + IF (ICOUNT .GT. 50) THEN + CALL SETER (' CONSSD -- NUMBER OF SHIELD POINTS .GT. 50',1,1) +C +C + NOAO - FTN write and format statement commented out; SETER is enough. +C WRITE(IERUNT,1001) + ICOUNT = 50 + ENDIF +C1001 FORMAT(' ERROR 1 IN CONSSD -- NUMBER OF SHIELD POINTS .GT. 50') +C - NOAO +C +C SET THE SHIELDING FLAG TO TRUE +C + SHIELD = .TRUE. +C +C COMPUTE POINTERS FOR THE USERS SHIELDING ARRAYS +C + DO 300 I = 1,ICOUNT + XVS(I) = X(I) + 300 YVS(I) = Y(I) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/constp.f b/sys/gio/ncarutil/conlib/constp.f new file mode 100644 index 00000000..8df0e23b --- /dev/null +++ b/sys/gio/ncarutil/conlib/constp.f @@ -0,0 +1,135 @@ + SUBROUTINE CONSTP (XD,YD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C COMPUTE STEP SIZE IN X AND Y DIRECTION +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) +C + SAVE +C +C FIND SMALLEST AND LARGST X AND Y +C + XST = XD(1) + XED = XD(1) + YST = YD(1) + YED = YD(1) + DO 130 I=2,NDP + IF (XST .LE. XD(I)) GO TO 100 + XST = XD(I) + GO TO 110 + 100 IF (XED .GE. XD(I)) GO TO 110 + XED = XD(I) + 110 IF (YST .LE. YD(I)) GO TO 120 + YST = YD(I) + GO TO 130 + 120 IF (YED .GE. YD(I)) GO TO 130 + YED = YD(I) + 130 CONTINUE +C +C COMPUTE STEP SIZE +C + XRG = (ABS(XED-XST)) + YRG = (ABS(YED-YST)) + SQRG = XRG + IF (SQRG .LT. YRG) SQRG = YRG + STPSZ = SQRG/FLOAT(IGRAD-1) +C +C COMPUTE PARAMETERS FOR SET CALL +C + DIFX = XRG/SQRG + DIFY = YRG/SQRG + PXST = .5-(BORD*DIFX)/2. + PXED = .5+(BORD*DIFX)/2. + PYST = .5-(BORD*DIFY)/2. + PYED = .5+(BORD*DIFY)/2. + XRG = XRG/FLOAT(ITICK) + YRG = YRG/FLOAT(ITICK) +C +C TEST IF THE ASPECT RATIO FOR THE COORDINATES IS REASONABLE. +C REASONABLE IS CURRENTLY DEFINED AS 5 TO 1. +C IF IT IS NOT REASONABLE THEN A POOR PLOT MAY BE GENERATED +C SO IT IS NICE THE WARN THE USER WHEN THIS HAPPENS. +C + TEST = XRG/YRG + IF (TEST.LE.5. .AND. TEST.GE.0.2) RETURN +C +C WARN THE USER ON THE STANDARD OUTPUT UNIT THAT THE PLOT MAY +C NOT BE TOO GOOD. +C +C SET RECOVERY MODE +C + CALL ENTSR(IROLD,IREC) +C +C FLAG THE ERROR +C + CALL SETER(' ASPECT RATIO OF X AND Y GREATER THAN 5 TO 1', + 1 1,1) +C + CALL EPRIN +C +C CLEAR THE ERROR +C + CALL ERROF +C +C RESET USER ERROR MODE +C + CALL ENTSR(IDUM,IROLD) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contlk.f b/sys/gio/ncarutil/conlib/contlk.f new file mode 100644 index 00000000..201b4d07 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contlk.f @@ -0,0 +1,98 @@ + SUBROUTINE CONTLK (XD,YD,NDP,IPT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW THE TRIANGLES CREATED BY CONTNG +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,IPT(1) +C + SAVE +C +C STATEMENT FUNCTIONS TO SCALE DATA FOR OVERLAYS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C ADVANCE PICTURE IF DESIRED +C + IF (FRADV) CALL FRAME +C +C DRAW TRIANGLES +C + DO 100 K=1,NT + I = K*3 + I1 = IPT(I) + I2 = IPT(I-1) + I3 = IPT(I-2) + XX = FX(XD(I1),YD(I1)) + CALL FL2INT (XX,FY(XD(I1),YD(I1)),MX1,MY1) + CALL PLOTIT (MX1,MY1,0) + XX = FX(XD(I2),YD(I2)) + CALL FL2INT (XX,FY(XD(I2),YD(I2)),MX,MY) + CALL PLOTIT (MX,MY,1) + XX = FX(XD(I3),YD(I3)) + CALL FL2INT (XX,FY(XD(I3),YD(I3)),MX,MY) + CALL PLOTIT (MX,MY,1) + CALL PLOTIT (MX1,MY1,1) + 100 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contng.f b/sys/gio/ncarutil/conlib/contng.f new file mode 100644 index 00000000..7ebad596 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contng.f @@ -0,0 +1,432 @@ + SUBROUTINE CONTNG (NDP,XD,YD,NT,IPT,NL,IPL,IWL,IWP,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE PERFORMS TRIANGULATION. IT DIVIDES THE X-Y +C PLANE INTO A NUMBER OF TRIANGLES ACCORDING TO GIVEN DATA +C POINTS IN THE PLANE, DETERMINES LINE SEGMENTS THAT FORM THE +C BORDER OF DATA AREA, AND DETERMINES THE TRIANGLE NUMBERS +C CORRESPONDING TO THE BORDER LINE SEGMENTS. +C AT COMPLETION, POINT NUMBERS OF THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. POINT NUMBERS OF THE END POINTS +C OF EACH BORDER LINE SEGMENT ARE LISTED COUNTER-CLOCKWISE, +C LISTING ORDER OF THE LINE SEGMENTS BEING COUNTER-CLOCKWISE. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD = ARRAY OF DIMENSION NDP CONTAINING THE +C X COORDINATES OF THE DATA POINTS, +C YD = ARRAY OF DIMENSION NDP CONTAINING THE +C Y COORDINATES OF THE DATA POINTS. +C THE OUTPUT PARAMETERS ARE +C NT = NUMBER OF TRIANGLES, +C IPT = ARRAY OF DIMENSION 6*NDP-15, WHERE THE POINT +C NUMBERS OF THE VERTEXES OF THE (IT)TH TRIANGLE +C ARE TO BE STORED AS THE (3*IT-2)ND, (3*IT-1)ST, +C AND (3*IT)TH ELEMENTS, IT=1,2,...,NT, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = ARRAY OF DIMENSION 6*NDP, WHERE THE POINT +C NUMBERS OF THE END POINTS OF THE (IL)TH BORDER +C LINE SEGMENT AND ITS RESPECTIVE TRIANGLE NUMBER +C ARE TO BE STORED AS THE (3*IL-2)ND, (3*IL-1)ST, +C AND (3*IL)TH ELEMENTS, IL=1,2,..., NL. +C THE OTHER PARAMETERS ARE +C IWL = INTEGER ARRAY OF DIMENSION 18*NDP USED +C INTERNALLY AS A WORK AREA, +C IWP = INTEGER ARRAY OF DIMENSION NDP USED +C INTERNALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + SAVE +C + INTEGER CONXCH + COMMON /CONRA3/ IREC + DIMENSION XD(*) ,YD(*) ,IPT(*) ,IPL(*) , + 1 IWL(*) ,IWP(*) ,WK(*) + DIMENSION ITF(2) + CHARACTER*4 IP1C, IP2C + CHARACTER*64 ITEMP + DATA RATIO/1.0E-6/, NREP/100/ +C +C STATEMENT FUNCTIONS +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 + SIDE(U1,V1,U2,V2,U3,V3) = (V3-V1)*(U2-U1)-(U3-U1)*(V2-V1) +C +C PRELIMINARY PROCESSING +C + NDPM1 = NDP-1 +C +C DETERMINES THE CLOSEST PAIR OF DATA POINTS AND THEIR MIDPOINT. +C + DSQMN = DSQF(XD(1),YD(1),XD(2),YD(2)) + IPMN1 = 1 + IPMN2 = 2 + DO 140 IP1=1,NDPM1 + X1 = XD(IP1) + Y1 = YD(IP1) + IP1P1 = IP1+1 + DO 130 IP2=IP1P1,NDP + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .NE. 0.) GO TO 120 +C +C ERROR, IDENTICAL INPUT DATA POINTS +C + ITEMP = ' CONTNG-IDENTICAL INPUT DATA POINTS FOUND + 1 AT AND ' +C +C + NOAO - FTN internal writes rewritten as calls to encode for IRAF +C +C WRITE(IP1C,'(I4)')IP1 +C WRITE(IP2C,'(I4)')IP2 + call encode (4, '(I4)', ip1c, ip1) + call encode (4, '(I4)', ip2c, ip2) +C - NOAO +C + CALL SETER (ITEMP,1,1) + ITEMP(46:49) = IP1C + ITEMP(55:58) = IP2C + RETURN + 120 IF (DSQI .GE. DSQMN) GO TO 130 + DSQMN = DSQI + IPMN1 = IP1 + IPMN2 = IP2 + 130 CONTINUE + 140 CONTINUE + DSQ12 = DSQMN + XDMP = (XD(IPMN1)+XD(IPMN2))/2.0 + YDMP = (YD(IPMN1)+YD(IPMN2))/2.0 +C +C SORTS THE OTHER (NDP-2) DATA POINTS IN ASCENDING ORDER OF +C DISTANCE FROM THE MIDPOINT AND STORES THE SORTED DATA POINT +C NUMBERS IN THE IWP ARRAY. +C + JP1 = 2 + DO 150 IP1=1,NDP + IF (IP1.EQ.IPMN1 .OR. IP1.EQ.IPMN2) GO TO 150 + JP1 = JP1+1 + IWP(JP1) = IP1 + WK(JP1) = DSQF(XDMP,YDMP,XD(IP1),YD(IP1)) + 150 CONTINUE + DO 170 JP1=3,NDPM1 + DSQMN = WK(JP1) + JPMN = JP1 + DO 160 JP2=JP1,NDP + IF (WK(JP2) .GE. DSQMN) GO TO 160 + DSQMN = WK(JP2) + JPMN = JP2 + 160 CONTINUE + ITS = IWP(JP1) + IWP(JP1) = IWP(JPMN) + IWP(JPMN) = ITS + WK(JPMN) = WK(JP1) + 170 CONTINUE +C +C IF NECESSARY, MODIFIES THE ORDERING IN SUCH A WAY THAT THE +C FIRST THREE DATA POINTS ARE NOT COLLINEAR. +C + AR = DSQ12*RATIO + X1 = XD(IPMN1) + Y1 = YD(IPMN1) + DX21 = XD(IPMN2)-X1 + DY21 = YD(IPMN2)-Y1 + DO 180 JP=3,NDP + IP = IWP(JP) + IF (ABS((YD(IP)-Y1)*DX21-(XD(IP)-X1)*DY21) .GT. AR) GO TO 190 + 180 CONTINUE + CALL SETER (' CONTNG - ALL COLLINEAR DATA POINTS',1,1) + 190 IF (JP .EQ. 3) GO TO 210 + JPMX = JP + JP = JPMX+1 + DO 200 JPC=4,JPMX + JP = JP-1 + IWP(JP) = IWP(JP-1) + 200 CONTINUE + IWP(3) = IP +C +C FORMS THE FIRST TRIANGLE. STORES POINT NUMBERS OF THE VER- +C TEXES OF THE TRIANGLE IN THE IPT ARRAY, AND STORES POINT NUM- +C BERS OF THE BORDER LINE SEGMENTS AND THE TRIANGLE NUMBER IN +C THE IPL ARRAY. +C + 210 IP1 = IPMN1 + IP2 = IPMN2 + IP3 = IWP(3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 220 + IP1 = IPMN2 + IP2 = IPMN1 + 220 NT0 = 1 + NTT3 = 3 + IPT(1) = IP1 + IPT(2) = IP2 + IPT(3) = IP3 + NL0 = 3 + NLT3 = 9 + IPL(1) = IP1 + IPL(2) = IP2 + IPL(3) = 1 + IPL(4) = IP2 + IPL(5) = IP3 + IPL(6) = 1 + IPL(7) = IP3 + IPL(8) = IP1 + IPL(9) = 1 +C +C ADDS THE REMAINING (NDP-3) DATA POINTS, ONE BY ONE. +C + DO 400 JP1=4,NDP + IP1 = IWP(JP1) + X1 = XD(IP1) + Y1 = YD(IP1) +C +C - DETERMINES THE VISIBLE BORDER LINE SEGMENTS. +C + IP2 = IPL(1) + JPMN = 1 + DXMN = XD(IP2)-X1 + DYMN = YD(IP2)-Y1 + DSQMN = DXMN**2+DYMN**2 + ARMN = DSQMN*RATIO + JPMX = 1 + DXMX = DXMN + DYMX = DYMN + DSQMX = DSQMN + ARMX = ARMN + DO 240 JP2=2,NL0 + IP2 = IPL(3*JP2-2) + DX = XD(IP2)-X1 + DY = YD(IP2)-Y1 + AR = DY*DXMN-DX*DYMN + IF (AR .GT. ARMN) GO TO 230 + DSQI = DX**2+DY**2 + IF (AR.GE.(-ARMN) .AND. DSQI.GE.DSQMN) GO TO 230 + JPMN = JP2 + DXMN = DX + DYMN = DY + DSQMN = DSQI + ARMN = DSQMN*RATIO + 230 AR = DY*DXMX-DX*DYMX + IF (AR .LT. (-ARMX)) GO TO 240 + DSQI = DX**2+DY**2 + IF (AR.LE.ARMX .AND. DSQI.GE.DSQMX) GO TO 240 + JPMX = JP2 + DXMX = DX + DYMX = DY + DSQMX = DSQI + ARMX = DSQMX*RATIO + 240 CONTINUE + IF (JPMX .LT. JPMN) JPMX = JPMX+NL0 + NSH = JPMN-1 + IF (NSH .LE. 0) GO TO 270 +C +C - SHIFTS (ROTATES) THE IPL ARRAY TO HAVE THE INVISIBLE BORDER +C - LINE SEGMENTS CONTAINED IN THE FIRST PART OF THE IPL ARRAY. +C + NSHT3 = NSH*3 + DO 250 JP2T3=3,NSHT3,3 + JP3T3 = JP2T3+NLT3 + IPL(JP3T3-2) = IPL(JP2T3-2) + IPL(JP3T3-1) = IPL(JP2T3-1) + IPL(JP3T3) = IPL(JP2T3) + 250 CONTINUE + DO 260 JP2T3=3,NLT3,3 + JP3T3 = JP2T3+NSHT3 + IPL(JP2T3-2) = IPL(JP3T3-2) + IPL(JP2T3-1) = IPL(JP3T3-1) + IPL(JP2T3) = IPL(JP3T3) + 260 CONTINUE + JPMX = JPMX-NSH +C +C - ADDS TRIANGLES TO THE IPT ARRAY, UPDATES BORDER LINE +C - SEGMENTS IN THE IPL ARRAY, AND SETS FLAGS FOR THE BORDER +C - LINE SEGMENTS TO BE REEXAMINED IN THE IWL ARRAY. +C + 270 JWL = 0 + DO 310 JP2=JPMX,NL0 + JP2T3 = JP2*3 + IPL1 = IPL(JP2T3-2) + IPL2 = IPL(JP2T3-1) + IT = IPL(JP2T3) +C +C - - ADDS A TRIANGLE TO THE IPT ARRAY. +C + NT0 = NT0+1 + NTT3 = NTT3+3 + IPT(NTT3-2) = IPL2 + IPT(NTT3-1) = IPL1 + IPT(NTT3) = IP1 +C +C - - UPDATES BORDER LINE SEGMENTS IN THE IPL ARRAY. +C + IF (JP2 .NE. JPMX) GO TO 280 + IPL(JP2T3-1) = IP1 + IPL(JP2T3) = NT0 + 280 IF (JP2 .NE. NL0) GO TO 290 + NLN = JPMX+1 + NLNT3 = NLN*3 + IPL(NLNT3-2) = IP1 + IPL(NLNT3-1) = IPL(1) + IPL(NLNT3) = NT0 +C +C - - DETERMINES THE VERTEX THAT DOES NOT LIE ON THE BORDER +C - - LINE SEGMENTS. +C + 290 ITT3 = IT*3 + IPTI = IPT(ITT3-2) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3-1) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 300 IF (CONXCH(XD,YD,IP1,IPTI,IPL1,IPL2) .EQ. 0) GO TO 310 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(ITT3-2) = IPTI + IPT(ITT3-1) = IPL1 + IPT(ITT3) = IP1 + IPT(NTT3-1) = IPTI + IF (JP2 .EQ. JPMX) IPL(JP2T3) = IT + IF (JP2.EQ.NL0 .AND. IPL(3).EQ.IT) IPL(3) = NT0 +C +C - - SETS FLAGS IN THE IWL ARRAY. +C + JWL = JWL+4 + IWL(JWL-3) = IPL1 + IWL(JWL-2) = IPTI + IWL(JWL-1) = IPTI + IWL(JWL) = IPL2 + 310 CONTINUE + NL0 = NLN + NLT3 = NLNT3 + NLF = JWL/2 + IF (NLF .EQ. 0) GO TO 400 +C +C - IMPROVES TRIANGULATION. +C + NTT3P3 = NTT3+3 + DO 390 IREP=1,NREP + DO 370 ILF=1,NLF + ILFT2 = ILF*2 + IPL1 = IWL(ILFT2-1) + IPL2 = IWL(ILFT2) +C +C - - LOCATES IN THE IPT ARRAY TWO TRIANGLES ON BOTH SIDES OF +C - - THE FLAGGED LINE SEGMENT. +C + NTF = 0 + DO 320 ITT3R=3,NTT3,3 + ITT3 = NTT3P3-ITT3R + IPT1 = IPT(ITT3-2) + IPT2 = IPT(ITT3-1) + IPT3 = IPT(ITT3) + IF (IPL1.NE.IPT1 .AND. IPL1.NE.IPT2 .AND. + 1 IPL1.NE.IPT3) GO TO 320 + IF (IPL2.NE.IPT1 .AND. IPL2.NE.IPT2 .AND. + 1 IPL2.NE.IPT3) GO TO 320 + NTF = NTF+1 + ITF(NTF) = ITT3/3 + IF (NTF .EQ. 2) GO TO 330 + 320 CONTINUE + IF (NTF .LT. 2) GO TO 370 +C +C - - DETERMINES THE VERTEXES OF THE TRIANGLES THAT DO NOT LIE +C - - ON THE LINE SEGMENT. +C + 330 IT1T3 = ITF(1)*3 + IPTI1 = IPT(IT1T3-2) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3-1) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3) + 340 IT2T3 = ITF(2)*3 + IPTI2 = IPT(IT2T3-2) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3-1) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 350 IF (CONXCH(XD,YD,IPTI1,IPTI2,IPL1,IPL2) .EQ. 0) + 1 GO TO 370 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(IT1T3-2) = IPTI1 + IPT(IT1T3-1) = IPTI2 + IPT(IT1T3) = IPL1 + IPT(IT2T3-2) = IPTI2 + IPT(IT2T3-1) = IPTI1 + IPT(IT2T3) = IPL2 +C +C - - SETS NEW FLAGS. +C + JWL = JWL+8 + IWL(JWL-7) = IPL1 + IWL(JWL-6) = IPTI1 + IWL(JWL-5) = IPTI1 + IWL(JWL-4) = IPL2 + IWL(JWL-3) = IPL2 + IWL(JWL-2) = IPTI2 + IWL(JWL-1) = IPTI2 + IWL(JWL) = IPL1 + DO 360 JLT3=3,NLT3,3 + IPLJ1 = IPL(JLT3-2) + IPLJ2 = IPL(JLT3-1) + IF ((IPLJ1.EQ.IPL1 .AND. IPLJ2.EQ.IPTI2) .OR. + 1 (IPLJ2.EQ.IPL1 .AND. IPLJ1.EQ.IPTI2)) + 2 IPL(JLT3) = ITF(1) + IF ((IPLJ1.EQ.IPL2 .AND. IPLJ2.EQ.IPTI1) .OR. + 1 (IPLJ2.EQ.IPL2 .AND. IPLJ1.EQ.IPTI1)) + 2 IPL(JLT3) = ITF(2) + 360 CONTINUE + 370 CONTINUE + NLFC = NLF + NLF = JWL/2 + IF (NLF .EQ. NLFC) GO TO 400 +C +C - - RESETS THE IWL ARRAY FOR THE NEXT ROUND. +C + JWL = 0 + JWL1MN = (NLFC+1)*2 + NLFT2 = NLF*2 + DO 380 JWL1=JWL1MN,NLFT2,2 + JWL = JWL+2 + IWL(JWL-1) = IWL(JWL1-1) + IWL(JWL) = IWL(JWL1) + 380 CONTINUE + NLF = JWL/2 + 390 CONTINUE + 400 CONTINUE +C +C REARRANGE THE IPT ARRAY SO THAT THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. +C + DO 410 ITT3=3,NTT3,3 + IP1 = IPT(ITT3-2) + IP2 = IPT(ITT3-1) + IP3 = IPT(ITT3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 410 + IPT(ITT3-2) = IP2 + IPT(ITT3-1) = IP1 + 410 CONTINUE + NT = NT0 + NL = NL0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conxch.f b/sys/gio/ncarutil/conlib/conxch.f new file mode 100644 index 00000000..6309f360 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conxch.f @@ -0,0 +1,67 @@ + INTEGER FUNCTION CONXCH (X,Y,I1,I2,I3,I4) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO +C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION +C BY C. L. LAWSON. +C THE INPUT PARAMETERS ARE +C X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA +C POINTS, +C I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2, +C P3, AND P4 THAT FORM A QUADRILATERAL +C WITH P3 AND P4 CONNECTED DIADONALLY. +C THIS FUNCTION RETURNS A VALUE 1 (ONE) WHEN AN EXCHANGE IS +C NEEDED, AND 0 (ZERO) OTHERWISE. +C DECLARATION STATEMENTS +C + DIMENSION X(1) ,Y(1) + DIMENSION X0(4) ,Y0(4) + EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ),(A4SQ,B1SQ), + 1 (B4SQ,A2SQ),(C4SQ,C3SQ) +C + SAVE +C +C STATEMENT FUNCTIONS +C +C CALCULATION +C + X0(1) = X(I1) + Y0(1) = Y(I1) + X0(2) = X(I2) + Y0(2) = Y(I2) + X0(3) = X(I3) + Y0(3) = Y(I3) + X0(4) = X(I4) + Y0(4) = Y(I4) + IDX = 0 + U3 = (Y0(2)-Y0(3))*(X0(1)-X0(3))-(X0(2)-X0(3))*(Y0(1)-Y0(3)) + U4 = (Y0(1)-Y0(4))*(X0(2)-X0(4))-(X0(1)-X0(4))*(Y0(2)-Y0(4)) + IF (U3*U4 .LE. 0.0) GO TO 100 + U1 = (Y0(3)-Y0(1))*(X0(4)-X0(1))-(X0(3)-X0(1))*(Y0(4)-Y0(1)) + U2 = (Y0(4)-Y0(2))*(X0(3)-X0(2))-(X0(4)-X0(2))*(Y0(3)-Y0(2)) + A1SQ = (X0(1)-X0(3))**2+(Y0(1)-Y0(3))**2 + B1SQ = (X0(4)-X0(1))**2+(Y0(4)-Y0(1))**2 + C1SQ = (X0(3)-X0(4))**2+(Y0(3)-Y0(4))**2 + A2SQ = (X0(2)-X0(4))**2+(Y0(2)-Y0(4))**2 + B2SQ = (X0(3)-X0(2))**2+(Y0(3)-Y0(2))**2 + C3SQ = (X0(2)-X0(1))**2+(Y0(2)-Y0(1))**2 + S1SQ = U1*U1/(C1SQ*AMAX1(A1SQ,B1SQ)) + S2SQ = U2*U2/(C2SQ*AMAX1(A2SQ,B2SQ)) + S3SQ = U3*U3/(C3SQ*AMAX1(A3SQ,B3SQ)) + S4SQ = U4*U4/(C4SQ*AMAX1(A4SQ,B4SQ)) + IF (AMIN1(S1SQ,S2SQ) .LT. AMIN1(S3SQ,S4SQ)) IDX = 1 + 100 CONXCH = IDX + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/mkpkg b/sys/gio/ncarutil/conlib/mkpkg new file mode 100644 index 00000000..5ebdc2cb --- /dev/null +++ b/sys/gio/ncarutil/conlib/mkpkg @@ -0,0 +1,37 @@ +# Update the CONCOM and CONTERP contributions to LIBNCAR. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + concal.f + concld.f + concls.f + concom.f + condet.f + condrw.f + condsd.f + conecd.f + congen.f + conint.f + conlcm.f + conlin.f + conloc.f + conlod.f + conop1.f + conop2.f + conop3.f + conop4.f + conot2.f + conout.f + conpdv.f + conreo.f + consld.f + conssd.f + constp.f + contlk.f + contng.f + conxch.f + ; diff --git a/sys/gio/ncarutil/conran.f b/sys/gio/ncarutil/conran.f new file mode 100644 index 00000000..bc23a6cc --- /dev/null +++ b/sys/gio/ncarutil/conran.f @@ -0,0 +1,1976 @@ + SUBROUTINE CONRAN (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SUBROUTINE CONRAN(XD,YD,ZD,NDP,WK,IWK,SCRARR) +C STANDARD AND SMOOTH VERSIONS OF CONRAN +C +C DIMENSION OF XD(NDP),YD(NDP),ZD(NDP),WK(13*NDP) +C ARGUMENTS IWK((27+NCP)*NDP),SCRARR(RESOLUTION**2) +C WHERE NCP = 4 AND RESOLUTION = 40 BY +C DEFAULT. +C +C LATEST REVISION JULY 1984 +C +C OVERVIEW CONRAN PERFORMS CONTOURING OF IRREGULARLY +C DISTRIBUTED DATA. IT IS THE STANDARD AND +C SMOOTH MEMBERS OF THE CONRAN FAMILY. THIS +C VERSION WILL PLOT CONTOURS; SMOOTH THEM USING +C SPLINES UNDER TENSION (IF THE PACKAGE DASHSMTH +C IS LOADED); PLOT A PERIMETER OR GRID; TITLE THE +C PLOT; PRINT A MESSAGE GIVING THE CONTOUR INTERVALS +C BELOW THE MAP; PLOT THE INPUT DATA ON THE MAP; +C AND LABEL THE CONTOUR LINES. +C +C PURPOSE CONRAN PLOTS CONTOUR LINES USING RANDOM, +C SPARSE OR IRREGULAR DATA SETS. THE DATA IS +C TRIANGULATED AND THEN CONTOURED. CONTOURING +C IS PERFORMED USING INTERPOLATION OF THE TRI- +C ANGULATED DATA. THERE ARE TWO METHODS OF +C INTERPOLATION: C1 SURFACES AND LINEAR. +C +C USAGE CALL CONRAN(XD,YD,ZD,NDP,WK,IWK,SCRARR) +C AN OPTION SETTING ROUTINE CAN ALSO BE IN- +C VOKED, SEE WRITEUP BELOW. FRAME MUST BE +C CALLED BY THE USER. +C +C IF DIFFERENT COLORS (OR INTENSITIES) ARE TO BE +C USED FOR NORMAL INTENSITY, LOW INTENSITY OR +C TEXT OUTPUT, THEN THE VALUES IN COMMON BLOCK +C RANINT SHOULD BE CHANGED: +C +C IRANMJ COLOR INDEX FOR NORMAL (MAJOR) INTENSITY +C LINES. +C IRANMN COLOR INDEX FOR LOW INTENSITY LINES +C IRANTX COLOR INDEX FOR TEXT (LABELS) +C +C +C ARGUMENTS +C +C ON INPUT XD +C ARRAY OF DIMENSION NDP CONTAINING THE X- +C COORDINATES OF THE DATA POINTS. +C +C YD +C ARRAY OF DIMENSION NDP CONTAINING THE Y- +C COORDINATES OF THE DATA POINTS. +C +C ZD +C ARRAY OF DIMENSION NDP CONTAINING THE +C DATA VALUES AT THE POINTS. +C +C NDP +C NUMBER OF DATA POINTS (MUST BE 4 OR +C GREATER) TO BE CONTOURED. +C +C WK +C REAL WORK ARRAY OF DIMENSION AT LEAST +C 13*NDP +C +C IWK +C INTEGER WORK ARRAY. WHEN USING C1 SURFACES +C THE ARRAY MUST BE AT LEAST IWK((27+NCP)*NDP). +C WHEN USING LINEAR INTERPOLATION THE ARRAY +C MUST BE AT LEAST IWK((27+4)*NDP). +C +C SCRARR +C REAL WORK ARRAY OF DIMENSION AT LEAST +C (RESOLUTION**2) WHERE RESOLUTION IS +C DESCRIBED IN THE SSZ OPTION BELOW. RESO- +C LUTION IS 40 BY DEFAULT. +C +C ON OUTPUT ALL ARGUMENTS REMAIN UNCHANGED EXCEPT THE +C SCRATCH ARRAYS IWK, WK, AND SCRARR WHICH HAVE +C BEEN WRITTEN INTO. IF MAKING MULTIPLE RUNS +C ON THE SAME TRIANGULATION IWK AND WK MUST BE +C SAVED AND RETURNED TO THE NEXT INVOCATION OF +C CONRAN. +C +C ENTRY POINTS CONRAN, CONDET, CONINT, CONCAL, CONLOC, CONTNG, +C CONDRW, CONCLS, CONSTP, CONBDN, CONTLK +C CONPDV, CONOP1, CONOP2, CONOP3, CONOP4, +C CONXCH, CONREO, CONCOM, CONCLD, CONPMM, +C CONGEN, CONLOD, CONECD, CONOUT, CONOT2, +C CONSLD, CONLCM, CONLIN, CONDSD, CONSSD +C +C COMMON BLOCKS CONRA1, CONRA2, CONRA3, CONRA4, CONRA5, CONRA6, +C CONRA7, CONRA8, CONRA9, CONR10, CONR11, CONR12, +C CONR13, CONR14, CONR15, CONR16, CONR17, RANINT +C INTPR FROM THE DASH PACKAGE +C +C I/O PLOTS THE CONTOUR MAP AND, VIA THE ERPRT77 +C PACKAGE, OUTPUTS MESSAGES TO THE MESSAGE +C OUTPUT UNIT; AT NCAR THIS UNIT IS THE +C PRINTER. THE OPTION VALUES ARE ALL LISTED ON +C STANDARD ERPRT77 OUTPUT UNIT; AT NCAR THIS +C UNIT IS THE PRINTER. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY STANDARD VERSION: DASHCHAR, WHICH AT NCAR IS +C ROUTINES LOADED BY DEFAULT. +C SMOOTH VERSION: DASHSMTH WHICH MUST BE +C REQUESTED AT NCAR. +C BOTH VERSIONS REQUIRE CONCOM, CONTERP, GRIDAL +C THE ERPRT77 PACKAGE, AND THE SPPS. +C +C LANGUAGE FORTRAN77 +C +C HISTORY +C +C ALGORITHM THE SPARSE DATA IS TRIANGULATED AND A VIRTUAL +C GRID IS LAID OVER THE TRIANGULATED AREA. +C EACH VIRTUAL GRID POINT RECEIVES AN INTERPO- +C LATED VALUE. THE GRID IS SCANNED ONCE FOR +C EACH CONTOUR LEVEL AND ALL CONTOURS AT THAT +C LEVEL ARE PLOTTED. +C THERE ARE TWO METHODS OF INTERPOLATION. THE +C FIRST IS A SMOOTH DATA INTERPOLATION +C SCHEME BASED ON LAWSON'S C1 +C SURFACE INTERPOLATION ALGORITHM, WHICH HAS +C BEEN REFINED BY HIROSHA AKIMA. PARTS OF +C AKIMA'S ALGORITHM ARE USED IN THIS PACKAGE. +C SEE THE "REFERENCE" SECTION BELOW. +C THE SECOND IS A LINEAR INTERPOLATION SCHEME. +C WHEN DATA IS SPARSE IT IS USUALLY BETTER TO +C USE THE C1 INTERPOLATION. IF YOU HAVE DENSE +C DATA (OVER 100 POINTS) THEN THE LINEAR +C INTERPOLATION WILL GIVE THE BETTER RESULTS. +C +C PORTABILITY ANSI FORTRAN +C +C +C OPERATION CALL CONRAN (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C FRAME MUST BE CALLED BY THE USER. +C +C CONRAN HAS MANY OPTIONS, EACH OF WHICH MAY +C BE CHANGED BY CALLING ONE OF THE FOUR +C SUBROUTINES CONOP1, CONOP2, CONOP3, OR +C CONOP4. THE NUMBER OF ARGUMENTS TO EACH +C CONOP ROUTINE IS THE SAME AS THE FINAL +C SUFFIX CHARACTER IN THE ROUTINE'S NAME. +C +C THE CONOP ROUTINES ARE CALLED BEFORE CONRAN +C IS CALLED, AND VALUES SET BY THESE CALLS +C CONTINUE TO BE IN EFFECT UNTIL THEY ARE +C CHANGED BY ANOTHER CALL TO A CONOP ROUTINE. +C +C ALL THE CONOP ROUTINES HAVE AS THEIR FIRST +C ARGUMENT A CHARACTER STRING TO IDENTIFY THE +C OPTION BEING CHANGED. THIS IS THE ONLY +C ARGUMENT TO CONOP1. CONOP2 HAS AN INTEGER +C SECOND ARGUMENT. CONOP3 HAS A REAL ARRAY (OR +C CONSTANT) AS ITS SECOND ARGUMENT AND AN +C INTEGER (USUALLY THE DIMENSION OF THE +C ARRAY) AS ITS THIRD ARGUMENT. CONOP4 HAS A +C CHARACTER STRING AS ITS SECOND ARGUMENT AND +C INTEGERS FOR THE THIRD AND FOURTH ARGUMENTS. +C +C ONLY THE FIRST TWO CHARACTERS ON EACH SIDE OF +C THE EQUAL SIGN ARE SCANNED. THEREFORE ONLY 2 +C CHARACTERS FOR EACH OPTION ARE REQUIRED ON +C INPUT TO CONOP (I.E. 'SCA=PRI' AND 'SC=PR' +C ARE EQUIVALENT.) +C +C REMEMBER, THERE MUST BE AT LEAST 4 DATA POINTS. +C THIS IS EQUAL TO THE DEFAULT NUMBER OF +C DATA POINTS TO BE USED FOR ESTIMATION OF PAR- +C TIAL DERIVATIVES AT EACH DATA POINT. +C THE ESTIMATED PARTIAL DERIVATIVES ARE +C USED FOR THE CONSTRUCTION OF THE INTERPOLAT- +C ING POLYNOMIAL'S COEFFICIENTS. +C +C LISTED BELOW ARE OPTIONS WHICH CAN ENHANCE +C YOUR PLOT. AN EXAMPLE OF AN APPROPRIATE +C CONOP CALL IS GIVEN FOR EACH OPTION. A +C COMPLETE LIST OF DEFAULT SETTINGS FOLLOWS +C THE LAST OPTION. +C +C OPTIONS +C +C CHL THIS FLAG DETERMINES HOW THE HIGH AND LOW +C CONTOUR VALUES ARE SET. THESE CONTOUR VALUES +C MAY BE SET BY THE PROGRAM OR BY THE USER. IF +C CHL=OFF, THE PROGRAM EXAMINES THE USER'S IN- +C PUT DATA AND DETERMINES BOTH THE HIGH AND LOW +C VALUES. IF CHL=ON, THE USER MUST SPECIFY THE +C DESIRED HIGH (HI) AND LOW (FLO) VALUES. +C THE DEFAULT IS CHL=OFF. +C +C IF PROGRAM SET: CALL CONOP3('CHL=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CHL=ON',ARRAY,2) +C WHERE ARRAY(1)=HI, ARRAY(2)=FLO +C +C NOTE: THE VALUES SUPPLIED FOR CONTOUR INCRE- +C MENT AND CONTOUR HIGH AND LOW VALUES ASSUMES +C THE UNSCALED DATA VALUES. SEE THE SDC FLAG, +C BELOW. +C +C EXAMPLE: CALL CONOP3('CHL=ON',ARRAY,2) +C WHERE ARRAY(1)=5020. (THE DESIRED +C HIGH CONTOUR VALUE) AND ARRAY(2)= +C 2000 (THE DESIRED LOW CONTOUR VALUE). +C THESE ARE FLOATING POINT NUMBERS. +C +C CIL THIS FLAG DETERMINES HOW THE CONTOUR INCRE- +C MENT (CINC) IS SET. THE INCREMENT IS EITHER +C CALCULATED BY THE PROGRAM (CIL=OFF) USING THE +C RANGE OF HIGH AND LOW VALUES FROM THE USER'S +C INPUT DATA, OR SET BY THE USER (CIL=ON). THE +C DEFAULT IS CIL=OFF. +C +C IF PROGRAM SET: CALL CONOP3('CIL=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CIL=ON',CINC,1) +C +C NOTE: BY DEFAULT, THE PROGRAM WILL EXAMINE +C THE USER'S INPUT DATA AND DETERMINE THE CONTOUR +C INTERVAL (CINC) AT SOME APPROPRIATE RANGE BETWEEN +C THE LEVEL OF HIGH AND LOW VALUES SUPPLIED, USUALLY +C GENERATING BETWEEN 15 AND 20 CONTOUR LEVELS. +C ELS. +C +C EXAMPLE: CALL CONOP3('CIL=ON',15.,1) +C WHERE 15. REPRESENTS THE +C CONTOUR INCREMENT DESIRED +C BY THE USER. +C +C CON THIS FLAG DETERMINES HOW THE CONTOUR LEVELS +C ARE SET. IF CON=ON, THE USER MUST SPECIFY +C THE ARRAY OF CONTOUR VALUES AND THE NUMBER OF +C CONTOUR LEVELS. A MAXIMUM OF 30 CONTOUR (NCL) +C LEVELS ARE PERMITTED. IF CON=OFF, DEFAULT +C VALUES ARE USED. IN THIS CASE, THE PROGRAM +C WILL CALCULATE THE VALUES FOR THE ARRAY AND +C NCL USING INPUT DATA. THE DEFAULT IS OFF. +C +C IF PROGRAM SET: CALL CONOP3('CON=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CON=ON',ARRAY,NCL) +C +C NOTE: THE ARRAY (ARRAY) CONTAINS THE CONTOUR +C LEVELS (FLOATING POINT ONLY) AND NCL IS THE +C NUMBER OF LEVELS. THE MAXIMUM NUMBER OF CON- +C TOUR LEVELS ALLOWED IS 30. WHEN ASSIGNING +C THE ARRAY OF CONTOUR VALUES, THE VALUES MUST +C BE ORDERED FROM SMALLEST TO LARGEST. +C +C EXAMPLE: +C DATA RLIST(1),...,RLIST(5)/1.,2.,3.,10.,12./ +C +C CALL CONOP3('CON=ON',RLIST,5) WHERE +C 'RLIST' CONTAINS THE USER SPECIFIED +C CONTOUR LEVELS, AND 5 IS THE +C NUMBER OF USER SPECIFIED CONTOUR +C LEVELS (NCL). +C +C WARNING ON CONTOUR OPTIONS: +C IT IS ILLEGAL TO USE THE CON OPTION WHEN +C EITHER CIL OR CHL ARE ACTIVATED. IF +C THIS IS DONE, THE OPTION CALL THAT DETECTED +C THE ERROR WILL NOT BE EXECUTED. +C +C DAS THIS FLAG DETERMINES WHICH CONTOURS ARE +C REPRESENTED BY DASHED LINES. THE USER SETS +C THE DASHED LINE PATTERN. THE USER MAY SPECI- +C FY THAT DASHED LINES BE USED FOR CONTOURS +C WHOSE VALUE IS LESS THAN, EQUAL TO, OR +C GREATER THAN THE DASH PATTERN BREAKPOINT (SEE +C THE DBP OPTION BELOW), WHICH IS ZERO BY +C DEFAULT. IF DAS=OFF (THE DEFAULT VALUE), ALL +C SOLID LINES ARE USED. +C +C ALL SOLID LINES: CALL CONOP4('DAS=OFF',' ',0,0) +C +C IF GREATER: CALL CONOP4('DAS=GTR',PAT,0,0) +C +C IF EQUAL: CALL CONOP4('DAS=EQU',PAT,0,0) +C +C IF LESS: CALL CONOP4('DAS=LSS',PAT,0,0) +C +C IF ALL SAME: CALL CONOP4('DAS=ALL',PAT,0,0) +C +C NOTE: PAT MUST BE A TEN CHARACTER +C STRING WITH A DOLLAR SIGN ($) FOR SOLID AND A +C SINGLE QUOTE (') FOR BLANK. RECALL THAT IN +C FORTRAN 77, IN A QUOTED STRING A SINGLE QUOTE +C IS REPRESENTED BY TWO SINGLE QUOTES (''). +C +C EXAMPLE: +C CALL CONOP4('DAS=GTR','$$$$$''$$$$',0,0) +C +C DBP THIS FLAG DETERMINES HOW THE DASH PATTERN +C BREAK POINT (BP) IS SET. IF DBP=ON, BP MUST +C BE SET BY THE USER BY SPECIFYING BP. IF +C DBP=OFF THE PROGRAM WILL SET BP TO THE +C DEFAULT VALUE WHICH IS ZERO. +C +C IF PROGRAM SET: CALL CONOP3('DBP=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('DBP=ON',BP,1) +C +C NOTE: BP IS A FLOATING POINT NUMBER WHERE THE +C BREAK FOR GTR AND LSS CONTOUR DASH PATTERNS +C ARE DEFINED. BP IS ASSUMED TO BE GIVEN RELA- +C TIVE TO THE UNTRANSFORMED CONTOURS. +C +C EXAMPLE: CALL CONOP3('DBP=ON',5.,1) +C WHERE 5. IS THE USER SPECI- +C FIED BREAK POINT. +C +C DEF RESET FLAGS TO DEFAULT VALUES. ACTIVATING +C THIS OPTION SETS ALL FLAGS TO THE DEFAULT +C VALUE. DEF HAS NO 'ON' OF 'OFF' STATES. +C +C TO ACTIVATE: CALL CONOP1('DEF') +C +C EXT FLAG TO SET EXTRAPOLATION. NORMALLY ALL +C CONRAN VERSIONS WILL ONLY PLOT THE BOUNDARIES +C OF THE CONVEX HULL DEFINED BY THE USER'S DATA. +C TO HAVE THE CONTOURS FILL THE RECTANGULAR +C AREA OF THE FRAME, SET THE EXT SWITCH ON. +C THE DEFAULT IS OFF. +C +C TO TURN ON: CALL CONOP1('EXT=ON') +C +C TO TURN OFF: CALL CONOP1('EXT=OFF') +C +C FMT FLAG FOR THE FORMAT OF THE PLOTTED INPUT DATA +C VALUES. IF FMT=OFF, THE DEFAULT VALUES FOR +C FT, L, AND IF ARE USED. THE DEFAULT VALUES +C ARE: +C +C FT = '(G10.3)' +C L = 7 CHARACTERS INCLUDING THE PARENTHESES +C IF = 10 CHARACTERS PRINTED IN THE OUTPUT +C FIELD BY THE FORMAT +C +C IF FMT=ON, THE USER MUST SPECIFY VALUES FOR +C FT, L, AND IF. ALL USER SPECIFIED VALUES +C MUST BE GIVEN IN THE CORRECT FORMAT. +C +C IF PROGRAM SET: CALL CONOP4('FMT=OFF',' ',0,0) +C +C IF USER SET: CALL CONOP4('FMT=ON',FT,L,IF) +C +C NOTE: FT IS A CHARACTER STRING CONTAINING THE +C FORMAT. THE FORMAT MUST BE ENCLOSED IN +C PARENTHESES. ANY FORMAT, UP TO 10 CHARACTERS +C WHICH IS ALLOWED AT YOUR INSTALLATION WILL BE +C ACCEPTED. L IS THE NUMBER OF CHARACTERS IN +C FT. IF IS THE LENGTH OF THE FIELD CREATED BY +C THE FORMAT. +C +C EXAMPLE: CALL CONOP4('FMT=ON','(G30.2)',7,30) +C +C WARNING: CONRAN WILL NOT TEST FOR A VALID +C FORMAT. THE FORMAT IS ONLY ALLOWED TO BE +C 10 CHARACTERS LONG. +C +C GRI FLAG TO DISPLAY THE GRID. GRI IS OFF BY DEFAULT. +C +C TO TURN ON: CALL CONOP1('GRI=ON') +C +C TO TURN OFF: CALL CONOP1('GRI=OFF') +C +C NOTE: IF GRI IS ON, THE VIRTUAL GRID WILL +C BE SUPERIMPOSED OVER THE CONTOUR PLOT. +C THE X AND Y TICK INTERVALS WILL BE DISPLAYED +C UNDER THE MAP ONLY IF PER=ON. (SEE PER) +C +C INT FLAG TO DETERMINE THE INTENSITIES OF THE CON- +C TOUR LINES AND OTHER PARTS OF THE PLOT. IF +C INT=OFF, ALL INTENSITIES ARE SET TO THE DEFAULT +C VALUES. IF INT=ALL, ALL INTENSITIES ARE SET +C TO THE GIVEN VALUE, IVAL. IF INT IS SET TO +C ONE OF THE OTHER POSSIBLE OPTIONS (MAJ, MIN, +C LAB OR DAT), THE INTENSITY LEVEL FOR THAT +C OPTION IS SET TO THE GIVEN VALUE, IVAL. +C +C IF PROGRAM SET: CALL CONOP2('INT=OFF',0) +C +C ALL THE SAME: CALL CONOP2('INT=ALL',IVAL) +C +C MAJOR LINES: CALL CONOP2('INT=MAJ',IVAL) +C +C MINOR LINES: CALL CONOP2('INT=MIN',IVAL) +C +C TITLE AND MESSAGE: +C CALL CONOP2('INT=LAB',IVAL) +C +C DATA VALUES: CALL CONOP2('INT=DAT',IVAL) +C +C NOTE: 'INT=DAT' RELATES TO THE PLOTTED DATA +C VALUES AND THE PLOTTED MAXIMUMS AND MINIMUMS. +C +C NOTE: IVAL IS THE INTENSITY DESIRED. FOR AN +C EXPLANATION OF THE OPTION VALUE SETTINGS SEE +C THE OPTN ROUTINE IN THE NCAR SYSTEM PLOT +C PACKAGE DOCUMENTATION. BRIEFLY, IVAL VALUES +C RANGE FROM 0 TO 255 OR THE CHARACTER STRINGS +C 'LO' AND 'HI'. THE DEFAULT IS 'HI' EXCEPT +C FOR INT=MIN WHICH IS SET TO 'LO'. +C +C EXAMPLE: CALL CONOP2('INT=ALL',110) +C +C ITP SET THE INTERPOLATION SCHEME. +C THERE ARE TWO SCHEMES--C1 SURFACES AND LINEAR. +C THE C1 METHOD TAKES LONGER BUT WILL GIVE THE +C BEST RESULTS WHEN THE DATA IS SPARSE (LESS +C THAN 100 POINTS). THE LINEAR METHOD WILL +C PRODUCE A BETTER PLOT WHEN THERE IS A DENSE +C DATA SET. THE DEFAULT IS C1 SURFACE. +C +C FOR C1 SURFACE CALL CONOP1('ITP=C1') +C +C FOR LINEAR CALL CONOP1('ITP=LIN') +C +C LAB THIS FLAG CAN BE SET TO EITHER LABEL THE CON- +C TOURS (LAB=ON) OR NOT (LAB=OFF). THE DEFAULT +C VALUE IS LAB=ON. +C +C TO TURN ON: CALL CONOP1('LAB=ON') +C +C TO TURN OFF: CALL CONOP1('LAB=OFF') +C +C LOT FLAG TO LIST OPTIONS ON THE PRINTER. THE DE- +C FAULT VALUE IS SET TO OFF, AND NO OPTIONS +C WILL BE DISPLAYED. +C +C TO TURN ON: CALL CONOP1('LOT=ON') +C +C TO TURN OFF: CALL CONOP1('LOT=OFF') +C +C NOTE: IF USERS WANT TO PRINT THE OPTION +C VALUES, THEY SHOULD TURN THIS OPTION ON. THE +C OPTION VALUES WILL BE SENT TO THE STANDARD +C OUTPUT UNIT AS DEFINED BY THE SUPPORT +C ROUTINE I1MACH. +C +C LSZ THIS FLAG DETERMINES THE LABEL SIZE. IF +C LSZ=OFF, THE DEFAULT ISZLSZ VALUE WILL BE +C USED. IF LSZ=ON, THE USER SHOULD SPECIFY +C ISZLSZ. THE DEFAULT VALUE IS 9 PLOTTER +C ADDRESS UNITS. +C +C IF PROGRAM SET: CALL CONOP2('LSZ=OFF',0) +C +C IF USER SET: CALL CONOP2('LSZ=ON',ISZLSZ) +C +C NOTE: ISZLSZ IS THE REQUESTED CHARACTER +C SIZE IN PLOTTER ADDRESS UNITS. +C +C EXAMPLE: CALL CONOP2('LSZ=ON',4) +C WHERE 4 IS THE USER DESIRED +C INTEGER PLOTTER ADDRESS +C UNITS. +C +C MES FLAG TO PLOT A MESSAGE. THE DEFAULT IS ON. +C +C TO TURN ON: CALL CONOP1('MES=ON') +C +C TO TURN OFF: CALL CONOP1('MES=OFF') +C +C NOTE: IF MES=ON, A MESSAGE IS PRINTED BELOW +C THE PLOT GIVING CONTOUR INTERVALS AND EXECU- +C TION TIME IN SECONDS. IF PER OR GRI ARE ON, +C THE MESSAGE ALSO CONTAINS THE X AND Y TICK +C INTERVALS. +C +C NCP FLAG TO INDICATE THE NUMBER OF DATA POINTS +C USED FOR THE PARTIAL DERIVATIVE +C ESTIMATION. IF NCP=OFF, NUM IS SET TO +C 4, WHICH IS THE DEFAULT VALUE. IF NCP=ON, +C THE USER MUST SPECIFY NUM GREATER THAN OR +C EQUAL TO 2. +C +C IF PROGRAM SET: CALL CONOP2('NCP=OFF',0) +C +C IF USER SET: CALL CONOP2('NCP=ON',NUM) +C +C NOTE: NUM = NUMBER OF DATA POINTS USED FOR +C ESTIMATION. CHANGING THIS VALUE EFFECTS THE +C CONTOURS PRODUCED AND THE SIZE OF INPUT ARRAY +C IWK. +C +C EXAMPLE: CALL CONOP2('NCP=ON',3) +C +C PDV FLAG TO PLOT THE INPUT DATA VALUES. THE +C DEFAULT VALUE IS PDV=OFF. +C +C TO TURN ON: CALL CONOP1('PDV=ON') +C +C TO TURN OFF: CALL CONOP1('PDV=OFF') +C +C NOTE: IF PDV=ON, THE INPUT DATA VALUES ARE +C PLOTTED RELATIVE TO THEIR LOCATION ON THE +C CONTOUR MAP. IF YOU ONLY WISH TO SEE THE +C LOCATIONS AND NOT THE VALUES, SET PDV=ON AND +C CHANGE FMT TO PRODUCE AN ASTERISK (*) SUCH AS +C (I1). +C +C PER FLAG TO SET THE PERIMETER. THE DEFAULT VALUE +C IS PER=ON, WHICH CAUSES A PERIMETER TO BE +C DRAWN AROUND THE CONTOUR PLOT. +C +C TO TURN ON: CALL CONOP1('PER=ON') +C +C TO TURN OFF: CALL CONOP1('PER=OFF') +C +C NOTE: IF MES IS ON, THE X AND Y TICK INTERVALS +C WILL BE GIVEN. THESE ARE THE INTERVALS IN USER +C COORDINATES THAT EACH TICK MARK REPRESENTS. +C +C PMM FLAG TO PLOT RELATIVE MINIMUMS AND MAXIMUMS. +C THIS FLAG IS OFF BY DEFAULT. +C +C TO TURN OFF: CALL CONOP1('PMM=OFF') +C +C TO TURN ON: CALL CONOP1('PMM=ON') +C +C PSL FLAG WHICH SETS THE PLOT SHIELD OPTION. +C THE OUTLINE OF THE SHIELD WILL BE DRAWN ON +C THE SAME FRAME AS THE CONTOUR PLOT. +C BY DEFAULT THIS OPTION IS OFF. +C (SEE SLD OPTION). +C +C DRAW THE SHIELD: CALL CONOP1('PSL=ON') +C +C DON'T DRAW IT: CALL CONOP1('PSL=OFF') +C +C REP FLAG INDICATING THE USE OF THE SAME DATA IN +C A NEW EXECUTION. THE DEFAULT VALUE IS OFF. +C +C TO TURN ON: CALL CONOP1('REP=ON') +C +C TO TURN OFF: CALL CONOP1('REP=OFF') +C +C NOTE: IF REP=ON, THE SAME X-Y DATA AND TRIANGU- +C LATION ARE TO BE USED BUT IT IS ASSUMED +C THE USER HAS CHANGED CONTOUR VALUES OR RESOLUTION +C FOR THIS RUN. SCRATCH ARRAYS WK AND IWK MUST +C REMAIN UNCHANGED. +C +C SCA FLAG FOR SCALING OF THE PLOT ON A FRAME. +C THIS FLAG IS ON BY DEFAULT. +C +C USER SCALING: CALL CONOP1('SCA=OFF') +C +C PROGRAM SCALING: CALL CONOP1('SCA=ON') +C +C PRIOR WINDOW: CALL CONOP1('SCA=PRI') +C +C NOTE: WITH SCA=OFF, PLOTTING INSTRUCTIONS +C WILL BE ISSUED USING THE USER'S INPUT COORDI- +C NATES, UNLESS THEY ARE TRANSFORMED VIA FX AND +C FY TRANSFORMATIONS. USERS WILL FIND AN +C EXTENDED DISCUSSION IN THE "INTERFACING WITH +C OTHER GRAPHICS ROUTINES" SECTION BELOW. THE SCA +C OPTION ASSUMES THAT ALL INPUT DATA FALLS INTO +C THE CURRENT WINDOW SETTING. WITH SCA=ON, THE +C ENTRY POINT WILL ESTABLISH A VIEWPORT SO THAT +C THE USER'S PLOT WILL FIT INTO THE CENTER 90 +C PERCENT OF THE FRAME. WHEN SCA=PRI, THE +C PROGRAM MAPS THE USER'S PLOT INSTRUCTIONS INTO +C THE PORTION OF THE FRAME DEFINED BY THE +C CURRENT NORMALIZATION TRANSFORMATION. SCA=OFF +C SHOULD BE USED TO INTERFACE WITH EZMAP. +C +C SDC FLAG TO DETERMINE HOW TO SCALE THE DATA ON +C THE CONTOURS. IF SDC=OFF, THE FLOATING POINT +C VALUE IS GIVEN BY SCALE. IF SDC=ON, THE USER +C MAY SPECIFY SCALE. THE DEFAULT VALUE FOR SCALE +C IS 1. +C +C IF PROGRAM SET: CALL CONOP3('SDC=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('SDC=ON',SCALE,1) +C +C NOTE: THE DATA PLOTTED ON CONTOUR LINES AND +C THE DATA PLOTTED FOR RELATIVE MINIMUMS AND +C MAXIMUMS WILL BE SCALED BY THE FLOATING POINT +C VALUE GIVEN BY SCALE. TYPICAL SCALE VALUES +C ARE 10., 100., 1000., ETC. THE ORIGINAL DATA +C VALUES ARE MULTIPLIED BY SCALE. SCALE MUST BE +C A FLOATING POINT NUMBER AND IS DISPLAYED IN THE +C MESSAGE (SEE MES). +C +C EXAMPLE: CALL CONOP2('SDC=ON',100.,1) +C +C SLD ACTIVATE OR DEACTIVATE THE SHIELDING OPTION. +C WHEN THIS OPTION IS ACTIVATED, ONLY THOSE +C CONTOURS WITHIN THE SHIELD ARE DRAWN. THE SHIELD +C IS A POLYGON SPECIFIED BY THE USER WHICH MUST +C BE GIVEN IN THE SAME COORDINATE RANGE AS THE +C THE DATA. IT MUST DEFINE ONLY ONE POLYGON. +C +C TO ACTIVATE THE SHIELD: +C CALL CONOP3('SLD=ON',ARRAY,ICSD) +C +C TO DEACTIVATE THE SHIELD: +C CALL CONOP3('SLD=OFF',0.,0) +C +C NOTE: ARRAY IS A REAL ARRAY ICSD ELEMENTS LONG. +C THE FIRST ICSD/2 ELEMENTS ARE X COORDINATES AND +C THE SECOND ICSD/2 ELEMENTS ARE Y COORDINATES. +C ICSD IS THE LENGTH OF ENTIRE ARRAY, THE +C NUMBER OF (X + Y) SHIELD COORDS. THE POLYGON +C MUST BE CLOSED, THAT IS THE FIRST AND LAST +C POINTS DESCRIBING IT MUST BE THE SAME. +C +C EXAMPLE: DIMENSION SHLD +C DATA SHLD/ 7.,10.,10.,7.,7., +C 1 7.,7.,10.,10.,7./ +C CALL CONOP3 (6HSLD=ON,SHLD,10) +C +C +C SML FLAG TO DETERMINE THE SIZE OF MINIMUM AND +C MAXIMUM CONTOUR LABELS. IF SML=OFF, THE +C ISZSML DEFAULT VALUE OF 15 IS USED. +C IF SML=ON, THE USER MUST SPECIFY ISZSML. +C +C IF PROGRAM SET: CALL CONOP2('SML=OFF',0) +C +C IF USER SET: CALL CONOP2('SML=ON',ISZSML) +C +C NOTE: ISZSML IS AN INTEGER NUMBER WHICH IS +C THE SIZE OF LABELS IN PLOTTER ADDRESS UNITS +C AS DEFINED IN THE SPPS ENTRY WTSTR. +C +C EXAMPLE: CALL CONOP2('SML=ON',12) +C +C SPD FLAG FOR THE SIZE OF THE PLOTTED INPUT DATA +C VALUES. IF SPD=OFF, THE VALUE OF ISZSPD IS +C 8, WHICH IS THE DEFAULT. IF SPD=ON, THE USER +C MUST SPECIFY ISZSPD. +C +C IF PROGRAM SET: CALL CONOP2('SPD=OFF',0) +C +C IF USER SET: CALL CONOP2('SPD=ON',ISZSPD) +C +C NOTE: ISZSPD IS AN INTEGER NUMBER GIVING THE +C SIZE TO PLOT THE DATA VALUES IN PLOTTER ADDRESS +C UNITS AS DEFINED IN THE SPPS ENTRY WTSTR. . +C +C EXAMPLE: CALL CONOP2('SPD=ON',6) +C +C SSZ FLAG TO DETERMINE THE RESOLUTION (NUMBER OF +C STEPS IN EACH DIRECTION). IF SSZ=ON, THE +C USER SETS ISTEP, OR, IF SSZ=OFF, THE PROGRAM +C WILL AUTOMATICALLY SET ISTEP AT THE DEFAULT +C VALUE OF 40. +C +C IF PROGRAM SET: CALL CONOP2('SSZ=OFF',0) +C +C IF USER SET: CALL CONOP2('SSZ=ON',ISTEP) +C +C NOTE: ISTEP IS AN INTEGER SPECIFYING THE DENSITY +C OF THE VIRTUAL GRID. IN MOST CASES, THE DEFAULT +C VALUE OF 40 PRODUCES PLEASING CONTOURS. FOR +C COARSER BUT QUICKER CONTOURS, LOWER THE +C VALUE. FOR SMOOTHER CONTOURS AT +C THE EXPENSE OF TAKING LONGER TIME, RAISE +C THE VALUE. NOTE: FOR STEP SIZES GREATER +C THAN 200 IN CONRAN, THE ARRAYS PV IN COMMON +C CONRA1 AND ITLOC IN COMMON CONRA9, MUST BE +C EXPANDED TO ABOUT 10 MORE THAN ISTEP. +C SEE CONRA1 AND CONRA9 COMMENTS BELOW FOR MORE +C INFORMATION. +C +C EXAMPLE: CALL CONOP2('SSZ=ON',25) +C THIS ISTEP VALUE WILL PRO- +C DUCE A COARSE CONTOUR. +C +C STL FLAG TO DETERMINE THE SIZE OF THE TITLE. +C ISZSTL MAY BE SET BY THE USER (STL=ON), OR +C THE PROGRAM WILL SET IT TO THE DEFAULT SIZE +C OF 16 PLOTTER ADDRESS UNITS (STL=OFF). +C +C IF PROGRAM SET: CALL CONOP2('STL=OFF',0) +C +C IF USER SET: CALL CONOP2('STL=ON',ISZSTL) +C +C NOTE: WHEN 30 OR 40 CHARACTERS ARE USED FOR +C THE TITLE, THE DEFAULT SIZE OF 16 PLOTTER +C ADDRESS UNITS WORKS WELL. FOR LONGER TITLES, +C A SMALLER TITLE SIZE IS REQUIRED. +C +C EXAMPLE: CALL CONOP2('STL=ON',13) +C +C TEN FLAG TO DETERMINE THE TENSION FACTOR APPLIED +C WHEN SMOOTHING CONTOUR LINES. THE USER MAY +C SET TENS OR ALLOW THE PROGRAM TO SET THE +C VALUE. IF USER SET, TENS MUST HAVE A VALUE +C GREATER THAN ZERO AND LESS THAN OR EQUAL TO +C 30. THE DEFAULT VALUE IS 2.5. +C +C IF PROGRAM SET: CALL CONOP3('TEN=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('TEN=ON',TENS,1) +C +C NOTE: TENS IS NOT AVAILABLE IN THE STANDARD +C VERSION OF CONRAN. +C SMOOTHING OF CONTOUR LINES IS ACCOMPLISHED +C WITH SPLINES UNDER TENSION. TO ADJUST THE +C AMOUNT OF SMOOTHING APPLIED, ADJUST THE TEN- +C SION FACTOR. SETTING TENS VERY LARGE +C (I.E. 30.), EFFECTIVELY SHUTS OFF SMOOTHING. +C +C EXAMPLE: CALL CONOP3('TEN=ON',14.,1) +C +C TFR FLAG TO ADVANCE THE FRAME BEFORE TRIANGULATION. +C THE DEFAULT VALUE IS TFR=ON, WHICH MEANS THAT +C THE CONTOURS AND THE TRIANGLES WILL BE PLOTTED +C ON SEPARATE FRAMES. +C +C IF PROGRAM SET: CALL CONOP1('TFR=ON') +C +C TO TURN OFF: CALL CONOP1('TFR=OFF') +C +C NOTE: TRIANGLES ARE PLOTTED AFTER THE CON- +C TOURING IS COMPLETED. TO SEE THE TRIANGLES +C OVER THE CONTOURS, TURN THIS SWITCH OFF. +C +C TLE FLAG TO PLACE A TITLE AT THE TOP OF THE PLOT. +C IF TLE=ON, THE USER MUST SPECIFY CHARS AND +C INUM. CHARS IS THE CHARACTER STRING CONTAINING +C THE TITLE. INUM IS THE NUMBER OF CHARACTERS +C IN CHARS. THE DEFAULT VALUE IS OFF. +C +C TO TURN ON: CALL CONOP4('TLE=ON',CHARS,INUM,0) +C +C TO TURN OFF: CALL CONOP4('TLE=OFF',' ',0,0) +C +C NOTE: IF LONGER THAN 64-CHARACTER TITLES ARE +C DESIRED, THE CHARACTER VARIABLE ISTRNG FOUND +C IN CONRA7 MUST BE INCREASED APPROPRIATELY. +C +C EXAMPLE: CALL CONOP4('TLE=ON','VECTOR REVIEW' +C ,13,0) +C +C TOP FLAG TO PLOT ONLY THE TRIANGLES. +C +C TO TURN OFF: CALL CONOP1('TOP=OFF') +C +C TO TURN ON: CALL CONOP1('TOP=ON') +C +C NOTE: THE USER MAY WISH TO OVERLAY THE TRIAN- +C GLES ON SOME OTHER PLOT. 'TOP=ON' WILL +C ALLOW THAT. THIS OPTION WHEN ACTIVATED +C (TOP=ON), WILL SET TRI=ON, AND TFR=OFF. IF +C THE USER WANTS TFR=ON, IT SHOULD BE SET AFTER +C TOP IS SET. IF THE USER SETS TOP=OFF IT WILL +C SET TRI=OFF AND TFR=ON. IF THE USER WANTS TRI +C OR TFR DIFFERENT, SET THEM AFTER THE +C TOP CALL. +C +C TRI FLAG TO PLOT THE TRIANGULATION. THE DEFAULT IS +C OFF AND THEREFORE THE TRIANGLES ARE NOT DRAWN. +C +C TO TURN ON: CALL CONOP1('TRI=ON') +C +C TO TURN OFF: CALL CONOP1('TRI=OFF') +C +C NOTE: PLOTTING THE TRIANGLES WILL INDICATE TO +C THE USER WHERE GOOD AND BAD POINTS OF INTER- +C POLATION ARE OCCURRING IN THE CONTOUR MAP. +C EQUILATERAL TRIANGLES ARE OPTIMAL FOR INTER- +C POLATION. QUALITY DEGRADES AS TRIANGLES +C APPROACH A LONG AND NARROW SHAPE. THE CONVEX +C HULL OF THE TRIANGULATION IS ALSO A POOR +C POINT OF INTERPOLATION. +C +C OPTION DEFAULT BELOW ARE LISTED THE DEFAULT +C VALUES VALUES FOR THE VARIOUS OPTIONS GIVEN ABOVE. +C UNLESS THE USER SPECIFIES OTHERWISE, THESE +C VALUES WILL BE USED IN EXECUTION OF THE VARI- +C OUS OPTIONS. +C +C CHL=OFF LOT=OFF SLD=OFF +C CIL=OFF LSZ=OFF SML=OFF +C CON=OFF MES=ON SPD=OFF +C DAS=OFF NCP=OFF SPT=OFF +C DBP=OFF PDV=OFF SSZ=OFF +C EXT=OFF PER=ON STL=OFF +C FMT=OFF PMM=OFF TEN=OFF +C GRI=OFF REP=OFF TFR=ON +C ITP=C1 SCA=ON TOP=OFF +C LAB=ON SDC=OFF TRI=OFF +C +C DEFAULT VALUES FOR THE OPTION DEFAULT VALUES GIVEN ABOVE, IF +C USER SPECIFIED USED, WILL SET DEFAULT VALUES FOR THE FOLLOW- +C PARAMETERS ING PARAMETERS: +C +C PARAMETER DEFAULT +C --------- ------- +C +C ARRAY UP TO 30 CONTOUR LEVELS ALLOWED. +C VALUES ARE COMPUTED BY THE +C PROGRAM, BASED ON INPUT. +C +C BP 0. +C +C CINC COMPUTED BY THE PROGRAM BASED ON THE +C RANGE OF HI AND LO VALUES OF THE +C INPUT DATA. +C +C FLO COMPUTED BY THE PROGRAM BASED ON THE +C LOWEST UNSCALED INPUT DATA. +C +C FT (G10.3) PARENTHESES MUST BE +C INCLUDED. +C +C HI COMPUTED BY THE PROGRAM BASED ON THE +C HIGHEST UNSCALED INPUT DATA. +C +C CHARS NO TITLE +C +C IF 10 CHARACTERS +C +C INUM NO TITLE +C +C IPAT '$$$$$$$$$$' (THIS IS A 10 CHARACTER +C STRING.) +C +C ISZLSZ 9 PLOTTER ADDRESS UNITS +C +C ISZSML 15 PLOTTER ADDRESS UNITS +C +C ISZSPD 8 PLOTTER ADDRESS UNITS +C +C ISZSTL 16 PLOTTER ADDRESS UNITS +C +C ISTEP 40 +C +C IVAL 'HI' FOR ALL EXCEPT MINOR CON- +C TOUR LINES WHICH ARE 'LO'. +C +C L 7 CHARACTERS (INCLUDING BOTH +C PARENTHESES) +C +C NCL COMPUTED BY THE PROGRAM BASED ON +C INPUT DATA. UP TO 30 CONTOUR +C LEVELS ARE PERMITTED. +C +C NUM 4 DATA POINTS +C +C SCALE 1. (NO SCALING PERFORMED) +C +C TENS 2.5 +C +C ICSD 0 (NO SHIELD) +C +C OPTIONS WHICH THE SHAPE OF THE CONTOURS MAY BE MODIFIED BY +C EFFECT THE CHANGING NCP AND SSZ. NCP CONTROLS THE +C CONTOURS NUMBER OF DATA POINTS TO BE USED IN THE +C INTERPOLATION. INCREASING NCP CAUSES MORE +C OF THE SURROUNDING DATA TO INFLUENCE THE +C POINT OF INTERPOLATION. SOME DATASETS CAUSE +C DIFFICULTY WHEN TRYING TO PRODUCE MEANINGFUL +C CONTOURS (TRIANGLES WHICH ARE LONG AND NARROW). +C BY MODIFYING NCP A USER CAN FINE-TUNE A +C PLOT. INCREASING ISTEP, THE DENSITY OF THE +C VIRTUAL GRID, WILL SMOOTH OUT THE CONTOUR +C LINES AND PICK UP MORE DETAIL (NEW CONTOURS +C WILL APPEAR AS ISTEP INCREASES AND OLD ONES WILL +C SOMETIMES BREAK INTO MORE DISTINCT UNITS). +C ISTEP IS CHANGED BY THE SSD OPTION. +C +C NOTE IF NCP.GT.25, ARRAYS DSQ0 AND IPC0 IN CONDET +C MUST BE ADJUSTED ACCORDINGLY. ALSO NCPSZ IN +C CONBDN (25 BY DEFAULT), MUST BE INCREASED TO +C NCP. THE DEFAULT VALUE OF NCP, WHICH IS 4, +C PRODUCES PLEASING PICTURES IN MOST CASES. +C HOWEVER, FINE-TUNING OF THE INTERPOLATION CAN +C BE OBTAINED BY INCREASING THE SIZE OF NCP, +C WITH A CORRESPONDING LINEAR INCREASE IN WORK +C SPACE. +C +C THE INTERPOLATION METHOD USED WILL ALSO CAUSE +C DIFFERENT LOOKING CONTOURS. THE C1 METHOD +C IS RECOMMENDED WHEN THE DATA IS SPARSE. IT +C WILL SMOOTH THE DATA AND ADD TRENDS (FALSE +C HILLS AND VALLEYS). THE LINEAR METHOD IS +C RECOMMENDED WHEN DATA IS DENSE (GT 50 TO 100) +C IT WILL NOT SMOOTH THE DATA OR ADD TRENDS. +C +C INTERFACING WITH NORMALLY THE SCALING FACTOR WILL BE SET TO OFF. +C OTHER GRAPHICS IN MOST CASES MAPPING CAN BE PERFORMED BEFORE +C ROUTINES CALLING THE CONRAN ENTRY POINT, THUS SAVING THE +C USER FROM MODIFYING THE FILE. IF REASONABLE +C RESULTS CANNOT BE OBTAINED, THE STATEMENT +C FUNCTIONS, FX AND FY, WILL HAVE TO BE REPLACED. +C THE ROUTINES HAVING THESE STATEMENT FUNCTIONS +C ARE: +C +C CONDRW, CONPDV, CONTLK, CONPMS, CONGEN +C +C REFERENCES AKIMA, HIROSHA +C A METHOD OF BIVARIATE INTERPOLATION AND +C SMOOTH SURFACE FITTING FOR IRREGULARLY +C DISTRIBUTED DATA POINTS. +C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE +C VOL 4, NO. 2, JUNE 1978, PAGES 148-159 +C LAWSON, C.L. +C SOFTWARE FOR C1 SURFACE INTERPOLATION +C JPL PUBLICATION 77-30 +C AUGUST 15, 1977 +C +C CONRAN ERROR ERROR ROUTINE MESSAGE +C MESSAGES +C 1 CONRAN INPUT PARAMETER NDP LT NCP +C 2 CONRAN NCP GT MAX SIZE OR LT 2 +C 3 CONTNG ALL COLINEAR DATA POINTS +C 4 CONTNG IDENTICAL INPUT DATA POINTS +C FOUND +C 5 CONOP UNDEFINED OPTION +C 6 CONCLS CONSTANT INPUT FIELD +C 7 CONOP INCORRECT CONOP CALL USED +C 8 CONOP ILLEGAL USE OF CON OPTION +C WITH CIL OR CHL OPTIONS +C 9 CONOP NUMBER OF CONTOUR LEVELS +C EXCEEDS 30 +C 10 CONDRW CONTOUR STORAGE EXHAUSTED +C THIS ERROR IS TRAPPED AND +C NULLIFIED BY CONRAN. IT +C SERVES TO SIGNAL THE USER +C THAT A CONTOUR LEVEL MAY NOT +C BE COMPLETE. +C 11 CONSTP ASPECT RATIO OF X AND Y +C GREATER THAN 5 TO 1. +C (THIS ERROR MAY CAUSE A POOR +C QUALITY PLOT. USUALLY THIS +C CAN BE FIXED BY MULTIPLYING +C X OR Y BY A CONSTANT FACTOR. +C IF THIS SOLUTION IS +C UNACCEPTABLE THEN INCREASING +C SSZ TO A VERY LARGE VALUE +C MAY HELP. NOTE: THIS CAN BE +C EXPENSIVE.) +C +C THE ERRORS LISTED ABOVE ARE DEFINED AS RECOVERABLE +C ERRORS SHOULD THE USER WISH TO USE THEM IN THAT +C FASHION. THE DOCUMENTATION ON THE ERPRT77 PACKAGE +C EXPLAINS HOW TO RECOVER FROM AN ERROR. +C +C NOTE: THE COMMON BLOCKS LISTED INCLUDE ALL THE COMMON USED BY +C THE ENTIRE CONRAN FAMILY. NOT ALL MEMBERS WILL USE ALL +C THE COMMON VARIABLES. +C +C CONRA1 +C CL-ARRAY OF CONTOUR LEVELS +C NCL-NUMBER OF CONTOUR LEVELS +C OLDZ-Z VALUE OF LEFT NEIGHBOR TO CURRENT LOCATION +C PV-ARRAY OF PREVIOUS ROW VALUES +C HI-LARGEST CONTOUR PLOTTED +C FLO-LOWEST CONTOUR PLOTTED +C FINC-INCREMENT LEVEL BETWEEN EQUALLY SPACED CONTOURS +C CONRA2 +C REPEAT-FLAG TO TRIANGULATE AND DRAW OR JUST DRAW +C EXTRAP-PLOT DATA OUTSIDE OF CONVEX DATA HULL +C PER-PUT PERIMETER AROUND PLOT +C MESS-FLAG TO INDICATE MESSAGE OUTPUT +C ISCALE-SCALING SWITCH +C LOOK-PLOT TRIANGLES FLAG +C PLDVLS-PLOT THE DATA VALUES FLAG +C GRD-PLOT GRID FLAG +C CON-USER SET OR PROGRAM SET CONTOURS FLAG +C CINC-USER OR PROGRAM SET INCREMENT FLAG +C CHILO-USER OR PROGRAM SET HI LOW CONTOURS +C LABON-FLAG TO CONTROL LABELING OF CONTOURS +C PMIMX-FLAG TO CONTROL THE PLOTTING OF MIN'S +C AND MAX'S +C SCALE-THE SCALE FACTOR FOR CONTOUR LINE VALUES +C AND MIN, MAX PLOTTED VALUES +C FRADV-ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C EXTRI-ONLY PLOT TRIANGULATION +C BPSIZ-BREAKPOINT SIZE FOR DASHPATTERNS +C LISTOP-LIST OPTIONS ON UNIT6 FLAG +C CONRA3 +C IRED-ERPRT77 RECOVERABLE ERROR FLAG +C CONRA4 +C NCP-NUMBER OF DATA POINTS USED AT EACH POINT FOR +C POLYNOMIAL CONSTRUCTION. +C NCPSZ-MAX SIZE ALLOWED FOR NCP +C CONRA5 +C NIT-FLAG TO INDICATE STATUS OF SEARCH DATA BASE +C ITIPV-LAST TRIANGLE INTERPOLATION OCCURRED IN +C CONRA6 +C XST-X COORDINATE START POINT FOR CONTOURING +C YST-Y COORDINATE START POINT FOR CONTOURING +C XED-X COORDINATE END POINT FOR CONTOURING +C YED-Y COORDINATE END POINT FOR CONTOURING +C STPSZ-STEP SIZE FOR X,Y CHANGE WHEN CONTOURING +C IGRAD-NUMBER OF GRADUATIONS FOR CONTOURING (STEP SIZE) +C IG-RESET VALUE FOR IGRAD +C XRG-X RANGE OF COORDINATES +C YRG-Y RANGE OF COORDINATES +C BORD-PERCENT OF FRAME USED FOR CONTOUR PLOT +C PXST-X PLOTTER START ADDRESS FOR CONTOURS +C PYST-Y PLOTTER START ADDRESS FOR CONTOURS +C PXED-X PLOTTER END ADDRESS FOR CONTOURS +C PYED-Y PLOTTER END ADDRESS FOR CONTOURS +C ITICK-NUMBER OF TICK MARKS FOR GRIDS AND PERIMETERS +C CONRA7 +C TITLE-SWITCH TO INDICATE IF TITLE OPTION ON OR OFF +C ISTRNG-CHARACTER STRING CONTAINING THE TITLE +C ICNT-CHARACTER COUNT OF ISTRNG +C ITLSIZ-SIZE OF TITLE IN PWRIT UNITS +C CONRA8 +C IHIGH-DEFAULT INTENSITY SETTING +C INMAJ-CONTOUR LEVEL INTENSITY FOR MAJOR LINES +C INMIN-CONTOUR LEVEL INTENSITY FOR MINOR LINES +C INLAB-TITLE AND MESSAGE INTENSITY +C INDAT-DATA VALUE INTENSITY +C FORM-THE FORMAT FOR PLOTTING THE DATA VALUES +C LEN-THE NUMBER OF CHARACTERS IN THE FORMAT +C IFMT-SIZE OF THE FORMAT FIELD +C LEND-DEFAULT FORMAT LENGTH +C IFMTD-DEFAULT FORMAT FIELD SIZE +C ISIZEP-SIZE OF THE PLOTTED DATA VALUES +C CONRA9 +C X-ARRAY OF X COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C Y-ARRAY OF Y COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C NP-COUNT IN X AND Y +C MXXY-SIZE OF X AND Y +C TR-TOP RIGHT CORNER VALUE OF CURRENT CELL +C BR-BOTTOM RIGHT CORNER VALUE OF CURRENT CELL +C TL-TOP LEFT CORNER VALUE OF CURRENT CELL +C BL-BOTTOM LEFT CORNER VALUE OF CURRENT CELL +C CONV-CURRENT CONTOUR VALUE +C XN-X POSITION WHERE CONTOUR IS BEING DRAWN +C YN-Y POSITION WHERE CONTOUR IS BEING DRAWN +C ITLL-TRIANGLE WHERE TOP LEFT CORNER OF CURRENT CELL LIES +C IBLL-TRIANGLE OF BOTTOM LEFT CORNER +C ITRL-TRIANGLE OF TOP RIGHT CORNER +C IBRL-TRIANGLE OF BOTTOM RIGHT CORNER +C XC-X COORDINATE OF CURRENT CELL +C YC-Y COORDINATE OF CURRENT CELL +C ITLOC-IN CONJUNCTION WITH PV STORES THE TRIANGLE WHERE PV +C VALUE CAME FROM +C CONR10 +C NT-NUMBER OF TRIANGLES GENERATED +C NL-NUMBER OF LINE SEGMENTS +C NTNL-NT+NL +C JWIPT-POINTER INTO IWK WHERE WHERE TRIANGLE POINT NUMBERS +C ARE STORED +C JWIWL-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIWP-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIPL-IN IWK THE LOCATION OF END POINTS FOR BORDER LINE +C SEGMENTS +C IPR-IN WK THE LOCATION OF THE PARTIAL DERIVATIVES AT EACH +C DATA POINT +C ITPV-THE TRIANGLE WHERE THE PREVIOUS VALUE CAME FROM +C CONR11 +C NREP-NUMBER OF REPETITIONS OF DASH PATTERN BEFORE A LABEL +C NCRT-NUMBER OF CRT UNITS FOR A DASH MARK OR BLANK +C ISIZEL-SIZE OF CONTOUR LINE LABELS +C NDASH-ARRAY CONTAINING THE NEGATIVE VALUED CONTOUR DASH +C PATTERN +C MINGAP-NUMBER OF UNLABELED LINES BETWEEN EACH LABELED ONE +C IDASH-POSITIVE VALUED CONTOUR DASH PATTERN +C ISIZEM-SIZE OF PLOTTED MINIMUMS AND MAXIMUMS +C EDASH-EQUAL VALUED CONTOUR DASH PATTERN +C TENS-DEFAULT TENSION SETTING FOR SMOOTHING +C CONR12 +C IXMAX,IYMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C CONR13 +C XVS-ARRAY OF THE X COORDINATES FOR SHIELDING +C YVS-ARRAY OF THE Y COORDINATES FOR SHIELDING +C IXVST-POINTER TO THE USERS X ARRAY FOR SHIELDING +C IYVST-POINTER TO THE USERS Y ARRAY FOR SHIELDING +C ICOUNT-COUNT OF THE SHIELD ELEMENTS +C SPVAL-SPECIAL VALUE USED TO HALT CONTOURING AT THE SHIELD +C BOUNDARY +C SHIELD-LOGICAL FLAG TO SIGNAL STATUS OF SHIELDING +C SLDPLT-LOGICAL FLAG TO INDICATE STATUS OF SHIELD PLOTTING +C CONR14 +C LINEAR-C1 LINEAR INTERPOLATING FLAG +C CONR15 +C ISTRNG-TITLE OF THE PLOT +C CONR16 +C FORM-FORMAT USED FOR DATA +C CONR17 +C NDASH-DASH PATTERN USED FOR CONTOUR LINES LESS THAN BP +C IDASH-DASH PATTERN USED FOR CONTOUR LINES GREATER THAN BP +C EDASH-DASH PATTERN USED FOR CONTOUR LINES EQUAL TO THE BP +C RANINT +C IRANMJ-COLOR INDEX FOR NORMAL (MAJOR) INTENSITY LINES +C IRANMN-COLOR INDEX FOR LOW INTENSITY LINES +C IRANMJ-COLOR INDEX FOR TEXT (LABELS) +C +C +NOAO - Blockdata data conbdn rewritten as run time initialization +C Variable LNGTHS not used. +C +C EXTERNAL CONBDN +C DIMENSION LNGTHS(4), HOLD(4) + DIMENSION HOLD(4) +C - NOAO + CHARACTER*110 IWORK + CHARACTER*13 ENCSCR, ENSCRY + CHARACTER*1 ICHAR + CHARACTER*500 DPAT + REAL WIND(4), VIEW(4), NWIND(4), NVIEW(4) + DIMENSION XD(*) ,YD(*) ,ZD(*) ,WK(*) , + 1 IWK(*) ,SCRARR(*) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + INTEGER OPLASF, OTXASF, LASF(13), OCOLI, OTEXCI + SAVE +C +C +C+NOAO - Variable LNGTHS not used. +C DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4)/13,4,21,6/ +C-NOAO +C +C ICONV CONVERT FORM 0-32767 TO 1-1024 +C + DATA ICONV/32/ +C +C IABOVE AMOUNT TITLE IS PLACED ABOVE PLOT +C IBELOW, IBEL2 AMOUNT MESSAGE IS BELOW PLOT +C +C DATA IABOVE,IBELOW,IBEL2/30,-30,-45/ +C +C + NOAO - Label placement is improved by changed these values. Also, +C call the run time initialization subroutine, conbdn. +C + iabove = 30 + ibelow = -15 + ibel2 = -30 + call conbdn +C - NOAO +C +C THE FOLLOWING CALL IS FOR MONOTORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','CONRAN','CONRAN','VERSION 01') +C +C LIST THE OPTION VALUES IF REQUESTED +C + IF (LISTOP) CALL CONOUT (2) +C +C SET SWITCH TO MAP TRIANGLES, IN CONLOC, FOR QUICK SEARCHES +C + NIT = 0 +C +C TEST TO SEE IF ENOUGH INPUT DATA +C + IF (NDP.GE.NCP) GO TO 10 + CALL SETER (' CONRAN - INPUT PARAMETER NDP LESS THAN NCP',1, + 1 IREC) + RETURN +C + 10 IF (NCPSZ.GE.NCP .AND. NCP.GE.2) GO TO 20 + CALL SETER (' CONRAN - NCP LT 2 OR GT NCPSZ',2,IREC) +C + 20 IWK(1) = NDP + IWK(2) = NCP + IWK(3) = 1 +C +C SET POLYLINE COLOR ASF TO INDIVIDUAL +C + CALL GQASF(IERR,LASF) + OPLASF = LASF(3) + LASF(3) = 1 + OTXASF = LASF(10) + LASF(10) = 1 + CALL GSASF(LASF) +C +C INQUIRE CURRENT POLYLINE AND TEXT COLOR +C + CALL GQPLCI(IERR,OCOLI) + CALL GQTXCI(IERR,OTEXCI) +C +C SET POLYLINE AND TEXT COLOR TO VALUE IN COMMON +C + CALL GSPLCI(IRANMJ) + CALL GSTXCI(IRANTX) +C +C CONSTRUCTION OF WORK SPACE POINTERS +C +C TRIANGLE POINT NUMBERS +C + JWIPT = 16 +C +C SCRATCH SPACE +C + JWIWL = 6*NDP + 1 +C +C END POINTS OF BORDER LINE SEGMENTS AND TRIANGLE NUMBER +C + JWIPL = 24*NDP + 1 +C +C POINT NUMBERS WHERE THE NCP DATA POINTS AROUND EACH POINT +C + JWIPC = 27*NDP + 1 +C +C SCRATCH SPACE +C + JWIWP = 30*NDP + 1 +C +C PARTIAL DERIVATIVES AT EACH DATA POINT +C + IPR = 8*NDP + 1 +C +C TEST IF REPEAT (JUST NEW CONTOURS OF INTERPOLATED DATA) +C OR NO REPEAT (TRIANGULATE AND CONTOUR) +C + IF (REPEAT) GO TO 30 +C +C TRIANGULATES THE X-Y PLANE. +C + CALL CONTNG (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),IWK(JWIWL), + 1 IWK(JWIWP),WK) + IF (NERRO(ITEMP).NE.0) RETURN +C + IWK(5) = NT + IWK(6) = NL + NTNL = NT+NL +C +C SKIP IF NOT LINEAR INTERPOLATION +C + IF (.NOT.LINEAR) GO TO 25 +C +C FIND THE COEFICENTS FOR LINER INTERPOLATION OF EACH TRIANGLE +C + CALL CONLIN(XD,YD,ZD,NT,IWK(JWIPT),WK(IPR)) + GO TO 35 +C +C +C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. +C + 25 CALL CONDET (NDP,XD,YD,NCP,IWK(JWIPC)) +C +C ESTIMATE THE PARTIAL DERIVATIVES AT ALL DATA POINTS +C + CALL CONINT (NDP,XD,YD,ZD,NCP,IWK(JWIPC),WK(IPR)) +C +C VERIFY DATA VALUES VALID +C + 30 NT = IWK(5) + NL = IWK(6) + NTNL = NT+NL +C +C COMPUTE STEP SIZE FOR CONTOURING +C + 35 CALL CONSTP (XD,YD,NDP) +C +C SAVE ORIGINAL WINDOW, VIEWPORT OF TRANSFORMATION 1, AND ORIGINAL +C LOG SCALING FLAG. +C + CALL GQCNTN(IER,IOLDNT) + CALL GQNT(IOLDNT,IER,WIND,VIEW) + RX1 = VIEW(1) + RX2 = VIEW(2) + RY1 = VIEW(3) + RY2 = VIEW(4) +C SAVE NORMALIZATION TRANSFORMATION 1 + CALL GQNT(1,IER,WIND,VIEW) + CALL GETUSV('LS',IOLLS) +C +C DETERMINE SCALING OPTION +C + ISC = ISCALE+1 + GO TO ( 40, 60, 50),ISC +C +C CONRAN SETS SCALING FACTOR +C + 40 CALL SET(PXST,PXED,PYST,PYED,XST,XED,YST,YED,1) + GO TO 60 +C +C CONRAN PLOTS WITHIN USERS BOUNDARIES +C + 50 CALL SET(RX1,RX2,RY1,RY2,XST,XED,YST,YED,1) +C +C IF TRIANGULATION PLOT ONLY BRANCH +C + 60 IF (EXTRI) GO TO 390 +C +C GENERATE CONTOURS IF NONE SUPPLIED BY USER +C + CALL CONCLS (ZD,NDP) + IF (NERRO(ITEMP).NE.0) RETURN +C +C REORDER THE CONTOUR LINES FOR CORRECT PATTERN DISPLAY +C + MAJLNS = 0 + IF (LABON) CALL CONREO (MAJLNS) +C +C MAKE SURE INTEGER COORDINATES IN 1-1024 RANGE +C + CALL SETUSV('XF',10) + CALL SETUSV('YF',10) +C +C SET THE DASH PATTERNS TO DEFAULT IF THEY HAVE NOT BEEN SET +C +C + IF (IDASH(1:1).NE.' ') GO TO 80 +C +C SET POSITIVE CONTOUR VALUE TO DEFAULT +C + IDASH = '$$$$$$$$$$' + 80 IF (NDASH(1:1).NE.' ') GO TO 100 +C +C SET NEGATIVE CONTOUR DASH PATTERN TO DEFAULT +C + NDASH = '$$$$$$$$$$' + 100 IF (EDASH(1:1).NE.' ') GO TO 120 +C +C SET EQUAL CONTOUR DASH PATTERN TO DEFAULT +C + EDASH = '$$$$$$$$$$' +C +C INITIALIZE THE CONTOURING DATA STRUCTURE +C + 120 IF (.NOT.EXTRAP) YST = YST+STPSZ +C +C LOAD THE SCRATCH SPACE +C + CALL CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C PERFORM SHIELDING IF SO REQUESTED +C + IF (SHIELD) CALL CONSLD(SCRARR) +C +C ******************************************************* +C * * +C * IF THE USER NEEDS TO DIVIDE THE PROGRAM UP * +C * THIS IS THE BREAK POINT. ALL SUBROUTINES CALLED * +C * PRIOR TO THIS MESSAGE ARE NOT USED AGAIN AND * +C * ALL ROUTINES AFTER THIS MESSAGE ARE NOT USED * +C * ANY EARLIER. NOTE THIS ONLY REFEARS TO ENTRY POINTS* +C * WHICH ARE PART OF THE CONRAN PACKAGE. * +C * ALL DATA STRUCTURES AND VARIABLES MUST BE RETAINED. * +C ******************************************************* +C +C +C PLOT RELATIVE MINIMUMS AND MAXIMUMS IF REQUESTED +C + IF (PMIMX) CALL CONPMM (SCRARR) +C +C + LENDAS = NREP*10 +C +C SET THE ERROR MODE TO RECOVERY FOR THE CONTOURING STORAGE ERROR +C + CALL ENTSR (IROLD,1) +C +C DRAW THE CONTOURS +C + DO 250 I=1,NCL +C + CONV = CL(I) + IF (CONV.GE.BPSIZ) GO TO 150 +C +C SET UP NEGATIVE CONTOUR PATTERN +C + DO 140 J=1,10 + ICHAR = NDASH(J:J) + DO 130 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 130 CONTINUE + 140 CONTINUE + GO TO 210 +C +C SET UP POSITIVE CONTOUR DASH PATTERN +C + 150 IF (CONV.EQ.BPSIZ) GO TO 180 + DO 170 J=1,10 + ICHAR = IDASH(J:J) + DO 160 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 160 CONTINUE + 170 CONTINUE + GO TO 210 +C +C SET UP EQUAL CONTOUR DASH PATTERN +C + 180 DO 200 J=1,10 + ICHAR = EDASH(J:J) + DO 190 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 190 CONTINUE + 200 CONTINUE +C + 210 IF (I.GT.MAJLNS) GO TO 230 +C +C SET UP MAJOR LINES +C + CALL GSPLCI (IRANMJ) + CALL CONECD (CONV,IWORK,NCUSED) + NCHAR = LENDAS + NCUSED + DPAT(LENDAS+1:NCHAR) = IWORK(1:NCUSED) + GO TO 240 +C +C SET UP MINOR LINES +C + 230 NCHAR = 10 + CALL GSPLCI (IRANMN) +C +C PROCESS FOR ALL CONTOURS +C + 240 CALL DASHDC (DPAT(1:NCHAR),NCRT,ISIZEL) +C +C DRAW ALL CONTOURS AT THIS LEVEL +C + CALL CONDRW (SCRARR) +C +C GET NEXT CONTOUR LEVEL +C + 250 CONTINUE +C +C CONTOURING COMPLETED CHECK FOR OPTIONAL OUTPUTS ON PLOT +C +C FIRST SET ERROR MODE BACK TO USERS VALUE +C + CALL RETSR (IROLD) +C +C GET PLOT BOUNDRIES FOR TITLING AND MESSAGE POSITIONING +C + CALL GQCNTN(IER,ICN) + CALL GQNT(ICN,IER,NWIND,NVIEW) + XST = NWIND(1) + XED = NWIND(2) + YST = NWIND(3) + YED = NWIND(4) + CALL GETUSV('LS',LT) +C +C RESET POLYLINE COLOR INDEX TO MAJOR (NORMAL) +C + CALL GSPLCI (IRANMJ) +C +C DRAW SHIELD ON PLOT IF REQUESTED +C + IF(SLDPLT.AND.SHIELD) CALL CONDSD +C +C DRAW PERIMETER ARROUND PLOT IF DESIRED +C + IF (PER) CALL PERIM (ITICK,0,ITICK,0) +C +C DRAW GRID IF REQUESTED +C + IF (GRD) CALL GRID (ITICK,0,ITICK,0) +C +C PLOT THE DATA VALUES IF REQUESTED +C + IF (.NOT.PLDVLS) GO TO 260 + CALL CONPDV (XD,YD,ZD,NDP) +C +C OUTPUT TITLE IF REQUESTED +C + 260 IF (.NOT.TITLE) GO TO 270 + CALL GSTXCI (IRANTX) + CALL FL2INT (XED,YED,MX,MY) + MY = (MY/ICONV)+IABOVE + ILAST = 64 + DO 261 I = 64,1,-1 + IF (ISTRNG(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 262 + ENDIF + 261 CONTINUE + 262 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY) + CALL WTSTR(XC,YC,ISTRNG(1:ILAST),ITLSIZ,0,0) + CALL GSELNT(ICN) +C +C +C OUTPUT MESSAGE IF REQUESTED +C + 270 IF (.NOT.MESS) GO TO 390 +C + CALL GSTXCI(IRANTX) + CALL FL2INT (XST,YST,MX,MY) + MY = (MY/ICONV) +C +C IF PERIMETER OR GRID PUT OUT TICK INTERVAL +C + IMSZ = 0 + IF (.NOT.PER .AND. .NOT.GRD) GO TO 300 + IWORK(1:36) = 'X INTERVAL= Y INTERVAL=' +C +C +NOAO - FTN internal writes rewritten as calls to encode. +C WRITE(ENCSCR,'(G13.5)')XRG +C WRITE(ENSCRY,'(G13.5)')YRG + call encode (13, '(f13.5)', encscr, xrg) + call encode (13, '(f13.5)', enscry, yrg) +C -NOAO + IWORK(12:24) = ENCSCR + IWORK(37:49) = ENSCRY + IMSZ = 50 + 300 IF (SCALE .EQ. 1.) GOTO 330 + IWORK(IMSZ:IMSZ+10) = ' SCALED BY ' +C +NOAO +C WRITE(ENCSCR,'(G13.5)')SCALE + call encode (13, '(f13.5)', encscr, scale) +C -NOAO + IWORK(IMSZ+11:IMSZ+23) = ENCSCR + IMSZ = 73 + 330 IF (IMSZ .NE. 0) THEN + ILAST = IMSZ + DO 291 I = IMSZ,1,-1 + IF (IWORK(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 292 + ENDIF + 291 CONTINUE + 292 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY+IBEL2) + CALL WTSTR(XC,YC,IWORK(1:ILAST),8,0,0) + CALL GSELNT(ICN) + ENDIF +C +C PRODUCE CONTOUR INFO +C + IWORK(1:42) = 'CONTOUR FROM TO ' + IWORK(43:77) = 'CONTOUR INTERVAL OF ' + HOLD(1) = FLO + HOLD(2) = HI + HOLD(3) = FINC +C +C +NOAO +C WRITE(ENCSCR,'(G13.5)')HOLD(1) + call encode (13, '(f13.5)', encscr, hold(1)) + IWORK(13:25) = ENCSCR +C WRITE(ENCSCR,'(G13.5)')HOLD(2) + call encode (13, '(f13.5)', encscr, hold(2)) + IWORK(29:41) = ENCSCR +C WRITE(ENCSCR,'(G13.5)')HOLD(3) + call encode (13, '(f13.5)', encscr, hold(3)) + IWORK(62:74) = ENCSCR +C -NOAO +C +C IF IRREGULAR SPACED CONTOURS MODIFY CONTOUR INTERVAL STATEMENT +C + IF (FINC.GE.0.) GO TO 380 + NC = 62 + IWORK(NC:NC+15) = ' IRREGULAR ' +C + ILAST = 77 + 380 DO 381 I = 77,1,-1 + IF (IWORK(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 382 + ENDIF + 381 CONTINUE + 382 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY+IBELOW) + CALL WTSTR(XC,YC,IWORK(1:ILAST),8,0,0) + CALL GSELNT(ICN) +C +C +C +C PLOT TRIANGLES IF REQUESTED +C + 390 IF (LOOK) THEN + CALL GSPLCI(IRANMN) + CALL CONTLK (XD,YD,NDP,IWK(JWIPT)) + CALL GSPLCI(IRANMJ) + ENDIF +C RESTORE NORMALIZATION TRANSFORMATION 1 AND LOG SCALING + IF (ISCALE .NE. 1) THEN + CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), + - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) + ENDIF +C RESTORE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER + CALL GSELNT (IOLDNT) +C +C RESTORE ORIGINAL COLOR +C + CALL GSPLCI(OCOLI) + CALL GSTXCI(OTEXCI) +C +C RESTORE POLYLINE COLOR ASF TO WHAT IT WAS ON ENTRY TO GRIDAL +C + LASF(10) = OTXASF + LASF(3) = OPLASF + CALL GSASF(LASF) + RETURN + END + SUBROUTINE CONPMM (SCRARR) +C +C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM +C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN +C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE +C IS + OR - IXRG IN THE X DIRECTION AND + OR - IYRG IN THE Y DIRECTION. +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(*) + CHARACTER*10 IA + SAVE +C +C CONVERT FROM 0-32767 TO 1-1024 +C + DATA ICONV/32/ +C +C ACCESSING FUNCTION INTO SCRARR +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C GRAPHICS MAPPING FUNCTIONS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C MAPPING FROM INTEGER TO USER INPUT FLOATING POINT +C + CONVX(IXX) = XST + FLOAT(IXX-1)*STPSZ + CONVY(IYY) = YST + FLOAT(IYY-1)*STPSZ +C +C SET INTENSITY TO HIGH +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C COMPUTE THE SEARCH RANGE FOR MIN AND MAX DETERMINATION +C + IXRG = MIN0(15,MAX0(2,IFIX(FLOAT(IXMAX)/8.))) + IYRG = MIN0(15,MAX0(2,IFIX(FLOAT(IYMAX)/8.))) +C +C LOOP THROUGH ALL ROWS OF THE DATA SEARCHING FOR AN IMMEDIATE MIN OR +C MAX. +C + IX = 1 +C +C SCAN A ROW +C +C IF EXTRAPOLATING DONT LIMIT ROW SCANS +C + 10 IF (.NOT.EXTRAP) GO TO 20 + IYST = 1 + IYED = IYMAX + IY = 1 + GO TO 30 +C +C NOT EXTRAPOLATING STAY IN HULL BOUNDRIES +C + 20 IYST = ITLOC(IX*2-1) + IYED = ITLOC(IX*2) + IF (IYST.EQ.0) GO TO 240 + IY = IYST + 30 VAL = SCRTCH(IX,IY) +C +C SEARCH FOR A MIN +C +C +C BRANCH IF NOT FIRST ON A ROW +C + IF (IY.NE.IYST) GO TO 40 + IF (VAL.GE.SCRTCH(IX,IY+1)) GO TO 130 + IF (VAL.GE.SCRTCH(IX,IY+2)) GO TO 130 + GO TO 60 +C +C BRANCH IF NOT LAST ON ROW +C + 40 IF (IY.NE.IYED) GO TO 50 + IF (VAL.GE.SCRTCH(IX,IY-1)) GO TO 140 + IF (VAL.GE.SCRTCH(IX,IY-2)) GO TO 140 + GO TO 60 +C +C IN MIDDLE OF ROW +C + 50 IF (VAL.GE.SCRTCH(IX,IY+1)) GO TO 150 + IF (VAL.GE.SCRTCH(IX,IY-1)) GO TO 150 +C +C POSSIBLE MIN FOUND SEARCH NEIGHBORHOOD +C + 60 IXST = MAX0(1,IX-IXRG) + IXSTOP = MIN0(IXMAX,IX+IXRG) +C +C IF NOT EXTRAPOLATING BRANCH +C + 70 IF (.NOT.EXTRAP) GO TO 80 + IYSRS = 1 + IYSRE = IYMAX + GO TO 90 +C +C NOT EXTRAPOLATING STAY IN CONVEX HULL +C + 80 IYSRS = ITLOC(IXST*2-1) + IYSRE = ITLOC(IXST*2) + IF (IYSRS.EQ.0) GO TO 120 +C + 90 IYSRS = MAX0(IYSRS,IY-IYRG) + IYSRE = MIN0(IYSRE,IY+IYRG) +C + 100 CUR = SCRTCH(IXST,IYSRS) + IF (VAL.LT.CUR) GO TO 110 + IF (VAL.GT.CUR) GO TO 230 + IF (IX.EQ.IXST .AND. IY.EQ.IYSRS) GO TO 110 + GO TO 230 +C +C SUCCESS SO FAR TRY NEXT SPACE +C + 110 IYSRS = IYSRS+1 + IF (IYSRS.LE.IYSRE) GO TO 100 + 120 IXST = IXST+1 + IF (IXST.LE.IXSTOP) GO TO 70 +C +C SUCCESS, WE HAVE FOUND A RELATIVE MIN +C + X = CONVX(IX) + Y = CONVY(IY) + X1 = FX(X,Y) + CALL FL2INT (X1,FY(X,Y),MX,MY) + MX = MX/ICONV + MY = MY/ICONV +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) + CALL WTSTR(XC,YC,'L',ISIZEM,0,0) + CALL GSELNT(ICN) +C + CALL CONECD (VAL,IA,NC) + MY = MY - 2*ISIZEM +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + YC = CPUY(MY) + CALL WTSTR(XC,YC,IA(1:NC),ISIZEM,0,0) + CALL GSELNT(ICN) +C + GO TO 230 +C +C SEARCH FOR A LOCAL MAXIMUM +C +C IF FIRST LOC ON A ROW +C + 130 IF (VAL.LE.SCRTCH(IX,IY+1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY+2)) GO TO 230 + GO TO 160 +C +C IF LAST ON ROW +C + 140 IF (VAL.LE.SCRTCH(IX,IY-1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY-2)) GO TO 230 + GO TO 160 +C +C IN MIDDLE OF ROW +C + 150 IF (VAL.LE.SCRTCH(IX,IY+1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY-1)) GO TO 230 +C +C POSSIBLE MIN FOUND SEARCH NEIGHBORHOOD +C + 160 IXST = MAX0(1,IX-IXRG) + IXSTOP = MIN0(IXMAX,IX+IXRG) + 170 IF (.NOT.EXTRAP) GO TO 180 + IYSRS = 1 + IYSRE = IYMAX + GO TO 190 +C +C NOT EXTRAPOLATING STAY IN CONVEX HULL +C + 180 IYSRS = ITLOC(IXST*2-1) + IYSRE = ITLOC(IXST*2) + IF (IYSRS.EQ.0) GO TO 220 +C + 190 IYSRS = MAX0(IYSRS,IY-IYRG) + IYSRE = MIN0(IYSRE,IY+IYRG) +C + 200 CUR = SCRTCH(IXST,IYSRS) + IF (VAL.GT.CUR) GO TO 210 + IF (VAL.LT.CUR) GO TO 230 + IF (IX.EQ.IXST .AND. IY.EQ.IYSRS) GO TO 210 + GO TO 230 +C +C SUCCESS SO FAR TRY NEXT SPACE +C + 210 IYSRS = IYSRS+1 + IF (IYSRS.LE.IYSRE) GO TO 200 + 220 IXST = IXST+1 + IF (IXST.LE.IXSTOP) GO TO 170 +C +C SUCCESS WE HAVE A MAXIMUM +C + X = CONVX(IX) + Y = CONVY(IY) + X1 = FX(X,Y) + CALL FL2INT (X1,FY(X,Y),MX,MY) + MX = MX/ICONV + MY = MY/ICONV +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) + CALL WTSTR(XC,YC,'H',ISIZEM,0,0) + CALL GSELNT(ICN) +C + CALL CONECD (VAL,IA,NC) + MY = MY - 2*ISIZEM +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + YC = CPUY(MY) + CALL WTSTR(XC,YC,IA(1:NC),ISIZEM,0,0) + CALL GSELNT(ICN) +C +C END OF SEARCH AT THIS LOCATION TRY NEXT +C + 230 IY = IY+1 + IF (IY.LE.IYED) GO TO 30 + 240 IX = IX+1 + IF (IX.LE.IXMAX) GO TO 10 +C + CALL GSTXCI (IRANTX) +C + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONRAN TO ULIB * +C* AUGUST 1980 CHANGED ACCESS CARD DOCUMENTATION * +C* DECEMBER 1980 MODIFIED COMMENT CARD DOCUMENTATION * +C* MARCH 1983 ADDED ASPECT RATIO ERROR * +C* JULY 1983 ADDED SHIELDING AND LINEAR INTERPOLATION * +C* REMOVED 7600 ACCESS CARDS * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conrec.f b/sys/gio/ncarutil/conrec.f new file mode 100644 index 00000000..b3e246c1 --- /dev/null +++ b/sys/gio/ncarutil/conrec.f @@ -0,0 +1,1313 @@ + SUBROUTINE CONREC (Z,L,M,N,FLO,HI,FINC,NSET,NHI,NDOT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C +C DIMENSION OF Z(L,N) +C ARGUMENTS +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE CONREC DRAWS A CONTOUR MAP FROM DATA STORED +C IN A RECTANGULAR ARRAY, LABELING THE LINES. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZCNTR (Z,M,N) +C +C ASSUMPTIONS: +C --ALL OF THE ARRAY IS TO BE CONTOURED. +C --CONTOUR LEVELS ARE PICKED +C INTERNALLY. +C --CONTOURING ROUTINE PICKS SCALE +C FACTORS. +C --HIGHS AND LOWS ARE MARKED. +C --NEGATIVE LINES ARE DRAWN WITH A +C DASHED LINE PATTERN. +C --EZCNTR CALLS FRAME AFTER DRAWING THE +C CONTOUR MAP. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL CONREC (Z,L,M,N,FLO,HI,FINC,NSET, +C NHI,NDOT) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZCNTR M BY N ARRAY TO BE CONTOURED. +C +C M +C FIRST DIMENSION OF Z. +C +C N +C SECOND DIMENSION OF Z. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR EZCNTR +C +C ON INPUT Z +C FOR CONREC THE (ORIGIN OF THE) ARRAY TO BE +C CONTOURED. Z IS DIMENSIONED L BY N. +C +C L +C THE FIRST DIMENSION OF Z IN THE CALLING +C PROGRAM. +C +C M +C THE NUMBER OF DATA VALUES TO BE CONTOURED +C IN THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING AN ENTIRE +C ARRAY, L = M. +C +C N +C THE NUMBER OF DATA VALUES TO BE CONTOURED +C IN THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C THE VALUE OF THE LOWEST CONTOUR LEVEL. +C IF FLO = HI = 0., A VALUE ROUNDED UP FROM +C THE MINIMUM Z IS GENERATED BY CONREC. +C +C HI +C THE VALUE OF THE HIGHEST CONTOUR LEVEL. +C IF HI = FLO = 0., A VALUE ROUNDED DOWN +C FROM THE MAXIMUM Z IS GENERATED BY +C CONREC. +C +C FINC +C > 0 INCREMENT BETWEEN CONTOUR LEVELS. +C = 0 A VALUE, WHICH PRODUCES BETWEEN 10 +C AND 30 CONTOUR LEVELS AT NICE VALUES, +C IS GENERATED BY CONREC. +C < 0 THE NUMBER OF LEVELS GENERATED BY +C CONREC IS ABS(FINC). +C +C NSET +C FLAG TO CONTROL SCALING. +C = 0 CONREC AUTOMATICALLY SETS THE +C WINDOW AND VIEWPORT TO PROPERLY +C SCALE THE FRAME TO THE STANDARD +C CONFIGURATION. +C THE GRIDAL ENTRY PERIM IS +C CALLED AND TICK MARKS ARE PLACED +C CORRESPONDING TO THE DATA POINTS. +C > 0 CONREC ASSUMES THAT THE USER +C HAS SET THE WINDOW AND VIEWPORT +C IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING +C INSTRUCTIONS GENERATED BY CONREC. +C PERIM IS NOT CALLED. +C < 0 CONREC GENERATES COORDINATES SO AS +C TO PLACE THE (UNTRANSFORMED) CONTOUR +C PLOT WITHIN THE LIMITS OF THE +C USER'S CURRENT WINDOW AND +C VIEWPORT. PERIM IS NOT CALLED. +C +C NHI +C FLAG TO CONTROL EXTRA INFORMATION ON THE +C CONTOUR PLOT. +C = 0 HIGHS AND LOWS ARE MARKED WITH AN H +C OR L AS APPROPRIATE, AND THE VALUE +C OF THE HIGH OR LOW IS PLOTTED UNDER +C THE SYMBOL. +C > 0 THE DATA VALUES ARE PLOTTED AT +C EACH Z POINT, WITH THE CENTER OF +C THE STRING INDICATING THE DATA +C POINT LOCATION. +C < 0 NEITHER OF THE ABOVE. +C +C NDOT +C A 10-BIT CONSTANT DESIGNATING THE DESIRED +C DASHED LINE PATTERN. +C IF ABS(NDOT) = 0, 1, OR 1023, SOLID LINES +C ARE DRAWN. +C > 0 NDOT PATTERN IS USED FOR ALL LINES. +C < 0 ABS(NDOT) PATTERN IS USED FOR NEGA- +C TIVE-VALUED CONTOUR LINES, AND SOLID IS +C USED FOR POSITIVE-VALUED CONTOURS. +C CONREC CONVERTS NDOT +C TO A 16-BIT PATTERN AND DASHDB IS USED. +C SEE DASHDB COMMENTS IN THE DASHLINE +C DOCUMENTATION FOR DETAILS. +C +C +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR CONREC +C +C +C ENTRY POINTS CONREC, CLGEN, REORD, STLINE, DRLINE, +C MINMAX, PNTVAL, CALCNT, EZCNTR, CONBD +C +C COMMON BLOCKS INTPR, RECINT, CONRE1, CONRE2, CONRE3, +C CONRE4,CONRE5 +C +C REQUIRED LIBRARY STANDARD VERSION: DASHCHAR, WHICH AT +C ROUTINES NCAR ISLOADED BY DEFAULT. +C SMOOTH VERSION: DASHSMTH WHICH MUST BE +C REQUESTED AT NCAR. +C BOTH VERSIONS REQUIRE GRIDAL, THE +C ERPRT77 PACKAGE, AND THE SPPS. +C +C I/O PLOTS CONTOUR MAP. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY REPLACES OLD CONTOURING PACKAGE CALLED +C CALCNT AT NCAR. +C +C ALGORITHM EACH LINE IS FOLLOWED TO COMPLETION. POINTS +C ALONG A LINE ARE FOUND ON BOUNDARIES OF THE +C (RECTANGULAR) CELLS. THESE POINTS ARE +C CONNECTED BY LINE SEGMENTS USING THE +C SOFTWARE DASHED LINE PACKAGE, DASHCHAR. +C DASHCHAR IS ALSO USED TO LABEL THE +C LINES. +C +C NOTE TO DRAW NON-UNIFORM CONTOUR LEVELS, SEE +C THE COMMENTS IN CLGEN. TO MAKE SPECIAL +C MODIFICATIONS FOR SPECIFIC NEEDS SEE THE +C EXPLANATION OF THE INTERNAL PARAMETERS +C BELOW. +C +C TIMING VARIES WIDELY WITH SIZE AND SMOOTHNESS OF +C Z. +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C ISIZEL 1 SIZE OF LINE LABELS, +C AS PER THE SIZE DEFINITIONS +C GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C ISIZEM 2 SIZE OF LABELS FOR MINIMUMS +C AND MAXIMUMS, +C AS PER THE SIZE DEFINITIONS +C GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C ISIZEP 0 SIZE OF LABELS FOR DATA +C POINT VALUES AS PER THE SIZE +C DEFINITIONS GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C NLA 16 APPROXIMATE NUMBER OF +C CONTOUR LEVELS WHEN +C INTERNALLY GENERATED. +C +C NLM 40 MAXIMUM NUMBER OF CONTOUR +C LEVELS. IF THIS IS TO BE +C INCREASED, THE DIMENSIONS +C OF CL AND RWORK IN CONREC +C MUST BE INCREASED BY THE +C SAME AMOUNT. +C +C XLT .05 LEFT HAND EDGE OF THE PLOT +C (0.0 IS THE LEFT EDGE OF +C THE FRAME AND 1.0 IS THE +C RIGHT EDGE OF THE FRAME.) +C +C YBT .05 BOTTOM EDGE OF THE PLOT +C (0.0 IS THE BOTTOM OF THE +C FRAME AND 1.0 IS THE TOP +C OF THE FRAME.) +C +C SIDE 0.9 LENGTH OF LONGER EDGE OF +C PLOT (SEE ALSO EXT). +C +C NREP 6 NUMBER OF REPETITIONS OF +C THE DASH PATTERN BETWEEN +C LINE LABELS. +C +C NCRT 2 NUMBER OF CRT UNITS PER +C ELEMENT (BIT) IN THE DASH +C PATTERN. +C +NOAO - Value of ncrt changed from 4 to 2 in conbd. +C -NOAO +C +C ILAB 1 FLAG TO CONTROL THE DRAWING +C OF LINE LABELS. +C . ILAB NON-ZERO MEANS LABEL +C THE LINES. +C . ILAB = 0 MEANS DO NOT +C LABEL THE LINES. +C +C NULBLL 3 NUMBER OF UNLABELED LINES +C BETWEEN LABELED LINES. FOR +C EXAMPLE, WHEN NULBLL = 3, +C EVERY FOURTH LEVEL IS +C LABELED. +C +C IOFFD 0 FLAG TO CONTROL +C NORMALIZATION OF LABEL +C NUMBERS. +C . IOFFD = 0 MEANS INCLUDE +C DECIMAL POINT WHEN +C POSSIBLE (DO NOT +C NORMALIZE UNLESS +C REQUIRED). +C . IOFFD NON-ZERO MEANS +C NORMALIZE ALL LABEL +C NUMBERS AND OUTPUT A +C SCALE FACTOR IN THE +C MESSAGE BELOW THE GRAPH. +C +C EXT .0625 LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO M +C AND N (WHEN CONREC SETS +C THE WINDOW AND VIEWPORT). +C IN EXTREME CASES, WHEN +C MIN(M,N)/MAX(M,N) IS LESS +C THAN EXT, CONREC +C PRODUCES A SQUARE PLOT. +C +C IOFFP 0 FLAG TO CONTROL SPECIAL +C VALUE FEATURE. +C . IOFFP = 0 MEANS SPECIAL +C VALUE FEATURE NOT IN USE. +C . IOFFP NON-ZERO MEANS +C SPECIAL VALUE FEATURE IN +C USE. (SPVAL IS SET TO THE +C SPECIAL VALUE.) CONTOUR +C LINES WILL THEN BE +C OMITTED FROM ANY CELL +C WITH ANY CORNER EQUAL TO +C THE SPECIAL VALUE. +C +C SPVAL 0. CONTAINS THE SPECIAL VALUE +C WHEN IOFFP IS NON-ZERO. +C +C IOFFM 0 FLAG TO CONTROL THE MESSAGE +C BELOW THE PLOT. +C . IOFFM = 0 IF THE MESSAGE +C IS TO BE PLOTTED. +C . IOFFM NON-ZERO IF THE +C MESSAGE IS TO BE OMITTED. +C +C ISOLID 1023 DASH PATTERN FOR +C NON-NEGATIVE CONTOUR LINES. +C +C +C +NOAO - Block data conbd rewritten as run time initialization. +C EXTERNAL CONBD +C -NOAO +C + SAVE + CHARACTER*1 IGAP ,ISOL ,RCHAR + CHARACTER ENCSCR*22 ,IWORK*126 +C +NOAO - Character variable added for improved label processing. + character*25 string(5) +C -NOAO + DIMENSION LNGTHS(5) ,HOLD(5) ,WNDW(4) ,VWPRT(4) + DIMENSION Z(L,N) ,CL(40) ,RWORK(40) ,LASF(13) + COMMON /INTPR/ PAD1, FPART, PAD(8) + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE3/ IXBITS ,IYBITS + COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , + 1 NCRT ,ILAB ,NULBLL ,IOFFD , + 2 EXT ,IOFFM ,ISOLID ,NLA , + 3 NLM ,XLT ,YBT ,SIDE + COMMON /CONRE5/ SCLY + COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX +C +NOAO - Value of LNGTHS have been changed from original defaults. Additional +C common block noaolb added for communication with calling routine. +C + common /noaolb/ hold + DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4),LNGTHS(5) + 1 / 13, 4, 21, 10, 19 / + DATA ISOL, IGAP /'$', ''''/ +C +C -NOAO +C +C ISOL AND IGAP (DOLLAR-SIGN AND APOSTROPHE) ARE USED TO CONSTRUCT PAT- +C TERNS PASSED TO ROUTINE DASHDC IN THE SOFTWARE DASHED-LINE PACKAGE. +C +C +C +C +NOAO - Blockdata conbd called as run time initialization subroutine + call conbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','CONREC','VERSION 01') +C +C NONSMOOTHING VERSION +C +C +C +C CALL RESET FOR COMPATIBILITY WITH ALL DASH ROUTINES(EXCEPT DASHLINE) +C + CALL RESET +C +C GET NUMBER OF BITS IN INTEGER ARITHMETIC +C + IARTH = I1MACH(8) + IXBITS = 0 + DO 101 I=1,IARTH + IF (M .LE. (2**I-1)) GO TO 102 + IXBITS = I+1 + 101 CONTINUE + 102 IYBITS = 0 + DO 103 I=1,IARTH + IF (N .LE. (2**I-1)) GO TO 104 + IYBITS = I+1 + 103 CONTINUE + 104 IF ((IXBITS*IYBITS).GT.0 .AND. (IXBITS+IYBITS).LE.24) GO TO 105 +C +C REPORT ERROR NUMBER ONE +C + IWORK = 'CONREC - DIMENSION ERROR - M*N .GT. (2**IARTH) M = + + N = ' +C +NOAO +C +C WRITE (IWORK(56:62),'(I6)') M + call encode (6, '(i6)', iwork(56:62), m) +C WRITE (IWORK(73:79),'(I6)') N + call encode (6, '(i6)', iwork(73:79), n) +C -NOAO +C + CALL SETER( IWORK, 1, 1 ) + RETURN + 105 CONTINUE +C +C INQUIRE CURRENT TEXT AND LINE COLOR INDEX +C + CALL GQTXCI ( IERR, ITXCI ) + CALL GQPLCI ( IERR, IPLCI ) +C +C SET LINE AND TEXT ASF TO INDIVIDUAL +C + CALL GQASF ( IERR, LASF ) + LSV3 = LASF(3) + LSV10 = LASF(10) + LASF(3) = 1 + LASF(10) = 1 + CALL GSASF ( LASF ) +C + GL = FLO + HA = HI + GP = FINC + MX = L + NX = M + NY = N + IDASH = NDOT + NEGPOS = ISIGN(1,IDASH) + IDASH = IABS(IDASH) + IF (IDASH.EQ.0 .OR. IDASH.EQ.1) IDASH = ISOLID +C +C SET CONTOUR LEVELS. +C + CALL CLGEN (Z,MX,NX,NY,GL,HA,GP,NLA,NLM,CL,NCL,ICNST) +C +C FIND MAJOR AND MINOR LINES +C + IF (ILAB .NE. 0) CALL REORD (CL,NCL,RWORK,NML,NULBLL+1) + IF (ILAB .EQ. 0) NML = 0 +C +C SAVE CURRENT NORMALIZATION TRANS NUMBER NTORIG AND LOG SCALING FLAG +C + CALL GQCNTN ( IERR, NTORIG ) + CALL GETUSV ('LS',IOLLS) +C +C SET UP SCALING +C + CALL GETUSV ( 'YF' , IYVAL ) + SCLY = 1.0 / ISHIFT ( 1, 15 - IYVAL ) +C + IF (NSET) 106,107,111 + 106 CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) +C +C SAVE NORMALIZATION TRANS 1 +C + CALL GQNT (1,IERR,WNDW,VWPRT) +C +C DEFINE NORMALIZATION TRANS AND LOG SCALING +C + CALL SET(X1, X2, Y1, Y2, 1.0, FLOAT(NX), 1.0, FLOAT(NY), 1) + GO TO 111 + 107 CONTINUE + X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + X3 = NX + Y3 = NY + IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .LT. EXT) GO TO 110 + IF (NX-NY) 108,110,109 + 108 X2 = SIDE*X3/Y3+XLT + GO TO 110 + 109 Y2 = SIDE*Y3/X3+YBT +C +C SAVE NORMALIZATION TRANS 1 +C + 110 CALL GQNT ( 1, IERR, WNDW, VWPRT ) +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) +C +C DRAW PERIMETER +C + CALL PERIM (NX-1,1,NY-1,1) + 111 IF (ICNST .NE. 0) GO TO 124 +C +C SET UP LABEL SCALING +C + IOFFDT = IOFFD + IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) + 1 IOFFDT = 1 + IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) + 1 IOFFDT = 1 + ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA),ABS(GP)))-5000.)- + 1 5000) + IF (IOFFDT .EQ. 0) ASH = 1. + HOLD(1) = GL + HOLD(2) = HA + HOLD(3) = GP + HOLD(4) = Z(3,3) + HOLD(5) = ASH + NCHAR = 0 + IF (IOFFM .NE. 0) GO TO 115 +C +NOAO - This label generation has been reworked to eliminate the large +C spaces in between fields of the label. +C IWORK = 'CONTOUR FROM TO CONTOUR INTERVAL +C 1 OF PT(3,3)= LABELS SCALED BY' + string(1)(1:13) = 'CONTOUR FROM ' + string(2)(1:4) = ' TO ' + string(3)(1:21) = '; CONTOUR INTERVAL = ' + string(4)(1:11) = '; PT(3,3)= ' + string(5)(1:19) = '; LABELS SCALED BY ' +C + DO 114 I=1,5 +C (NOAO) WRITE ( ENCSCR, '(G13.5)' ) HOLD(I) + call encd (hold(i), ash, encscr, nc, ioffd) + do 1113 k = 1, lngths(i) + nchar = nchar + 1 + 1113 iwork(nchar:nchar) = string(i)(k:k) +C +C (NOAO) NCHAR = NCHAR+LNGTHS(I) +C (NOAO) DO 113 J=1,13 + do 113 j = 1, nc + NCHAR = NCHAR+1 + IWORK(NCHAR:NCHAR) = ENCSCR(J:J) + 113 CONTINUE + 114 CONTINUE +C +C +NOAO IF (ASH .EQ. 1.) NCHAR = NCHAR-13-LNGTHS(5) + if (ash .eq. 1.) nchar = nchar - nc - lngths(5) +C -NOAO +C +C SET TEXT INTENSITY TO LOW, AND WRITE TITLE USING NORMALIZATION +C TRANS NUMBER 0 +C + CALL GSTXCI (IRECTX) + CALL GETUSV('LS',LSO) + CALL SETUSV('LS',1) + CALL GSELNT (0) +C +NOAO - following text output centered on current viewport +C CALL WTSTR ( 0.5, 0.015625, IWORK(1:NCHAR), 0, 0, 0 ) + CALL WTSTR ( ((x1+x2)/2.0), y1 - 0.03, IWORK(1:NCHAR), 0, 0, 0 ) +C -NOAO + CALL SETUSV('LS',LSO) + CALL GSELNT (1) +C +C +C +C * * * * * * * * * * +C * * * * * * * * * * +C +C +C PROCESS EACH LEVEL +C + 115 FPART = .5 +C + DO 123 I=1,NCL + CONTR = CL(I) + NDASH = IDASH + IF (NEGPOS.LT.0 .AND. CONTR.GE.0.) NDASH = ISOLID +C +C CHANGE 10 BIT PATTERN TO 10 CHARACTER PATTERN. +C + DO 116 J=1,10 + IBIT = IAND(ISHIFT(NDASH,(J-10)),1) + RCHAR = IGAP + IF (IBIT .NE. 0) RCHAR = ISOL + IWORK(J:J) = RCHAR + 116 CONTINUE + IF (I .GT. NML) GO TO 121 +C +C SET UP MAJOR LINE (LABELED) +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI ( IRECMJ ) +C +C NREP REPITITIONS OF PATTERN PER LABEL. +C + NCHAR = 10 + IF (NREP .LT. 2) GO TO 119 + DO 118 J=1,10 + NCHAR = J + RCHAR = IWORK(J:J) + DO 117 K=2,NREP + NCHAR = NCHAR+10 + IWORK(NCHAR:NCHAR) = RCHAR + 117 CONTINUE + 118 CONTINUE + 119 CONTINUE +C +C PUT IN LABEL. +C + CALL ENCD (CONTR,ASH,ENCSCR,NCUSED,IOFFDT) + DO 120 J=1,NCUSED + NCHAR = NCHAR+1 + IWORK(NCHAR:NCHAR) = ENCSCR(J:J) + 120 CONTINUE + GO TO 122 +C +C SET UP MINOR LINE (UNLABELED). +C + 121 CONTINUE +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI ( IRECMN ) + NCHAR = 10 + 122 CALL DASHDC ( IWORK(1:NCHAR),NCRT, ISIZEL ) +C +C +C DRAW ALL LINES AT THIS LEVEL. +C + CALL STLINE (Z,MX,NX,NY,CONTR) +C +C + 123 CONTINUE +C +C FIND RELATIVE MINIMUMS AND MAXIMUMS IF WANTED, AND MARK VALUES IF +C WANTED. +C + IF (NHI .EQ. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEM,ASH,IOFFDT) + IF (NHI .GT. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEP,-ASH,IOFFDT) + FPART = 1. + GO TO 127 + 124 CONTINUE + IWORK = 'CONSTANT FIELD' +C +NOAO +C WRITE( ENCSCR, '(G22.14)' ) GL + i = gl + call encode (22, '(g22.14)', encscr, i) +C -NOAO + DO 126 I=1,22 + IWORK(I+14:I+14) = ENCSCR(I:I) + 126 CONTINUE +C +C WRITE TITLE USING NORMALIZATION TRNS 0 +C + CALL GETUSV('LS',LSO) + CALL SETUSV('LS',1) + CALL GSELNT (0) +C +NOAO +C CALL WTSTR ( 0.09765, 0.48825, IWORK(1:36), 3, 0, -1 ) + CALL WTSTR ( x1+0.03, (y1+y2)/2.0, IWORK(1:36), 3, 0, -1 ) +C -NOAO +C +C RESTORE NORMALIZATION TRANS 1, LINE AND TEXT INTENSITY TO ORIGINAL +C + 127 IF (NSET.LE.0) THEN + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + END IF + CALL GSPLCI ( IPLCI ) + CALL GSTXCI ( ITXCI ) +C +C SELECT ORIGINAL NORMALIZATION TRANS NUMBER NTORIG, AND RESTORE ASF +C + CALL GSELNT ( NTORIG ) + LASF(3) = LSV3 + LASF(10) = LSV10 + CALL GSASF ( LASF ) +C + RETURN +C +C + END + SUBROUTINE CLGEN (Z,MX,NX,NNY,CCLO,CHI,CINC,NLA,NLM,CL,NCL,ICNST) + SAVE + DIMENSION CL(NLM) ,Z(MX,NNY) + COMMON /CONRE1/ IOFFP ,SPVAL +C +C CLGEN PUTS THE VALUES OF THE CONTOUR LEVELS IN CL. +C VARIABLE NAMES MATCH THOSE IN CONREC, WITH THE FOLLOWING ADDITIONS. +C NCL -NUMBER OF CONTOUR LEVELS PUT IN CL. +C ICNST -FLAG TO TELL CONREC IF A CONSTANT FIELD WAS DETECTED. +C .ICNST=0 MEANS NON-CONSTANT FIELD. +C .ICNST NON-ZERO MEANS CONSTANT FIELD. +C +C TO PRODUCE NON-UNIFORM CONTOUR LEVEL SPACING, REPLACE THE CODE IN THIS +C SUBROUTINE WITH CODE TO PRODUCE WHATEVER SPACING IS DESIRED. +C + ICNST = 0 + NY = NNY + CLO = CCLO + GLO = CLO + HA = CHI + FANC = CINC + CRAT = NLA + IF (HA-GLO) 101,102,111 + 101 GLO = HA + HA = CLO + GO TO 111 + 102 IF (GLO .NE. 0.) GO TO 120 + GLO = Z(1,1) + HA = Z(1,1) + IF (IOFFP .EQ. 0) GO TO 107 + DO 106 J=1,NY + DO 105 I=1,NX + IF (Z(I,J) .EQ. SPVAL) GO TO 105 + GLO = Z(I,J) + HA = Z(I,J) + DO 104 JJ=J,NY + DO 103 II=1,NX + IF (Z(II,JJ) .EQ. SPVAL) GO TO 103 + GLO = AMIN1(Z(II,JJ),GLO) + HA = AMAX1(Z(II,JJ),HA) + 103 CONTINUE + 104 CONTINUE + GO TO 110 + 105 CONTINUE + 106 CONTINUE + GO TO 110 + 107 DO 109 J=1,NY + DO 108 I=1,NX + GLO = AMIN1(Z(I,J),GLO) + HA = AMAX1(Z(I,J),HA) + 108 CONTINUE + 109 CONTINUE + 110 IF (GLO .GE. HA) GO TO 119 + 111 IF (FANC) 112,113,114 + 112 CRAT = AMAX1(1.,-FANC) + 113 FANC = (HA-GLO)/CRAT + P = 10.**(IFIX(ALOG10(FANC)+5000.)-5000) + FANC = AINT(FANC/P)*P + 114 IF (CHI-CLO) 116,115,116 + 115 GLO = AINT(GLO/FANC)*FANC + HA = AINT(HA/FANC)*FANC*(1.+SIGN(1.E-6,HA)) + 116 DO 117 K=1,NLM + CC = GLO+FLOAT(K-1)*FANC + IF (CC .GT. HA) GO TO 118 + KK = K + CL(K) = CC + 117 CONTINUE + 118 NCL = KK + CCLO = CL(1) + CHI = CL(NCL) + CINC = FANC + RETURN + 119 ICNST = 1 + NCL = 1 + CCLO = GLO + RETURN + 120 CL(1) = GLO + NCL = 1 + RETURN + END + SUBROUTINE DRLINE (Z,L,MM,NN) + SAVE + DIMENSION Z(L,NN) +C +C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +C + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c + noao: dimension of ir array in conre2 changed from 500 to 20000 6March87 +c + noao: dimension of ir array in conre2 changed from 20000 to 80000 6-93 + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE3/ IXBITS ,IYBITS + LOGICAL IPEN ,IPENO + DATA IPEN,IPENO/.TRUE.,.TRUE./ +C + FX(X,Y) = X + FY(X,Y) = Y + IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY + C(P1,P2) = (P1-CV)/(P1-P2) +C + M = MM + N = NN + IF (IOFFP .EQ. 0) GO TO 101 + ASSIGN 110 TO JUMP1 + ASSIGN 115 TO JUMP2 + GO TO 102 + 101 ASSIGN 112 TO JUMP1 + ASSIGN 117 TO JUMP2 + 102 IX0 = IX + IY0 = IY + IS0 = IS + IF (IOFFP .EQ. 0) GO TO 103 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL + IPENO = IPEN + 103 IF (IDX .EQ. 0) GO TO 104 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 105 + 104 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 105 CALL FRSTD (FX(X,Y),FY(X,Y)) + 106 IS = IS+1 + IF (IS .GT. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + IF (ISS .NE. 0) GO TO 107 + IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 120 + 107 IF (CV-Z(IX2,IY2)) 108,108,109 + 108 IS = IS+4 + IX = IX2 + IY = IY2 + GO TO 106 + 109 IF (IS/2*2 .EQ. IS) GO TO 106 + GO TO JUMP1,(110,112) + 110 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + IF (ISS .NE. 0) GO TO 111 + IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 120 + IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 120 + 111 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. + 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL + 112 IF (IDX .EQ. 0) GO TO 113 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 114 + 113 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 114 GO TO JUMP2,(115,117) + 115 IF (.NOT.IPEN) GO TO 118 + IF (IPENO) GO TO 116 +C +C END OF LINE SEGMENT +C + CALL LASTD + CALL FRSTD (FX(XOLD,YOLD),FY(XOLD,YOLD)) +C +C CONTINUE LINE SEGMENT +C + 116 CONTINUE + 117 CALL VECTD (FX(X,Y),FY(X,Y)) + 118 XOLD = X + YOLD = Y + IF (IS .NE. 1) GO TO 119 + NP = NP+1 + IF (NP .GT. NR) GO TO 120 + IR(NP) = IXYPAK(IX,IY) + 119 IF (ISS .EQ. 0) GO TO 106 + IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 106 +C +C END OF LINE +C + 120 CALL LASTD + RETURN + END + SUBROUTINE MINMAX (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) +C +C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM +C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN +C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE +C IS + OR - MN IN THE X DIRECTION AND + OR - NM IN THE Y DIRECTION. +C +C ORIGINATOR DAVID KENNISON +C + SAVE + CHARACTER*6 IA + DIMENSION Z(L,NN) +C +C +C + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE5/ SCLY +C + FX(X,Y) = X + FY(X,Y) = Y +C + M = MM + N = NN +C +C SET UP SCALING FOR LABELS +C + SIZEM = (ISSIZM + 1)*256*SCLY + ISIZEM = ISSIZM +C + ASH = ABS(AASH) + IOFFDT = JOFFDT +C + IF (AASH .LT. 0.0) GO TO 128 +C + MN = MIN0(15,MAX0(2,IFIX(FLOAT(M)/8.))) + NM = MIN0(15,MAX0(2,IFIX(FLOAT(N)/8.))) + NM1 = N-1 + MM1 = M-1 +C +C LINE LOOP FOLLOWS - THE COMPLETE TWO-DIMENSIONAL TEST FOR A MINIMUM OR +C MAXIMUM OF THE FIELD IS ONLY PERFORMED FOR POINTS WHICH ARE MINIMA OR +C MAXIMA ALONG SOME LINE - FINDING THESE CANDIDATES IS MADE EFFICIENT BY +C USING A COUNT OF CONSECUTIVE INCREASES OR DECREASES OF THE FUNCTION +C ALONG THE LINE +C + DO 127 JP=2,NM1 +C + IM = MN-1 + IP = -1 + GO TO 126 +C +C CONTROL RETURNS TO STATEMENT 10 AS LONG AS THE FUNCTION IS INCREASING +C ALONG THE LINE - WE SEEK A POSSIBLE MAXIMUM +C + 101 IP = IP+1 + AA = AN + IF (IP .EQ. MM1) GO TO 104 + AN = Z(IP+1,JP) + IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 + IF (AA-AN) 102,103,104 + 102 IM = IM+1 + GO TO 101 + 103 IM = 0 + GO TO 101 +C +C FUNCTION DECREASED - TEST FOR MAXIMUM ON LINE +C + 104 IF (IM .GE. MN) GO TO 106 + IS = MAX0(1,IP-MN) + IT = IP-IM-1 + IF (IS .GT. IT) GO TO 106 + DO 105 II=IS,IT + IF (AA .LE. Z(II,JP)) GO TO 112 + 105 CONTINUE + 106 IS = IP+2 + IT = MIN0(M,IP+MN) + IF (IS .GT. IT) GO TO 109 + DO 108 II=IS,IT + IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 107 + IP = II-1 + GO TO 125 + 107 IF (AA .LE. Z(II,JP)) GO TO 112 + 108 CONTINUE +C +C WE HAVE MAXIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MAXIMUM OF FIELD +C + 109 JS = MAX0(1,JP-NM) + JT = MIN0(N,JP+NM) + IS = MAX0(1,IP-MN) + IT = MIN0(M,IP+MN) + DO 111 JK=JS,JT + IF (JK .EQ. JP) GO TO 111 + DO 110 IK=IS,IT + IF (Z(IK,JK).GE.AA .OR. + 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 112 + 110 CONTINUE + 111 CONTINUE +C + X = FLOAT(IP) + Y = FLOAT(JP) + CALL WTSTR ( FX(X,Y),FY(X,Y),'H',ISIZEM,0,0 ) + CALL FL2INT ( FX(X,Y),FY(X,Y),IFX,IFY ) +C +C SCALE TO USER SET RESOLUTION +C + IFY = IFY*SCLY + CALL ENCD (AA,ASH,IA,NC,IOFFDT) + MY = IFY - SIZEM + TMY = CPUY ( MY ) + CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) + 112 IM = 1 + IF (IP-MM1) 113,127,127 +C +C CONTROL RETURNS TO STATEMENT 20 AS LONG AS THE FUNCTION IS DECREASING +C ALONG THE LINE - WE SEEK A POSSIBLE MINIMUM +C + 113 IP = IP+1 + AA = AN + IF (IP .EQ. MM1) GO TO 116 + AN = Z(IP+1,JP) + IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 + IF (AA-AN) 116,115,114 + 114 IM = IM+1 + GO TO 113 + 115 IM = 0 + GO TO 113 +C +C FUNCTION INCREASED - TEST FOR MINIMUM ON LINE +C + 116 IF (IM .GE. MN) GO TO 118 + IS = MAX0(1,IP-MN) + IT = IP-IM-1 + IF (IS .GT. IT) GO TO 118 + DO 117 II=IS,IT + IF (AA .GE. Z(II,JP)) GO TO 124 + 117 CONTINUE + 118 IS = IP+2 + IT = MIN0(M,IP+MN) + IF (IS .GT. IT) GO TO 121 + DO 120 II=IS,IT + IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 119 + IP = II-1 + GO TO 125 + 119 IF (AA .GE. Z(II,JP)) GO TO 124 + 120 CONTINUE +C +C WE HAVE MINIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MINIMUM OF FIELD +C + 121 JS = MAX0(1,JP-NM) + JT = MIN0(N,JP+NM) + IS = MAX0(1,IP-MN) + IT = MIN0(M,IP+MN) + DO 123 JK=JS,JT + IF (JK .EQ. JP) GO TO 123 + DO 122 IK=IS,IT + IF (Z(IK,JK).LE.AA .OR. + 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 124 + 122 CONTINUE + 123 CONTINUE +C + X = FLOAT(IP) + Y = FLOAT(JP) + CALL WTSTR ( FX(X,Y),FY(X,Y),'L',ISIZEM,0,0 ) + CALL FL2INT( FX(X,Y),FY(X,Y),IFX,IFY ) + IFY = SCLY*IFY + CALL ENCD (AA,ASH,IA,NC,IOFFDT) + MY = IFY - SIZEM + TMY = CPUY ( MY ) + CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) + 124 IM = 1 + IF (IP-MM1) 101,127,127 +C +C SKIP SPECIAL VALUES ON LINE +C + 125 IM = 0 + 126 IP = IP+1 + IF (IP .GE. MM1) GO TO 127 + IF (IOFFP.NE.0 .AND. Z(IP+1,JP).EQ.SPVAL) GO TO 125 + IM = IM+1 + IF (IM .LE. MN) GO TO 126 + IM = 1 + AN = Z(IP+1,JP) + IF (Z(IP,JP)-AN) 101,103,113 +C + 127 CONTINUE +C + RETURN +C +C ****************************** ENTRY PNTVAL ************************** +C ENTRY PNTVAL (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) +C + 128 CONTINUE + II = (M-1+24)/24 + JJ = (N-1+48)/48 + NIQ = 1 + NJQ = 1 + DO 130 J=NJQ,N,JJ + Y = J + DO 129 I=NIQ,M,II + X = I + ZZ = Z(I,J) + IF (IOFFP.NE.0 .AND. ZZ.EQ.SPVAL) GO TO 129 + CALL ENCD (ZZ,ASH,IA,NC,IOFFDT) + CALL WTSTR (FX(X,Y),FY(X,Y),IA(1:NC),ISIZEM,0,0 ) + 129 CONTINUE + 130 CONTINUE + RETURN + END + SUBROUTINE REORD (CL,NCL,C1,MARK,NMG) + SAVE + DIMENSION CL(NCL) ,C1(NCL) +C +C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MARK. C1 IS USED AS A WORK SPACE. NMG IS THE +C NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS BETWEEN +C MAJOR LEVELS). +C + NL = NCL + IF (NL.LE.4 .OR. NMG.LE.1) GO TO 113 + NML = NMG-1 + IF (NL .LE. 10) NML = 1 +C +C CHECK FOR ZERO OR OTHER NICE NUMBER FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 101 I=1,NL + ISAVE = I + IF (CL(I) .EQ. 0.) GO TO 104 + 101 CONTINUE + L = NL/2 + L = ALOG10(ABS(CL(L)))+1. + Q = 10.**L + DO 103 J=1,3 + Q = Q/10. + DO 102 I=1,NL + ISAVE = I + IF (AMOD(ABS(CL(I)+1.E-9*CL(I))/Q,FLOAT(NMLP1)) .LE. .0001) + 1 GO TO 104 + 102 CONTINUE + 103 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN C1 +C + 104 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART .EQ. 0) ISTART = NMLP1 + NMAJL = 0 + DO 105 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + C1(NMAJL) = CL(I) + 105 CONTINUE + MARK = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN C1 +C + IF (ISTART .EQ. 1) GO TO 107 + DO 106 I=2,ISTART + ISUB = L+I-1 + C1(ISUB) = CL(I-1) + 106 CONTINUE + 107 L = NMAJL+ISTART-1 + DO 109 I=2,NMAJL + DO 108 J=1,NML + L = L+1 + ISUB = ISTART+(I-2)*NMLP1+J + C1(L) = CL(ISUB) + 108 CONTINUE + 109 CONTINUE + NLML = NL-L + IF (L .EQ. NL) GO TO 111 + DO 110 I=1,NLML + L = L+1 + C1(L) = CL(L) + 110 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 111 DO 112 I=1,NL + CL(I) = C1(I) + 112 CONTINUE + RETURN + 113 MARK = NL + RETURN + END + SUBROUTINE STLINE (Z,LL,MM,NN,CONV) + SAVE + DIMENSION Z(LL,NN) +C +C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +C CONV. +C + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c + noao: dimension of ir array in conre2 changed from 500 to 20000 6March87 +c + noao: dimension of ir array in conre2 changed from 20000 to 80000 6-93 + COMMON /CONRE3/ IXBITS ,IYBITS +C +C +C +C +C +C + IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY +C + L = LL + M = MM + N = NN + CV = CONV + NP = 0 + ISS = 0 + DO 102 IP1=2,M + I = IP1-1 + IF (Z(I,1).GE.CV .OR. Z(IP1,1).LT.CV) GO TO 101 + IX = IP1 + IY = 1 + IDX = -1 + IDY = 0 + IS = 1 + CALL DRLINE (Z,L,M,N) + 101 IF (Z(IP1,N).GE.CV .OR. Z(I,N).LT.CV) GO TO 102 + IX = I + IY = N + IDX = 1 + IDY = 0 + IS = 5 + CALL DRLINE (Z,L,M,N) + 102 CONTINUE + DO 104 JP1=2,N + J = JP1-1 + IF (Z(M,J).GE.CV .OR. Z(M,JP1).LT.CV) GO TO 103 + IX = M + IY = JP1 + IDX = 0 + IDY = -1 + IS = 7 + CALL DRLINE (Z,L,M,N) + 103 IF (Z(1,JP1).GE.CV .OR. Z(1,J).LT.CV) GO TO 104 + IX = 1 + IY = J + IDX = 0 + IDY = 1 + IS = 3 + CALL DRLINE (Z,L,M,N) + 104 CONTINUE + ISS = 1 + DO 108 JP1=3,N + J = JP1-1 + DO 107 IP1=2,M + I = IP1-1 + IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 107 + IXY = IXYPAK(IP1,J) + IF (NP .EQ. 0) GO TO 106 + DO 105 K=1,NP + IF (IR(K) .EQ. IXY) GO TO 107 + 105 CONTINUE + 106 NP = NP+1 + IF (NP .GT. NR) THEN +C +C THIS PRINTS AN ERROR MESSAGE IF THE LOCAL ARRAY IR IN SUBROUTINE +C STLINE HAS AN OVERFLOW +C THIS MESSAGE IS WRITTEN BOTH ON THE FRAME AND ON THE STANDARD ERROR +C UNIT +C +C +NOAO - Message is written only to stderr, not to the plotting frame. +C Error is written with uliber, not FTN write statement. +C + call uliber (1, 'STLINE (CONREC) - WORK ARRAY OVERFLOW', 80) + call uliber (1,'STLINE - ***WARNING -- PICTURE INCOMPLETE***',80) +C IUNIT = I1MACH(4) +C WRITE(IUNIT,1000) +C1000 FORMAT( +C 1' WARNING FROM ROUTINE STLINE IN CONREC--WORK ARRAY OVERFLOW') +C CALL GETSET(VXA,VXB,VYA,VYB,XA,XB,YA,YB,LTYPE) +C Y = (YB - YA) / 2. +C X = (XB - XA) / 2. +C CALL PWRIT(X,Y, +C 1'**WARNING--PICTURE INCOMPLETE**', +C 2 31,3,0,0) +C Y = Y * .7 +C CALL PWRIT(X,Y, +C 1'WORK ARRAY OVERFLOW IN STLINE', +C 2 29,3,0,0) +C -NOAO + RETURN + ENDIF + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + CALL DRLINE (Z,L,M,N) + 107 CONTINUE + 108 CONTINUE + RETURN + END + SUBROUTINE CALCNT (Z,M,N,A1,A2,A3,I1,I2,I3) +C +C THIS ENTRY POINT IS FOR USERS WHO ARE TOO LAZY TO SWITCH OLD DECKS +C TO THE NEW CALLING SEQUENCE. +C + DIMENSION Z(M,N) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','CALCNT','VERSION 01') +C + CALL CONREC (Z,M,M,N,A1,A2,A3,I1,I2,-IABS(I3)) + RETURN + END + SUBROUTINE EZCNTR (Z,M,N) +C +C CONTOURING VIA SHORTEST POSSIBLE ARGUMENT LIST +C ASSUMPTIONS -- +C ALL OF THE ARRAY IS TO BE CONTOURED, +C CONTOUR LEVELS ARE PICKED INTERNALLY, +C CONTOURING ROUTINE PICKS SCALE FACTORS, +C HIGHS AND LOWS ARE MARKED, +C NEGATIVE LINES ARE DRAWN WITH A DASHED LINE PATTERN, +C EZCNTR CALLS FRAME AFTER DRAWING THE CONTOUR MAP. +C IF THESE ASSUMPTIONS ARE NOT MET, USE CONREC. +C +C ARGUMENTS +C Z ARRAY TO BE CONTOURED +C M FIRST DIMENSION OF Z +C N SECOND DIMENSION OF Z +C + SAVE + DIMENSION Z(M,N) + DATA NSET,NHI,NDASH/0,0,682/ +C +C 682=1252B +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','EZCNTR','VERSION 01') +C + CALL CONREC (Z,M,M,N,0.,0.,0.,NSET,NHI,-NDASH) +C +NOAO - EZCNTR no longer calls frame. +C CALL FRAME +C -NOAO + RETURN + END +C +C REVISION HISTORY--- +C +C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +C +C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +C DOCUMENTATION CLARIFIED AND CORRECTED. +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +C +C JUNE 1985 ERROR HANDLING LINES ADDED; IF OVERFLOW HAPPENS TO +C WORK ARRAY IN STLINE, A WARNING MESSAGE IS WRITTEN +C BOTH ON PLOT FRAME AND ON STANDARD ERROR MESSAGE. +C------------------------------------------------------------------- +C diff --git a/sys/gio/ncarutil/dashbd.f b/sys/gio/ncarutil/dashbd.f new file mode 100644 index 00000000..cf499bc2 --- /dev/null +++ b/sys/gio/ncarutil/dashbd.f @@ -0,0 +1,143 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data changed to run time initialization. Logical param +c "first" added, so initialization doesn't occur more than once. +c BLOCKDATA DASHBD + subroutine dashbd +C +C DASHBD IS USED TO INITIALIZE VARIABLES IN NAMED COMMON. +C + logical first +c + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C + COMMON /FDFLAG/ IFLAG +C + COMMON /DDFLAG/ IFCFLG +C + COMMON /DCFLAG/ IFSTFL +C + COMMON /DFFLAG/ IFSTF2 +C + COMMON /CFFLAG/ IVCTFG +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C + COMMON /SMFLAG/ IOFFS +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C + SAVE + data first /.true./ + if (.not. first) return + first = .false. + +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C +c DATA IFSTFL /1/ + IFSTFL = 1 +C +C IVCTFG INDICATES IF VECTD IS BEING CALLED OR LASTD (IN CFVLD) +C +c DATA IVCTFG /1/ + IVCTFG = 1 +C +C ISL IS A FLAG FOR AN ALL SOLID PATTERN (+1) OR AN ALL GAP PATTERN (-1) +C +c DATA ISL /1/ + ISL = 1 +C +C IGP IS AN INTERNAL PARAMETER. IT IS DESCRIBED IN THE DOCUMENTATION +C TO THE DASHED LINE PACKAGE. +C +c DATA IGP /9/ + IGP = 9 +C +C MNCSTR IS THE MAXIMUM NUMBER OF CHARACTERS ALLOWED IN A HOLLERITH +C STRING PASSED TO DASHDC. +C +c DATA MNCSTR /15/ + MNCSTR = 15 +C +C IOFFS IS AN INTERNAL PARAMETER. +C IOFFS IS USED IN FDVDLD AND DRAWPV. +C +c DATA IOFFS /0/ + IOFFS = 0 +C +C INTERNAL PARAMETERS +C +c DATA IPAU/3/ + IPAU = 3 +c DATA FPART/1./ + FPART = 1. +c DATA TENSN/2.5/ + TENSN = 2.5 +c DATA NP/150/ + NP = 150 +c DATA SMALL/128./ + SMALL = 128. +c DATA L1/70/ + L1 = 70 +c DATA ADDLR/2./ + ADDLR = 2. +c DATA ADDTB/2./ + ADDTB = 2. +c DATA MLLINE/384/ + MLLINE = 384 +c DATA ICLOSE/6/ + ICLOSE = 6 +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED (IN SUBROUTINE FDVDLD), WHENEVER DASHDB OR DASHDC +C HAS BEEN CALLED. +C +c DATA IFSTF2 /1/ + IFSTF2 = 1 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C +c DATA IFLAG /1/ + IFLAG = 1 +C +C IFCFLG IS THE FIRST CALL FLAG FOR SUBROUTINES DASHDB AND DASHDC. +C 1 = FIRST CALL TO DASHDB OR DASHDC. +C 2 = DASHDB OR DASHDC HAS BEEN CALLED BEFORE. +C +c DATA IFCFLG /1/ + IFCFLG = 1 +C +C IXSTOR AND IYSTOR CONTAIN THE CURRENT PEN POSITION. THEY ARE +C INITIALIZED TO AN IMPOSSIBLE VALUE. +C +c DATA IXSTOR,IYSTOR /-9999,-9999/ + IXSTOR = -9999 + IYSTOR = -9999 +C +C SLP1 AND SLPN ARE INITIALIZED TO AVOID THAT THEY ARE PASSED AS ACTUAL +C PARAMETERS FROM FDVDLD TO KURV1S WITHOUT BEING DEFINED. +C +c DATA SLP1,SLPN /-9999.,-9999./ + SLP1 = -9999. + SLPN = -9999. +c -noao +C + END diff --git a/sys/gio/ncarutil/dashsmth.f b/sys/gio/ncarutil/dashsmth.f new file mode 100644 index 00000000..2fe25185 --- /dev/null +++ b/sys/gio/ncarutil/dashsmth.f @@ -0,0 +1,1224 @@ + SUBROUTINE FDVDLD (IENTRY,IIX,IIY) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SOFTWARE DASHED LINE PACKAGE WITH CHARACTER CAPABILITY AND SMOOTHING +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE DASHSMTH IS A SOFTWARE DASHED LINE PACKAGE WITH +C SMOOTHING CAPABILITIES. DASHSMTH IS DASHCHAR +C WITH SMOOTHING FEATURES ADDED. +C +C USAGE FIRST, EITHER +C CALL DASHDB (IPAT) +C WHERE IPAT IS A 16-BIT DASH PATTERN AS +C DESCRIBED IN THE SUBROUTINE DASHDB (SEE +C DASHLINE DOCUMENTATION), OR +C CALL DASHDC (IPAT,JCRT,JSIZE) +C AS DESCRIBED BELOW. +C +C THEN, CALL ANY OF THE FOLLOWING: +C CALL CURVED (X,Y,N) +C CALL FRSTD (X,Y) +C CALL VECTD (X,Y) +C CALL LASTD +C +C LASTD IS CALLED ONLY AFTER THE LAST +C POINT OF A LINE HAS BEEN PROCESSED IN VECTD. +C +C THE FOLLOWING MAY ALSO BE CALLED, BUT NO +C SMOOTHING WILL RESULT: +C CALL LINED (XA,YA,XB,YB) +C +C +C ARGUMENTS IPAT +C ON INPUT A CHARACTER STRING OF ARBITRARY LENGTH +C TO DASHDC (60 CHARACTERS SEEMS TO BE A PRACTICAL +C LIMIT) WHICH SPECIFIES THE DASH PATTERN +C TO BE USED. A DOLLAR SIGN IN IPAT +C INDICATES SOLID; AN APOSTROPHE INDICATES +C A GAP; BLANKS ARE IGNORED. ANY CHARACTER +C IN IPAT WHICH IS NOT A DOLLAR SIGN, +C APOSTROPHE, OR BLANK IS CONSIDERED TO BE +C PART OF A LINE LABEL. EACH LINE LABEL +C CAN BE AT MOST 15 CHARACTERS IN LENGTH. +C SUFFICIENT WHITE SPACE IS RESERVED IN THE +C DASHED LINE FOR WRITING LINE LABELS. +C +C JCRT +C THE LENGTH IN PLOTTER ADDRESS UNITS PER +C $ OR APOSTROPHE. +C +C JSIZE +C IS THE SIZE OF THE PLOTTED CHARACTERS: +C . IF BETWEEN 0 AND 3 , IT IS 1., 1.5, 2. +C AND 3. TIMES AN 8 PLOTTER ADDRESS UNIT +C WIDTH. +C . IF GREATER THAN 3, IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C +C ARGUMENTS TO CURVED(X,Y,N) +C OTHER LINE-DRAWING X AND Y ARE ARRAYS OF WORLD COORDINATE VALUES +C ROUTINES OF LENGTH N OR GREATER. LINE SEGMENTS OBEYING +C THE SPECIFIED DASH PATTERN ARE DRAWN TO +C CONNECT THE N POINTS. +C +C FRSTD(X,Y) +C THE CURRENT PEN POSITION IS SET TO +C THE WORLD COORDINATE VALUE (X,Y) +C +C VECTD(X,Y) +C A LINE SEGMENT IS DRAWN BETWEEN THE +C WORLD COORDINATE VALUE (X,Y) AND THE +C MOST RECENT PEN POSITION. (X,Y) THEN +C BECOMES THE MOST RECENT PEN POSITION. +C +C LINED(XA,XB,YA,YB) +C A LINE IS DRAWN BETWEEN WORLD COORDINATE +C VALUES (XA,YA) AND (XB,YB). +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED FOR ALL ROUTINES. +C +C NOTE WHEN USING FRSTD AND VECTD, LASTD MUST BE +C CALLED (NO ARGUMENTS NEEDED). LASTD SETS UP +C THE CALLS TO THE SMOOTHING ROUTINES KURV1S AND +C KURV2S. +C +C WHEN SWITCHING FROM THE REGULAR PLOTTING +C ROUTINES TO A DASHED LINE PACKAGE THE FIRST +C CALL SHOULD NOT BE TO VECTD. +C +C ENTRY POINTS DASHDB, DASHDC, CURVED, FRSTD, VECTD, LINED, +C RESET, LASTD, KURV1S, KURV2S, CFVLD, FDVDLD, +C DRAWPV, DASHBD +C +C COMMON BLOCKS INTPR, DASHD1, DASHD2, DDFLAG, DCFLAG, DSAVE1, +C DSAVE2, DSAVE3, DSAVE5, CFFLAG, SMFLAG, DFFLAG, +C FDFLAG +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SOLID OR DASHED LINES, POSSIBLY WITH +C CHARACTERS AT INTERVALS IN THE LINE. +C THE LINES MAY ALSO BE SMOOTHED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN OCTOBER 1973. +C MADE PORTABLE IN SEPTEMBER 1977 FOR USE +C WITH ALL MACHINES WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BIT RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JUNE, 1984. +C +C ALGORITHM POINTS FOR EACH LINE +C SEGMENT ARE PROCESSED AND PASSED TO THE +C ROUTINES, KURV1S AND KURV2S, WHICH COMPUTE +C SPLINES UNDER TENSION PASSING THROUGH THESE +C POINTS. NEW POINTS ARE GENERATED BETWEEN THE +C GIVEN POINTS, RESULTING IN SMOOTH LINES. +C +C ACCURACY PLUS OR MINUS .5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C TIMING ABOUT THREE TIMES AS LONG AS DASHCHAR. +C +C +C +C +C +C +C +C +C*********************************************************************** +C +C FDVDLD RECEIVES IN ITS ARGUMENTS THE POINTS TO BE PROCESSED FOR A +C LINE SEGMENT. IT PASSES THESE POINTS TO THE ROUTINES KURV1S AND KURV2S +C WHICH COMPUTE SPLINES UNDER TENSION PASSING THROUGH THESE POINTS. +C FDVDLD THEN CALLS CFVLD TO CONNECT THE POINTS GENERATED IN KURV2S. +C + DIMENSION XP(70), YP(70), TEMP(70) +C +C THE VARIABLES IN DSAVE5 HAVE TO BE SAVED FOR THE NEXT CALL TO FDVDLD. +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C +C IOFFS IS AN INTERNAL PARAMETER. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN FDVDLD AND DRAWPV. +C + COMMON /SMFLAG/ IOFFS +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED. +C + COMMON /DFFLAG/ IFSTF2 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C + COMMON /FDFLAG/ IFLAG +C +C NOTE THAT THIS IFSTF2 FLAG CANNOT BE IDENTICAL TO THE IFSTFL FLAG +C IN THE ROUTINE CFVLD, BECAUSE A CALL TO THE FRSTD ENTRY OF FDVDLD DOES +C NOT ELIMINATE THE NECESSITY OF A CALL TO THE FRSTD ENTRY OF CFVLD, +C AND REVERSE. +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE +C +C +C OTHER CONSTANTS. +C + DATA PI /3.14159265358/ + DATA IDUMMY /0/ +C +C + GO TO (10,15,35),IENTRY +C +C ************************************* +C +C ENTRY FRSTD (XX,YY) +C + 10 DEG = 180./PI +C + MX = IIX + MY = IIY + IFSTF2 = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 + IF (IOFFS .GE. 1) CALL CFVLD (1,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 15 CONTINUE +C +C TEST FOR PREVIOUS FRSTD CALL +C + IF (IFSTF2 .EQ. 0) GO TO 20 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER(' FDVDLD- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 10 + 20 MX = IIX + MY = IIY +C +C VECTD SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + IF (IOFFS .GE. 1) CALL CFVLD (2,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C IF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 40 + RETURN +C +C ************************************* +C +C ENTRY LASTD +C + 35 CONTINUE + IF (IFSTF2 .NE. 0) RETURN + IFSTF2 = 1 +C +C LASTD CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C + IF (IOFFS .GE. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + IF (IOFFS .GE. 1) RETURN +C +C IFLAG = 0 OK TO CALL LASTD DIRECTLY +C IFLAG = 1 LASTD WAS JUST CALLED FROM BY VECTD +C IGNORE CALL TO LASTD +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 40 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 60 + IF (N-2) 150,140,50 + 50 IF (N .GE. 4) GO TO 60 +C + IF (IPRD .NE. 0) GO TO 60 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 100 + 60 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 80 + IF (NSEG .GE. 1) GO TO 70 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 100 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 70 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 100 + 80 IF (NSEG .GE. 1) GO TO 90 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 100 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 90 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 100 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 110 + NPRIME = FLOAT(NP)-(S*FLOAT(NP)*.5)/32767. + IF (S .GE. 32767.) NPRIME = .5*FLOAT(NP) + NPL = AMAX1(FLOAT(NPRIME)*S/32767.,2.5) + 110 DT = 1./FLOAT(NPL) + IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + IF (NSEG .LE. 0) GO TO 112 + CALL DRAWPV (IX,IY,0) + GO TO 114 + 112 CONTINUE + CALL CFVLD (1,IX,IY) + 114 CONTINUE + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + DO 120 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + IX = IFIX(XS) + IY = IFIX (YS) + CALL CFVLD (2,IX,IY) + 120 CONTINUE + IF (IPRD .NE. 0) GO TO 130 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + IX = IFIX (XSV1) + IY = IFIX (YSV1) + CALL CFVLD (2,IX,IY) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 130 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + GO TO 150 +C +C FOR THE CASE WHEN THERE ARE ONLY 2 DISTINCT POINTS ON A LINE. +C + 140 IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + CALL CFVLD (1,IX,IY) + IX = IFIX (XSAVE(N)) + IY = IFIX (YSAVE(N)) + CALL CFVLD (2,IX,IY) + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) +C + 150 CONTINUE + RETURN + END + SUBROUTINE RESET +C +C THIS USER ENTRY POINT IS HERE ONLY FOR COMPATIBILITY WITH USE IN +C THE CONREC FAMILY WHICH CALL RESET WHEN USED WITH DASHSUPR. +C + RETURN + END + SUBROUTINE DASHDC (IPAT,JCRT,JSIZE) +C +C +C +C +C +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C USER ENTRY POINT. +C DASHDC GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENTS. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*(*) IPAT + CHARACTER*1 IBLK, IGAP, ISOL, ICR + CHARACTER*16 IPC(100) +C +C DASHD1 AND DASHD2 ARE USED +C FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB, DASHDC AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB AND DASHDC. +C IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB AND DASHDC ARE SAVED IN DSAVE2 +C FOR THE NEXT CALL +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C SAVE ALL VARIABLES + SAVE +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C +C NPD IS THE NUMBER OF WORDS IN IP +C + DATA NPD/100/ +C +C INITIALIZE CHARACTER FLAGS +C + DATA IBLK,IGAP,ISOL/' ','''','$'/ +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDC', 'VERSION 1') +C +C NC IS THE NUMBER OF CHARACTERS IN IPAT +C + NC = LEN(IPAT) + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDC -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN TO BE PASSED TO OPTN (65535=177777B). +C + MASK=IOR(ISHIFT(32767,1),1) +C +C + IFCFLG = 2 +C +C NCHRTS - NUMBER OF CHARS IN THIS HOLLERITH STRING. +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C +C RETRIEVE THE RESOLUTION AS SET BY THE USER. +C + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) +C +C IADJUS - TO ADJUST NUMBERS TO THE GIVEN RESOLUTION. +C + IADJUS = ISHIFT(1,15-LXSAVE) + ICRT = JCRT*IADJUS + ISIZE = JSIZE + CHARW = FLOAT(ISIZE*IADJUS) + IF (ISIZE .GT. 3) GO TO 30 + CHARW = 256. + FLOAT(ISIZE)*128. + IF (ISIZE .EQ. 3) CHARW = 768. +C + 30 CONTINUE + IF (ICRT .LT. 1) GO TO 230 + MODE = 2 +C +C START MAIN LOOP +C +C THIS LOOP GENERATES THE IP ARRAY (NEEDED BY CURVED,VECTD,ETC.) FROM +C THE CHARACTER STRING IN IPAT. EACH ITERATION OF THE LOOP PROCESSES +C ONE CHAR OF IPAT. A SOLID OR GAP IS CONSIDERED TO BE A TYPE 1 ENTRY, +C AND A LABEL CHARACTER IS CONSIDERED TO BE A TYPE 2 ENTRY. +C +C IN THE CODE, L IS THE NUMBER OF CHANGES IN THE LINESTYLE (FROM GAP +C TO SOLID, SOLID TO CHARACTER, ETC.) THE IP AND IPFLAG ARRAYS DESCRIBE +C THE LINE TO BE DRAWN, AND THESE ARRAYS ARE INDEXED FROM 1 TO L. THE +C RELATIONSHIP BETWEEN IP AND IPFLAG IS: +C +C IPFLAG(N) IP(N) +C --------- ----- +C 1 LENGTH (IN PLOTTER ADDRESS UNITS) OF SOLID LINE TO +C BE DRAWN. +C 0 NUMBER OF CHARACTERS TO BE PLOTTED. +C -1 LENGTH (IN PLOTTER ADDRESS UNITS) OF GAP. +C +C THE 160 LOOP HANDLES 5 CASES: +C +C 1.) CONTINUE TYPE 2 ENTRY (60-80) +C 2.) START TYPE 2 ENTRY (80-90) +C 3.) END TYPE 2 ENTRY AND START TYPE 1 ENTRY (90-160) +C 4.) START TYPE 1 ENTRY, OR SWITCH TYPE 1 ENTRY FROM SOLID TO +C GAP OR FROM GAP TO SOLID (140-160) +C 5.) CONTINUE TYPE 1 ENTRY (150-160) +C + DO 160 J=1,NC +C +C GET NEXT CHAR INTO ICR, RIGHT JUSTIFIED ZERO FILLED. +C + ICR = IPAT(J:J) +C +C MODE SPECIFIES WHAT THE LAST CHARACTER PROCESSED WAS: +C +C LAST ICR WAS $ (SOLID), MODE IS 8 +C LAST ICR WAS ' (GAP), MODE IS 2 +C LAST ICR WAS HOLLERITH CHAR, MODE IS 5 +C +C NMODE SPECIFIES WHAT THE CURRENT CHARACTER TO BE PROCESSED IS: +C +C ICR NMODE +C --- ----- +C $ 1 +C CHAR 0 +C ' -1 +C + NMODE = 0 + IF (ICR .EQ. IBLK) GO TO 160 + IF (ICR .EQ. IGAP) NMODE = -1 + IF (ICR .EQ. ISOL) NMODE = 1 + IF (L.EQ.0 .AND. NMODE.EQ.-1) MODE = 8 +C +C NGO DETERMINES WHERE TO BRANCH BASED ON CASE TO BE PROCESSED. +C COMPUTE MODE FOR NEXT ITERATION. +C + NGO = NMODE+MODE + MODE = NMODE*3+5 + GO TO (150,80,140,90,60,90,140,80,150),NGO +C +C CHAR TO CHAR +C +C CASE 1) - CONTINUE TYPE 2 ENTRY. +C + 60 IF (NCHRTS .EQ. MNCSTR) GO TO 160 + NCHRTS = NCHRTS + 1 + IP(L) = NCHRTS + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C BLANK OR SOLID TO CHAR +C +C CASE 2) - START STRING ENTRY. LGBSTR POINTS TO THE GAP WHICH +C WILL CONTAIN THE STRING. +C + 80 LGBSTR = MIN0(L+1,NPD) + L = MIN0(LGBSTR+1,NPD) + IPFLAG(L) = 0 + NCHRTS = 1 + IP(L) = 1 + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C CHAR TO SOLID OR GAP +C +C CASE 3) - END STRING ENTRY. ICR IS A $ OR '. +C + 90 CONTINUE + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS) + .5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C BLANK TO SOLID OR SOLID TO BLANK +C +C CASE 4) - START TYPE 1 ENTRY. +C + 140 L = MIN0(L+1,NPD) + IP(L) = 0 +C +C ADD TO A BLANK OR SOLID LINE +C +C CASE 5) - CONTINUE TYPE 1 ENTRY. ICR IS A $ OR '. +C ADD ICRT UNITS TO THE PLOTTER ADDRESS UNITS IN IP(L). +C NMODE INDICATES IF IT IS A GAP OR A SOLID. +C + 150 IP(L) = IP(L) + ICRT + IPFLAG(L) = NMODE + 160 CONTINUE +C +C IF LAST ICR PROCESSED WAS A LABEL CHARACTER, MUST END STRING +C ENTRY. +C + IF (NGO.NE.2 .AND. NGO.NE.5 .AND. NGO.NE.8) GO TO 220 + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS)+.5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C IF IP ARRAY HAS ONLY ONE TYPE 1 ENTRY, SET ISL FLAG. +C + 220 IF (L .GT. 1) RETURN + IBIG = ISHIFT(1,MAX0(LXSAVE,LYSAVE)) + IF (IP(L) .GE. IBIG) GO TO 230 + IF (IPFLAG(L)) 240,240,230 + 230 ISL = 1 + RETURN + 240 ISL = -1 + RETURN + END + SUBROUTINE DASHDB (IPAT) +C +C ARGUMENTS IPAT +C ON INPUT IPAT IS A 16-BIT DASH PATTERN. BY DEFAULT +C EACH BIT IN THE PATTERN REPRESENTS 3 PLOTTER +C ADDRESS UNITS (1=SOLID, 0=BLANK) +C +C +C +C USER ENTRY POINT. +C DASHDB GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENT. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + DIMENSION IPAT(1) + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C DASHD1 IS FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB. IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB HAS BEEN CALLED. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. IT IS +C INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB ARE SAVED IN DSAVE2 FOR THE NEXT CALL TO +C DASHDB. +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C + SAVE +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDB', 'VERSION 1') + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDB -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN +C + MASK=IOR(ISHIFT(32767,1),1) +C + IFCFLG = 2 +C +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C + ICRT = IPAU*ISHIFT(1,15-10) + IF (IPAT(1) .NE. 0) GO TO 260 + ISL = -1 + RETURN + 260 IF (IPAT(1) .NE. MASK) GO TO 270 + ISL = 1 + RETURN + 270 NMODE1 = IAND(ISHIFT(IPAT(1),-15),1) + DO 290 I = 1,16 + IF (NMODE1 .NE. IAND(ISHIFT(IPAT(1),I-16),1)) GO TO 280 + NMODE1 = 1 - NMODE1 + L = L + 1 + IP(L) = 0 + IPFLAG(L) = 1 - 2*NMODE1 + 280 IP(L) = IP(L) + ICRT + 290 CONTINUE + RETURN + END + SUBROUTINE DRAWPV (IX,IY,IND) +C +C DRAWPV INTERCEPTS THE CALL TO PLOTIT TO CHECK IF THE PEN HAS TO BE +C MOVED OR IF IT IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C IF IND=2 NEVER MOVE PEN, JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C +C IN IXSTOR AND IYSTOR THE CURRENT POSITION OF THE PEN IS SAVED. +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE + IIND = IND + 1 + GOTO (100,90,105), IIND +C + 90 CONTINUE +C +C DRAW LINE AND SAVE POSITION OF PEN. +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,1) + GOTO 110 +C + 100 CONTINUE +C +C CHECK IF PEN IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C + DIFF = FLOAT(IABS(IXSTOR-IX)+IABS(IYSTOR-IY)) + IF (DIFF .LE. FLOAT(ICLOSE)) GO TO 110 +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,0) + GOTO 110 +C + 105 CONTINUE +C +C DO NOT MOVE PEN. JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C + IXSTOR = IX + IYSTOR = IY +C + 110 CONTINUE +C + RETURN + END +C + SUBROUTINE CFVLD (IENTRY,IIX,IIY) +C +C CFVLD CONNECTS POINTS WHOSE COORDINATES ARE SUPPLIED IN THE ARGUMENTS, +C ACCORDING TO THE DASH PATTERN WHICH IS PASSED FROM ROUTINE DASHDB +C OR DASHDC IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*16 IPC(100) +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C THE VARIABLES IN DASHD1 AND DASHD2 ARE USED FOR COMMUNICATION WITH +C DASHDC AND DASHDB. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C THE VARIABLES IN DSAVE1 HAVE TO BE SAVED FOR THE NEXT CALL TO CFVLD. +C + COMMON /DSAVE1/ X,Y,X2,Y2,X3,Y3,M,BTI,IB,IX,IY +C +C THE FLAGS IFSTFL AND IVCTFG ARE INITIALIZED IN THE BLOCK DATA DASHBD. +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED. +C IVCTFG IS A FLAG TO INDICATE IF CFVLD IS BEING CALLED FROM VECTD OR +C LASTD. +C + COMMON /DCFLAG/ IFSTFL + COMMON /CFFLAG/ IVCTFG + SAVE +C +C +C CMN IS USED TO DETERMINE WHEN TO STOP DRAWING A LINE SEGMENT +C + DATA CMN/1.5/ +C +C IMPOS IS USED AS AN IMPOSSIBLE PEN POSITION. +C + DATA IMPOS /-9999/ +C +C +C ISL= -1 ALL BLANK ) FLAG TO AVOID MOST CALCULATIONS +C 0 DASHED ) IF PATTERN IS ALL SOLID OR +C 1 ALL SOLID ) ALL BLANK +C +C X,IX,Y,IY CURRENT POSITION +C X1,Y1 START OF A USER LINE SEGMENT +C X2,Y2 END OF A USER LINE SEGMENT +C X3,Y3 START OF A GAP PATTERN SEGMENT +C +C SYMBOLS,IF PRESENT ARE CENTERED IN AN IMMEDIATLY PRECEEDING +C GAP SEGMENT, OR DONE AT THE CURRENT POSITION OTHERWISE +C +C SEGMENT TYPES ARE RECOGNIZED AS FOLLOWS +C SOLID - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS 1. +C GAP - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS -1. +C SYMBOL - WORD IN IP-ARRAY CONTAINS CHARACTER REPRESENTATIONS. +C CORRESPONDING ELEMENT IN IPFLAG IS 0. +C SYMBOL COUNT FOR CHAR STRING IN CHAR NUMBER MNCSTR+1. +C THE IP ARRAY AND THE IPFLAG ARRAY ARE COMPOSED OF L ELEMENTS. +C +C BTI - BITS THIS INCREMENT +C BPBX,BPBY BITS PER BIT X(Y) +C +C +C BRANCH DEPENDING ON FUNCTION TO BE PERFORMED. +C + GO TO (330,305,350),IENTRY +C +C INITIALIZE VARIABLES (ENTRY FRSTD ONLY) +C + 30 CONTINUE + X = IX + Y = IY + X2 = X + X3 = X + Y2 = Y + Y3 = Y + M = 1 + IB = IPFLAG(1) + IF (IPFLAG(1) .NE. 0) GO TO 40 + IB = 0 + BTI = 0 + 40 CONTINUE + BTI = FLOAT(IP(1))*FPART + GO TO 300 +C +C MAIN LOOP START +C + 50 CONTINUE + X1 = X2 + Y1 = Y2 + MX = IIX + MY = IIY + X2 = MX + Y2 = MY + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .LT. CMN) GO TO 190 + 60 BPBX = DX/D + BPBY = DY/D + CALL DRAWPV (IX,IY,0) + 70 BTI = BTI-D + IF (BTI) 100,100,80 +C +C LINE SEGMENT WILL FIT IN CURRENT PATTERN ELEMENT +C + 80 X = X2 + Y = Y2 + IX = X2 + IY = Y2 + IF (IB) 200,160,90 + 90 CALL DRAWPV (IX,IY,1) + GO TO 200 +C +C LINE SEGMENT WONT FIT IN CURRENT PATTERN ELEMENT +C DO IT TO END OF ELEMENT, SAVE HOW MUCH OF SEGMENT LEFT TO DO (D) +C + 100 BTI = BTI+D + D = D-BTI + X = X+BPBX*BTI + Y = Y+BPBY*BTI + IX = X+.5 + IY = Y+.5 + IF (IB) 110,160,120 + 110 CALL DRAWPV (IX,IY,0) + GO TO 130 + 120 CALL DRAWPV (IX,IY,1) +C +C GET THE NEXT PATTERN ELEMENT +C + 130 M = MOD(M,L)+1 + IB = IPFLAG(M) + IF (IB) 140,160,150 + 140 X3 = X + Y3 = Y + BTI = FLOAT(IP(M)) + GO TO 70 + 150 X3 = -1. + BTI = FLOAT(IP(M)) + GO TO 70 +C +C CHARACTER GENERATION +C + 160 S = 0. + IF (IGP .NE. 9) GO TO 162 +C + DX = X-X3 + DY = Y-Y3 + GO TO 164 +C + 162 CONTINUE + DX = X - X1 + DY = Y - Y1 + 164 CONTINUE +C + IF (DY) 170,180,170 + 170 S = ATAN2(DY,DX) + IF (ABS(S-.00005) .GT. 1.5708) S = S-SIGN(3.14159,S) + 180 IF (IGP .NE. 9) GO TO 182 +C + MX = X3 + DX*.5 + MY = Y3 + DY*.5 + LIGP = 0 + GO TO 184 +C + 182 CONTINUE + MX = X + MY = Y + LIGP = 1 +C + 184 CONTINUE + IS = IFIX(S*180./3.14 + .5) + IF (IS .LT. 0) IS = 360+IS + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) + MX = ISHIFT (MX,LXSAVE-15) + MY = ISHIFT(MY,LYSAVE-15) + CALL WTSTR(CPUX(MX),CPUY(MY),IPC(M)(1:IP(M)),ISIZE,IS,LIGP) + CALL DRAWPV (IMPOS,IMPOS,2) + CALL DRAWPV (IX,IY,0) + GO TO 130 + 190 X2 = X1 + Y2 = Y1 + 200 CONTINUE +C +C EXIT IF CALL WAS TO VECTD. +C + IF (IVCTFG .NE. 2) GO TO 210 + IVCTFG = 1 + GO TO 300 +C +C EXIT IF NOT PLOTTING A GAP +C + 210 IF (IB .GE. 0) GO TO 300 +C +C MUST BE IN A GAP AT END OF LASTD. EXIT IF NOT A LABEL GAP. +C + MO = M + M = MOD(M,L) + 1 + IF (IPFLAG(M) .NE. 0) GO TO 300 +C +C CHECK PREVIOUS PLOTTED ELEMENT. WAS IT A GAP OR A LINE. +C + MPREV = M - 2 + IF (MPREV .LE. 0) MPREV = MPREV + L + IB = IPFLAG(MPREV) + IF (IB .GE. 0) GO TO 250 +C +C PREVIOUS ELEMENT WAS A GAP - LOOK FOR NEXT LINE. +C EXIT IF NO LINES IN PATTERN. +C + 230 CONTINUE + 240 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 300 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 245 + BTI = FLOAT(IP(M)) + 245 CONTINUE +C +C IF IP(M) NOT A LINE, CONTINUE LOOKING. +C + IF (IB) 240,230,280 +C +C PREVIOUS ELEMENT WAS A LINE - LOOK FOR NEXT GAP. +C IF NO NON-LABEL GAPS IN PATTERN, GO TO 290. +C + 250 CONTINUE + 260 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 290 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 265 + BTI = FLOAT(IP(M)) + 265 CONTINUE +C +C IF IP(M) NOT A GAP, CONTINUE LOOKING. +C + IF (IB) 270,250,260 +C +C FOUND A GAP. IF ITS A LABEL GAP, GO LOOK FOR NEXT GAP. +C + 270 MT = M + M = MOD(M,L)+1 + IF (IPFLAG(M) .EQ. 0) GO TO 250 + M = MT +C +C M POINTS TO NEXT ELEMENT TO PLOT. SET UP AND GO PLOT. +C + 280 X1 = X3 + Y1 = Y3 + X = X3 + Y = Y3 + IX = X+0.5 + IY = Y+0.5 + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .GE. CMN) GO TO 60 + GO TO 300 +C +C NO NON-LABEL GAPS IN THE PATTERN - FILL IN WITH SOLID LINE. +C + 290 IX = X3+0.5 + IY = Y3+0.5 + CALL DRAWPV (IX,IY,0) + IX = X2 + IY = Y2 + CALL DRAWPV (IX,IY,1) + 300 RETURN +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 305 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD. +C + IF (IFSTFL .EQ. 2) GO TO 310 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER ('CFVLD -- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 330 + 310 K = 1 + IVCTFG = 2 + IF (ISL) 300,50,320 + 320 IX = IIX + IY = IIY + CALL DRAWPV (IX,IY,1) + GO TO 300 +C +C ************************************* +C +C ENTRY FRSTD (FLDX,FLDY) +C + 330 IX = IIX + IY = IIY + IFSTFL = 2 +C AVOID UNEXPECTED PEN POSITION IF CALLS TO SYSTEM PLOT PACKAGE +C ROUTINES WERE MADE. + CALL DRAWPV (IMPOS,IMPOS,2) + IF (ISL) 300,30,340 + 340 CALL DRAWPV (IX,IY,0) + GO TO 300 +C +C ************************************* +C +C ENTRY LASTD +C + 350 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD +C + IF (IFSTFL .NE. 2) GO TO 300 + IFSTFL = 1 + K = 1 + IF (ISL .NE. 0) GO TO 300 + GO TO 210 + END + SUBROUTINE FRSTD (X,Y) +C USER ENTRY PPINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (1,IIX,IIY) + RETURN + END + SUBROUTINE VECTD (X,Y) +C USER ENTRY POINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (2,IIX,IIY) + RETURN + END + SUBROUTINE LASTD +C USER ENTRY POINT. SEE DOCUMENTATION FOR PURPOSE. + DATA IDUMMY /0/ + CALL FDVDLD (3,IDUMMY,IDUMMY) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE CURVED (X,Y,N) +C USER ENTRY POINT. +C + DIMENSION X(N),Y(N) +C + CALL FRSTD (X(1),Y(1)) + DO 10 I=2,N + CALL VECTD (X(I),Y(I)) + 10 CONTINUE +C + CALL LASTD +C + RETURN + END + SUBROUTINE LINED (XA,YA,XB,YB) +C USER ENTRY POINT. +C + DATA IDUMMY /0/ + CALL FL2INT (XA,YA,IXA,IYA) + CALL FL2INT (XB,YB,IXB,IYB) +C + CALL CFVLD (1,IXA,IYA) + CALL CFVLD (2,IXB,IYB) + CALL CFVLD (3,IDUMMY,IDUMMY) +C + RETURN +C +C------REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN77 AND GKS +C +C DECEMBER 1979 ADDED REVISION HISTORY AND STATISTICS +C CALL +C +C----------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/ezmap.f b/sys/gio/ncarutil/ezmap.f new file mode 100644 index 00000000..8d87a4d7 --- /dev/null +++ b/sys/gio/ncarutil/ezmap.f @@ -0,0 +1,4598 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C*********************************************************************** +C P A C K A G E E Z M A P - I N T R O D U C T I O N +C*********************************************************************** +C +C THIS FILE CONTAINS IMPLEMENTATION INSTRUCTIONS, A WRITE-UP, AND THE +C CODE FOR THE PACKAGE EZMAP. BANNERS LIKE THE ONE ABOVE DELIMIT THE +C MAJOR SECTIONS OF THE FILE. THE CODE ITSELF IS SEPARATED INTO THREE +C SECTIONS: USER-LEVEL ROUTINES, INTERNAL ROUTINES, AND THE BLOCK DATA +C ROUTINE WHICH DETERMINES THE DEFAULT VALUES OF INTERNAL PARAMETERS. +C WITHIN EACH SECTION, ROUTINES APPEAR IN ALPHABETICAL ORDER. +C +C*********************************************************************** +C P A C K A G E E Z M A P - I M P L E M E N T A T I O N +C*********************************************************************** +C +C THE EZMAP PACKAGE IS WRITTEN IN FORTRAN-77 AND SHOULD BE RELATIVELY +C EASY TO IMPLEMENT. THE OUTLINE DATA REQUIRED MAY BE GENERATED BY +C RUNNING THE PROGRAM +C +C PROGRAM CONVRT +C DIMENSION FLIM(4),PNTS(200) +C 1 READ (1,3,END=2) NPTS,IGID,(FLIM(I),I=1,4) +C IF (NPTS.GT.1) READ (1,4,END=2) (PNTS(I),I=1,NPTS) +C WRITE (2) NPTS,IGID,(FLIM(I),I=1,4),(PNTS(I),I=1,NPTS) +C GO TO 1 +C 2 STOP +C 3 FORMAT (2I8,4F8.3) +C 4 FORMAT (10F8.3) +C END +C +C WITH THE FILE EZMAPDAT ASSIGNED TO UNIT 1. THE OUTPUT FILE, ON UNIT +C 2, CONTAINS THE BINARY OUTLINE DATA TO BE USED BY EZMAP. THE EZMAP +C ROUTINE MAPIO (WHICH SEE) MUST THEN BE MODIFIED TO ACCESS THIS FILE. +C +C THE ROUTINE MAPCHI CONTAINS THE STATEMENTS +C +C CALL GETUSV ('IN',INTO) +C CALL SETUSV ('IN',IFIX(10000.*FLOAT(INTS(IPRT))/255.)) +C +C (TO BE EXECUTED FOR A POSITIVE VALUE OF IPRT) AND THE STATEMENT +C +C CALL SETUSV ('IN',INTO) +C +C (TO BE EXECUTED FOR A NEGATIVE VALUE OF IPRT). THESE STATEMENTS +C SET/RESET THE INTENSITY FOR VARIOUS PORTIONS OF THE MAP. IF COLOR +C IS AVAILABLE ON THE DEVICE(S) BEING DRIVEN, THESE STATEMENTS SHOULD +C BE OMITTED AND THE IMPLEMENTOR SHOULD PROVIDE A DEFAULT VERSION OF +C MAPUSR WHICH SETS/RESETS THE INTENSITY AND COLOR AS DESIRED. THIS +C DEFAULT VERSION OF MAPUSR SHOULD DECLARE THE LABELLED COMMON BLOCK +C MAPNTS AND MAKE USE OF THE CURRENT VALUES IN THE ARRAY INTS TO SET +C THE INTENSITY; IT SHOULD ALSO BE PUBLISHED TO AID USERS IN SETTING +C UP THEIR OWN VERSIONS. +C +C +C*********************************************************************** +C P A C K A G E E Z M A P - U S E R ' S G U I D E +C*********************************************************************** +C +C LATEST REVISION AUGUST, 1985 +C +C PURPOSE TO PLOT MAPS OF THE EARTH ACCORDING TO ANY +C ONE OF TEN DIFFERENT PROJECTIONS, SHOWING +C CONTINENTAL, INTERNATIONAL, AND/OR U.S. STATE +C OUTLINES, PARALLELS, AND MERIDIANS. THE +C ORIGIN AND ORIENTATION OF THE PROJECTION ARE +C SELECTED BY THE USER. POINTS ON THE EARTH +C DEFINED BY LATITUDE AND LONGITUDE ARE MAPPED +C TO POINTS IN THE PLANE OF PROJECTION - THE +C U/V PLANE. THE U AND V AXES ARE PARALLEL TO +C THE X AND Y AXES OF THE PLOTTER, RESPECTIVELY. +C A RECTANGULAR FRAME WHOSE SIDES ARE PARALLEL +C TO THE U AND V AXES IS CHOSEN AND MATERIAL +C WITHIN THAT FRAME (OR AN INSCRIBED ELLIPTICAL +C FRAME) IS PLOTTED. +C +C USAGE THE ROUTINE MAPDRW DRAWS A COMPLETE MAP, AS +C DIRECTED BY THE CURRENT VALUES OF PARAMETERS +C IN THE EZMAP PACKAGE. TO CHANGE THE VALUES +C OF THOSE PARAMETERS, AND THUS THE APPEARANCE +C OF THE MAP, ONE MAY FIRST CALL ONE OF THE +C ROUTINES MAPROJ (TO CHANGE THE PROJECTION TO +C BE USED), MAPSET (TO CHANGE WHAT PORTION OF +C THE U/V PLANE IS TO BE VIEWED), MAPPOS (TO +C CHANGE WHAT PORTION OF THE PLOTTER FRAME IS +C TO BE USED), OR ONE OF THE PARAMETER-SETTING +C ROUTINES MAPSTC, MAPSTI, MAPSTL, AND MAPSTR +C (TO CHANGE VARIOUS OTHER PARAMETERS, OF TYPES +C CHARACTER, INTEGER, LOGICAL, AND REAL). THE +C PARAMETER-RETRIEVAL ROUTINES MAPGTC, MAPGTI, +C MAPGTL, AND MAPGTR ALLOW THE USER TO RETRIEVE +C THE VALUES OF EZMAP PARAMETERS. +C +C THE ROUTINE MAPSAV ALLOWS ONE TO SAVE THE +C CURRENT STATE OF EZMAP, THE ROUTINE MAPRST TO +C RESTORE A SAVED STATE. +C +C USERS WITH SPECIAL NEEDS MAY WISH TO CALL THE +C LOWER-LEVEL ROUTINES MAPINT (TO INITIALIZE +C THE PACKAGE - IT MUST BE CALLED INITIALLY AND +C AGAIN WHENEVER CERTAIN PARAMETERS ARE CHANGED), +C MAPGRD (TO DRAW PARALLELS AND MERIDIANS), +C MAPLBL (TO LABEL THE INTERNATIONAL DATE LINE, +C THE EQUATOR, THE GREENWICH MERIDIAN, AND THE +C POLES, AND TO DRAW THE PERIMETER), AND MAPLOT +C (TO DRAW THE SELECTED GEOGRAPHIC OUTLINES). +C THESE ROUTINES ARE NORMALLY CALLED BY MAPDRW. +C +C INTENSITIES OF VARIOUS MAP PORTIONS MAY BE SET +C BY CALLS TO THE ROUTINE MAPSTI. THE ROUTINE +C MAPUSR IS CALLED BY EZMAP JUST BEFORE/AFTER +C DRAWING VARIOUS PORTIONS OF THE MAP; THE +C DEFAULT VERSION, WHICH DOES NOTHING, MAY BE +C REPLACED BY A USER VERSION WHICH SETS/RESTORES +C COLOR, SPOT SIZE, INTENSITY, DASH PATTERN, ETC. +C +C THE ROUTINE MAPEOS IS CALLED BY EZMAP ONCE FOR +C EACH OUTLINE SEGMENT. THE USER MAY SUPPLY A +C VERSION WHICH EXAMINES THE SEGMENT TO SEE IF +C IT OUGHT TO BE PLOTTED AND, IF NOT, TO DELETE +C IT. THIS MAY BE USED, FOR EXAMPLE, TO REDUCE +C THE CLUTTER IN NORTHERN CANADA. +C +C TO OVERLAY OBJECTS OF ONE'S OWN ON THE MAP +C DRAWN BY MAPDRW, ONE MAY USE ONE OR MORE OF +C THE ROUTINES MAPTRN (TO COMPUTE THE U/V +C COORDINATES OF A POINT, GIVEN ITS LATITUDE +C AND LONGITUDE), MAPIT (TO DO "PEN-UP/DOWN" +C MOVES), MAPFST (TO DO "PEN-UP" MOVES), AND +C MAPVEC (TO DO "PEN-DOWN" MOVES). +C +C THE ROUTINE SUPMAP, FROM WHICH EZMAP GREW, IS +C IMPLEMENTED WITHIN IT AND ALLOWS ONE TO DRAW +C A COMPLETE MAP WITH A SINGLE, RATHER LENGTHY, +C CALL. THE ROUTINE SUPCON, WHICH IS THE OLD +C ANALOGUE OF MAPTRN, IS ALSO IMPLEMENTED. +C +C THE OLD ROUTINE EZMAP, WHICH WAS IMPLEMENTED +C IN SUCH A WAY AS TO CAUSE PORTABILITY PROBLEMS, +C HAS BEEN REMOVED. STATISTICS INDICATED THAT +C IT WAS NOT BEING USED, ANYWAY. +C +C SEE THE WRITE-UPS OF INDIVIDUAL ROUTINES BELOW. +C +C I/O GRAPHICAL OUTPUT IS GENERATED. OUTLINE DATA +C IS READ FROM A "TAPE UNIT". +C +C ERROR CONDITIONS WHEN AN ERROR OCCURS DURING A CALL TO AN EZMAP +C ROUTINE, AN ERROR MESSAGE IS LOGGED, USING THE +C NCAR VERSION OF THE PORT ERROR ROUTINE SETERR +C (CALLED SETER); BY DEFAULT, THE PROGRAM IS THEN +C ABORTED. ERROR RECOVERY IS POSSIBLE, HOWEVER. +C INSERT THE CALL +C +C CALL ENTSR (IOLD,1) +C +C AT THE BEGINNING OF YOUR PROGRAM. THIS MAKES +C ERROR RECOVERY POSSIBLE. THEN, FOLLOWING EACH +C CALL TO AN EZMAP ROUTINE WHICH COULD CAUSE AN +C ERROR, INSERT CODE LIKE THE FOLLOWING: +C +C IF (NERRO(IERR).NE.0) THEN +C CALL EPRIN +C CALL ERROF +C END IF +C +C THE VALUE OF THE FUNCTION NERRO IS NON-ZERO IF +C SETER HAS BEEN CALLED. THE CALL TO EPRIN DUMPS +C OUT THE ERROR MESSAGE (WHICH HAS NOT YET BEEN +C PRINTED) AND THE CALL TO ERROF TURNS OFF THE +C ERROR CONDITION IN SETER. THIS DOES NOT CLEAR +C EZMAP'S ERROR FLAG, HOWEVER; IT REMAINS SET +C UNTIL AFTER THE NEXT SUCCESSFUL CALL TO MAPINT, +C PREVENTING OTHER EZMAP ROUTINES FROM TRYING TO +C EXECUTE (AND POSSIBLY BOMBING AS A RESULT). +C POSSIBLE ERROR FLAGS ARE AS FOLLOWS: +C +C 1 MAPGTC - UNKNOWN PARAMETER NAME XX +C 2 MAPGTI - UNKNOWN PARAMETER NAME XX +C 3 MAPGTL - UNKNOWN PARAMETER NAME XX +C 4 MAPGTR - UNKNOWN PARAMETER NAME XX +C 5 MAPINT - ATTEMPT TO USE NON-EXISTENT +C PROJECTION +C 6 MAPINT - ANGULAR LIMITS TOO GREAT +C 7 MAPINT - MAP HAS ZERO AREA +C 8 MAPINT - MAP LIMITS INAPPROPIATE +C 9 MAPROJ - UNKNOWN PROJECTION NAME XX +C 10 MAPSET - UNKNOWN MAP AREA SPECIFIER XX +C 11 MAPSTC - UNKNOWN OUTLINE NAME XX +C 12 MAPSTC - UNKNOWN PARAMETER NAME XX +C 13 MAPSTI - UNKNOWN PARAMETER NAME XX +C 14 MAPSTL - UNKNOWN PARAMETER NAME XX +C 15 MAPSTR - UNKNOWN PARAMETER NAME XX +C 16 MAPTRN - ATTEMPT TO USE NON-EXISTENT +C PROJECTION +C 17 MAPIO - OUTLINE DATASET IS UNREADABLE +C 18 MAPIO - EOF ENCOUNTERED IN OUTLINE +C DATASET +C 19 MAPPOS - ARGUMENTS ARE INCORRECT +C 20 MAPRST - ERROR ON READ +C 21 MAPRST - EOF ON READ +C 22 MAPSAV - ERROR ON WRITE +C +C PRECISION SINGLE. +C +C LANGUAGE FORTRAN. +C +C HISTORY IN ABOUT 1963, R. L. PARKER OF UCSD WROTE THE +C ORIGINAL CODE CALLED SUPERMAP, USING OUTLINE +C DATA GENERATED BY HERSHEY. THIS WAS ADAPTED +C FOR USE AT NCAR BY LEE, IN 1968. REVISIONS +C OCCURRED IN JANUARY OF 1969 AND MAY OF 1971. +C THE CODE WAS PUT IN STANDARD NSSL FORMAT IN +C OCTOBER OF 1973. FURTHER REVISIONS OCCURRED +C IN JULY, 1974, IN AUGUST, 1976, AND IN JULY, +C 1978. IN LATE 1984 AND EARLY 1985, THE CODE +C WAS HEAVILY REVISED TO ACHIEVE FORTRAN-77 AND +C GKS COMPATIBILITY, TO REMOVE ERRORS, AND TO +C EXPAND THE OUTLINE DATASETS. CICELY RIDLEY, +C JAY CHALMERS, AND DAVE KENNISON (THE CURRENT +C CURATOR) HAVE ALL HAD A HAND IN THE CREATION +C OF THIS PACKAGE. +C +C REFERENCES HERSHEY, A.V., "THE PLOTTING OF MAPS ON A +C CRT PRINTER." NWL REPORT NO. 1844, 1963. +C +C LEE, TSO-HWA, "STUDENTS' SUMMARY REPORTS, +C WORK-STUDY PROGRAM IN SCIENTIFIC COMPUTING". +C NCAR, 1968. +C +C PARKER, R.L., "2UCSD SUPERMAP: WORLD +C PLOTTING PACKAGE". +C +C STEERS, J.A., "AN INTRODUCTION TO THE STUDY +C OF MAP PROJECTIONS". UNIVERSITY OF LONDON +C PRESS, 1962. +C +C ACCURACY THE DEFINITION OF THE MAP PRODUCED IS LIMITED +C BY TWO FACTORS: THE RESOLUTION OF THE OUTLINE +C DATA AND THE RESOLUTION OF THE GRAPHICS +C DEVICE. +C +C DATA POINTS IN THE CONTINENTAL OUTLINES ARE +C ABOUT ONE DEGREE APART AND THE COORDINATES +C ARE ACCURATE TO .01 DEGREE. DATA POINTS IN +C U.S. STATE OUTLINES ARE ABOUT .05 DEGREES +C APART AND THE COORDINATES ARE ACCURATE TO +C .001 DEGREE. BOTH THE SPACING AND THE +C ACCURACY OT THE INTERNATIONAL BOUNDARIES +C FALLS SOMEWHERE BETWEEN THESE TWO EXTREMES. +C +C THE DICOMED HAS 15-BIT COORDINATE REGISTERS, +C BUT AN EFFECTIVE RESOLUTION OF AT MOST 1 IN +C 4096 IN BOTH X AND Y. +C +C TIMING THE MARCH, 1985, UPDATE HAS MADE EZMAP RUN +C SIGNIFICANTLY SLOWER. THIS IS MOSTLY BECAUSE +C THE DEFAULT RESOLUTION HAS BEEN INCREASED TO +C A VALUE SUITABLE FOR THE DICOMED, RATHER THAN +C THE DD80. USERS WHO ARE CONCERNED ABOUT THIS +C MAY INCREASE THE VALUES OF THE PARAMETERS 'MV' +C AND/OR 'DD' (SEE THE DESCRIPTION OF MAPSTX) +C TO DECREASE THE TIMING (AT THE EXPENSE OF PLOT +C QUALITY, OF COURSE). +C +C PORTABILITY THE CODE IS WRITTEN IN FORTRAN-77 AND SHOULD +C BE VERY PORTABLE. A BINARY DATASET CONTAINING +C OUTLINE DATA MUST BE GENERATED AND THE ROUTINE +C MAPIO MUST BE MODIFIED TO READ THAT DATASET. +C SEE THE IMPLEMENTATION INSTRUCTIONS AT THE +C BEGINNING OF THIS FILE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P D R W - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW THE COMPLETE MAP DESCRIBED BY THE +C CURRENT VALUES OF THE EZMAP PARAMETERS. +C +C MAPDRW CALLS MAPINT (IF REQUIRED), MAPGRD, +C MAPLBL, AND MAPLOT, IN THAT ORDER. THE USER +C MAY WISH TO CALL THESE ROUTINES DIRECTLY. +C +C USAGE CALL MAPDRW +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P E O S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE MAPEOS IS CALLED BY EZMAP TO EXAMINE EACH +C SEGMENT IN THE OUTLINE DATASETS. THE DEFAULT +C VERSION DOES NOTHING. A USER-SUPPLIED VERSION +C MAY CAUSE SELECTED SEGMENTS TO BE DELETED (TO +C REDUCE THE CLUTTER IN NORTHERN CANADA, FOR +C EXAMPLE). +C +C USAGE (BY EZMAP) CALL MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) +C +C ARGUMENTS NOUT IS THE NUMBER OF THE OUTLINE DATASET FROM +C WHICH THE SEGMENT COMES, AS FOLLOWS: +C +C NOUT DATASET TO WHICH SEGMENT BELONGS. +C ---- ------------------------------------ +C 1 'CO' - CONTINENTAL OUTLINES ONLY. +C 2 'US' - U.S STATE OUTLINES ONLY. +C 3 'PS' - CONTINENTAL, U.S STATE, AND +C INTERNATIONAL OUTLINES. +C 4 'PO' - CONTINENTAL AND INTERNATIONAL +C OUTLINES. +C +C NSEG IS THE NUMBER OF THE SEGMENT WITHIN THE +C OUTLINE DATASET. +C +C IGID IDENTIFIES THE GROUP TO WHICH THE SEGMENT +C BELONGS, AS FOLLOWS: +C +C IGID GROUP TO WHICH SEGMENT BELONGS. +C ---- ------------------------------------ +C 1 CONTINENTAL OUTLINES. +C 2 U.S. STATE BOUNDARIES. +C 3 INTERNATIONAL BOUNDARIES. +C +C NPTS IS THE NUMBER OF POINTS DEFINING THE +C OUTLINE SEGMENT. NPTS MAY BE ZEROED TO +C SUPPRESS PLOTTING OF THE SEGMENT. +C +C PNTS IS AN ARRAY OF COORDINATES. PNTS(1) +C AND PNTS(2) ARE THE LATITUDE AND LONGITUDE +C OF THE FIRST POINT, PNTS(3) AND PNTS(4) THE +C LATITUDE AND LONGITUDE OF THE SECOND POINT, ... +C PNTS(2*NPTS-1) AND PNTS(2*NPTS) THE LATITUDE +C AND LONGITUDE OF THE LAST POINT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P F S T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL TO +C MAPDRW - USED IN CONJUNCTION WITH MAPVEC. +C +C USAGE CALL MAPFST (RLAT,RLON) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPIT (RLAT,RLON,0) +C +C ARGUMENTS RLAT AND RLON ARE DEFINED AS FOR MAPIT. SEE +C THE DESCRIPTION OF MAPIT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P G R D - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A GRID MADE UP OF LINES OF LATITUDE AND +C LONGITUDE. IF EZMAP NEEDS INITIALIZATION OR IF +C THE ERROR FLAG 'ER' IS NON-ZERO, MAPGRD DOES +C NOTHING. +C +C USAGE CALL MAPGRD +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P G T X - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO GET THE VALUES OF EZMAP PARAMETERS. +C +C USAGE CALL MAPGTC (WHCH,CVAL) +C CALL MAPGTI (WHCH,IVAL) +C CALL MAPGTL (WHCH,LVAL) +C CALL MAPGTR (WHCH,RVAL) +C +C ARGUMENTS WHCH IS A CHARACTER STRING SPECIFYING THE +C PARAMETER TO GET. +C +C CVAL, IVAL, LVAL, OR RVAL IS A VARIABLE TO +C RECEIVE THE VALUE OF THE PARAMETER SPECIFIED +C BY WHCH - OF TYPE CHARACTER, INTEGER, LOGICAL, +C OR REAL, RESPECTIVELY. +C +C ALL OF THE PARAMETERS LISTED IN THE DISCUSSION +C OF MAPSTX MAY BE RETRIEVED. THE FOLLOWING MAY +C ALSO BE RETRIEVED: +C +C WHCH TYPE MEANING +C ---- ---- ------- +C +C AREA C THE VALUE OF THE MAP LIMITS +C SPECIFIER JLTS FROM THE LAST +C CALL TO MAPSET. THE DEFAULT +C VALUE IS 'MA'. +C +C ERROR I THE CURRENT VALUE OF THE ERROR +C FLAG. DEFAULT IS ZERO. +C +C INITIALIZE I,L INITIALIZATION FLAG. IF TRUE +C (NON-ZERO), EZMAP IS IN NEED +C OF INITIALIZATION (BY MEANS OF +C A CALL MAPINT). THE DEFAULT +C VALUE IS TRUE (NON-ZERO). +C +C PROJECTION C THE VALUE OF THE PROJECTION +C SPECIFIER JPRJ FROM THE LAST +C CALL TO MAPROJ. THE DEFAULT +C VALUE IS 'CE'. +C +C PN I,R THE VALUE OF PLON FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C PT I,R THE VALUE OF PLAT FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C PN I,R "N" IS AN INTEGER BETWEEN 1 +C AND 8. RETRIEVES VALUES FROM +C THE LAST CALL TO MAPSET. P1 +C THROUGH P4 GET YOU PLM1(1), +C PLM2(1), PLM3(1), AND PLM4(1), +C WHILE P5 THROUGH P8 GET YOU +C PLM1(2), PLM2(2), PLM3(2), AND +C PLM4(2). THE DEFAULT VALUES +C ARE ALL ZERO. +C +C ROTATION I,R THE VALUE OF ROTA FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C XLEFT R THE PARAMETERS XLOW, XROW, +C XRIGHT R YBOW, AND YTOW FROM THE LAST +C YBOTTOM R CALL TO MAPPOS. DEFAULTS +C YTOP R ARE .05, .95, .05, AND .95. +C +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I N T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO INITIALIZE THE PACKAGE AFTER THE VALUES OF +C SOME PARAMETERS HAVE BEEN CHANGED. THE FLAG +C 'IN', WHICH MAY BE RETRIEVED BY A CALL TO +C MAPGTI OR MAPGTL, INDICATES WHETHER OR NOT +C INITIALIZATION IS REQUIRED AT A GIVEN TIME. +C (SOME PARAMETERS MAY BE RESET AT ANY TIME AND +C DO NOT REQUIRE MAPINT TO BE CALLED AGAIN.) +C +C USAGE CALL MAPINT +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL +C TO MAPDRW. MAPIT ATTEMPTS TO OMIT NON-VISIBLE +C PORTIONS AND TO HANDLE "CROSS-OVER" - A JUMP +C FROM ONE END OF THE MAP TO THE OTHER CAUSED +C BY THE PROJECTION'S HAVING SLIT THE GLOBE +C ALONG SOME HALF OF A GREAT CIRCLE AND LAID IT +C OPEN WITH THE TWO SIDES OF THE SLIT AT OPPOSITE +C ENDS OF THE MAP. CROSS-OVER CAN OCCUR ON +C CYLINDRICAL AND CONICAL PROJECTIONS; MAPIT +C HANDLES IT VERY WELL ON THE FORMER AND NOT SO +C WELL ON THE LATTER. +C +C THE EZMAP PARAMETER 'DL' DETERMINES WHETHER +C MAPIT DRAWS SOLID LINES OR DOTTED LINES. THE +C PARAMETERS 'DD' AND 'MV' ALSO AFFECT MAPIT'S +C BEHAVIOR. SEE THE DESCRIPTION OF THE ROUTINE +C MAPSTX, BELOW. +C +C A SEQUENCE OF CALLS TO MAPIT SHOULD BE FOLLOWED +C BY A CALL TO MAPIQ (WHICH SEE, ABOVE) TO FLUSH +C ITS BUFFERS. +C +C POINTS IN TWO CONTIGUOUS PEN-DOWN CALLS TO +C MAPIT SHOULD NOT BE FAR APART ON THE GLOBE. +C +C USAGE CALL MAPIT (RLAT,RLON,IFST) +C +C ARGUMENTS RLAT AND RLON ARE THE LATITUDE AND LONGITUDE +C OF A POINT TO WHICH THE "PEN" IS TO BE MOVED. +C BOTH ARE GIVEN IN DEGREES. RLAT MUST BE +C BETWEEN -90. AND +90., INCLUSIVE; RLON MUST BE +C BETWEEN -540. AND +540., INCLUSIVE. +C +C IFST IS 0 TO DO A "PEN-UP" MOVE, 1 TO DO A +C "PEN-DOWN" MOVE IF THE DISTANCE FROM THE LAST +C POINT TO THE NEW POINT IS GREATER THAN 'MV' +C PLOTTER UNITS, 2 OR GREATER TO DO THE MOVE +C REGARDLESS OF THE DISTANCE FROM THE LAST POINT +C TO THE NEW ONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I Q - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FLUSH MAPIT'S BUFFERS. THIS IS PARTICULARLY +C IMPORTANT BEFORE A STOP OR A CALL FRAME AND +C BEFORE CHANGING INTENSITY, DASH PATTERN, COLOR, +C ETC. +C +C USAGE CALL MAPIQ +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P L B L - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO LABEL THE INTERNATIONAL DATE LINE (ID), THE +C EQUATOR (EQ), THE GREENWICH MERIDIAN (GM), AND +C THE POLES (NP AND SP), AND TO DRAW THE BORDER +C AROUND THE MAP. IF EZMAP NEEDS INITIALIZATION +C OR IF THE ERROR FLAG 'ER' IS SET, MAPLBL DOES +C NOTHING. +C +C USAGE CALL MAPLBL +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P L O T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW THE CONTINENTAL AND/OR INTERNATIONAL +C AND/OR U.S. STATE OUTLINES SELECTED BY THE +C PARAMETER 'OU'. IF EZMAP CURRENTLY NEEDS +C INITIALIZATION OR IF THE ERROR FLAG 'ER' IS +C SET, MAPLOT DOES NOTHING. +C +C USAGE CALL MAPLOT +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P P O S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE POSITION OF THE MAP ON THE +C PLOTTER FRAME. +C +C USAGE CALL MAPPOS (XLOW,XROW,YBOW,YTOW) +C +C ARGUMENTS THE ARGUMENTS ARE FRACTIONS BETWEEN 0 AND 1 +C DETERMINING THE POSITION OF A WINDOW IN THE +C PLOTTER FRAME WITHIN WHICH THE MAP IS TO BE +C DRAWN. XLOW AND XROW POSITION THE LEFT AND +C RIGHT EDGES AND ARE STATED AS FRACTIONS OF THE +C DISTANCE FROM LEFT TO RIGHT IN THE PLOTTER +C FRAME. YBOW AND YTOW POSITION THE BOTTOM AND +C TOP EDGES AND ARE STATED AS FRACTIONS OF THE +C DISTANCE FROM BOTTOM TO TOP IN THE PLOTTER +C FRAME. THE MAP IS CENTERED IN THE SPECIFIED +C WINDOW AND MADE AS LARGE AS POSSIBLE WHILE +C MAINTAINING ITS PROPER SHAPE. +C +C THE DEFAULT VALUES OF THE INTERNAL PARAMETERS +C CHANGED BY THIS ROUTINE ARE .05, .95, .05, AND +C .95, RESPECTIVELY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R O J - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE PROJECTION TO BE USED. +C +C USAGE CALL MAPROJ (JPRJ,PLAT,PLON,ROTA) +C +C ARGUMENTS JPRJ IS A CHARACTER VARIABLE DEFINING THE +C DESIRED PROJECTION TYPE, AS FOLLOWS: +C +C THE CONIC PROJECTION: +C +C 'LC' - LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS. +C +C THE AZIMUTHAL PROJECTIONS: +C +C 'ST' - STEREOGRAPHIC. +C +C 'OR' - ORTHOGRAPHIC. CAUSES THE PARAMETER +C 'SA' (WHICH SEE, IN THE DESCRIPTION +C OF THE ROUTINE MAPSTX) TO BE ZEROED. +C +C 'LE' - LAMBERT EQUAL AREA. +C +C 'GN' - GNOMONIC. +C +C 'AE' - AZIMUTHAL EQUIDISTANT. +C +C 'SV' - SATELLITE-VIEW. IF THE PARAMETER +C 'SA' (WHICH SEE, IN THE DESCRIPTION +C OF THE ROUTINE MAPSTX) IS GREATER +C THAN 1 OR LESS THAN -1, IT IS LEFT +C ALONE; OTHERWISE, IT IS GIVEN THE +C VALUE 6.631. +C +C THE CYLINDRICAL PROJECTIONS: +C +C 'CE' - CYLINDRICAL EQUIDISTANT. +C +C 'ME' - MERCATOR. +C +C 'MO' - MOLLWEIDE. THE PROJECTION USED IS +C NOT ACTUALLY A TRUE MOLLWEIDE. +C +C PLAT, PLON, AND ROTA ARE REALS SPECIFYING THE +C VALUES OF ANGULAR QUANTITIES, IN DEGREES. HOW +C THEY ARE USED DEPENDS ON THE VALUE OF JPRJ, AS +C FOLLOWS: +C +C IF JPRJ IS NOT EQUAL TO 'LC': PLAT AND PLON +C DEFINE THE LATITUDE AND LONGITUDE OF THE POLE +C OF THE PROJECTION - THE POINT ON THE GLOBE +C WHICH IS TO BE PROJECTED TO THE ORIGIN OF THE +C U/V PLANE. PLAT MUST BE BETWEEN -90. AND +90., +C INCLUSIVE, POSITIVE IN THE NORTHERN HEMISPHERE, +C NEGATIVE IN THE SOUTHERN. PLON MUST BE BETWEEN +C -180. AND +180., INCLUSIVE, POSITIVE TO THE +C EAST, AND NEGATIVE TO THE WEST, OF GREENWICH. +C ROTA IS THE ANGLE BETWEEN THE V AXIS AND NORTH +C AT THE ORIGIN. IT IS TAKEN TO BE POSITIVE IF +C THE ANGULAR MOVEMENT FROM NORTH TO THE V AXIS +C IS COUNTER-CLOCKWISE, NEGATIVE OTHERWISE. IF +C THE ORIGIN IS AT THE NORTH POLE, "NORTH" IS +C CONSIDERED TO BE IN THE DIRECTION OF PLON+180. +C IF THE ORIGIN IS AT THE SOUTH POLE, "NORTH" IS +C CONSIDERED TO BE IN THE DIRECTION OF PLON. +C FOR THE CYLINDRICAL PROJECTIONS, THE AXIS OF +C THE PROJECTION IS PARALLEL TO THE V AXIS. +C +C IF JPRJ IS EQUAL TO 'LC' (LAMBERT CONFORMAL +C CONIC WITH TWO STANDARD PARALLELS): PLON +C DEFINES THE CENTRAL MERIDIAN OF THE PROJECTION, +C WHILE PLAT AND ROTA DEFINE THE TWO STANDARD +C PARALLELS. IF PLAT AND ROTA ARE EQUAL, A +C CONIC PROJECTION WITH ONE STANDARD PARALLEL +C IS USED. +C +C MORE DETAILED DESCRIPTIONS OF THE PROJECTIONS +C MAY BE FOUND IN THE GRAPHICS MANUAL, TOGETHER +C WITH HELPFUL DIAGRAMS, BUT A FEW WORDS MAY BE +C HELPFUL HERE: +C +C THE CONICAL PROJECTION MAPS THE SURFACE OF THE +C EARTH ONTO THE SURFACE OF A CONE INTERSECTING +C THE EARTH ALONG THE TWO STANDARD PARALLELS. +C THE CONE IS THEN SLIT ALONG A LINE OPPOSITE +C THE CENTRAL MERIDIAN AND OPENED UP (WITH SOME +C STRETCHING) ONTO A FLAT SURFACE. +C +C THE AZIMUTHAL PROJECTIONS MAP THE SURFACE OF +C THE EARTH (OR OF ONE HEMISPHERE OF THE EARTH) +C ONTO A PLANE WHOSE ORIGIN IS TANGENT TO IT AT +C THE POINT (PLAT,PLON). THE SEVERAL AZIMUTHAL +C PROJECTIONS DIFFER ONLY IN THE FUNCTION USED +C TO MAP THE GREAT-CIRCLE DISTANCE OF A POINT +C FROM THE POLE (PLAT,PLON) TO A LINEAR DISTANCE +C OF THE PROJECTED POINT FROM THE ORIGIN (0,0). +C THE PROJECTED IMAGE MAY BE ROTATED USING THE +C PARAMETER ROTA. +C +C THE CYLINDRICAL PROJECTIONS MAP THE SURFACE OF +C THE EARTH ONTO A CYLINDER WHICH IS TANGENT TO +C IT ALONG A GREAT CIRCLE PASSING THROUGH THE +C POINT (PLAT,PLON) AT AN ANGLE DETERMINED BY +C ROTA. THE CYLINDER IS THEN SLIT ALONG ITS +C LENGTH THROUGH THE POINT OPPOSITE (PLAT,PLON) +C AND OPENED UP ONTO THE PLANE. THE SEVERAL +C CYLINDRICAL PROJECTIONS DIFFER PRINCIPALLY IN +C THE FUNCTION USED TO MAP THE DISTANCE FROM THE +C GREAT CIRCLE OF TANGENCY TO A DISTANCE ALONG +C THE CYLINDER. IF PLAT IS ZERO AND ROTA IS +C EITHER 0. OR 180., THE CYLINDRICAL PROJECTIONS +C ARE PARTICULARLY SIMPLE TO DO AND A FASTER PATH +C THROUGH THE CODE IS USED. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE RECALLS SET. INTENDED TO BE USED WHEN DATA +C IS TO BE PLOTTED OVER A MAP GENERATED IN A +C DIFFERENT OVERLAY (E.G., USING A FLASH BUFFER), +C AND WHEN THE SYSTEM PLOT PACKAGE DOES NOT +C RESIDE IN AN OUTER OVERLAY. +C +C USAGE CALL MAPRS +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R S T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE RESTORES A SAVED STATE OF EZMAP. THIS IS DONE +C BY READING SAVED PARAMETER VALUES FROM A USER +C UNIT AND THEN CALLING MAPINT. SEE MAPSAV. +C +C USAGE CALL MAPRST (IFNO) +C +C ARGUMENTS IFNO IS THE NUMBER OF A UNIT FROM WHICH A +C SINGLE UNFORMATTED RECORD IS TO BE READ. IT +C IS THE USER'S RESPONSIBILITY TO POSITION THIS +C UNIT. MAPRST DOES NOT REWIND IT, EITHER BEFORE +C OR AFTER READING THE RECORD. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S A V - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE SAVES THE CURRENT STATE OF EZMAP BY WRITING +C PARAMETER VALUES ONTO A USER UNIT. SEE MAPRST. +C +C USAGE CALL MAPSAV (IFNO) +C +C ARGUMENTS IFNO IS THE NUMBER OF A UNIT TO WHICH A SINGLE +C UNFORMATTED RECORD IS TO BE WRITTEN. IT IS THE +C USER'S RESPONSIBILITY TO POSITION THIS UNIT. +C MAPSAV DOES NOT REWIND IT, EITHER BEFORE OR +C AFTER WRITING THE RECORD. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S E T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE RECTANGULAR PORTION OF THE U/V +C PLANE TO BE DRAWN. +C +C USAGE CALL MAPSET (JLTS,PLM1,PLM2,PLM3,PLM4) +C +C ARGUMENTS JLTS CAN HAVE THE FOLLOWING CHARACTER VALUES. +C IT SPECIFIES ONE OF FIVE WAYS IN WHICH THE +C LIMITS OF THE MAP ARE DEFINED BY THE PARAMETERS +C PLM1, PLM2, PLM3, AND PLM4. +C +C JLTS='MA' (MAXIMUM). THE MAXIMUM USEFUL AREA +C PRODUCED BY THE PROJECTION IS PLOTTED. PLM1, +C PLM2, PLM3, AND PLM4 ARE NOT USED. +C +C JLTS='CO' (CORNERS). THE POINTS (PLM1,PLM2) +C AND (PLM3,PLM4) ARE TO BE AT OPPOSITE CORNERS +C OF THE MAP. PLM1 AND PLM3 ARE LATITUDES, IN +C DEGREES. PLM2 AND PLM4 ARE LONGITUDES, IN +C DEGREES. IF A CYLINDRICAL PROJECTION IS BEING +C USED, THE FIRST POINT SHOULD BE ON THE LEFT +C EDGE OF THE MAP AND THE SECOND POINT ON THE +C RIGHT EDGE; OTHERWISE, THE ORDER MAKES NO +C DIFFERENCE. +C +C JLTS='PO' (POINTS). PLM1, PLM2, PLM3, AND PLM4 +C ARE TWO-ELEMENT ARRAYS GIVING THE LATITUDES +C AND LONGITUDES, IN DEGREES, OF FOUR POINTS +C WHICH ARE TO BE ON THE EDGES OF THE RECTANGULAR +C MAP. IF A CYLINDRICAL PROJECTION IS BEING +C USED, THE FIRST POINT SHOULD BE ON THE LEFT +C EDGE AND THE SECOND POINT ON THE RIGHT EDGE; +C OTHERWISE, THE ORDER MAKES NO DIFFERENCE. +C NOTE THAT THE CALLING PROGRAM SHOULD INCLUDE +C THE FOLLOWING STATEMENT: +C +C DIMENSION PLM1(2),PLM2(2),PLM3(2),PLM4(2) +C +C (IN FACT, STRICT ADHERENCE TO THE FORTRAN-77 +C STANDARD REQUIRES THIS, NO MATTER WHAT THE +C VALUE OF JLTS.) +C +C JLTS='AN' (ANGLES). PLM1, PLM2, PLM3, AND PLM4 +C ARE POSITIVE ANGLES, IN DEGREES, REPRESENTING +C ANGULAR DISTANCES FROM A POINT ON THE MAP TO +C THE LEFT, RIGHT, BOTTOM, AND TOP EDGES OF THE +C MAP. FOR MOST PROJECTIONS, THESE ANGLES ARE +C MEASURED WITH THE CENTER OF THE EARTH AT THE +C VERTEX AND REPRESENT ANGULAR DISTANCES FROM THE +C POINT WHICH PROJECTS TO THE ORIGIN OF THE U/V +C PLANE; ON A SATELLITE-VIEW PROJECTION, THEY ARE +C MEASURED WITH THE SATELLITE AT THE VERTEX AND +C REPRESENT ANGULAR DEVIATIONS FROM THE LINE OF +C SIGHT. ANGULAR LIMITS ARE PARTICULARLY USEFUL +C FOR POLAR PROJECTIONS AND THE SATELLITE-VIEW +C PROJECTION; THEY ARE NOT APPROPRIATE FOR THE +C LAMBERT CONFORMAL CONIC AND AN ERROR WILL +C RESULT IF ONE ATTEMPTS TO USE JLTS='AN' WITH +C JPRJ='LC'. +C +C JLTS='LI' (LIMITS). PLM1, PLM2, PLM3, AND PLM4 +C SPECIFY THE MINIMUM VALUE OF U, THE MAXIMUM +C VALUE OF U, THE MINIMUM VALUE OF V, AND THE +C MAXIMUM VALUE OF V, RESPECTIVELY. KNOWLEDGE +C OF THE PROJECTION EQUATIONS IS NECESSARY IN +C ORDER TO USE THIS OPTION CORRECTLY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S T X - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SET THE VALUES OF EZMAP PARAMETERS. +C +C USAGE CALL MAPSTC (WHCH,CVAL) +C CALL MAPSTI (WHCH,IVAL) +C CALL MAPSTL (WHCH,LVAL) +C CALL MAPSTR (WHCH,RVAL) +C +C ARGUMENTS WHCH IS A CHARACTER STRING SPECIFYING THE +C PARAMETER TO BE SET. +C +C CVAL, IVAL, LVAL, OR RVAL IS THE VALUE TO BE +C GIVEN TO THE PARAMETER SPECIFIED BY WHCH - OF +C TYPE CHARACTER, INTEGER, LOGICAL, OR REAL, +C RESPECTIVELY. +C +C SOME PARAMETERS MAY BE SET IN MORE THAN ONE +C WAY. FOR EXAMPLE, THE PARAMETER 'GR' (GRID), +C WHICH SPECIFIES THE GRID SPACING, MAY BE GIVEN +C THE VALUE 10.0 IN EITHER OF TWO WAYS: +C +C CALL MAPSTI ('GR',10) +C CALL MAPSTR ('GR',10.) +C +C THE FLAG WHICH CONTROLS DOTTING OF OUTLINES +C MAY BE TURNED ON USING EITHER OF THESE CALLS: +C +C CALL MAPSTI ('DO',1) +C CALL MAPSTL ('DO',.TRUE.) +C +C THE IMPORTANT POINT TO REMEMBER IS THAT THE +C LAST CHARACTER OF THE ROUTINE NAME IMPLIES +C THE TYPE OF THE ARGUMENT. +C +C ONLY THE FIRST TWO CHARACTERS OF WHCH ARE +C EXAMINED. FOR THE SAKE OF CODE READABILITY, +C A LONGER CHARACTER STRING MAY BE USED. +C +C BELOW IS A LIST OF ALL THE PARAMETERS WHICH +C MAY BE SET USING THESE ROUTINES. +C +C WHCH TYPE MEANING +C ---- ---- ------- +C +C DASHPATTERN I DASHED-LINE PATTERN FOR THE +C GRIDS. A 16-BIT QUANTITY. +C DEFAULT IS 21845 (OCTAL 52525 +C OR BINARY 0101010101010101). +C +C DD I,R DISTANCE BETWEEN DOTS ALONG A +C DOTTED LINE DRAWN BY MAPIT. +C THE DEFAULT VALUE IS 12 (OUT +C OF 4096; SEE 'RE', BELOW). +C +C DL I,L IF TRUE (NON-ZERO), USER CALLS +C TO MAPIT DRAW DOTTED LINES. +C DEFAULT IS FALSE (ZERO); LINES +C DRAWN BY MAPIT ARE SOLID OR +C DASHED, DEPENDING ON THE +C CURRENT STATE OF THE DASHCHAR +C PACKAGE. +C +C DOT I,L IF TRUE (NON-ZERO), OUTLINES +C ARE DOTTED. DEFAULT IS FALSE +C (ZERO); OUTLINES ARE SOLID. +C +C ELLIPTICAL I,L IF TRUE (NON-ZERO), ONLY THAT +C PART OF THE MAP WHICH FALLS +C INSIDE AN ELLIPSE INSCRIBED +C WITHIN THE NORMAL RECTANGULAR +C PERIMETER IS DRAWN. THIS IS +C PARTICULARLY APPROPRIATE FOR +C USE WITH AZIMUTHAL PROJECTIONS +C AND ANGULAR LIMITS SPECIFYING +C A SQUARE, IN WHICH CASE THE +C ELLIPSE BECOMES A CIRCLE, BUT +C IT WILL WORK FOR ANY MAP. THE +C DEFAULT VALUE IS ZERO. +C +C GD R THE DISTANCE BETWEEN POINTS +C USED TO DRAW THE GRID, IN +C DEGREES. THE DEFAULT VALUE +C IS 1.; USER VALUES MUST FALL +C BETWEEN .001 AND 10. +C +C GRID I,R THE DESIRED GRID SPACING. A +C ZERO SUPPRESSES THE GRID. THE +C DEFAULT IS 10 DEGREES. +C +C IN I "N" IS AN INTEGER BETWEEN 1 +C AND 7. EACH "IN" SPECIFIES +C THE INTENSITY OF SOME PORTION +C OF THE MAP. VALUES ARE IN THE +C RANGE 0-255. DEFAULTS ARE: +C +C N USE DEFAULT +C - ----------- ------- +C 1 PERIMETER 240 +C 2 GRID 150 +C 3 LABELS 210 +C 4 LIMBS 240 +C 5 CONTINENTS 240 +C 6 U.S. STATES 180 +C 7 COUNTRIES 210 +C +C LABEL I,L IF TRUE (NON-ZERO), LABEL THE +C MERIDIANS AND POLES. DEFAULT +C IS TRUE (NON-ZERO). +C +C LS I CONTROLS LABEL SIZE. A +C CHARACTER WIDTH, TO BE USED +C IN CALLING PWRIT. THE DEFAULT +C VALUE IS 1, WHICH GIVES A +C CHARACTER WIDTH OF 12 PLOTTER +C UNITS. +C +C MV I,R MINIMUM VECTOR LENGTH FOR +C OUTLINES. A POINT CLOSER TO +C THE PREVIOUS POINT THAN THIS +C IS OMITTED. DEFAULT VALUE IS +C 4 (OUT OF 4096; SEE 'RE', +C BELOW). +C +C OUTLINE C SAYS WHICH SET OF OUTLINE DATA +C TO USE. POSSIBLE VALUES ARE +C 'NO', FOR NO OUTLINES, 'CO', +C FOR THE CONTINENTAL OUTLINES +C (THE DEFAULT), 'US', FOR U.S. +C STATE OUTLINES, 'PS', FOR +C CONTINENTAL OUTLINES PLUS +C INTERNATIONAL OUTLINES PLUS +C U.S. STATE OUTLINES, AND 'PO', +C FOR CONTINENTAL OUTLINES PLUS +C INTERNATIONAL OUTLINES. +C DEFAULT IS 'CO'. +C +C PERIM I,L IF TRUE (NON-ZERO), DRAW THE +C PERIMETER. DEFAULT IS TRUE +C (NON-ZERO). +C +C RESOLUTION I,R THE WIDTH OF THE TARGET +C PLOTTER, IN PLOTTER UNITS. +C DEFAULT VALUE IS 4096. +C +C SATELLITE I,R IF LESS THAN -1 OR GREATER +C THAN 1, CHANGES ORTHOGRAPHIC +C PROJECTION TO SATELLITE-VIEW. +C ABSOLUTE VALUE IS THE DISTANCE +C OF SATELLITE FROM THE CENTER +C OF THE EARTH, IN MULTIPLES OF +C THE EARTH'S RADIUS. THE SIGN +C INDICATES WHETHER A NORMAL +C PROJECTION (POSITIVE) OR AN +C EXTENDED PROJECTION (NEGATIVE) +C IS TO BE USED. THE EXTENDED +C PROJECTION IS USEFUL WHEN ONE +C IS OVERLAYING CONREC OUTPUT ON +C A MAP. THE DEFAULT VALUE OF +C 'SA' IS ZERO. SEE ALSO 'S1' +C AND 'S2', BELOW. +C +C S1 AND S2 I,R USED ONLY WHEN 'SA' IS OUTSIDE +C [-1,1]. BOTH ARE ANGLES, IN +C DEGREES. 'S1' MEASURES THE +C ANGLE BETWEEN THE CENTER OF +C THE EARTH AND THE AIM POINT +C OF THE SATELLITE'S CAMERA, AS +C SEEN FROM THE SATELLITE. IF +C 'S1' IS ZERO, THE PROJECTION +C SHOWS THE EARTH AS SEEN BY A +C SATELLITE LOOKING STRAIGHT +C DOWN; CALL THIS THE "BASIC +C VIEW". IF 'S1' IS NON-ZERO, +C 'S2' MEASURES THE ANGLE FROM +C THE POSITIVE U AXIS OF THE +C BASIC VIEW TO THE LINE OP, +C WHERE O IS THE ORIGIN OF THE +C BASIC VIEW AND P IS THE +C PROJECTION OF THE DESIRED LINE +C OF SIGHT ON THE BASIC VIEW, +C POSITIVE IF MEASURED COUNTER- +C CLOCKWISE. +C +C SR R A SEARCH RADIUS, IN DEGREES. +C USED BY MAPINT IN FINDING THE +C LATITUDE/LONGITUDE RANGE OF +C THE MAP. THE DEFAULT VALUE +C IS 1.; USER VALUES MUST FALL +C BETWEEN .001 AND 10. THIS +C PARAMETER SHOULD PROBABLY NOT +C BE CHANGED EXCEPT BY ADVICE +C OF A KNOWLEDGEABLE CONSULTANT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P T R N - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FIND THE PROJECTION IN THE U/V PLANE OF A +C POINT WHOSE LATITUDE AND LONGITUDE ARE KNOWN. +C MAY BE CALLED AT ANY TIME AFTER EZMAP HAS BEEN +C INITIALIZED (BY CALLING MAPINT OR OTHERWISE). +C +C USAGE CALL MAPTRN (RLAT,RLON,UVAL,VVAL) +C +C ARGUMENTS RLAT AND RLON ARE THE LATITUDE AND LONGITUDE, +C RESPECTIVELY, OF A POINT ON THE GLOBE. RLAT +C MUST BE BETWEEN -90. AND +90., INCLUSIVE; RLON +C MUST BE BETWEEN -540. AND +540., INCLUSIVE. +C +C (UVAL,VVAL) IS THE PROJECTION IN THE U/V PLANE +C OF (RLAT,RLON). THE UNITS OF UVAL AND VVAL +C DEPEND ON THE PROJECTION. +C +C IF THE POINT IS NOT PROJECTABLE, UVAL IS +C RETURNED EQUAL TO 1.E12. NOTE THAT, IF +C THE POINT IS PROJECTABLE, BUT OUTSIDE THE +C BOUNDARY OF THE MAP, AS DEFINED BY THE LAST +C CALL TO MAPSET, ITS U AND V COORDINATES ARE +C STILL RETURNED BY MAPTRN. THE USER MUST DO +C THE TEST REQUIRED TO DETERMINE IF THE POINT +C IS WITHIN LIMITS, IF THAT IS NECESSARY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P U S R - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE THE ROUTINE MAPUSR IS CALLED BY EZMAP JUST +C BEFORE AND JUST AFTER PORTIONS OF THE MAP +C ARE DRAWN. THE DEFAULT VERSION DOES NOTHING. +C (ACTUALLY, THAT'S NOT QUITE TRUE; FOR THE SAKE +C OF EFFICIENCY, THE NON-GKS VERSIONS RESETS THE +C DASH PATTERN FOR GRID LINES TO "SOLID" AND +C THEN DOES AN OPTN CALL TO MAKE THE TRANSLATOR +C GENERATE THE DESIRED PATTERN.) A USER-SUPPLIED +C VERSION MAY SET/RESET THE DOTTING PARAMETER +C 'DL', THE DASHCHAR DASH PATTERN, THE INTENSITY, +C THE COLOR, ETC., SO AS TO ACHIEVE A DESIRED +C EFFECT. +C +C USAGE (BY EZMAP) CALL MAPUSR (IPRT) +C +C ARGUMENTS IPRT, IF POSITIVE, SAYS THAT A PARTICULAR PART +C OF THE MAP IS ABOUT TO BE DRAWN, AS FOLLOWS: +C +C IPRT PART +C ---- ----------------------- +C 1 PERIMETER. +C 2 GRID. +C 3 LABELS. +C 4 LIMB LINES. +C 5 CONTINENTAL OUTLINES. +C 6 U.S. STATE OUTLINES. +C 7 INTERNATIONAL OUTLINES. +C +C IF IPRT IS NEGATIVE, IT SAYS THAT DRAWING OF +C THE LAST PART IS COMPLETE. THE ABSOLUTE VALUE +C OF IPRT WILL BE ONE OF THE ABOVE VALUES. +C CHANGED QUANTITIES SHOULD BE RESTORED. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P V E C - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL TO +C MAPDRW - USED IN CONJUNCTION WITH MAPFST. +C +C USAGE CALL MAPVEC (RLAT,RLON) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPIT (RLAT,RLON,1) +C +C ARGUMENTS RLAT AND RLON ARE DEFINED AS FOR MAPIT. SEE +C THE DESCRIPTION OF MAPIT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E S U P C O N - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FIND THE PROJECTION IN THE U/V PLANE OF A +C POINT WHOSE LATITUDE AND LONGITUDE ARE KNOWN. +C THIS ROUTINE IS PROVIDED FOR COMPATIBILITY +C WITH EARLIER VERSIONS OF THE PACKAGE. IF +C EFFICIENCY IS A CONSIDERATION, THE USER SHOULD +C BY-PASS THIS ROUTINE AND CALL MAPTRN DIRECTLY. +C +C USAGE CALL SUPCON (RLAT,RLON,UVAL,VVAL) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPTRN (RLAT,RLON,UVAL,VVAL) +C +C ARGUMENTS RLAT, RLON, UVAL, AND VVAL ARE DEFINED AS FOR +C THE ROUTINE MAPTRN. SEE THE DESCRIPTION OF +C MAPTRN. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E S U P M A P - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE AN IMPLEMENTATION OF THE ROUTINE FROM WHICH +C EZMAP GREW. A SINGLE CALL TO SUPMAP CREATES +C A MAP OF A DESIRED PORTION OF THE GLOBE, +C ACCORDING TO A DESIRED PROJECTION, WITH DESIRED +C OUTLINES DRAWN IN, AND WITH LINES OF LATITUDE +C AND LONGITUDE AT DESIRED INTERVALS. AN +C APPROPRIATE CALL TO THE ROUTINE SET IS +C PERFORMED, AND THE ROUTINE SUPCON (WHICH SEE) +C IS INITIALIZED SO THAT THE USER MAY MAP POINTS +C OF KNOWN LATITUDE AND LONGITUDE TO POINTS IN +C THE U/V PLANE AND USE THE U/V COORDINATES TO +C DRAW OBJECTS ON THE MAP PRODUCED BY SUPMAP. +C +C USAGE CALL SUPMAP (JPRJ,PLAT,PLON,ROTA,PLM1,PLM2, +C PLM3,PLM4,JLTS,JGRD,IOUT,IDOT, +C IERR) +C +C ARGUMENTS IABS(JPRJ) DEFINES THE PROJECTION TYPE, AS +C FOLLOWS (VALUES LESS THAN 1 OR GREATER THAN +C 10 ARE TREATED AS 1 OR 10, RESPECTIVELY): +C +C 1 STEREOGRAPHIC. +C 2 ORTHOGRAPHIC. +C 3 LAMBERT CONFORMAL CONIC. +C 4 LAMBERT EQUAL AREA. +C 5 GNOMONIC. +C 6 AZIMUTHAL EQUIDISTANT. +C 7 SATELLITE VIEW. +C 8 CYLINDRICAL EQUIDISTANT. +C 9 MERCATOR. +C 10 MOLLWEIDE. +C +C USING THE VALUE 2 CAUSES THE PARAMETER 'SA' TO +C BE ZEROED. USING THE VALUE 7 CAUSES 'SA' TO +C BE EXAMINED. IF IT HAS A NON-ZERO VALUE, THE +C VALUE IS LEFT ALONE. IF IT HAS A ZERO VALUE, +C ITS VALUE IS RESET TO 6.631, WHICH IS ABOUT +C RIGHT FOR A SATELLITE IN A GEOSYNCHRONOUS +C EQUATORIAL ORBIT (FOR WHATEVER THAT'S WORTH). +C +C THE SIGN OF JPRJ, WHEN IOUT IS -1, 0, OR 1, +C INDICATES WHETHER THE CONTINENTAL OUTLINES ARE +C TO BE PLOTTED OR NOT. SEE IOUT, BELOW. +C +C PLAT, PLON, AND ROTA DEFINE THE ORIGIN OF THE +C PROJECTION AND ITS ROTATION ANGLE AND ARE USED +C IN THE SAME WAY AS THEY WOULD BE IN A CALL TO +C THE ROUTINE MAPROJ (WHICH SEE). +C +C JLTS, PLM1, PLM2, PLM3, AND PLM4 SPECIFY THE +C RECTANGULAR LIMITS OF THE MAP. THESE ARGUMENTS +C ARE USED IN THE SAME WAY AS THEY WOULD BE IN +C A CALL TO MAPSET (WHICH SEE), EXCEPT THAT JLTS +C IS AN INTEGER INSTEAD OF A CHARACTER STRING. +C IABS(JLTS) MAY TAKE ON THE VALUES 1 THROUGH 5, +C AS FOLLOWS: +C +C 1 LIKE JLTS='MA' IN A CALL TO MAPSET. +C 2 LIKE JLTS='CO' IN A CALL TO MAPSET. +C 3 LIKE JLTS='LI' IN A CALL TO MAPSET. +C 4 LIKE JLTS='AN' IN A CALL TO MAPSET. +C 5 LIKE JLTS='PO' IN A CALL TO MAPSET. +C +C AT ONE TIME, THE SIGN OF JLTS SPECIFIED WHETHER +C OR NOT A LINE OF TEXT WAS TO BE WRITTEN AT THE +C BOTTOM OF THE PLOT PRODUCED. THIS LINE MAY NO +C LONGER BE WRITTEN AND THE SIGN OF JLTS IS +C THEREFORE IGNORED. +C +C MOD(IABS(JGRD),1000) IS THE VALUE, IN DEGREES, +C OF THE INTERVAL AT WHICH LINES OF LATITUDE AND +C LONGITUDE ARE TO BE PLOTTED. IF THE GIVEN +C INTERVAL IS ZERO, GRID LINES AND LABELS ARE +C NOT PLOTTED. IF JGRD IS LESS THAN ZERO, THE +C PERIMETER IS NOT PLOTTED. SET JGRD TO -1000 TO +C SUPPRESS BOTH GRID LINES AND PERIMETER AND TO +C +1000 TO SUPPRESS THE GRID LINES, BUT LEAVE THE +C PERIMETER. THE VALUE -0 MAY HAVE A MEANING ON +C ONES' COMPLEMENT MACHINES, BUT SHOULD BE +C AVOIDED; USE -1000 INSTEAD. +C +C IF IOUT HAS THE VALUE 0, U.S. STATE OUTLINES +C ARE OMITTED. IF IT HAS THE ABSOLUTE VALUE 1, +C THEY ARE PLOTTED. IN BOTH OF THESE CASES, THE +C SIGN OF JPRJ INDICATES WHETHER CONTINENTAL +C OUTLINES ARE TO BE PLOTTED (JPRJ POSITIVE) +C OR NOT (JPRJ NEGATIVE). ORIGINALLY, SUPMAP +C RECOGNIZED ONLY THESE VALUES OF IOUT; NOW, IF +C IOUT IS LESS THAN -1 OR GREATER THAN 1, THE +C SIGN OF JPRJ IS IGNORED, AND IOUT SELECTS AN +C OUTLINE GROUP, AS FOLLOWS: +C +C -2 OR LESS 'NO' (NO OUTLINES). +C 2 'CO' (CONTINENTAL OUTLINES). +C 3 'US' (U.S. STATE OUTLINES). +C 4 'PS' (CONTINENTAL OUTLINES +C PLUS INTERNATIONAL +C OUTLINES PLUS U.S. +C STATE OUTLINES). +C 5 OR GREATER 'PO' (CONTINENTAL OUTLINES +C PLUS INTERNATIONAL +C OUTLINES, BUT NO U.S. +C STATE OUTLINES). +C +C AT ONE TIME, THE SIGN OF IOUT SPECIFIED WHETHER +C OR NOT A LINE OF TEXT WAS TO BE WRITTEN ON THE +C PRINT OUTPUT. THIS MAY NO LONGER BE DONE. +C +C IDOT=0 TO GET CONTINUOUS OUTLINES, 1 TO GET +C DOTTED OUTLINES. +C +C IERR IS AN OUTPUT PARAMETER. A NON-ZERO VALUE +C INDICATES THAT AN ERROR HAS OCCURRED. +C +C*********************************************************************** +C T H E C O D E - U S E R - L E V E L R O U T I N E S +C*********************************************************************** +C + SUBROUTINE MAPDRW +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPDRW','VERSION 1') +C +C INITIALIZE THE PACKAGE, DRAW AND LABEL THE GRID, AND DRAW OUTLINES. +C + IF (INTF) CALL MAPINT + CALL MAPGRD + CALL MAPLBL + CALL MAPLOT +C + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) + DIMENSION PNTS(*) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPFST (XLAT,XLON) + CALL MAPIT (XLAT,XLON,0) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGRD +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C DEFINE LOCAL LOGICAL FLAGS. +C + LOGICAL IMF,IPF +C +C DEFINE REQUIRED CONSTANTS. +C + DATA DTOR / .017453292519943 / +C +C THE ARITHMETIC STATEMENT FUNCTIONS FLOOR AND CLING GIVE, RESPECTIVELY, +C THE "FLOOR" OF X - THE LARGEST INTEGER LESS THAN OR EQUAL TO X - AND +C THE "CEILING" OF X - THE SMALLEST INTEGER GREATER THAN OR EQUAL TO X. +C + FLOOR(X)=AINT(X+1.E4)-1.E4 + CLING(X)=-FLOOR(-X) +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGRD','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF THE GRID IS SUPPRESSED, DO NOTHING. +C + IF (GRID.LE.0.) RETURN +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR THE GRID. +C + CALL MAPCHI (2,0,IDSH) +C +C SET THE FLAGS IMF AND IPF, WHICH ARE TRUE IF AND ONLY IF MERIDIANS AND +C PARALLELS, RESPECTIVELY, ARE STRAIGHT LINES AND IT IS "SAFE" TO DRAW +C THEM USING LONG LINE SEGMENTS. WHAT WE HAVE TO BE SURE OF IS THAT AT +C LEAST ONE OF THE TWO ENDPOINTS OF EACH MERIDIAN, OR ITS MIDPOINT, WILL +C BE VISIBLE. (IF TWO POINTS ARE INVISIBLE, MAPIT DRAWS NOTHING, EVEN +C THOUGH THE LINE JOINING THEM MAY BE VISIBLE ALONG PART OF ITS LENGTH.) +C + IF (IPRJ.GE.1.AND.IPRJ.LE.6) THEN + IF (ELPF) THEN + IMF=(UCEN/URNG)**2+(VCEN/VRNG)**2.LT.1. + ELSE + IMF=UMIN*UMAX.LT.0..AND.VMIN*VMAX.LT.0. + END IF + IF (IPRJ.NE.1) IMF=IMF.AND.ABS(PHIA).GE.89.9999 + ELSE IF (IPRJ.EQ.10) THEN + IMF=.TRUE. + ELSE IF (IPRJ.EQ.11.AND.(.75*(VMAX-VMIN)).LE.VEPS) THEN + IMF=.TRUE. + ELSE + IMF=.FALSE. + END IF +C + IPF=IPRJ.EQ.10.OR.IPRJ.EQ.11.OR.(IPRJ.EQ.12.AND.ILTS.EQ.1) +C +C TRANSFER THE LATITUDE/LONGITUDE LIMITS COMPUTED BY MAPINT TO LOCAL, +C MODIFIABLE VARIABLES. +C + SLAT=SLAM + BLAT=BLAM + SLON=SLOM + BLON=BLOM +C +C FOR CERTAIN AZIMUTHAL PROJECTIONS CENTERED AT A POLE, THE LATITUDE +C LIMIT FURTHEST FROM THE POLE NEEDS ADJUSTMENT TO MAKE IT PROJECTABLE +C AND VISIBLE. OTHERWISE, WE HAVE TROUBLE WITH PORTIONS OF MERIDIANS +C DISAPPEARING. +C + IF (IPRJ.EQ.3.OR.IPRJ.EQ.4.OR.IPRJ.EQ.6) THEN + IF (PHIA.GT.+89.9999) THEN + SLAT=SLAT+SRCH + IF (IPRJ.EQ.3) SLAT=SLAT+SRCH + END IF + IF (PHIA.LT.-89.9999) THEN + BLAT=BLAT-SRCH + IF (IPRJ.EQ.3) BLAT=BLAT-SRCH + END IF + END IF +C +C RLON IS THE SMALLEST LONGITUDE FOR WHICH A MERIDIAN IS TO BE DRAWN, +C XLON THE BIGGEST. AVOID DRAWING A GIVEN MERIDIAN TWICE. +C + RLON=GRID*FLOOR(SLON/GRID) + XLON=GRID*CLING(BLON/GRID) + IF (XLON-RLON.GT.359.9999) THEN + IF (IPRJ.EQ.1) THEN + RLON=GRID*CLING((PHIO-179.9999)/GRID) + XLON=GRID*FLOOR((PHIO+179.9999)/GRID) + ELSE IF (IPRJ.GE.2.AND.IPRJ.LE.9) THEN + XLON=XLON-GRID + IF (XLON-RLON.GT.359.9999) XLON=XLON-GRID + END IF + END IF +C +C OLAT IS THE LATITUDE AT WHICH MERIDIANS WHICH ARE NOT MULTIPLES OF 90 +C ARE TO STOP. (EXCEPT ON CERTAIN FAST-PATH CYLINDRICAL PROJECTIONS, +C ONLY THE MERIDIANS AT LONGITUDES WHICH ARE MULTIPLES OF 90 RUN ALL +C THE WAY TO THE POLES. THIS AVOIDS A LOT OF CLUTTER.) +C + IF (IPRJ.EQ.10.OR.IPRJ.EQ.11) THEN + OLAT=90. + ELSE + OLAT=GRID*FLOOR(89.9999/GRID) + END IF +C +C DRAW THE MERIDIANS. +C + RLON=RLON-GRID + 101 RLON=RLON+GRID + XLAT=OLAT + IF (AMOD(RLON,90.).EQ.0.) XLAT=90. + RLAT=AMAX1(SLAT,-XLAT) + XLAT=AMIN1(BLAT,XLAT) + IF (IMF) THEN + DLAT=.5*(XLAT-RLAT) + ELSE + DLAT=(XLAT-RLAT)/CLING((XLAT-RLAT)/GRDR) + END IF + CALL MAPIT (RLAT,RLON,0) + 102 RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,1) + IF (RLAT.LT.XLAT-.9999) GO TO 102 + IF (RLON.LT.XLON-.9999) GO TO 101 +C +C ROUND THE LATITUDE LIMITS TO APPROPRIATE MULTIPLES OF GRID. +C + SLAT=GRID*FLOOR(SLAT/GRID) + IF (SLAT.LE.-90.) SLAT=SLAT+GRID + BLAT=GRID*CLING(BLAT/GRID) + IF (BLAT.GE.90.) BLAT=BLAT-GRID +C +C IF A FAST-PATH CYLINDRICAL EQUIDISTANT PROJECTION IS IN USE AND EITHER +C OR BOTH OF THE POLES IS WITHIN THE (RECTANGULAR) PERIMETER, ARRANGE +C FOR THE PARALLELS AT -90 AND/OR +90 TO BE DRAWN. +C + IF (IPRJ.EQ.10) THEN + CALL MAPTRN (-90.,PHIO,U,V) + IF (U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN.AND.V.LE.VMAX) + + SLAT=SLAT-GRID + CALL MAPTRN (90.,PHIO,U,V) + IF (U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN.AND.V.LE.VMAX) + + BLAT=BLAT+GRID + END IF +C +C DRAW THE PARALLELS. +C + XLAT=SLAT-GRID + 103 XLAT=XLAT+GRID + RLAT=AMAX1(-90.,AMIN1(90.,XLAT)) + RLON=FLOOR(SLON) + XLON=AMIN1(CLING(BLON),RLON+360.) + IF (IPF) THEN + DLON=.5*(XLON-RLON) + ELSE + DLON=(XLON-RLON)/CLING((XLON-RLON)/GRDR) + END IF + CALL MAPIT (RLAT,RLON,0) + 104 RLON=RLON+DLON + CALL MAPIT (RLAT,RLON,1) + IF (RLON.LT.XLON-.9999) GO TO 104 + IF (XLAT.LT.BLAT-.9999) GO TO 103 +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + CALL MAPCHI (-2,0,0) +C +C DRAW THE LIMB LINES. +C + CALL MAPLMB +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTC (WHCH,CVAL) +C + CHARACTER*(*) WHCH,CVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTC','VERSION 1') +C + IF (WHCH(1:2).EQ.'AR') THEN + CVAL=LDCT(ILTS) + ELSE IF (WHCH(1:2).EQ.'OU') THEN + CVAL=DDCT(NOUT+1) + ELSE IF (WHCH(1:2).EQ.'PR') THEN + CVAL=PDCT(JPRJ) + IF (JPRJ.EQ.3.AND.ABS(SALT).GT.1.) CVAL=PDCT(10) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=1 + CALL MAPCEM (' MAPGTC - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + CVAL=' ' + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTI (WHCH,IVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTI','VERSION 1') +C + IF (WHCH(1:2).EQ.'DA') THEN + IVAL=IDSH + ELSE IF (WHCH(1:2).EQ.'DD') THEN + IVAL=DDTS + ELSE IF (WHCH(1:2).EQ.'DL') THEN + IVAL=IDTL + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IVAL=IDOT + ELSE IF (WHCH(1:2).EQ.'EL') THEN + IVAL=0 + IF (ELPF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'ER') THEN + IVAL=IIER + ELSE IF (WHCH(1:2).EQ.'GR') THEN + IVAL=GRID + ELSE IF (WHCH(1:2).EQ.'IN') THEN + IVAL=0 + IF (INTF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'I1') THEN + IVAL=INTS(1) + ELSE IF (WHCH(1:2).EQ.'I2') THEN + IVAL=INTS(2) + ELSE IF (WHCH(1:2).EQ.'I3') THEN + IVAL=INTS(3) + ELSE IF (WHCH(1:2).EQ.'I4') THEN + IVAL=INTS(4) + ELSE IF (WHCH(1:2).EQ.'I5') THEN + IVAL=INTS(5) + ELSE IF (WHCH(1:2).EQ.'I6') THEN + IVAL=INTS(6) + ELSE IF (WHCH(1:2).EQ.'I7') THEN + IVAL=INTS(7) + ELSE IF (WHCH(1:2).EQ.'LA') THEN + IVAL=0 + IF (LBLF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'LS') THEN + IVAL=ILCW + ELSE IF (WHCH(1:2).EQ.'MV') THEN + IVAL=DPLT + ELSE IF (WHCH(1:2).EQ.'PE') THEN + IVAL=0 + IF (PRMF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'PN') THEN + IVAL=PHIO + ELSE IF (WHCH(1:2).EQ.'PT') THEN + IVAL=PHIA + ELSE IF (WHCH(1:2).EQ.'P1') THEN + IVAL=PLA1 + ELSE IF (WHCH(1:2).EQ.'P2') THEN + IVAL=PLA2 + ELSE IF (WHCH(1:2).EQ.'P3') THEN + IVAL=PLA3 + ELSE IF (WHCH(1:2).EQ.'P4') THEN + IVAL=PLA4 + ELSE IF (WHCH(1:2).EQ.'P5') THEN + IVAL=PLB1 + ELSE IF (WHCH(1:2).EQ.'P6') THEN + IVAL=PLB2 + ELSE IF (WHCH(1:2).EQ.'P7') THEN + IVAL=PLB3 + ELSE IF (WHCH(1:2).EQ.'P8') THEN + IVAL=PLB4 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + IVAL=PLTR + ELSE IF (WHCH(1:2).EQ.'RO') THEN + IVAL=ROTA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + IVAL=SALT + ELSE IF (WHCH(1:2).EQ.'S1') THEN + IVAL=ALFA + ELSE IF (WHCH(1:2).EQ.'S2') THEN + IVAL=BETA + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=2 + CALL MAPCEM (' MAPGTI - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + IVAL=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTL (WHCH,LVAL) +C + CHARACTER*(*) WHCH + LOGICAL LVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTL','VERSION 1') +C + IF (WHCH(1:2).EQ.'DL') THEN + LVAL=IDTL.NE.0 + ELSE IF (WHCH(1:2).EQ.'DO') THEN + LVAL=IDOT.NE.0 + ELSE IF (WHCH(1:2).EQ.'EL') THEN + LVAL=ELPF + ELSE IF (WHCH(1:2).EQ.'IN') THEN + LVAL=INTF + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LVAL=LBLF + ELSE IF (WHCH(1:2).EQ.'PE') THEN + LVAL=PRMF + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=3 + CALL MAPCEM (' MAPGTL - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + LVAL=.FALSE. + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTR (WHCH,RVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTR','VERSION 1') +C + IF (WHCH(1:2).EQ.'DD') THEN + RVAL=DDTS + ELSE IF (WHCH(1:2).EQ.'GD') THEN + RVAL=GRDR + ELSE IF (WHCH(1:2).EQ.'GR') THEN + RVAL=GRID + ELSE IF (WHCH(1:2).EQ.'MV') THEN + RVAL=DPLT + ELSE IF (WHCH(1:2).EQ.'PN') THEN + RVAL=PHIO + ELSE IF (WHCH(1:2).EQ.'PT') THEN + RVAL=PHIA + ELSE IF (WHCH(1:2).EQ.'P1') THEN + RVAL=PLA1 + ELSE IF (WHCH(1:2).EQ.'P2') THEN + RVAL=PLA2 + ELSE IF (WHCH(1:2).EQ.'P3') THEN + RVAL=PLA3 + ELSE IF (WHCH(1:2).EQ.'P4') THEN + RVAL=PLA4 + ELSE IF (WHCH(1:2).EQ.'P5') THEN + RVAL=PLB1 + ELSE IF (WHCH(1:2).EQ.'P6') THEN + RVAL=PLB2 + ELSE IF (WHCH(1:2).EQ.'P7') THEN + RVAL=PLB3 + ELSE IF (WHCH(1:2).EQ.'P8') THEN + RVAL=PLB4 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + RVAL=PLTR + ELSE IF (WHCH(1:2).EQ.'RO') THEN + RVAL=ROTA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + RVAL=SALT + ELSE IF (WHCH(1:2).EQ.'S1') THEN + RVAL=ALFA + ELSE IF (WHCH(1:2).EQ.'S2') THEN + RVAL=BETA + ELSE IF (WHCH(1:2).EQ.'SR') THEN + RVAL=SRCH + ELSE IF (WHCH(1:2).EQ.'XL') THEN + RVAL=XLOW + ELSE IF (WHCH(1:2).EQ.'XR') THEN + RVAL=XROW + ELSE IF (WHCH(1:2).EQ.'YB') THEN + RVAL=YBOW + ELSE IF (WHCH(1:2).EQ.'YT') THEN + RVAL=YTOW + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=4 + CALL MAPCEM (' MAPGTR - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RVAL=0. + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPINT +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C SET UP ALTERNATE NAMES FOR SOME OF THE VARIABLES IN COMMON. +C + EQUIVALENCE (PHIA,FLT1),(ROTA,FLT2) +C + EQUIVALENCE (PLA1,AUMN),(PLA2,AUMX), + + (PLA3,AVMN),(PLA4,AVMX) +C +C ENSURE THAT THE BLOCK DATA ROUTINE WILL LOAD, SO THAT VARIABLES WILL +C HAVE THE PROPER DEFAULT VALUES. +C + EXTERNAL MAPBD +C +C DEFINE THE NECESSARY CONSTANTS. +C + DATA RESL / 10. / + DATA DTOR / .017453292519943 / + DATA OV90 / .011111111111111 / + DATA PI / 3.14159265358979 / + DATA RTOD / 57.2957795130823 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPINT','VERSION 1') +C +C CHECK FOR AN ERROR IN THE PROJECTION SPECIFIER. +C + IF (JPRJ.LE.0.OR.JPRJ.GE.10) GO TO 901 +C +C IPRJ EQUALS JPRJ UNTIL WE FIND OUT IF FAST-PATH PROJECTIONS ARE TO BE +C USED. PHOC IS JUST A COPY OF PHIO. +C + IPRJ=JPRJ + PHOC=PHIO +C + IF (IPRJ.EQ.1) THEN +C +C COMPUTE CONSTANTS FOR THE LAMBERT CONFORMAL CONIC. +C + SINO=SIGN(1.,.5*(FLT1+FLT2)) + CHI1=(90.-SINO*FLT1)*DTOR + IF (FLT1.EQ.FLT2) THEN + COSO=COS(CHI1) + ELSE + CHI2=(90.-SINO*FLT2)*DTOR + COSO=ALOG(SIN(CHI1)/SIN(CHI2))/ALOG(TAN(.5*CHI1)/TAN(.5*CHI2)) + END IF +C + ELSE +C +C COMPUTE CONSTANTS REQUIRED FOR ALL THE OTHER PROJECTIONS. +C + TMP1=ROTA*DTOR + TMP2=PHIA*DTOR + SINR=SIN(TMP1) + COSR=COS(TMP1) + SINO=SIN(TMP2) + COSO=COS(TMP2) +C +C COMPUTE CONSTANTS REQUIRED ONLY BY THE CYLINDRICAL PROJECTIONS. +C + IF (IPRJ.GE.7) THEN +C +C SEE IF FAST-PATH TRANSFORMATIONS CAN BE USED. (PLAT = 0 AND ROTA = 0 +C OR 180.) +C + IF (ABS(PHIA).GE..0001.OR.(ABS(ROTA).GE..0001.AND. + + ABS(ROTA).LE.179.9999)) THEN +C +C NO. COMPUTE CONSTANTS FOR THE ORDINARY CYLINDRICAL PROJECTIONS. +C + SINT=COSO*COSR + COST=SQRT(1.-(SINT)**2) + TMP1=SINR/COST + TMP2=SINO/COST + PHIO=PHIO-ATAN2(TMP1,-COSR*TMP2)*RTOD + PHOC=PHIO + SINR=TMP1*COSO + COSR=-TMP2 + SINO=SINT + COSO=COST +C + ELSE +C +C YES. THE FAST PATHS ARE IMPLEMENTED AS THREE ADDITIONAL PROJECTIONS. +C + IPRJ=IPRJ+3 +C + IF (ABS(ROTA).LT..0001) THEN + SINO=1. + ELSE + SINO=-1. + PHIO=PHIO+180. + PHOC=PHIO + END IF +C + COSO=0. + SINR=0. + COSR=1. +C + END IF +C + END IF +C + END IF +C +C NOW, SET UMIN, UMAX, VMIN, AND VMAX TO CORRESPOND TO THE MAXIMUM +C USEFUL AREA PRODUCED BY THE PROJECTION. +C + GO TO (101,102,101,102,102,103,104,103,105,104,103,105) , IPRJ +C +C LAMBERT CONFORMAL CONIC AND ORTHOGRAPHIC. +C + 101 IF (IPRJ.NE.3.OR.ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + UMIN=-1. + UMAX=1. + VMIN=-1. + VMAX=1. + ELSE + TMP1=SALT*SALT*CALF*CALF-1. + TMP2=CALF*SQRT(SALT*SALT*(1.-SALF*SALF*SBET*SBET)-1.) + UMIN=SRSS*(-SALF*CBET-TMP2)/TMP1 + UMAX=SRSS*(-SALF*CBET+TMP2)/TMP1 + TMP2=CALF*SQRT(SALT*SALT*(1.-SALF*SALF*CBET*CBET)-1.) + VMIN=SRSS*(-SALF*SBET-TMP2)/TMP1 + VMAX=SRSS*(-SALF*SBET+TMP2)/TMP1 + END IF +C + GO TO 106 +C +C STEREOGRAPHIC, LAMBERT EQUAL AREA, AND GNOMONIC. +C + 102 UMIN=-2. + UMAX=2. + VMIN=-2. + VMAX=2. + GO TO 106 +C +C AZIMUTHAL EQUIDISTANT AND MERCATOR. +C + 103 UMIN=-PI + UMAX=PI + VMIN=-PI + VMAX=PI + GO TO 106 +C +C CYLINDRICAL EQUIDISTANT. +C + 104 UMIN=-180. + UMAX=180. + VMIN=-90. + VMAX=90. + GO TO 106 +C +C MOLLWEIDE. +C + 105 UMIN=-2. + UMAX=2. + VMIN=-1. + VMAX=1. +C +C COMPUTE THE QUANTITIES USED BY MAPIT IN CHECKING FOR CROSS-OVER. +C + 106 UEPS=.75*(UMAX-UMIN) + VEPS=.75*(VMAX-VMIN) +C +C AS ALWAYS, THE CONICAL PROJECTION IS THE ODDBALL. CROSS-OVER IS NOT +C DETECTED IN U AND V, BUT IN LONGITUDE, SO THE VALUE HAS TO BE SET +C DIFFERENTLY. +C + IF (IPRJ.EQ.1) UEPS=180. +C +C NOW, JUMP TO THE APPROPRIATE LIMIT-SETTING CODE. +C + GO TO (600,200,300,400,500) , ILTS +C +C ILTS=2 POINTS (PL1,PL2) AND (PL3,PL4) ARE ON OPPOSITE CORNERS +C ------ OF THE PLOT. +C + 200 E=0. + 201 CALL MAPTRN (PLA1,PLA2+E,TMP1,TMP3) + CALL MAPTRN (PLA3,PLA4-E,TMP2,TMP4) + IF (IPRJ.GE.7.AND.TMP1.GE.TMP2.AND.E.EQ.0.) THEN + E=.0001 + GO TO 201 + END IF + UMIN=AMIN1(TMP1,TMP2) + UMAX=AMAX1(TMP1,TMP2) + VMIN=AMIN1(TMP3,TMP4) + VMAX=AMAX1(TMP3,TMP4) + IF (UMAX.GE.1.E12) GO TO 904 + GO TO 600 +C +C ILTS=3 FOUR EDGE POINTS ARE GIVEN. +C ------ +C + 300 E=0. + 301 CALL MAPTRN (PLA1,PLB1+E,TMP1,TMP5) + CALL MAPTRN (PLA2,PLB2-E,TMP2,TMP6) + IF (IPRJ.GE.7.AND.TMP1.GE.TMP2.AND.E.EQ.0.) THEN + E=.0001 + GO TO 301 + END IF + CALL MAPTRN (PLA3,PLB3,TMP3,TMP7) + CALL MAPTRN (PLA4,PLB4,TMP4,TMP8) + UMIN=AMIN1(TMP1,TMP2,TMP3,TMP4) + UMAX=AMAX1(TMP1,TMP2,TMP3,TMP4) + VMIN=AMIN1(TMP5,TMP6,TMP7,TMP8) + VMAX=AMAX1(TMP5,TMP6,TMP7,TMP8) + IF (UMAX.GE.1.E12) GO TO 904 + GO TO 600 +C +C ILTS=4 ANGULAR DISTANCES ARE GIVEN. +C ------ +C + 400 CUMI=COS(AUMN*DTOR) + SUMI=SIN(AUMN*DTOR) + CUMA=COS(AUMX*DTOR) + SUMA=SIN(AUMX*DTOR) + CVMI=COS(AVMN*DTOR) + SVMI=SIN(AVMN*DTOR) + CVMA=COS(AVMX*DTOR) + SVMA=SIN(AVMX*DTOR) +C + GO TO (904,401,402,403,404,405,406,407,408,406,407,408) , IPRJ +C +C STEREOGRAPHIC. +C + 401 IF (SUMI.LT..0001) THEN + IF (CUMI.GT.0.) UMIN=0. + ELSE + UMIN=-(1.-CUMI)/SUMI + END IF + IF (SUMA.LT..0001) THEN + IF (CUMA.GT.0.) UMAX=0. + ELSE + UMAX=(1.-CUMA)/SUMA + END IF + IF (SVMI.LT..0001) THEN + IF (CVMI.GT.0.) VMIN=0. + ELSE + VMIN=-(1.-CVMI)/SVMI + END IF + IF (SVMA.LT..0001) THEN + IF (CVMA.GT.0.) VMAX=0. + ELSE + VMAX=(1.-CVMA)/SVMA + END IF + GO TO 600 +C +C ORTHOGRAPHIC. +C + 402 IF (ABS(SALT).LE.1.) THEN + IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GT.90.) GO TO 902 + UMIN=-SUMI + UMAX=SUMA + VMIN=-SVMI + VMAX=SVMA + ELSE + IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GE.90.) GO TO 902 + UTMP=SRSS*SALF/CALF + VTMP=0. + UCEN=UTMP*CBET-VTMP*SBET + VCEN=VTMP*CBET+UTMP*SBET + UMIN=UCEN-SRSS*CALF*SUMI/CUMI + UMAX=UCEN+SRSS*CALF*SUMA/CUMA + VMIN=VCEN-SRSS*CALF*SVMI/CVMI + VMAX=VCEN+SRSS*CALF*SVMA/CVMA + END IF + GO TO 600 +C +C LAMBERT EQUAL AREA. +C + 403 IF (SUMI.LT..0001) THEN + IF (CUMI.GT.0.) UMIN=0. + ELSE + UMIN=-2./SQRT(1.+((1.+CUMI)/SUMI)**2) + END IF + IF (SUMA.LT..0001) THEN + IF (CUMA.GT.0.) UMAX=0. + ELSE + UMAX=2./SQRT(1.+((1.+CUMA)/SUMA)**2) + END IF + IF (SVMI.LT..0001) THEN + IF (CVMI.GT.0.) VMIN=0. + ELSE + VMIN=-2./SQRT(1.+((1.+CVMI)/SVMI)**2) + END IF + IF (SVMA.LT..0001) THEN + IF (CVMA.GT.0.) VMAX=0. + ELSE + VMAX=2./SQRT(1.+((1.+CVMA)/SVMA)**2) + END IF + GO TO 600 +C +C GNOMONIC. +C + 404 IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GE.89.9999) GO TO 902 + UMIN=-SUMI/CUMI + UMAX=SUMA/CUMA + VMIN=-SVMI/CVMI + VMAX=SVMA/CVMA + GO TO 600 +C +C AZIMUTHAL EQUIDISTANT. +C + 405 UMIN=-AUMN*DTOR + UMAX=AUMX*DTOR + VMIN=-AVMN*DTOR + VMAX=AVMX*DTOR + GO TO 600 +C +C CYLINDRICAL EQUIDISTANT. +C + 406 UMIN=-AUMN + UMAX=AUMX + VMIN=-AVMN + VMAX=AVMX + GO TO 600 +C +C MERCATOR. +C + 407 IF (AMAX1(AVMN,AVMX).GE.89.9999) GO TO 902 + UMIN=-AUMN*DTOR + UMAX=AUMX*DTOR + VMIN=-ALOG((1.+SVMI)/CVMI) + VMAX=ALOG((1.+SVMA)/CVMA) + GO TO 600 +C +C MOLLWEIDE. +C + 408 UMIN=-AUMN*OV90 + UMAX=AUMX*OV90 + VMIN=-SVMI + VMAX=SVMA + GO TO 600 +C +C ILTS=5 VALUES IN THE U/V PLANE ARE GIVEN. +C ------ +C + 500 UMIN=PLA1 + UMAX=PLA2 + VMIN=PLA3 + VMAX=PLA4 +C +C COMPUTE THE WIDTH AND HEIGHT OF THE PLOT. +C + 600 DU=UMAX-UMIN + DV=VMAX-VMIN +C +C ERROR IF MAP HAS ZERO AREA. +C + IF (DU.LE.0..OR.DV.LE.0.) GO TO 903 +C +C POSITION THE MAP ON THE PLOTTER FRAME. +C + IF (DU/DV.LT.(XROW-XLOW)/(YTOW-YBOW)) THEN + ULOW=.5*(XLOW+XROW)-.5*(DU/DV)*(YTOW-YBOW) + UROW=.5*(XLOW+XROW)+.5*(DU/DV)*(YTOW-YBOW) + VBOW=YBOW + VTOW=YTOW + ELSE + ULOW=XLOW + UROW=XROW + VBOW=.5*(YBOW+YTOW)-.5*(DV/DU)*(XROW-XLOW) + VTOW=.5*(YBOW+YTOW)+.5*(DV/DU)*(XROW-XLOW) + END IF +C +C ERROR IF MAP HAS ESSENTIALLY ZERO AREA. +C + IF (AMIN1(UROW-ULOW,VTOW-VBOW)*PLTR.LT.RESL) GO TO 903 +C +C DO THE REQUIRED SET CALL. +C + CALL SET (ULOW,UROW,VBOW,VTOW,UMIN,UMAX,VMIN,VMAX,1) +C +C COMPUTE THE QUANTITIES USED BY MAPIT TO SEE IF POINTS ARE FAR ENOUGH +C APART TO DRAW THE LINE BETWEEN THEM AND THE QUANTITIES USED BY MAPVP +C TO DETERMINE THE NUMBER OF DOTS TO INTERPOLATE BETWEEN TWO POINTS. +C + DSCA=(UROW-ULOW)*PLTR/DU + DPSQ=DPLT*DPLT + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA +C +C SET PARAMETERS REQUIRED IF AN ELLIPTICAL PERIMETER IS BEING USED. THE +C ELLIPSE IS MADE TO BE JUST A LITTLE BIGGER THAN AN INSCRIBED ELLIPSE +C SO AS TO AVOID ROUND-OFF PROBLEMS WHEN DRAWING THE LIMB OF CERTAIN +C PROJECTIONS. +C + UCEN=.5*(UMIN+UMAX) + VCEN=.5*(VMIN+VMAX) + URNG=.50005*(UMAX-UMIN) + VRNG=.50005*(VMAX-VMIN) +C +C NOW, COMPUTE THE LATITUDE/LONGITUDE LIMITS WHICH WILL BE REQUIRED BY +C MAPGRD AND MAPLOT, IF ANY. +C + IF (GRID.GT.0..OR.NOUT.NE.0) THEN +C +C AT FIRST, ASSUME THE WHOLE GLOBE WILL BE PROJECTED. +C + SLAM=-90. + BLAM=+90. + SLOM=PHIO-180. + BLOM=PHIO+180. +C +C JUMP IF IT'S OBVIOUS THAT REALLY IS THE CASE. +C + IF (ILTS.EQ.1.AND.(JPRJ.EQ.4.OR.JPRJ.EQ.6.OR.JPRJ.EQ.7.OR. + + JPRJ.EQ.9)) GO TO 700 +C +C OTHERWISE, THE WHOLE GLOBE IS NOT BEING PROJECTED. THE FIRST THING +C TO DO IS TO FIND A POINT (CLAT,CLON) WHOSE PROJECTION IS KNOWN TO BE +C ON THE MAP. FIRST, TRY THE POLE OF THE PROJECTION. +C + CLAT=PHIA + CLON=PHIO + CALL MAPTRN (CLAT,CLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 611 +C +C IF THAT DIDN'T WORK, TRY A POINT BASED ON THE LIMITS SPECIFIER. +C + IF (ILTS.EQ.2) THEN + CLAT=.5*(PLA1+PLA3) + CLON=.5*(PLA2+PLA4) + ELSE IF (ILTS.EQ.3) THEN + TMP1=AMIN1(PLA1,PLA2,PLA3,PLA4) + TMP2=AMAX1(PLA1,PLA2,PLA3,PLA4) + TMP3=AMIN1(PLB1,PLB2,PLB3,PLB4) + TMP4=AMAX1(PLB1,PLB2,PLB3,PLB4) + CLAT=.5*(TMP1+TMP2) + CLON=.5*(TMP3+TMP4) + ELSE + GO TO 700 + END IF + CALL MAPTRN (CLAT,CLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 611 + GO TO 700 +C +C ONCE WE HAVE THE LATITUDES AND LONGITUDES OF A POINT ON THE MAP, WE +C FIND THE MINIMUM AND MAXIMUM LATITUDE AND THE MINIMUM AND MAXIMUM +C LONGITUDE BY RUNNING A SEARCH POINT ABOUT ON A FINE LAT/LON GRID. +C +C FIND THE MINIMUM LATITUDE. +C + 611 RLAT=CLAT + RLON=CLON + DLON=SRCH + 612 RLAT=RLAT-SRCH + IF (RLAT.LE.-90.) GO TO 621 + 613 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLON=SRCH + GO TO 612 + END IF + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 613 + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 613 + SLAM=RLAT +C +C FIND THE MAXIMUM LATITUDE. +C + 621 RLAT=CLAT + RLON=CLON + DLON=SRCH + 622 RLAT=RLAT+SRCH + IF (RLAT.GT.90.) GO TO 631 + 623 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLON=SRCH + GO TO 622 + END IF + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 623 + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 623 + BLAM=RLAT +C +C FIND THE MINIMUM LONGITUDE. +C + 631 RLAT=CLAT + RLON=CLON + DLAT=SRCH + 632 RLON=RLON-SRCH + IF (RLON.LE.CLON-360.) GO TO 651 + 633 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLAT=SRCH + GO TO 632 + END IF + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 633 + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 633 + SLOM=RLON-SIGN(180.,RLON+180.)+SIGN(180.,180.-RLON) +C +C FIND THE MAXIMUM LONGITUDE. +C + 641 RLAT=CLAT + RLON=CLON + DLAT=SRCH + 642 RLON=RLON+SRCH + IF (RLON.GE.CLON+360.) GO TO 651 + 643 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLAT=SRCH + GO TO 642 + END IF + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 643 + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 643 + BLOM=RLON-SIGN(180.,RLON+180.)+SIGN(180.,180.-RLON) + IF (BLOM.LE.SLOM) BLOM=BLOM+360. + GO TO 700 +C + 651 SLOM=PHIO-180. + BLOM=PHIO+180. +C + END IF +C +C ZERO THE ERROR FLAG AND TURN OFF THE INITIALIZATION-REQUIRED FLAG. +C + 700 IIER=0 + INTF=.FALSE. +C +C DONE. +C + RETURN +C +C ERROR RETURNS. +C + 901 IIER=5 + CALL SETER (' MAPINT - ATTEMPT TO USE NON-EXISTENT PROJECTION', + 1 IIER,1) + RETURN +C + 902 IIER=6 + CALL SETER (' MAPINT - ANGULAR LIMITS TOO GREAT',IIER,1) + RETURN +C + 903 IIER=7 + CALL SETER (' MAPINT - MAP HAS ZERO AREA',IIER,1) + RETURN +C + 904 IIER=8 + CALL SETER (' MAPINT - MAP LIMITS INAPPROPIATE',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIT (RLAT,RLON,IFST) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM8/ P,Q,R + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL +C + DIMENSION CPRJ(3) +C + SAVE IVSO,POLD,QOLD,UOLD,VOLD +C + DATA CPRJ / 360.,6.28318530717959,4. / +C + DATA IVSO,POLD,QOLD,UOLD,VOLD / 0,0.,0.,0.,0. / +C +C PROJECT THE POINT (RLAT,RLON) TO (U,V). +C + CALL MAPTRN (RLAT,RLON,U,V) +C +C FOR THE SAKE OF EFFICIENCY, EXECUTE ONE OF TWO PARALLEL ALGORITHMS, +C DEPENDING ON WHETHER AN ELLIPTICAL OR A RECTANGULAR PERIMETER IS IN +C USE. (THAT WAY, WE TEST ELPF ONLY ONCE.) +C + IF (ELPF) THEN +C +C ELLIPTICAL - ASSUME THE NEW POINT IS VISIBLE UNTIL WE FIND OTHERWISE. +C + IVIS=1 +C +C SEE IF THE NEW POINT IS INVISIBLE. +C + IF (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.GT.1.) THEN +C +C THE NEW POINT IS INVISIBLE. RESET THE VISIBILITY FLAG. +C + IVIS=0 +C +C IF THE NEW POINT IS A "FIRST POINT" OR IF THE LAST POINT WAS NOT +C VISIBLE OR IF THE NEW POINT IS INVISIBLE BECAUSE ITS PROJECTION IS +C UNDEFINED, DRAW NOTHING. THE POSSIBLE EXISTENCE OF A VISIBLE SEGMENT +C ALONG THE LINE JOINING TWO INVISIBLE POINTS IS INTENTIONALLY IGNORED, +C FOR REASONS OF EFFICIENCY. FOR THIS REASON, OBJECTS SHOULD NOT BE +C DRAWN USING LONG LINE SEGMENTS. +C + IF (IFST.EQ.0.OR.IVSO.EQ.0.OR.U.GE.1.E12) GO TO 108 +C +C OTHERWISE, THE NEW POINT IS NOT A "FIRST POINT", THE LAST POINT WAS +C VISIBLE, AND THE PROJECTION OF THE NEW POINT IS DEFINED, SO WE NEED +C TO CONTINUE THE LINE. FIRST, IF THERE'S A CROSS-OVER PROBLEM, MOVE +C THE NEW POINT TO ITS ALTERNATE POSITION. THIS MAY MAKE IT VISIBLE. +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) THEN +C + IF (JPRJ.GE.7) THEN + P=P-SIGN(CPRJ(JPRJ-6),P) + U=P + IF (JPRJ.EQ.9) U=U*SQRT(1.-V*V) + ELSE + GO TO 108 + END IF +C + IF (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.) THEN + IVIS=1 + GO TO 107 + END IF +C + END IF +C +C IF IT'S STILL INVISIBLE, INTERPOLATE TO THE EDGE OF THE FRAME, EXTEND +C THE LINE TO THAT POINT, AND QUIT. +C + CALL MAPTRE (UOLD,VOLD,U,V,UINT,VINT) + CALL MAPVP (UOLD,VOLD,UINT,VINT) + GO TO 108 +C + END IF +C +C THE NEW POINT IS VISIBLE. IF IT'S THE FIRST POINT OF A LINE, GO START +C A NEW LINE. +C + IF (IFST.EQ.0.OR.UOLD.GE.1.E12) GO TO 106 +C +C THE NEW POINT IS VISIBLE, BUT IT'S NOT THE FIRST POINT OF A LINE. +C CHECK FOR CROSS-OVER PROBLEMS. +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) GO TO 101 +C +C THE NEW POINT IS VISIBLE, IT'S NOT THE FIRST POINT OF A LINE, AND +C THERE ARE NO CROSS-OVER PROBLEMS. IF THE OLD POINT WAS INVISIBLE, +C JUMP TO DRAW THE VISIBLE PORTION OF THE LINE FROM THE OLD POINT TO +C THE NEW ONE. +C + IF (IVSO.EQ.0) GO TO 102 +C +C THE NEW POINT IS VISIBLE, IT'S NOT THE FIRST POINT OF A LINE, THERE +C ARE NO CROSS-OVER PROBLEMS, AND THE LAST POINT WAS VISIBLE. JUMP TO +C JUST CONTINUE THE LINE. +C + GO TO 107 +C +C WE HAVE THE MOST DIFFICULT CASE. THE NEW POINT IS VISIBLE, IT'S NOT +C THE FIRST POINT OF A LINE, AND THERE IS A CROSS-OVER PROBLEM. NONE, +C ONE, OR TWO SEGMENTS MAY NEED TO BE DRAWN. +C + 101 IF (JPRJ.LT.7) GO TO 106 +C +C IF THE OLD POINT WAS VISIBLE, GENERATE THE ALTERNATE PROJECTION OF THE +C NEW POINT AND DRAW THE VISIBLE PORTION OF THE LINE SEGMENT JOINING THE +C OLD POINT TO THE ALTERNATE PROJECTION POINT. +C + IF (IVSO.NE.0) THEN +C + UTMP=P-SIGN(CPRJ(JPRJ-6),P) + VTMP=Q + IF (JPRJ.EQ.9) UTMP=UTMP*SQRT(1.-VTMP*VTMP) +C + IF (((UTMP-UCEN)/URNG)**2+((VTMP-VCEN)/VRNG)**2.GT.1.) THEN + CALL MAPTRE (UOLD,VOLD,UTMP,VTMP,UTMP,VTMP) + END IF +C + CALL MAPVP (UOLD,VOLD,UTMP,VTMP) +C + END IF +C +C NOW GENERATE AN ALTERNATE PROJECTION OF THE OLD POINT CLOSE TO THE NEW +C ONE AND DRAW THE VISIBLE PORTION OF THE LINE SEGMENT JOINING IT TO THE +C NEW POINT. +C + UOLD=POLD-SIGN(CPRJ(JPRJ-6),POLD) + IF (JPRJ.EQ.9) UOLD=UOLD*SQRT(1.-VOLD*VOLD) +C + IF (((UOLD-UCEN)/URNG)**2+((VOLD-VCEN)/VRNG)**2.LE.1.) GO TO 105 +C +C MOVE (UOLD,VOLD) BY INTERPOLATING TO THE EDGE OF THE FRAME. +C + 102 CALL MAPTRE (U,V,UOLD,VOLD,UOLD,VOLD) +C + ELSE +C +C RECTANGULAR - REPEAT THE ABOVE CODE, CHANGING THE TESTS FOR A POINT'S +C BEING INSIDE/OUTSIDE THE PERIMETER. COMMENTING WILL BE ABBREVIATED. +C + IVIS=1 +C + IF (U.LT.UMIN.OR.U.GT.UMAX.OR.V.LT.VMIN.OR.V.GT.VMAX) THEN +C + IVIS=0 +C + IF (IFST.EQ.0.OR.IVSO.EQ.0.OR.U.GE.1.E12) GO TO 108 +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) THEN +C + IF (JPRJ.GE.7) THEN + P=P-SIGN(CPRJ(JPRJ-6),P) + U=P + IF (JPRJ.EQ.9) U=U*SQRT(1.-V*V) + ELSE + GO TO 108 + END IF +C + IF (U.GE.UMIN.AND.U.LE.UMAX.AND. + + V.GE.VMIN.AND.V.LE.VMAX) THEN + IVIS=1 + GO TO 107 + END IF + END IF +C + CALL MAPTRP (UOLD,VOLD,U,V,UINT,VINT) + CALL MAPVP (UOLD,VOLD,UINT,VINT) + GO TO 108 +C + END IF +C + IF (IFST.EQ.0.OR.UOLD.GE.1.E12) GO TO 106 +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) GO TO 103 +C + IF (IVSO.EQ.0) GO TO 104 +C + GO TO 107 +C + 103 IF (JPRJ.LT.7) GO TO 106 +C + IF (IVSO.NE.0) THEN +C + UTMP=P-SIGN(CPRJ(JPRJ-6),P) + VTMP=Q + IF (JPRJ.EQ.9) UTMP=UTMP*SQRT(1.-VTMP*VTMP) +C + IF (UTMP.LT.UMIN.OR.UTMP.GT.UMAX.OR. + + VTMP.LT.VMIN.OR.VTMP.GT.VMAX) THEN + CALL MAPTRP (UOLD,VOLD,UTMP,VTMP,UTMP,VTMP) + END IF +C + CALL MAPVP (UOLD,VOLD,UTMP,VTMP) + END IF +C + UOLD=POLD-SIGN(CPRJ(JPRJ-6),POLD) + IF (JPRJ.EQ.9) UOLD=UOLD*SQRT(1.-VOLD*VOLD) +C + IF (UOLD.GE.UMIN.AND.UOLD.LE.UMAX.AND. + + VOLD.GE.VMIN.AND.VOLD.LE.VMAX) GO TO 105 +C + 104 CALL MAPTRP (U,V,UOLD,VOLD,UOLD,VOLD) +C + END IF +C +C DRAW THE VISIBLE PORTION OF THE LINE JOINING THE OLD POINT TO THE NEW. +C + 105 IF (IDTL.EQ.0) THEN + CALL FRSTD (UOLD,VOLD) + DATL=0. + END IF +C + CALL MAPVP (UOLD,VOLD,U,V) +C + GO TO 108 +C +C START A NEW LINE. +C + 106 IF (IDTL.EQ.0) THEN + CALL FRSTD (U,V) + DATL=0. + END IF +C + GO TO 108 +C +C CONTINUE THE LINE. +C + 107 IF (IFST.LT.2.AND.((U-UOLD)**2+(V-VOLD)**2)*DSSQ.LE.DPSQ) RETURN + CALL MAPVP (UOLD,VOLD,U,V) +C +C SAVE INFORMATION ABOUT THE CURRENT POINT FOR THE NEXT CALL AND QUIT. +C + 108 IVSO=IVIS + POLD=P + QOLD=Q + UOLD=U + VOLD=V +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIQ +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C FLUSH THE POINTS BUFFER. +C + IF (NPTB.GT.0) THEN + CALL POINTS (XPTB,YPTB,NPTB,0,0) + NPTB=0 + END IF +C +C FLUSH PLOTIT'S BUFFER, TOO. +C + CALL PLOTIT (0,0,0) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLBL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER +C +C DEFINE REQUIRED CONSTANTS. SIN1 AND COS1 ARE RESPECTIVELY THE SINE +C AND COSINE OF ONE DEGREE. +C + DATA SIN1 / .017452406437283 / + DATA COS1 / .999847695156390 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPLBL','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF REQUESTED, LETTER KEY MERIDIANS AND POLES. +C + IF (LBLF) THEN +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR LABELLING. +C + CALL MAPCHI (3,1,0) +C +C FIRST, THE NORTH POLE. +C + CALL MAPTRN (90.,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + CALL WTSTR (U,V,'NP',ILCW,0,0) +C +C THEN, THE SOUTH POLE. +C + CALL MAPTRN (-90.,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + CALL WTSTR (U,V,'SP',ILCW,0,0) +C +C THE EQUATOR. +C + RLON=PHIO-10. + DO 101 I=1,36 + RLON=RLON+10. + CALL MAPTRN (0.,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 102 + 101 CONTINUE + GO TO 103 + 102 CALL WTSTR (U,V,'EQ',ILCW,0,0) +C +C THE GREENWICH MERIDIAN. +C + 103 RLAT=85. + DO 104 I=1,16 + RLAT=RLAT-10. + CALL MAPTRN (RLAT,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 105 + 104 CONTINUE + GO TO 106 + 105 CALL WTSTR (U,V,'GM',ILCW,0,0) +C +C INTERNATIONAL DATE LINE. +C + 106 RLAT=85. + DO 107 I=1,16 + RLAT=RLAT-10. + CALL MAPTRN (RLAT,180.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 108 + 107 CONTINUE + GO TO 109 + 108 CALL WTSTR (U,V,'ID',ILCW,0,0) +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + 109 CALL MAPCHI (-3,0,0) +C + END IF +C +C DRAW PERIMETER, IF REQUESTED. +C + IF (PRMF) THEN +C +C RESET THE LINE INTENSITY, DOTTING, AND DASH PATTERN FOR THE PERIMETER. +C + CALL MAPCHI (1,0,IOR(ISHIFT(32767,1),1)) +C +C THE PERIMETER IS EITHER AN ELLIPSE OR A RECTANGLE, DEPENDING ON ELPF. +C + IF (ELPF) THEN + U=.9999*URNG + V=0. + DATL=0. + CALL FRSTD (UCEN+U,VCEN) + DO 110 I=1,360 + UOLD=U + VOLD=V + U=COS1*UOLD-SIN1*VOLD + V=SIN1*UOLD+COS1*VOLD + CALL MAPVP (UCEN+UOLD,VCEN+VOLD*VRNG/URNG, + + UCEN+U ,VCEN+V *VRNG/URNG) + 110 CONTINUE + ELSE + DATL=0. + UMINX=UMIN+.9999*(UMAX-UMIN) + UMAXX=UMAX-.9999*(UMAX-UMIN) + VMINX=VMIN+.9999*(VMAX-VMIN) + VMAXX=VMAX-.9999*(VMAX-VMIN) + CALL FRSTD (UMINX,VMINX) + CALL MAPVP (UMINX,VMINX,UMAXX,VMINX) + CALL MAPVP (UMAXX,VMINX,UMAXX,VMAXX) + CALL MAPVP (UMAXX,VMAXX,UMINX,VMAXX) + CALL MAPVP (UMINX,VMAXX,UMINX,VMINX) + END IF +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + CALL MAPCHI (-1,0,0) +C + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLOT +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C DEFINE REQUIRED CONSTANTS. +C + DATA PI / 3.14159265358979 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPLOT','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF THE SELECTED OUTLINE TYPE IS "NONE", DO NOTHING. +C + IF (NOUT.LE.0) RETURN +C +C SET THE FLAG IWGF TO SAY WHETHER OR NOT THE WHOLE GLOBE IS SHOWN BY +C THE CURRENT PROJECTION. IF SO (IWGF=1), THERE'S NO NEED TO WASTE THE +C TIME REQUIRED TO CHECK EACH OUTLINE POINT GROUP FOR INTERSECTION WITH +C THE WINDOW. +C + IWGF=0 + IF (BLAM-SLAM.GT.179.9999.AND.BLOM-SLOM.GT.359.9999) IWGF=1 +C +C IGIS KEEPS TRACK OF CHANGES IN THE GROUP IDENTIFIER, SO THAT THE +C INTENSITY CAN BE CHANGED WHEN NECESSARY. +C + IGIS=0 +C +C POSITION TO THE USER-SELECTED PORTION OF THE OUTLINE DATASET. +C + CALL MAPIO (1) + NSEG=0 +C +C READ THE NEXT RECORD (GROUP OF POINTS). +C + 101 CALL MAPIO (2) + NSEG=NSEG+1 +C +C CHECK FOR THE END OF THE DESIRED DATA. +C + IF (NPTS.EQ.0) GO TO 103 +C +C IF LESS THAN THE WHOLE GLOBE IS SHOWN BY THE PROJECTION, DO A QUICK +C CHECK FOR INTERSECTION OF THE BOX SURROUNDING THE POINT GROUP WITH +C THE AREA SHOWN. +C + IF (IWGF.EQ.0) THEN + IF (SLAG.GT.BLAM.OR.BLAG.LT.SLAM) GO TO 101 + IF ((SLOG .GT.BLOM.OR.BLOG .LT.SLOM).AND. + + (SLOG-360..GT.BLOM.OR.BLOG-360..LT.SLOM).AND. + + (SLOG+360..GT.BLOM.OR.BLOG+360..LT.SLOM)) GO TO 101 + END IF +C +C SEE IF THE USER WANTS TO OMIT THIS POINT GROUP. +C + CALL MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) + IF (NPTS.LE.1) GO TO 101 +C +C IF WE'VE SWITCHED TO A NEW GROUP, SET THE INTENSITY, DOTTING, AND +C DASH PATTERN FOR THE GROUP. +C + IF (IGID.NE.IGIS) THEN + IF (IGIS.NE.0) CALL MAPCHI (-4-IGIS,0,0) + CALL MAPCHI (4+IGID,IDOT,IOR(ISHIFT(32767,1),1)) + IGIS=IGID + END IF +C +C PLOT THE GROUP. +C + CALL MAPIT (PNTS(1),PNTS(2),0) +C + DO 102 K=2,NPTS-1 + CALL MAPIT (PNTS(2*K-1),PNTS(2*K),1) + 102 CONTINUE +C + CALL MAPIT (PNTS(2*NPTS-1),PNTS(2*NPTS),2) +C +C GO GET ANOTHER GROUP. +C + GO TO 101 +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN, IF NECESSARY. +C + 103 IF (IGIS.NE.0) CALL MAPCHI (-4-IGIS,0,0) +C +C IF THE LIMB LINES HAVE NOT ALREADY BEEN DRAWN, DO IT NOW. +C + IF (GRID.LE.0.) CALL MAPLMB +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPPOS (ARG1,ARG2,ARG3,ARG4) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPPOS','VERSION 1') +C +C CHECK THE ARGUMENTS FOR ERRORS. +C + IF (ARG1.LT.0..OR.ARG1.GE.ARG2.OR.ARG2.GT.1.) GO TO 901 + IF (ARG3.LT.0..OR.ARG3.GE.ARG4.OR.ARG4.GT.1.) GO TO 901 +C +C TRANSFER IN THE VALUES. +C + XLOW=ARG1 + XROW=ARG2 + YBOW=ARG3 + YTOW=ARG4 +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=19 + CALL SETER (' MAPPOS - ARGUMENTS ARE INCORRECT',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPROJ (ARG1,ARG2,ARG3,ARG4) +C + CHARACTER*(*) ARG1 +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPROJ','VERSION 1') +C +C TRANSFER THE PARAMETERS DEFINING THE PROJECTION. +C + I=IDICTL(ARG1,PDCT,10) + IF (I.EQ.0) GO TO 901 +C + JPRJ=I +C + IF (JPRJ.EQ.3) THEN + CALL MAPSTR ('SA',0.) + ELSE IF (JPRJ.EQ.10) THEN + JPRJ=3 + IF (ABS(SALT).LE.1.) CALL MAPSTR ('SA',6.631) + END IF +C + PHIA=ARG2 + PHIO=ARG3 + ROTA=ARG4 +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=9 + CALL MAPCEM (' MAPROJ - UNKNOWN PROJECTION NAME ',ARG1,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPRS +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPRS','VERSION 1') +C +C RESTORE THE SET CALL. +C + CALL SET (ULOW,UROW,VBOW,VTOW,UMIN,UMAX,VMIN,VMAX,1) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPRST (IFNO) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPRST','VERSION 1') +C +C READ A RECORD OF SAVED PARAMETERS. +C + READ (IFNO,ERR=901,END=902) NOUT,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1, + + PLA2,PLA3,PLA4,PLB1,PLB2,PLB3,PLB4, + + PLTR,GRID,IDSH,IDOT,LBLF,PRMF,ELPF, + + XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH, + + ILCW,DPLT,DDTS,SALT,SSMO,SRSS,ALFA, + + BETA,SALF,CALF,SBET,CBET, + + (INTS(I),I=1,7) +C +C RE-INITIALIZE EZMAP. +C + CALL MAPINT +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=20 + CALL SETER ('MAPRST - ERROR ON READ',IIER,1) + RETURN +C + 902 IIER=21 + CALL SETER ('MAPRST - EOF ON READ',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSAV (IFNO) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSAV','VERSION 1') +C +C WRITE A RECORD CONTAINING ALL THE USER-SETTABLE PARAMETERS. +C + WRITE (IFNO,ERR=901) NOUT,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1, + + PLA2,PLA3,PLA4,PLB1,PLB2,PLB3,PLB4, + + PLTR,GRID,IDSH,IDOT,LBLF,PRMF,ELPF, + + XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH, + + ILCW,DPLT,DDTS,SALT,SSMO,SRSS,ALFA, + + BETA,SALF,CALF,SBET,CBET, + + (INTS(I),I=1,7) +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=22 + CALL SETER ('MAPSAV - ERROR ON WRITE',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSET (ARG1,ARG2,ARG3,ARG4,ARG5) +C + CHARACTER*(*) ARG1 + DIMENSION ARG2(2),ARG3(2),ARG4(2),ARG5(2) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSET','VERSION 1') +C +C TRANSFER THE PARAMETERS DEFINING THE MAP LIMITS. +C + I=IDICTL(ARG1,LDCT,5) + IF (I.EQ.0) GO TO 901 + ILTS=I +C + PLA1=ARG2(1) + PLA2=ARG3(1) + PLA3=ARG4(1) + PLA4=ARG5(1) +C + IF (I.EQ.3) THEN + PLB1=ARG2(2) + PLB2=ARG3(2) + PLB3=ARG4(2) + PLB4=ARG5(2) + END IF +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=10 + CALL MAPCEM (' MAPSET - UNKNOWN MAP AREA SPECIFIER ',ARG1,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTC (WHCH,CVAL) +C + CHARACTER*(*) WHCH,CVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTC','VERSION 1') +C + IF (WHCH(1:2).EQ.'OU') THEN + I=IDICTL(CVAL,DDCT,5) + IF (I.EQ.0) GO TO 901 + NOUT=I-1 + ELSE + GO TO 902 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=11 + CALL MAPCEM (' MAPSTC - UNKNOWN OUTLINE NAME ',CVAL,IIER,1) + RETURN +C + 902 IIER=12 + CALL MAPCEM (' MAPSTC - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTI (WHCH,IVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTI','VERSION 1') +C + IF (WHCH(1:2).EQ.'DA') THEN + IDSH=IVAL + ELSE IF (WHCH(1:2).EQ.'DD') THEN + DDTS=IVAL + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'DL') THEN + IDTL=IVAL + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IDOT=IVAL + ELSE IF (WHCH(1:2).EQ.'EL') THEN + ELPF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'GR') THEN + GRID=IVAL + ELSE IF (WHCH(1:2).EQ.'I1') THEN + INTS(1)=IVAL + ELSE IF (WHCH(1:2).EQ.'I2') THEN + INTS(2)=IVAL + ELSE IF (WHCH(1:2).EQ.'I3') THEN + INTS(3)=IVAL + ELSE IF (WHCH(1:2).EQ.'I4') THEN + INTS(4)=IVAL + ELSE IF (WHCH(1:2).EQ.'I5') THEN + INTS(5)=IVAL + ELSE IF (WHCH(1:2).EQ.'I6') THEN + INTS(6)=IVAL + ELSE IF (WHCH(1:2).EQ.'I7') THEN + INTS(7)=IVAL + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LBLF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'LS') THEN + ILCW=IVAL + ELSE IF (WHCH(1:2).EQ.'MV') THEN + DPLT=IVAL + DPSQ=DPLT*DPLT + ELSE IF (WHCH(1:2).EQ.'PE') THEN + PRMF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + PLTR=IVAL + DSCA=(UROW-ULOW)*PLTR/(UMAX-UMIN) + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + SALT=IVAL + IF (ABS(SALT).GT.1.) THEN + SSMO=SALT*SALT-1. + SRSS=SQRT(SSMO) + END IF + ELSE IF (WHCH(1:2).EQ.'S1') THEN + ALFA=IVAL + SALF=SIN(.017453292519943*ALFA) + CALF=COS(.017453292519943*ALFA) + ELSE IF (WHCH(1:2).EQ.'S2') THEN + BETA=IVAL + SBET=SIN(.017453292519943*BETA) + CBET=COS(.017453292519943*BETA) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=13 + CALL MAPCEM (' MAPSTI - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTL (WHCH,LVAL) +C + CHARACTER*(*) WHCH + LOGICAL LVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTL','VERSION 1') +C + IF (WHCH(1:2).EQ.'DL') THEN + IDTL=0 + IF (LVAL) IDTL=1 + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IDOT=0 + IF (LVAL) IDOT=1 + ELSE IF (WHCH(1:2).EQ.'EL') THEN + ELPF=LVAL + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LBLF=LVAL + ELSE IF (WHCH(1:2).EQ.'PE') THEN + PRMF=LVAL + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=14 + CALL MAPCEM (' MAPSTL - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTR (WHCH,RVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTR','VERSION 1') +C + IF (WHCH(1:2).EQ.'DD') THEN + DDTS=RVAL + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'GD') THEN + GRDR=AMAX1(.001,AMIN1(10.,RVAL)) + ELSE IF (WHCH(1:2).EQ.'GR') THEN + GRID=RVAL + ELSE IF (WHCH(1:2).EQ.'MV') THEN + DPLT=RVAL + DPSQ=DPLT*DPLT + ELSE IF (WHCH(1:2).EQ.'RE') THEN + PLTR=RVAL + DSCA=(UROW-ULOW)*PLTR/(UMAX-UMIN) + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + SALT=RVAL + IF (ABS(SALT).GT.1.) THEN + SSMO=SALT*SALT-1. + SRSS=SQRT(SSMO) + END IF + ELSE IF (WHCH(1:2).EQ.'S1') THEN + ALFA=RVAL + SALF=SIN(.017453292519943*ALFA) + CALF=COS(.017453292519943*ALFA) + ELSE IF (WHCH(1:2).EQ.'S2') THEN + BETA=RVAL + SBET=SIN(.017453292519943*BETA) + CBET=COS(.017453292519943*BETA) + ELSE IF (WHCH(1:2).EQ.'SR') THEN + SRCH=AMAX1(.001,AMIN1(10.,RVAL)) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=15 + CALL MAPCEM (' MAPSTR - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRN (RLAT,RLON,U,V) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM8/ P,Q,R + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C DEFINE REQUIRED CONSTANTS. DTOR IS PI OVER 180, DTRH IS HALF OF DTOR +C OR PI OVER 360, AND TOPI IS 2 OVER PI. +C + DATA DTOR / .017453292519943 / + DATA DTRH / .008726646259971 / + DATA RTOD / 57.2957795130823 / + DATA TOPI / .636619772367581 / +C +C SET UP U AND V FOR THE FAST PATHS. U IS A LONGITUDE, IN DEGREES, +C BETWEEN -180. AND +180., INCLUSIVE, AND V IS A LATITUDE, IN DEGREES. +C + TMP1=RLON-PHOC + U=TMP1-SIGN(180.,TMP1+180.)+SIGN(180.,180.-TMP1) + V=RLAT +C +C TAKE FAST PATHS FOR SIMPLE CYLINDRICAL PROJECTIONS. +C + IF (IPRJ-10) 101,116,112 +C +C NO FAST PATH. SORT OUT THE LAMBERT CONFORMAL CONIC FROM THE REST. +C + 101 IF (IPRJ-1) 901,102,103 +C +C LAMBERT CONFORMAL CONIC. +C + 102 P=U + CHI=90.-SINO*RLAT + IF (CHI.GE.179.9999) GO TO 118 + R=TAN(DTRH*CHI)**COSO + U=U*COSO*DTOR + V=-R*SINO*COS(U) + U=R*SIN(U) + GO TO 117 +C +C NOT LAMBERT CONFORMAL CONIC. CALCULATE CONSTANTS COMMON TO MOST OF +C THE OTHER PROJECTIONS. +C + 103 TMP1=U*DTOR + TMP2=V*DTOR + SINPH=SIN(TMP1) + SINLA=SIN(TMP2) + COSPH=COS(TMP1) + COSLA=COS(TMP2) + TCOS=COSLA*COSPH + COSA=AMAX1(-1.,AMIN1(+1.,SINLA*SINO+TCOS*COSO)) + SINA=SQRT(1.-COSA*COSA) + IF (SINA.LT..0001) THEN + SINA=0. + IF (IPRJ.GE.7.OR.COSA.LT.0.) GO TO 118 + U=0. + V=0. + GO TO 116 + END IF + SINB=COSLA*SINPH/SINA + COSB=(SINLA*COSO-TCOS*SINO)/SINA +C +C JUMP TO CODE APPROPRIATE FOR THE CHOSEN PROJECTION. +C + GO TO (104,105,106,107,108,109,110,111) , IPRJ-1 +C +C STEREOGRAPHIC. +C + 104 IF (ABS(SINA).LT..0001) THEN + R=SINA/2. + ELSE + R=(1.-COSA)/SINA + END IF + GO TO 115 +C +C ORTHOGRAPHIC OR SATELLITE-VIEW, DEPENDING ON THE VALUE OF SALT. +C + 105 IF (ABS(SALT).LE.1.) THEN + IF (COSA.GT.0.) THEN + R=SINA + ELSE + IF (SALT.GE.0.) GO TO 118 + R=2.-SINA + END IF + GO TO 115 + ELSE + IF (COSA.GT.1./ABS(SALT)) THEN + R=SRSS*SINA/(ABS(SALT)-COSA) + ELSE + IF (SALT.GE.0.) GO TO 118 + R=2.-SRSS*SINA/(ABS(SALT)-COSA) + END IF + IF (ALFA.EQ.0.) GO TO 115 + UTM1=R*(SINB*COSR+COSB*SINR) + VTM1=R*(COSB*COSR-SINB*SINR) + UTM2=UTM1*CBET+VTM1*SBET + VTM2=VTM1*CBET-UTM1*SBET + UTM3=SRSS*UTM2/(UTM2*SALF+SRSS*CALF) + VTM3=SRSS*VTM2*CALF/(UTM2*SALF+SRSS*CALF) + U=UTM3*CBET-VTM3*SBET + V=VTM3*CBET+UTM3*SBET + GO TO 116 + END IF +C +C LAMBERT EQUAL AREA. +C + 106 IF (ABS(COSA+1.).LT.1.E-6) GO TO 118 + R=(1.+COSA)/SINA + R=2./SQRT(1.+R*R) + GO TO 115 +C +C GNOMONIC. +C + 107 IF (COSA.LE..0001) GO TO 118 + R=SINA/COSA + GO TO 115 +C +C AZIMUTHAL EQUIDISTANT. +C + 108 IF (ABS(COSA+1.).LT.1.E-6) GO TO 118 + R=ACOS(COSA) + GO TO 115 +C +C CYLINDRICAL EQUIDISTANT, ARBITRARY POLE AND ORIENTATION. +C + 109 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR)*RTOD + V=90.-ACOS(COSA)*RTOD + GO TO 116 +C +C MERCATOR, ARBITRARY POLE AND ORIENTATION. +C + 110 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR) + V=ALOG((1.+COSA)/SINA) + GO TO 116 +C +C MOLLWEIDE, ARBITRARY POLE AND ORIENTATION. +C + 111 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR)*TOPI + P=U + V=COSA + U=U*SINA + GO TO 117 +C +C FAST-PATH CYLINDRICAL PROJECTIONS (WITH PLAT=ROTA=0). +C + 112 IF (IPRJ-12) 113,114,901 +C +C FAST-PATH MERCATOR. +C + 113 IF (ABS(RLAT).GT.89.9999) GO TO 118 + U=U*DTOR + V=ALOG(TAN((RLAT+90.)*DTRH)) + GO TO 116 +C +C FAST-PATH MOLLWEIDE. +C + 114 U=U/90. + V=SIN(RLAT*DTOR) + P=U + U=U*SQRT(1.-V*V) + GO TO 117 +C +C COMMON TERMINAL CODE FOR CERTAIN PROJECTIONS. +C + 115 U=R*(SINB*COSR+COSB*SINR) + V=R*(COSB*COSR-SINB*SINR) +C + 116 P=U +C + 117 Q=V +C +C NORMAL EXIT. +C + RETURN +C +C PROJECTION OF POINT IS INVISIBLE OR UNDEFINED. +C + 118 U=1.E12 + P=U + RETURN +C +C ERROR EXIT. +C + 901 IF (IIER.NE.0) GO TO 118 + IIER=16 + CALL SETER (' MAPTRN - ATTEMPT TO USE NON-EXISTENT PROJECTION', + + IIER,1) + GO TO 118 +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPUSR (IPRT) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPVEC (XLAT,XLON) + CALL MAPIT (XLAT,XLON,1) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE SUPCON (RLAT,RLON,UVAL,VVAL) + CALL MAPTRN (RLAT,RLON,UVAL,VVAL) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE SUPMAP (JPRJ,PLAT,PLON,ROTA,PLM1,PLM2,PLM3,PLM4,JLTS, + + JGRD,IOUT,IDOT,IERR) +C + DIMENSION PLM1(2),PLM2(2),PLM3(2),PLM4(2) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C + DIMENSION LPRJ(10),LLTS(5) +C + DATA LPRJ / 2,3,1,4,5,6,10,7,8,9 / + DATA LLTS / 1,2,5,4,3 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','SUPMAP','VERSION 1') +C +C SET EZMAP'S GRID-SPACING PARAMETER. +C + CALL MAPSTI ('GR',MOD(IABS(JGRD),1000)) +C +C SET EZMAP'S OUTLINE-SELECTION PARAMETER. +C + IF (IABS(IOUT).EQ.0.OR.IABS(IOUT).EQ.1) THEN + I=1+2*IABS(IOUT)+(1+ISIGN(1,JPRJ))/2 + ELSE + I=MAX0(1,MIN0(5,IOUT)) + END IF +C + CALL MAPSTC ('OU',DDCT(I)) +C +C SET EZMAP'S PERIMETER-DRAWING FLAG. +C + CALL MAPSTL ('PE',JGRD.GE.0) +C +C SET EZMAP'S GRID-LINE-LABELLING FLAG. +C + CALL MAPSTL ('LA',MOD(IABS(JGRD),1000).NE.0) +C +C SET EZMAP'S DOTTED-OUTLINE FLAG. +C + CALL MAPSTI ('DO',MAX0(0,MIN0(1,IDOT))) +C +C SET EZMAP'S PROJECTION-SELECTION PARAMETERS. +C + I=MAX0(1,MIN0(10,IABS(JPRJ))) + CALL MAPROJ (PDCT(LPRJ(I)),PLAT,PLON,ROTA) +C +C SET EZMAP'S RECTANGULAR-LIMITS-SELECTION PARAMETERS. +C + I=LLTS(MAX0(1,MIN0(5,IABS(JLTS)))) + CALL MAPSET (LDCT(I),PLM1,PLM2,PLM3,PLM4) +C +C DRAW THE MAP. +C + CALL MAPDRW +C +C RETURN THE ERROR FLAG TO THE USER. +C + IERR=IIER +C +C DONE. +C + RETURN +C + END +C +C*********************************************************************** +C T H E C O D E - I N T E R N A L R O U T I N E S +C*********************************************************************** +C + SUBROUTINE MAPCEM (IEM1,IEM2,IIER,IFLG) +C + CHARACTER*(*) IEM1,IEM2 +C +C MAPCEM IS CALLED TO DO A CALL TO SETER WHEN THE ERROR MESSAGE TO BE +C PRINTED IS IN TWO PARTS WHICH NEED TO BE CONCATENATED. FORTRAN-77 +C RULES MAKE IT NECESSARY TO CONCATENATE THE TWO PARTS OF THE MESSAGE +C INTO A LOCAL CHARACTER VARIABLE. +C + CHARACTER*100 IEMC +C + IEMC=IEM1//IEM2 + CALL SETER (IEMC,IIER,IFLG) +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPCHI (IPRT,IDTG,IDPT) +C +C MAPCHI IS CALLED BY VARIOUS EZMAP ROUTINES TO RESET THE INTENSITY, +C DOTTING, AND DASH PATTERN BEFORE AND AFTER DRAWING PARTS OF A MAP. +C +C THE ARGUMENT IPRT, IF POSITIVE, SAYS WHICH PART OF THE MAP IS ABOUT +C TO BE DRAWN, AS FOLLOWS: +C +C IPRT PART OF MAP. +C ---- ------------ +C 1 PERIMETER. +C 2 GRID. +C 3 LABELLING. +C 4 LIMB LINES. +C 5 OUTLINE POINT GROUP, CONTINENTAL. +C 6 OUTLINE POINT GROUP, U.S. +C 7 OUTLINE POINT GROUP, COUNTRY. +C +C A CALL WITH IPRT EQUAL TO THE NEGATIVE OF ONE OF THESE VALUES ASKS +C THAT THE INTENSITY SAVED BY THE LAST CALL, WITH IPRT POSITIVE, BE +C RESTORED. +C +C WHEN IPRT IS POSITIVE, IDTG IS ZERO IF SOLID LINES ARE TO BE USED, 1 +C IF DOTTED LINES ARE TO BE USED. IF IPRT IS NEGATIVE, IDTG IS IGNORED. +C +C WHEN IPRT IS POSITIVE AND IDTG IS ZERO, IDPT IS THE DASH PATTERN TO BE +C USED. IF IPRT IS NEGATIVE OR IDTG IS NON-ZERO, IDPT IS IGNORED. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPNTS/ INTS(7) +C +C DECLARE ONE OF THE DASH-PACKAGE COMMON BLOCKS, TOO. +C + COMMON /SMFLAG/ ISMO +C +C THE VARIABLES INTO, IDTS, AND ISMS NEED TO BE SAVED BETWEEN CALLS. +C + SAVE INTO,IDTS,ISMS +C +C FLUSH ALL BUFFERS BEFORE CHANGING ANYTHING. +C + CALL MAPIQ +C +C SET/RESET INTENSITY, DOTTING, AND DASH PATTERN. THE USER HAS THE +C LAST WORD. +C + IF (IPRT.GT.0) THEN + ISMS=ISMO + ISMO=1 + IDTS=IDTL + IDTL=IDTG + IF (IDTL.EQ.0) CALL DASHDB (IDPT) +C +C THE FOLLOWING LINES HAVE BEEN COMMENTED OUT BECAUSE THE INTENSITY +C SETTING CAUSES SOME STRANGE BEHAVIOUR ON CERTAIN TERMINALS AND +C WORKSTATIONS. +C +C CALL GETUSV ('IN',INTO) +C CALL SETUSV ('IN',IFIX(10000.*FLOAT(INTS(IPRT))/255.)) + CALL MAPUSR (IPRT) + ELSE + CALL MAPUSR (IPRT) +C +C THE FOLLOWING LINE HAVE BEEN COMMENTED OUT BECAUSE THE INTENSITY +C SETTING CAUSES SOME STRANGE BEHAVIOUR ON CERTAIN TERMINALS AND +C WORKSTATIONS. +C +C CALL SETUSV ('IN',INTO) + IF (IDTL.EQ.0) CALL DASHDB (IOR(ISHIFT(32767,1),1)) + IDTL=IDTS + ISMO=ISMS + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + INTEGER FUNCTION IDICTL (ISTR,IDCT,NDCT) +C + CHARACTER*(*) ISTR + CHARACTER*2 IDCT(NDCT) +C +C THE VALUE OF THIS FUNCTION IS THE INDEX IN THE NDCT-ELEMENT DICTIONARY +C IDCT OF THE STRING ISTR. ONLY THE FIRST TWO CHARACTERS OF ISTR AND +C IDCT(I) ARE COMPARED. IF ISTR IS NOT FOUND IN THE DICTIONARY, THE +C FUNCTION VALUE IS ZERO. +C + DO 101 I=1,NDCT + IF (ISTR(1:2).EQ.IDCT(I)) THEN + IDICTL=I + RETURN + END IF + 101 CONTINUE +C +C NOT FOUND. RETURN A ZERO. +C + IDICTL=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIO (IACT) +C +C THIS ROUTINE PERFORMS ALL POSITIONING AND INPUT OF THE OUTLINE DATASET +C FOR MAPLOT. THE ARGUMENT IACT SPECIFIES WHAT IS TO BE DONE: 1 ASKS +C THAT THE DATASET BE POSITIONED AT THE BEGINNING OF THE DESIRED "FILE", +C 2 THAT THE NEXT RECORD BE READ. +C +C FIVE LINES OF THE CODE BELOW HAVE BEEN INSERTED TO MAKE THIS ROUTINE +C RUN EFFICIENTLY ON NCAR'S CRAYS; THESE LINES SHOULD BE REMOVED BY +C ANYONE IMPLEMENTING EZMAP ON ANOTHER SYSTEM (EXCEPT PERHAPS ANOTHER +C CRAY). +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCMB/ IERR +C + IF (IACT.EQ.1) THEN +C +C POSITION TO THE DESIRED "FILE" WITHIN THE DATASET. +C +C THE FOLLOWING FIVE LINES ARE FOR NCAR'S CRAYS. +C +C ITPN=6LEZMPDT +C IF (IFDNT(ITPN).EQ.0) THEN +C CALL SDACCESS (IERR,ITPN) +C IF (IERR.NE.0) GO TO 901 +C END IF +C + REWIND ITPN +C + IF (NOUT.NE.1) THEN + ITMP=NOUT + 101 READ (ITPN,END=902) NPTS,IGID,BLAG,SLAG,BLOG,SLOG, + + (PNTS(I),I=1,NPTS) + IF (NPTS.GT.1) GO TO 101 + ITMP=ITMP-1 + IF (ITMP.GT.1) GO TO 101 + END IF +C + ELSE +C +C READ THE NEXT RECORD. +C + READ (ITPN) NPTS,IGID,BLAG,SLAG,BLOG,SLOG,(PNTS(I),I=1,NPTS) + NPTS=NPTS/2 +C + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=17 + CALL SETER (' MAPIO - OUTLINE DATASET IS UNREADABLE',IIER,1) + NOUT=0 + RETURN +C + 902 IIER=18 + CALL SETER (' MAPIO - EOF ENCOUNTERED IN OUTLINE DATASET',IIER,1) + NOUT=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLMB +C +C THE ROUTINE MAPLMB IS CALLED BY MAPGRD AND/OR MAPLOT TO DRAW THE LIMB +C LINES. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C DEFINE REQUIRED CONSTANTS. SIN1 AND COS1 ARE RESPECTIVELY THE SINE +C AND COSINE OF ONE DEGREE. +C + DATA SIN1 / .017452406437283 / + DATA COS1 / .999847695156390 / + DATA PI / 3.14159265358979 / +C +C THE ARITHMETIC STATEMENT FUNCTIONS FLOOR AND CLING GIVE, RESPECTIVELY, +C THE "FLOOR" OF X - THE LARGEST INTEGER LESS THAN OR EQUAL TO X - AND +C THE "CEILING" OF X - THE SMALLEST INTEGER GREATER THAN OR EQUAL TO X. +C + FLOOR(X)=AINT(X+1.E4)-1.E4 + CLING(X)=-FLOOR(-X) +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR LIMB LINES. +C + CALL MAPCHI (4,0,IOR(ISHIFT(32767,1),1)) +C +C DRAW LIMB LINES, THE NATURE OF WHICH DEPENDS ON THE PROJECTION. +C + GO TO (101,110,104,105,110,106,110,110,107,110,110,107) , IPRJ +C +C LAMBERT CONFORMAL CONIC WITH TWO STANDARD PARALLELS. +C + 101 DLAT=GRDR + RLON=PHIO+179.9999 + K=CLING(180./DLAT) + DO 103 I=1,2 + RLAT=-90. + CALL MAPIT (RLAT,RLON,0) + DO 102 J=1,K-1 + RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,1) + 102 CONTINUE + RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,2) + RLON=PHIO-179.9999 + 103 CONTINUE + GO TO 110 +C +C ORTHOGRAPHIC (OR SATELLITE-VIEW). +C + 104 IF (ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + URAD=1. + RVTU=1. + ELSE + DNOM=SALT*SALT*CALF*CALF-1. + URAD=SSMO*CALF/DNOM + RVTU=SQRT(DNOM)/SRSS + END IF + GO TO 108 +C +C LAMBERT EQUAL AREA. +C + 105 URAD=2. + RVTU=1. + GO TO 108 +C +C AZIMUTHAL EQUIDISTANT. +C + 106 URAD=PI + RVTU=1. + GO TO 108 +C +C MOLLWEIDE. +C + 107 URAD=2. + RVTU=0.5 +C + 108 UCIR=URAD + VCIR=0. + IVIS=-1 + DO 109 I=1,361 + IF (IPRJ.NE.3.OR.ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + U=UCIR + V=RVTU*VCIR + ELSE + UTMP=UCIR-SRSS*SALF/DNOM + VTMP=RVTU*VCIR + U=UTMP*CBET-VTMP*SBET + V=VTMP*CBET+UTMP*SBET + END IF + IF (.NOT.ELPF.AND. + + (U.LT.UMIN.OR.U.GT.UMAX.OR.V.LT.VMIN.OR.V.GT.VMAX)) THEN + IF (IVIS.EQ.1) THEN + CALL MAPTRP (UOLD,VOLD,U,V,UEDG,VEDG) + CALL MAPVP (UOLD,VOLD,UEDG,VEDG) + END IF + IVIS=0 + ELSE IF (ELPF.AND. + + (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.GT.1.)) THEN + IF (IVIS.EQ.1) THEN + CALL MAPTRE (UOLD,VOLD,U,V,UEDG,VEDG) + CALL MAPVP (UOLD,VOLD,UEDG,VEDG) + END IF + IVIS=0 + ELSE + IF (IVIS.LT.0) THEN + DATL=0. + CALL FRSTD (U,V) + IVIS=1 + ELSE + IF (IVIS.EQ.0) THEN + IF (.NOT.ELPF) CALL MAPTRP (U,V,UOLD,VOLD,UOLD,VOLD) + IF ( ELPF) CALL MAPTRE (U,V,UOLD,VOLD,UOLD,VOLD) + DATL=0. + CALL FRSTD (UOLD,VOLD) + IVIS=1 + END IF + CALL MAPVP (UOLD,VOLD,U,V) + END IF + END IF + UOLD=U + VOLD=V + UTMP=UCIR + VTMP=VCIR + UCIR=UTMP*COS1-VTMP*SIN1 + VCIR=UTMP*SIN1+VTMP*COS1 + 109 CONTINUE +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + 110 CALL MAPCHI (-4,0,0) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRE (UINS,VINS,UOUT,VOUT,UINT,VINT) +C +C THIS ROUTINE FINDS THE POINT OF INTERSECTION (UINT,VINT) OF THE LINE +C FROM (UINS,VINS) TO (UOUT,VOUT) WITH THE EDGE OF AN ELLIPTICAL FRAME. +C THE FIRST POINT IS INSIDE THE FRAME AND THE SECOND OUTSIDE THE FRAME. +C +C BECAUSE MAPTRE CAN BE CALLED WITH THE SAME ACTUAL ARGUMENTS FOR UINT +C AND VINT AS FOR UOUT AND VOUT, RESPECTIVELY, UINT AND VINT MUST NOT +C BE RESET UNTIL ALL USE OF UOUT AND VOUT IS COMPLETE. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C WHAT'S INVOLVED IS JUST A LOT OF ALGEBRA. +C + IF (ABS(UOUT-UINS).GT.ABS(VOUT-VINS)) THEN + P=(VOUT-VINS)/(UOUT-UINS) + Q=(UOUT*VINS-UINS*VOUT)/(UOUT-UINS) + A=VRNG*VRNG+P*P*URNG*URNG + B=2.*(P*Q*URNG*URNG-UCEN*VRNG*VRNG-P*URNG*URNG*VCEN) + C=UCEN*UCEN*VRNG*VRNG+Q*Q*URNG*URNG-2.*Q*URNG*URNG*VCEN+ + + URNG*URNG*VCEN*VCEN-URNG*URNG*VRNG*VRNG + UTM1=SQRT(AMAX1(B*B-4.*A*C,0.)) + UTM2=.5*(-B-UTM1)/A + IF ((UTM2-UOUT)*(UTM2-UINS).GT.0.) UTM2=.5*(-B+UTM1)/A + UINT=UTM2 + VINT=P*UINT+Q + ELSE + P=(UOUT-UINS)/(VOUT-VINS) + Q=(UINS*VOUT-UOUT*VINS)/(VOUT-VINS) + A=URNG*URNG+P*P*VRNG*VRNG + B=2.*(P*Q*VRNG*VRNG-URNG*URNG*VCEN-P*UCEN*VRNG*VRNG) + C=URNG*URNG*VCEN*VCEN+Q*Q*VRNG*VRNG-2.*Q*UCEN*VRNG*VRNG+ + + UCEN*UCEN*VRNG*VRNG-URNG*URNG*VRNG*VRNG + VTM1=SQRT(AMAX1(B*B-4.*A*C,0.)) + VTM2=.5*(-B-VTM1)/A + IF ((VTM2-VOUT)*(VTM2-VINS).GT.0.) VTM2=.5*(-B+VTM1)/A + VINT=VTM2 + UINT=P*VINT+Q + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRP (UINS,VINS,UOUT,VOUT,UINT,VINT) +C +C THIS ROUTINE FINDS THE POINT OF INTERSECTION (UINT,VINT) OF THE LINE +C FROM (UINS,VINS) TO (UOUT,VOUT) WITH THE EDGE OF A RECTANGULAR FRAME. +C THE FIRST POINT IS INSIDE THE FRAME AND THE SECOND OUTSIDE THE FRAME. +C +C BECAUSE MAPTRP CAN BE CALLED WITH THE SAME ACTUAL ARGUMENTS FOR UINT +C AND VINT AS FOR UOUT AND VOUT, RESPECTIVELY, UINT AND VINT MUST NOT +C BE RESET UNTIL ALL USE OF UOUT AND VOUT IS COMPLETE. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C GIVEN ONE COORDINATE OF A POINT ON THE LINE JOINING (UINS,VINS) AND +C (UOUT,VOUT), THE OTHER CAN BE OBTAINED BY USING ONE OF THE FOLLOWING +C ARITHMETIC STATEMENT FUNCTIONS: +C + UFUN(V)=UINS+(V-VINS)*DU/DV + VFUN(U)=VINS+(U-UINS)*DV/DU +C +C I I +C 5 I 4 I 6 +C I I +C ----------------- +C FIRST, DETERMINE IN WHICH I I +C OF THE AREAS SHOWN THE 2 I 1 I 3 +C POINT (UOUT,VOUT) LIES. I I +C ----------------- +C I I +C 8 I 7 I 9 +C I I +C + IREA=1 + IF (UOUT-UMIN) 101,104,102 + 101 IREA=IREA+1 + GO TO 104 + 102 IF (UOUT-UMAX) 104,104,103 + 103 IREA=IREA+2 + 104 IF (VOUT-VMIN) 105,108,106 + 105 IREA=IREA+6 + GO TO 108 + 106 IF (VOUT-VMAX) 108,108,107 + 107 IREA=IREA+3 +C +C NEXT, COMPUTE THE QUANTITIES REQUIRED BY UFUN AND VFUN AND JUMP TO THE +C APPROPRIATE PIECE OF CODE FOR THE GIVEN AREA. +C + 108 DU=UOUT-UINS + DV=VOUT-VINS +C + GO TO (119,113,114,115,109,110,116,111,112) , IREA +C + 109 IF (UFUN(VMAX)-UMIN) 113,115,115 + 110 IF (UFUN(VMAX)-UMAX) 115,115,114 + 111 IF (UFUN(VMIN)-UMIN) 113,116,116 + 112 IF (UFUN(VMIN)-UMAX) 116,116,114 +C + 113 UINT=UMIN + GO TO 117 + 114 UINT=UMAX + GO TO 117 + 115 VINT=VMAX + GO TO 118 + 116 VINT=VMIN + GO TO 118 +C + 117 VINT=VFUN(UINT) + RETURN +C + 118 UINT=UFUN(VINT) + RETURN +C + 119 UINT=UOUT + VINT=VOUT + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPVP (UOLD,VOLD,U,V) +C +C PLOT THE LINE SEGMENT FROM (UOLD,VOLD) TO (U,V), USING EITHER A SOLID +C LINE OR A DOTTED LINE (DEPENDING ON THE VALUE OF THE COMMON VARIABLE +C IDTL). +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C SELECT VECTOR OR DOT MODE. +C + IF (IDTL.EQ.0) THEN +C +C USE A SINGLE VECTOR. +C + CALL VECTD (U,V) +C + ELSE +C +C USE DOTS. DELU AND DELV ARE THE U AND V COMPONENTS OF THE VECTOR +C JOINING (UOLD,VOLD) TO (U,V) AND VLEN IS THE LENGTH OF THE VECTOR. +C + DELU=U-UOLD + DELV=V-VOLD +C + VLEN=SQRT(DELU*DELU+DELV*DELV) +C +C NOW DISTRIBUTE DOTS ALONG THE VECTOR. THE FIRST ONE IS SPACED JUST +C FAR ENOUGH ALONG IT (DATL UNITS) TO BE DBTD UNITS AWAY FROM THE LAST +C DOT ON THE PREVIOUS VECTOR AND THE REST ARE DBTD UNITS APART. +C + 101 IF (DATL.LT.VLEN) THEN + IF (NPTB.GE.50) THEN + CALL POINTS (XPTB,YPTB,NPTB,0,0) + NPTB=0 + END IF + NPTB=NPTB+1 + XPTB(NPTB)=UOLD+(DATL/VLEN)*DELU + YPTB(NPTB)=VOLD+(DATL/VLEN)*DELV + DATL=DATL+DBTD + GO TO 101 + END IF +C +C SET DATL FOR THE NEXT CALL. +C + DATL=DATL-VLEN +C + END IF +C +C DONE. +C + RETURN +C + END +C +C*********************************************************************** +C T H E B L O C K D A T A " R O U T I N E " - D E F A U L T S +C*********************************************************************** +C + BLOCK DATA MAPBD +C +C THE COMMON BLOCK MAPCM1 CONTAINS TRANSFORMATION CONSTANTS. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC +C +C THE COMMON BLOCK MAPCM2 CONTAINS AREA-SPECIFICATION VARIABLES. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C THE COMMON BLOCK MAPCM3 CONTAINS PARAMETERS HAVING TO DO WITH READING +C THE DATA FOR OUTLINES. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) +C +C THE COMMON BLOCK MAPCM4 CONTAINS MOST OF THE INPUT PARAMETERS. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW +C + LOGICAL INTF,LBLF,PRMF,ELPF +C +C THE COMMON BLOCK MAPCM5 CONTAINS VARIOUS LISTS ("DICTIONARIES") OF +C TWO-CHARACTER CODES REQUIRED BY EZMAP FOR PARAMETER-SETTING. +C + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) +C + CHARACTER*2 DDCT,LDCT,PDCT +C +C THE COMMON BLOCK MAPCM7 CONTAINS PARAMETERS DESCRIBING THE PORTION OF +C THE PLOTTER FRAME BEING USED. +C + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW +C +C THE COMMON BLOCK MAPCM8 CONTAINS PARAMETERS SET BY MAPTRN AND USED BY +C MAPIT IN HANDLING "CROSS-OVER" PROBLEMS. +C + COMMON /MAPCM8/ P,Q,R +C +C THE COMMON BLOCK MAPCMA CONTAINS VALUES WHICH ARE USED TO POSITION +C DOTS ALONG DOTTED OUTLINES AND TO AVOID DRAWING VECTORS WHICH ARE +C TOO SHORT. +C + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL +C +C THE COMMON BLOCK MAPCMB CONTAINS THE EZMAP ERROR FLAG. +C + COMMON /MAPCMB/ IIER +C +C THE COMMON BLOCK MAPCMP CONTAINS THE BUFFERS IN WHICH THE X AND Y +C COORDINATES OF POINTS ARE COLLECTED FOR AN EVENTUAL CALL TO POINTS. +C + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C THE COMMON BLOCK MAPNTS CONTAINS QUANTITIES SPECIFYING THE INTENSITIES +C TO BE USED FOR VARIOUS PORTIONS OF THE PLOT. +C + COMMON /MAPNTS/ INTS(7) +C +C THE COMMON BLOCK MAPSAT CONTAINS PARAMETERS FOR THE SATELLITE-VIEW +C PROJECTION. +C + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C +C BELOW ARE DESCRIPTIONS OF THE VARIABLES IN EACH OF THE COMMON BLOCKS, +C TOGETHER WITH DATA STATEMENTS GIVING DEFAULT VALUES TO THOSE VARIABLES +C WHICH NEED DEFAULT VARIABLES. +C +C +C VARIABLES IN MAPCM1: +C +C IPRJ IS AN INTEGER BETWEEN 1 AND 12, SPECIFYING WHAT PROJECTION IS +C CURRENTLY IN USE. THE VALUES 10, 11, AND 12 SPECIFY FAST-PATH +C VERSIONS OF THE VALUES 7, 8, AND 9, RESPECTIVELY. SINO, COSO, SINR, +C COSR, AND PHOC ARE PROJECTION VARIABLES COMPUTED BY MAPINT FOR USE BY +C MAPTRN. PHOC, AS IT HAPPENS, IS JUST A COPY OF PHIO, FROM THE COMMON +C BLOCK MAPCM4. +C +C +C VARIABLES IN MAPCM2: +C +C UMIN, UMAX, VMIN, AND VMAX SPECIFY THE LIMITS OF THE RECTANGLE TO BE +C DRAWN, IN PROJECTION SPACE. UEPS AND VEPS ARE SET BY MAPINT FOR USE +C IN MAPIT IN TESTING FOR CROSS-OVER PROBLEMS. UCEN, VCEN, URNG, AND +C VRNG ARE COMPUTED BY MAPINT FOR USE WHEN THE MAP PERIMETER IS MADE +C ELLIPTICAL (BY SETTING THE FLAG ELPF). BLAM, SLAM, BLOM, AND SLOM +C ARE RESPECTIVELY THE BIGGEST LATITUDE, THE SMALLEST LATITUDE, THE +C BIGGEST LONGITUDE, AND THE SMALLEST LONGITUDE ON THE MAP. THEY ARE +C USED IN MAPGRD AND IN MAPLOT TO MAKE THE DRAWING OF GRIDS AND OUTLINES +C MORE EFFICIENT. UMIN AND UMAX ARE GIVEN DEFAULT VALUES TO PREVENT +C IN MAPSTI AND MAPSTR FROM BLOWING UP WHEN PLTR IS SET PRIOR TO THE +C FIRST CALL TO MAPINT. +C + DATA UMIN,UMAX / 0.,1. / +C +C +C VARIABLES IN MAPCM3: +C +C ITPN IS THE UNIT NUMBER OF THE "TAPE" FROM WHICH OUTLINE DATA IS TO +C BE READ. NOUT IS THE NUMBER OF THE OUTLINE TO BE USED; THE VALUES 0 +C THROUGH 5 IMPLY 'NO', 'CO', 'US', 'PS', AND 'PO', RESPECTIVELY; THUS, +C IF NOUT IS ZERO, NO OUTLINES ARE TO BE USED, AND, IF IT IS NON-ZERO, +C IT IS THE NUMBER OF THE "FILE" TO BE READ FROM UNIT ITPN. NPTS, JUST +C AFTER A READ, IS THE NUMBER OF ELEMENTS READ INTO PNTS; IT IS THEN +C DIVIDED BY 2 TO BECOME THE NUMBER OF POINTS DEFINED BY THE GROUP JUST +C READ. IGID IS AN IDENTIFIER FOR THE GROUP, SO THAT, FOR EXAMPLE, ONE +C CAN DISTINGUISH A GROUP BELONGING TO A INTERNATIONAL BOUNDARY FROM +C ONE BELONGING TO A U.S. STATE BOUNDARY. BLAG, SLAG, BLOG, AND SLOG +C SPECIFY THE BIGGEST AND SMALLEST LATITUDE AND THE BIGGEST AND SMALLEST +C LONGITUDE OF THE POINTS IN THE GROUP, SO THAT, IN SOME CASES AT LEAST, +C ONE CAN DECIDE QUICKLY NOT TO BOTHER WITH THE GROUP. PNTS CONTAINS +C NPTS COORDINATE PAIRS, EACH CONSISTING OF A LATITUDE AND A LONGITUDE, +C IN DEGREES. +C + DATA ITPN,NOUT / 1,1 / +C +C +C VARIABLES IN MAPCM4: +C +C INTF IS A FLAG WHOSE VALUE AT ANY GIVEN TIME INDICATES WHETHER THE +C PACKAGE EZMAP IS IN NEED OF INITIALIZATION (.TRUE.) OR NOT (.FALSE). +C JPRJ IS AN INTEGER BETWEEN 1 AND 9 INDICATING THE TYPE OF PROJECTION +C CURRENTLY IN USE. PHIA, PHIO, AND ROTA ARE THE POLE LATITUDE AND +C LONGITUDE AND THE ROTATION ANGLE SPECIFIED BY THE LAST USER CALL TO +C MAPROJ. ILTS IS AN INTEGER BETWEEN 1 AND 5, SPECIFYING HOW THE LIMITS +C OF THE MAP ARE TO BE CHOSEN. PLA1-4 AND PLB1-4 ARE THE VALUES GIVEN +C BY THE USER FOR PLM1(1), PLM2(1), ..., PLM1(2), PLM2(2), ..., IN THE +C LAST CALL TO MAPSET. PLTR IS THE PLOTTER RESOLUTION - EFFECTIVELY, +C THE NUMBER OF ADDRESSABLE POINTS IN THE X DIRECTION. GRID IS THE +C DESIRED SPACING BETWEEN GRID LINES, IN DEGREES OF LATITUDE/LONGITUDE. +C IDSH IS THE DESIRED DASH PATTERN (16-BIT BINARY) FOR GRID LINES. IDOT +C IS A FLAG SELECTING SOLID OUTLINES (0) OR DOTTED OUTLINES (1). LBLF +C IS A LOGICAL FLAG INDICATING WHETHER THE INTERNATIONAL DATE LINE, THE +C EQUATOR, THE GREENWICH MERIDIAN, AND THE POLES ARE TO BE LABELLED OR +C NOT. PRMF IS A LOGICAL FLAG INDICATING WHETHER OR NOT A PERIMETER +C IS TO BE DRAWN. ELPF IS A LOGICAL FLAG INDICATING WHETHER THE MAP +C PERIMETER IS TO BE RECTANGULAR (.FALSE.) OR ELLIPTICAL (.TRUE.). +C XLOW, XROW, YBOW, AND YTOW ARE FRACTIONS BETWEEN 0. AND 1. SPECIFYING +C THE POSITION OF AREA OF THE PLOTTER FRAME IN WHICH THE MAP IS TO BE +C PUT; THE MAP IS CENTERED IN THIS AREA AND MADE AS LARGE AS POSSIBLE. +C IDTL IS A FLAG SPECIFYING THAT MAPIT SHOULD DRAW SOLID OUTLINES (0) +C OR DOTTEN OUTLINES (1). GRDR AND SRCH ARE MEASURED IN DEGREES AND +C LIE IN THE RANGE FROM .001 TO 10. GRDR SPECIFIES THE RESOLUTION WITH +C WHICH THE GRID IS TO BE DRAWN AND SRCH THE ACCURACY WITH WHICH THE +C LATITUDE/LONGITUDE LIMITS OF THE MAP ARE TO BE FOUND. ILCW IS THE +C CHARACTER WIDTH FOR CHARACTERS IN THE LABEL, AS REQUIRED FOR USE IN A +C CALL TO PWRIT. +C + DATA INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4,PLB1,PLB2 / + 1 .TRUE., 7, 0., 0., 0., 1, 0., 0., 0., 0., 0., 0. / +C + DATA PLB3,PLB4, PLTR,GRID, IDSH,IDOT, LBLF , PRMF , ELPF ,IDTL / + 1 0., 0.,4096., 10.,21845, 0,.TRUE.,.TRUE.,.FALSE., 0 / +C + DATA XLOW,XROW,YBOW,YTOW / .05,.95,.05,.95 / +C + DATA GRDR,SRCH / 1.,1. / +C + DATA ILCW / 1 / +C +C +C VARIABLES IN MAPCM5: +C +C DDCT IS THE DICTIONARY OF AVAILABLE DATASETS, LDCT THE DICTIONARY OF +C MAP LIMIT DEFINITION TYPES, AND PDCT THE DICTIONARY OF MAP PROJECTION +C NAMES. +C + DATA DDCT / 'NO','CO','US','PS','PO' / +C + DATA LDCT / 'MA','CO','PO','AN','LI' / +C + DATA PDCT / 'LC','ST','OR','LE','GN','AE','CE','ME','MO','SV' / +C +C +C VARIABLES IN MAPCM7: +C +C ULOW, UROW, VBOW, AND VTOW DEFINE THE FRACTION OF THE PLOTTER FRAME +C TO BE OCCUPIED BY THE MAP - THEY MAY BE THOUGHT OF AS THE FIRST FOUR +C ARGUMENTS OF THE SET CALL OR, IN THE GKS SCHEME, AS THE VIEWPORT. +C THEY ARE COMPUTED BY MAPINT. ULOW AND UROW ARE GIVEN DEFAULT VALUES +C TO PREVENT CODE IN MAPSTI AND MAPSTR FROM BLOWING UP WHEN PLTR IS +C SET PRIOR TO THE FIRST CALL TO MAPINT. +C + DATA ULOW,UROW / 0.,1. / +C +C +C VARIABLES IN MAPCM8: +C +C P, Q, AND R ARE SET BY MAPTRN EACH TIME IT MAPS (RLAT,RLON) TO (U,V). +C Q IS ALWAYS EQUAL TO V, BUT P IS NOT ALWAYS EQUAL TO U. INSTEAD, IT +C IS A VALUE OF U FROM AN INTERMEDIATE STEP IN THE PROJECTION PROCESS. +C FOR THE LAMBERT CONFORMAL CONIC, P IS THE DISTANCE, IN LONGITUDE, FROM +C THE CENTRAL MERIDIAN. FOR THE CYLINDRICAL PROJECTIONS, P IS A VALUE +C OF U PRIOR TO MULTIPLICATION BY A FUNCTION OF V SHRINKING THE MAP +C TOWARD A VERTICAL BISECTOR. THEY ARE ALL USED BY MAPIT, WHILE DRAWING +C LINES FROM POINT TO POINT, TO DETECT "CROSS-OVER" (A JUMP FROM ONE +C SIDE OF THE MAP TO THE OTHER, CAUSED BY THE PROJECTION'S HAVING SLIT +C THE GLOBE ALONG SOME HALF OF A GREAT CIRCLE AND LAID IT OPEN WITH THE +C TWO SIDES OF THE SLIT AT OPPOSITE ENDS OF THE MAP). +C +C +C VARIABLES IN MAPCMA: +C +C DPLT IS THE MIMIMUM VECTOR LENGTH; MAPIT REQUIRES TWO POINTS TO BE AT +C LEAST DPLT PLOTTER UNITS APART BEFORE IT WILL JOIN THEM WITH A VECTOR. +C DDTS IS THE DESIRED DISTANCE IN PLOTTER UNITS BETWEEN DOTS IN A DOTTED +C OUTLINE. THESE VALUES ARE RELATIVE TO THE "PLOTTER RESOLUTION" PLTR; +C DPLT/PLTR IS A FRACTION OF THE PLOTTER FRAME. DSCA IS THE RATIO OF +C THE LENGTH OF A VECTOR, MEASURED IN PLOTTER UNITS, TO THE LENGTH OF +C THE SAME VECTOR, MEASURED IN THE U/V PLANE. THUS, GIVEN A VECTOR OF +C LENGTH D IN THE U/V PLANE, D*DSCA IS ITS LENGTH IN PLOTTER UNITS. +C DPSQ AND DSSQ ARE THE SQUARES OF DPLT AND DSCA, RESPECTIVELY. DBTD +C IS THE DISTANCE, IN THE U/V PLANE, BETWEEN TWO DOTS DDTS PLOTTER +C UNITS APART. DPLT AND DDTS HAVE THE VALUES GIVEN BELOW AND ARE NOT +C RESET BY THE CODE; DSCA, DPSQ, DSSQ, AND DBTD ARE COMPUTED BY MAPINT. +C DSCA IS GIVEN A DEFAULT VALUE ONLY TO KEEP THE ROUTINES MAPSTI AND +C MAPSTR FROM BLOWING UP WHEN DDTS IS SET PRIOR TO ANY CALL TO MAPINT. +C DATL IS USED BY MAPIT AND MAPVP TO KEEP TRACK OF WHERE THE NEXT POINT +C ALONG A CURVE SHOULD GO. +C + DATA DPLT,DDTS,DSCA / 4.,12.,1. / +C +C +C VARIABLES IN MAPCMB: +C +C IIER IS AN ERROR FLAG, SET WHENEVER AN ERROR OCCURS DURING A CALL TO +C ONE OF THE EZMAP ROUTINES. ITS VALUE MAY BE RETRIEVED BY A CALL TO +C MAPGTI. +C + DATA IIER / 0 / +C +C +C VARIABLES IN MAPCMP: +C +C NPTB IS THE NUMBER OF POINTS WHOSE COORDINATES HAVE BEEN COLLECTED IN +C THE ARRAYS XPTB AND YPTB FOR EVENTUAL OUTPUT BY A CALL TO POINTS. +C + DATA NPTB / 0 / +C +C VARIABLES IN MAPNTS: +C +C THE ARRAY INTS SPECIFIES INTENSITIES TO BE USED FOR THE PERIMETER, FOR +C THE GRID, FOR LABELLING, FOR LIMBS, FOR THE CONTINENTAL OUTLINES, FOR +C THE U.S. STATE OUTLINES, AND FOR INTERNATIONAL POLITICAL OUTLINES. +C SEE THE ROUTINE MAPCHI. EACH ELEMENT IS AN INTEGER IN THE RANGE 0 TO +C 255, INCLUSIVE. +C + DATA INTS / 240,150,210,240,240,180,210 / +C +C +C VARIABLES IN MAPSAT: +C +C THE ABSOLUTE VALUE OF SALT, IF GREATER THAN 1, SERVES AS A FLAG THAT +C A SATELLITE-VIEW PROJECTION IS TO BE USED IN PLACE OF AN ORTHOGRAPHIC +C PROJECTION; ITS VALUE IS THE DISTANCE OF THE SATELLITE FROM THE CENTER +C OF THE EARTH, IN UNITS OF EARTH RADII. IN THIS CASE, SSMO IS THE +C SQUARE OF SALT MINUS 1 AND SRSS IS THE SQUARE ROOT OF SSMO. IF ALFA +C IS ZERO, THE PROJECTION SHOWS THE VIEW SEEN BY A SATELLITE LOOKING +C STRAIGHT AT THE CENTER OF THE EARTH; CALL THIS THE BASIC SATELLITE +C VIEW. IF ALFA IS NON-ZERO, IT AND BETA ARE ANGLES, IN DEGREES, +C DETERMINING WHERE THE LINE OF SIGHT OF THE PROJECTION IS. IF E IS +C AT THE CENTER OF THE EARTH, S IS AT THE SATELLITE, AND P IS A POINT +C ALONG THE LINE OF SIGHT, THEN ALFA MEASURES THE ANGLE ESP. IF O IS +C THE POINT AT THE ORIGIN OF THE BASIC SATELLITE VIEW AND P IS THE +C PROJECTION OF THE LINE OF SIGHT, THEN BETA MEASURES THE ANGULAR +C DISTANCE FROM THE POSITIVE U AXIS TO THE LINE OP, POSITIVE IF +C MEASURED COUNTER-CLOCKWISE. SALF, CALF, SBET, AND CBET ARE SINES +C AND COSINES OF ALFA AND BETA. THE SIGN OF SALT INDICATES WHETHER A +C NORMAL PROJECTION (POSITIVE) OR AN EXTENDED PROJECTION (NEGATIVE) +C IS TO BE USED. THE LATTER MAKES IT EASIER TO OVERLAY CONREC OUTPUT +C ON ONE OF THESE PROJECTIONS, BY PROJECTING POINTS OUT OF SIGHT AROUND +C THE LIMB TO POINT JUST OUTSIDE THE LIMB ON THE PROJECTED VIEW. +C + DATA SALT,ALFA,BETA,SALF,CALF,SBET,CBET / 0.,0.,0.,0.,1.,0.,1. / +C +C REVISION HISTORY: +C +C FEBRUARY, 1982 ADDED MODIFICATIONS SO THAT POINTS GENERATED BY THE +C DRAWING OF DOTTED CONTINENTAL OUTLINES ARE BUFFERED +C AND THEN PUT OUT WITH A CALL TO POINTS, INSTEAD OF +C BEING PUT OUT ONE AT A TIME WITH A CALL TO POINT AS +C BEFORE. THE LATTER RESULTED IN HUGE OVERHEAD IN THE +C PLOT FILE. ROUTINES MAPLOT AND MAPVP WERE MODIFIED, +C AND A NEW COMMON BLOCK MAPCMP WAS ADDED. +C +C AUGUST, 1984 CONVERTED TO FORTRAN-77 AND GKS. DELETED THE EZMAP +C ENTRY POINT. +C +C MARCH, 1985 COMPLETELY OVERHAULED THE CODE TO SIMPLIFY IT AND TO +C REMOVE KNOWN ERRORS. UPDATED THE OUTLINE DATASET +C TO REMOVE ERRORS AND TO INCLUDE INTERNATIONAL +C BOUNDARIES. IMPLEMENTED MANY CONTROLS AIMED AT +C OBVIATING THE NEED FOR SOURCE MODIFICATION BY USERS. +C +C MAY, 1985 ADDED CODE TO PREVENT PROBLEMS WHEN A SMOOTHING +C VERSION OF THE DASH PACKAGE IS LOADED. ADDED CODE +C IN MAPIT TO GET AROUND A CFT COMPILER PROBLEM. +C ADDED CODE TO DO EXTENDED ORTHOGRAPHIC AND SATELLITE- +C VIEW PROJECTIONS. +C +C JULY, 1985 FIXED A MISSING DECLARATION IN THE SUBROUTINE MAPSET +C AND LIMITED "CALL PLOTIT (0,0,0)" TO THE GKS VERSION. +C +C AUGUST, 1985 FIXED A PROBLEM IN MAPGRD WHICH CAUSED MERIDIANS ON +C MERCATOR MAPS WITH VERTICAL LIMITS TOO CLOSE TO THE +C POLES TO BE DRAWN IMPROPERLY. (THE TEST FOR CROSS- +C OVER, IN MAPIT, WAS BEING PASSED BECAUSE THE POINTS +C USED TO DRAW THE MERIDIANS WERE TOO FAR APART.) ALSO +C FIXED AN ERROR IN THE GKS CODE IN MAPCHI AND BEEFED +C UP THE IMPLEMENTORS' INSTRUCTIONS TO SAY WHAT TO DO +C WITH THAT ROUTINE WHEN COLOR IS AVAILABLE. +C +C NOVEMBER, 1985 ADDED CODE TO PREVENT GKS CLIPPING FROM DESTROYING +C PART OF THE PERIMETER. +C + END diff --git a/sys/gio/ncarutil/gridal.f b/sys/gio/ncarutil/gridal.f new file mode 100644 index 00000000..8ad31020 --- /dev/null +++ b/sys/gio/ncarutil/gridal.f @@ -0,0 +1,1583 @@ + SUBROUTINE GRIDAL(MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB,IGPH,X,Y) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C LATEST REVISION JULY, 1985 +C +C PURPOSE THIS IS A PACKAGE OF ROUTINES FOR DRAWING +C GRAPH PAPER, AXES, AND OTHER BACKGROUNDS. +C +C USAGE EACH USER ENTRY POINT IN THIS PACKAGE (GRID, +C GRIDL, PERIM, PERIML, HALFAX, LABMOD, +C TICK4, AND GRIDAL) WILL BE DESCRIBED +C SEPARATELY BELOW. FIRST, HOWEVER, WE +C WILL DISCUSS HOW MAJOR AND MINOR DIVISIONS +C IN THE GRAPH PAPER ARE HANDLED BY ALL +C ENTRIES WHICH USE THEM. +C +C GRIDAL, GRID, GRIDL, PERIM, PERIML, AND +C HALFAX HAVE ARGUMENTS MAJRX,MINRX,MAJRY, +C MINRY WHICH CONTROL THE NUMBER OF MAJOR AND +C MINOR DIVISIONS IN THE GRAPH PAPER OR +C PERIMETERS. THE NUMBER OF DIVISIONS REFERS +C TO THE HOLES BETWEEN LINES RATHER THAN THE +C LINES THEMSELVES. THIS MEANS THAT THERE +C IS ALWAYS ONE MORE MAJOR DIVISION LINE THAN +C THE NUMBER OF MAJOR DIVISIONS. SIMILARLY, +C THERE IS ONE LESS MINOR DIVISION LINE THAN +C MINOR DIVISIONS (PER MAJOR DIVISION.) +C +C MAJRX,MAJRY,MINRX,MINRY HAVE DIFFERENT +C MEANINGS DEPENDING UPON WHETHER LOG +C SCALING IS IN EFFECT (SET VIA SETUSV OR +C SET IN THE SPPS PACKAGE.) +C +C FOR LINEAR SCALING, +C MAJRX AND MAJRY SPECIFY THE NUMBER OF MAJOR +C DIVISIONS ALONG THE X-AXIS OR Y-AXIS +C RESPECTIVELY, AND MINRX AND MINRY SPECIFY +C THE NUMBER OF MINOR DIVISIONS PER MAJOR +C DIVISION. +C +C FOR LOG SCALING ALONG THE X-AXIS +C EACH MAJOR DIVISION OCCURS AT A FACTOR OF +C 10**MAJRX TIMES THE PREVIOUS DIVISION. +C FOR EXAMPLE, IF THE MINIMUM X-AXIS VALUE IS +C 3., AND THE MAXIMUM X-AXIS VALUE IS 3000., +C AND MAJRX IS 1, THEN MAJOR DIVISIONS WILL +C OCCUR AT 3., 30., 300., AND 3000. SIMILARLY +C FOR MAJRY. IF LOG SCALING IS IN EFFECT ON +C THE X-AXIS AND MINRX.LE.10, THEN THERE ARE +C NINE MINOR DIVISIONS BETWEEN EACH MAJOR +C DIVISION. FOR EXAMPLE, BETWEEN 3. AND 30. +C THERE WOULD BE A MINOR DIVISION AT 6., 9., +C 12.,...,27. IF LOG SCALING IS IN EFFECT ON +C THE X-AXIS AND MINRX.GT.10, THEN THERE WILL +C BE NO MINOR SUBDIVISIONS. MINRY IS TREATED +C IN THE SAME MANNER AS MINRX. +C +C IF DIFFERENT COLORS (OR INTENSITIES) ARE TO +C BE USED FOR NORMAL INTENSITY, LOW INTENSITY, +C OR TEXT COLOR, THEN THE VALUES IN COMMON +C BLOCK GRIINT SHOULD BE CHANGED AS FOLLOWS: +C +C IGRIMJ COLOR INDEX FOR NORMAL (MAJOR) +C INTENSITY LINES. +C IGRIMN COLOR INDEX FOR LOW INTENSITY +C LINES. +C IGRITX COLOR INDEX FOR TEXT (LABELS.) +C +C WE NOW DESCRIBE EACH ENTRY IN THIS PACKAGE. +C +C----------------------------------------------------------------------- +C SUBROUTINE GRID +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW GRAPH PAPER. +C +C USAGE CALL GRID (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE DRAWS GRAPH LINES IN THE PORTION +C OF THE PLOTTER SPECIFIED BY THE CURRENT VIEWPORT +C SETTING WITH THE NUMBER OF MAJOR AND MINOR +C DIVISIONS AS SPECIFIED BY THE ARGUMENTS. +C +C----------------------------------------------------------------------- +C SUBROUTINE GRIDAL +C----------------------------------------------------------------------- +C +C PURPOSE A GENERAL ENTRY POINT FOR ALL BACKGROUND ROUTINES +C WITH THE OPTION OF LINE LABELLING ON EACH AXIS. +C +C USAGE CALL GRIDAL (MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB, +C IGPH,X,Y) +C +C ARGUMENTS MAJRX,MINRX,MAJRY,MINRY +C MAJOR AND MINOR AXIS DIVISIONS AS DESCRIBED IN THE +C USAGE SECTION OF THE PACKAGE DOCUMENTATION ABOVE. +C +C IXLAB,IYLAB (INTEGERS) +C FLAGS FOR AXIS LABELS: +C +C IXLAB = -1 NO X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 0 X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 1 X-AXIS DRAWN +C X-AXIS LABELS +C +C IYLAB = -1 NO Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 0 Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 1 Y-AXIS DRAWN +C Y-AXIS LABELS +C +C +C IGPH +C FLAG FOR BACKGROUND TYPE: +C +C IGPH X-AXIS BACKGROUND Y-AXIS BACKGROUND +C ---- ----------------- ----------------- +C 0 GRID GRID +C 1 GRID PERIM +C 2 GRID HALFAX +C 4 PERIM GRID +C 5 PERIM PERIM +C 6 PERIM HALFAX +C 8 HALFAX GRID +C 9 HALFAX PERIM +C 10 HALFAX HALFAX +C +C X,Y +C WORLD COORDINATES OF THE INTERSECTION OF THE AXES +C IF IGPH=10 . +C +C----------------------------------------------------------------------- +C SUBROUTINE GRIDL +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW GRAPH PAPER. +C +C USAGE CALL GRIDL (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES EXACTLY AS GRID, BUT EACH +C MAJOR DIVISION IS LABELED WITH ITS NUMERICAL VALUE. +C +C----------------------------------------------------------------------- +C SUBROUTINE HALFAX +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW ORTHOGONAL AXES. +C +C USAGE CALL HALFAX (MAJRX,MINRX,MAJRY,MINRY,X,Y,IXLAB,IYLAB) +C +C DESCRIPTION THIS SUBROUTINE DRAWS ORTHOGONAL AXES INTERSECTING +C AT COORDINATE (X,Y) WITH OPTIONAL LABELING OPTIONS AS +C SPECIFIED BY IXLAB AND IYLAB. +C +C ARGUMENTS MAJRX,MINRX,MAJRY,MINRY +C MAJOR AND MINOR DIVISION SPECIFICATIONS AS PER THE +C DESCRIPTION IN THE PACKAGE USAGE SECTION ABOVE. +C +C X,Y +C WORLD COORDINATES SPECIFYING THE INTERSECTION POINT +C OF THE X AND Y AXES. +C +C IXLAB,IYLAB (INTEGERS) +C FLAGS FOR AXIS LABELS: +C +C IXLAB = -1 NO X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 0 X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 1 X-AXIS DRAWN +C X-AXIS LABELS +C +C IYLAB = -1 NO Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 0 Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 1 Y-AXIS DRAWN +C Y-AXIS LABELS +C +C----------------------------------------------------------------------- +C SUBROUTINE LABMOD +C----------------------------------------------------------------------- +C +C PURPOSE TO ALLOW MORE COMPLETE CONTROL OVER THE APPEARANCE +C OF THE LABELS ON THE BACKGROUND PLOTS. +C +C USAGE CALL LABMOD (FMTX,FMTY,NUMX,NUMY,ISIZX,ISIZY, +C IXDEC,IYDEC,IXOR) +C +C DESCRIPTION THIS SUBROUTINE PRESETS PARAMETERS FOR THE OTHER +C BACKGROUND ROUTINES IN THIS PACKAGE. LABMOD ITSELF +C DOES NO PLOTTING AND IT MUST BE CALLED BEFORE THE +C THE BACKGROUND ROUTINES FOR WHICH IT IS PRESETTING +C PARAMETERS. +C +C ARGUMENTS FMTX,FMTY (TYPE CHARACTER) +C FORMAT SPECIFICATIONS FOR THE X-AXIS AND Y-AXIS +C NUMERICAL LABELS IN GRIDL, PERIML, GRIDAL, OR +C HALFAX. THE SPECIFICATION MUST START WITH A LEFT +C PARENTHESIS AND END WITH A RIGHT PARENTHESIS AND +C SHOULD NOT USE MORE THAN 8 CHARACTERS. ONLY +C FLOATING-POINT CONVERSIONS (F, E, AND G) SUCH AS +C FMTX='(F8.2)' AND FMTY='(E10.0)' FOR EXAMPLE. +C +C NUMX,NUMY (INTEGER) +C THE NUMBER OF CHARACTERS SPECIFIED BY FMTX AND +C FMTY. FOR THE ABOVE EXAMPLES, THESE WOULD BE +C NUMX=8 AND NUMY=10 (NOT 6 AND 7). +C +C ISIZX,ISIZY +C CHARACTER SIZE CODES FOR THE LABELS. THESE SIZE +C CODES ARE THE SAME AS THOSE FOR THE SPPS ENTRY +C PWRIT. +C +C IXDEC +C THE DECREMENT IN PLOTTER ADDRESS UNITS FROM THE +C LEFTMOST PLOTTER COORDINATE (AS SPECIFIED BY THE +C CURRENT VIEWPORT) TO THE NEAREST X-ADDRESS OF THE +C LABEL SPECIFIED BY FMTY, NUMY, AND ISIZY. FOR +C EXAMPLE, IF THE MINIMUM X-COORDINATE OF THE CURRENT +C VIEWPORT IS .1, MINX IS 102 (.1*1024). IF IXDEC +C IS 60, THE LABEL WILL START AT 42 (102-60). THE +C FOLLOWING CONVENTIONS ARE USED: +C +C O IF IXDEC=0, IT IS AUTOMATICALLY RESET TO PROPERLY +C POSITION THE Y-AXIS LABELS TO THE LEFT OF THE +C LEFT Y-AXIS, IXDEC=20 . +C +C O IF IXDEC=1, Y-AXIS LABELS WILL GO TO THE RIGHT +C OF THE GRAPH, IXDEC=-20 . +C +C WHEN EITHER HALFAX OR GRIDAL IS CALLED TO DRAW AN +C AXIS, IXDEC IS THE DISTANCE FROM THE AXIS RATHER +C THAN FROM THE MINIMUM VIEWPORT COORDINATE. +C +C IYDEC +C THE DECREMENT IN PLOTTER ADDRESS UNITS FROM THE +C MINIMUM Y-AXIS COORDINATE AS SPECIFIED BY THE +C CURRENT VIEWPORT TO THE NEAREST Y-ADDRESS OF THE +C LABEL SPECIFIED BY FMTX, NUMX, AND ISIZX. FOR +C EXAMPLE, IF THE MINIMUM Y-COORDINATE OF THE +C CURRENT VIEWPORT IS .2, MINY IS 205 (.2*1024). +C IF IYDEC=30, THE LABEL WILL END AT 205-30=175. +C THE FOLLOWING CONVENTIONS ARE USED: +C +C O IF IYDEC=0, IT IS AUTOMATICALLY RESET TO +C PROPERLY POSITION X-AXIS LABELS ALONG THE +C BOTTOM, IYDEC=20 . +C +C O IF IYDEC=1, X-AXIS LABELS WILL GO ALONG THE +C TOP OF THE GRAPH, IYDEC=-20 . +C +C IXOR (INTEGER) +C ORIENTATION OF THE X-AXIS LABELS. +C +C IXOR = 0 +X (HORIZONTAL) +C = 1 +Y (VERTICAL) +C +C IN NORMAL ORIENTATION, THE ACTUAL NUMBER OF +C NON-BLANK DIGITS IS CENTERED UNDER THE LINE +C OR TICK TO WHICH IT APPLIES. +C +C----------------------------------------------------------------------- +C SUBROUTINE PERIM +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A PERIMETER WITH TICK MARKS. +C +C USAGE CALL PERIM (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES JUST AS GRID EXCEPT THAT +C INTERIOR LINES ARE REPLACED WITH TICK MARKS ALONG +C THE EDGES. TICK MARKS AT MAJOR DIVISIONS ARE +C SLIGHTLY LARGER THAN TICK MARKS AT MINOR DIVISIONS. +C +C----------------------------------------------------------------------- +C SUBROUTINE PERIML +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A PERIMETER WITH TICK MARKS AND LABELS. +C +C USAGE CALL PERIML (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES JUST AS PERIM, BUT EACH +C MAJOR DIVISION IS LABELED WITH ITS NUMERICAL VALUE. +C +C----------------------------------------------------------------------- +C SUBROUTINE TICK4 +C----------------------------------------------------------------------- +C +C PURPOSE TO ALLOW PROGRAM CONTROL OF TICK MARK LENGTH. +C +C USAGE CALL TICK4 (LMAJX,LMINX,LMAJY,LMINY) +C +C DESCRIPTION THIS SUBROUTINE ALLOWS PROGRAM CONTROL OF TICK +C MARK LENGTH IN PERIM, PERIML, GRIDAL, AND HALFAX. +C +C ARGUMENTS LMAJX,LMAJY +C LENGTH IN PLOTTER ADDRESS UNITS OF MAJOR DIVISION +C TICK MARKS ON THE X-AXIS AND Y-AXIS RESPECTIVELY. +C THESE VALUES ARE INITIALLY SET TO 12 . +C +C MINRX,MINRY +C LENGTH IN PLOTTER ADDRESS UNITS OF MINOR DIVISION +C TICK MARKS ON THE X-AXIS AND Y-AXIS RESPECTIVELY. +C THESE VALUES ARE INITIALLY SET TO 8 . +C +C----------------------------------------------------------------------- +C +C WE NOW RESUME THE PACKAGE DOCUMENTATION. +C +C ENTRY POINTS GRID,GRIDAL,GRIDL,HALFAX,LABMOD,PERIM,PERIML,TICK4, +C TICKS,CHSTR,EXPAND,GRIDT +C +C COMMON BLOCKS LAB,CLAB,TICK,GRIINT +C +C REQUIRED THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS BACKGROUNDS +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY WRITTEN IN JUNE, 1984. BASED ON THE NCAR SYSTEM +C PLOT PACKAGE ENTRIES HAVING THE SAME NAMES. +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX +C +C INTERNAL VARIABLES: +C +C CHUPX,CHUPY CHARACTER UP VECTOR VALUES ON ENTRY +C +C CURMAJ IF LOGMIN=.TRUE., THEN THIS IS THE +C CURRENT MAJOR TICK/GRID POSITION +C +C ICNT NORMALIZATION TRANSFORMATION NUMBER IN +C EFFECT ON ENTRY TO GRIDAL +C +C LASF(13) ASPECT SOURCE FLAG TABLE AS USED BY GKS. +C +C LGRID .TRUE. IF GRIDS ARE TO BE DRAWN ON THE +C CURRENT AXIS (OPPOSED TO TICKS) +C +C LOGMIN .TRUE. IF LOG SCALING IS IN EFFECT AND +C MINOR TICK MARKS OR GRIDS ARE DESIRED +C +C LOGVAL LINEAR OR LOG SCALING +C 1 = X LINEAR, Y LINEAR +C 2 = X LINEAR, Y LOG +C 3 = X LOG, Y LINEAR +C 4 = X LOG, Y LOG +C +C MINCNT NUMBER OF MINOR DIVISIONS PER MAJOR +C +C NERR COUNTS ERROR NUMBER +C +C NEXTMAJ IF LOGMIN=.TRUE., THEN THIS IS THE NEXT +C MAJOR TICK/GRID POSITION +C +C NWIND(4) WINDOW LIMITS IN WORLD COORDINATES +C AFTER EXPANSION +C +C OCOLI COLOR INDEX ON ENTRY TO GRIDAL +C +C OLDALH,OLDALV TEXT ALIGNMENT VALUES ON ENTRY +C (HORIZONTAL AND VERTICAL) +C +C OLDCH CHARACTER HEIGHT ON ENTRY TO GRIDAL +C +C OPLASF STORES VALUE OF POLYLINE COLOR ASF ON +C ENTRY TO GRIDAL +C +C OTXASF STORES VALUE OF TEXT COLOR ASF ON +C ENTRY TO GRIDAL +C +C OTXCOL TEXT COLOR INDEX ON ENTRY TO GRIDAL +C +C OWIND(4) WINDOW LIMITS IN WORLD COORDINATES +C ON ENTRY TO GRIDAL +C +C PY(2) 2 Y-COORDINATES FOR LINE TO BE DRAWN +C VIA GKS ROUTINE GPL +C +C PX(2) 2 X-COORDINATES FOR LINE TO BE DRAWN +C VIA GKS ROUTINE GPL +C +C START IF DRAWING TICKS/GRIDS ON X-AXIS: +C Y-COORD OF ORIGIN OF EACH LINE; +C IF DRAWING TICKS/GRIDS ON Y-AXIS: +C X-COORD OF ORIGIN OF EACH LINE +C +C TICBIG END OF MAJOR TICK LINE IN WORLD +C COORDINATES +C +C TICEND END OF MINOR TICK LINE IN WORLD +C COORDINATES +C +C TICMAJ LENGTH OF MAJOR TICKS IN WORLD +C COORDINATES +C +C TICMIN LENGTH OF MINOR TICKS IN WORLD +C COORDINATES +C +C VIEW(4) VIEWPORT LIMITS IN NDC PRIOR TO +C EXPANSION FOR LABELLING +C +C WIND(4) SAME AS IN OWIND(4) +C +C XCUR A TICK/GRID IS DRAWN AT THIS POSITION +C IF LOG SCALING IS IN EFFECT. +C +C XDEC LENGTH IN WORLD COORDINATES FROM +C X-AXIS TO LABEL +C +C XI ALOG10(X), IF LOG SCALING +C +C XINT INTERVAL BETWEEN MINOR X-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C XINTM INTERVAL BETWEEN MAJOR X-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C XMIRRO LOGICAL FLAGS FOR MIRROR-IMAGE +C +C XNUM TOTAL NUMBER OF X-AXIS TICKS/GRIDS +C WITH LINEAR SCALING +C +C XPOS IF LINEAR SCALING, KEEPS TRACK OF X-AXIS +C POSITION FOR CURRENT TICK/GRID +C +C XRANGE TOTAL RANGE IN X DIRECTION IN WORLD +C COORDINATES PRIOR TO EXPANSION FOR +C LABELLING. +C +C XRNEW RANGE IN X DIRECTION IN WORLD +C COORDINATES, AFTER EXPANSION +C +C YCUR A TICK/GRID IS DRAWN AT THIS POSITION +C IF LOG SCALING IS IN EFFECT. +C +C YDEC LENGTH IN WORLD COORDINATES FROM +C Y-AXIS TO LABEL +C +C YI ALOG10(Y), IF LOG SCALING +C +C YINTM INTERVAL BETWEEN MAJOR Y-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C YMIRRO PLOTTING. +C +C YNUM TOTAL NUMBER OF Y-AXIS TICKS/GRIDS +C WITH LINEAR SCALING +C +C YPOS IF LINEAR SCALING, KEEPS TRACK OF Y-AXIS +C POSITION FOR CURRENT TICK/GRID +C +C YRANGE TOTAL RANGE IN Y DIRECTION IN WORLD +C COORDINATES PRIOR TO EXPANSION FOR +C LABELLING. +C +C YRNEW RANGE IN Y DIRECTION IN WORLD +C COORDINATES, AFTER EXPANSION +C +C XLAB,YLAB IF LABELLING X-AXIS, Y-COORDINATE FOR +C FOR TEXT POSITION; +C IF LABELLING Y-AXIS, X-COORDINATE FOR +C TEXT POSITION. +C +C +C + CHARACTER*8 XFMT,YFMT + REAL WIND(4), VIEW(4), PX(2), PY(2), NWIND(4), OWIND(4) + REAL MAJX, MINX, MAJY, MINY + INTEGER TCOUNT, XTNUM, YTNUM, FIRST, LAST + INTEGER OPLASF, OTXASF, LASF(13), OCOLI, OTEXCI, OLDALH ,OLDALV + LOGICAL LGRID,LOGMIN + LOGICAL XMIRRO,YMIRRO + REAL MAJDIV, NEXTMA + CHARACTER*15 LABEL +C + DATA TICMIN,TICMAJ,XCUR,YCUR,EXCUR,EYCUR/0.,0.,0.,0.,0.,0./ +C +C +NOAO - Blockdata rewritten as run time initialization. +C EXTERNAL GRIDT + call gridt +C -NOAO +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4('GRAPHX','GRIDAL','GRIDAL','VERSION 01') + XRNEW = 0. + YRNEW = 0. +C +C INITIALIZE ERROR COUNT. +C + NERR = 0 +C +C CHECK FOR BAD VALUES OF IGPH. +C + IF (IGPH.LT.0.OR.IGPH.EQ.3.OR.IGPH.EQ.7.OR.IGPH.GT.10) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--INVALID IGPH VALUE',NERR,2) + ENDIF +C +C GET STANDARD ERROR MESSAGE UNIT +C + IERUNT = I1MACH(4) + XMIRRO = .FALSE. + YMIRRO = .FALSE. +C +C SET POLYLINE COLOR ASF TO INDIVIDAUL. +C + CALL GQASF(IERR,LASF) + OPLASF = LASF(3) + LASF(3) = 1 + OTXASF = LASF(10) + LASF(10) = 1 + CALL GSASF(LASF) +C +C INQUIRE CURRENT POLYLINE COLOR INDEX. +C + CALL GQPLCI(IERR,OCOLI) +C +C SET POLYLINE COLOR TO THE VALUE SPECIFIED IN COMMON. +C + CALL GSPLCI(IGRIMJ) +C +C INQUIRE CURRENT NORMALIZATION TRANSFORMATION NUMBER. +C + CALL GQCNTN(IERR,ICNT) +C +C INQUIRE CURRENT WINDOW AND VIEWPORT LIMITS. +C + CALL GQNT(ICNT,IERR,WIND,VIEW) +C +C STORE WINDOW VALUES +C + DO 10 I = 1,4 + OWIND(I) = WIND(I) + 10 CONTINUE +C +C LOG OR LINEAR SCALING? +C +C 1 = X LINEAR, Y LINEAR +C 2 = X LINEAR, Y LOG +C 3 = X LOG, Y LINEAR +C 4 = X LOG, Y LOG +C + CALL GETUSV('LS',LOGVAL) +C +C ADJUST WINDOW TO ACCOUNT FOR LOG SCALING. +C + IF (LOGVAL .EQ. 2) THEN + WIND(3) = 10.**WIND(3) + WIND(4) = 10.**WIND(4) + ELSE IF (LOGVAL .EQ. 3) THEN + WIND(1) = 10.**WIND(1) + WIND(2) = 10.**WIND(2) + ELSE IF (LOGVAL .EQ. 4) THEN + WIND(1) = 10.**WIND(1) + WIND(2) = 10.**WIND(2) + WIND(3) = 10.**WIND(3) + WIND(4) = 10.**WIND(4) + ENDIF +C +C DETERMINE IF MIRROR-IMAGE MAPPING IS REQUIRED. +C + IF (WIND(1) .GT. WIND(2)) THEN + XMIRRO = .TRUE. + ENDIF + IF (WIND(3) .GT. WIND(4)) THEN + YMIRRO = .TRUE. + ENDIF +C +C IF IGPH=10, CHECK FOR X(Y) VALUES IN RANGE (IF NOT, CHANGE TO +C DEFAULT. +C + IF (IGPH .EQ. 10) THEN + XI = X + YI = Y + IF (((XI .LT. WIND(1) .OR. XI .GT. WIND(2)) .AND. .NOT. + 1 XMIRRO) .OR. (XMIRRO.AND.(XI.GT.WIND(1).OR.XI.LT.WIND(2)))) + 2 THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--X VALUE OUT OF WINDOW RANGE',NERR,1) +C +NOAO - FTN writes and format statements deleted. Call to SETER okay. +C +C WRITE(IERUNT,1001)NERR +C1001 FORMAT(' ERROR',I3,' IN GRIDAL--X VALUE OUT OF WINDOW RANGE') + CALL ERROF + XI = WIND(1) + ENDIF + IF (((YI .LT. WIND(3) .OR. YI .GT. WIND(4)) .AND. .NOT. + 1 YMIRRO).OR.(YMIRRO.AND.(YI.GT.WIND(3).OR.YI.LT.WIND(4)))) + 2 THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--Y VALUE OUT OF WINDOW RANGE',NERR,1) +C WRITE(IERUNT,1002)NERR +C1002 FORMAT(' ERROR',I3,' IN GRIDAL--Y VALUE OUT OF WINDOW RANGE') +C -NOAO + CALL ERROF + YI = WIND(3) + ENDIF + ENDIF + MX = MAJRX + MY = MAJRY + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 3) THEN + IF (MX .LT. 1) MX = 1 + IF (WIND(1) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(1) = ALOG10(WIND(1)) + ENDIF + IF (WIND(2) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(2) = ALOG10(WIND(2)) + ENDIF + IF (IGPH .EQ. 10) THEN + XI = ALOG10(XI) + ENDIF + ENDIF +C + IF(LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) THEN + IF (MY .LT. 1) MY = 1 + IF (WIND(3) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(3) = ALOG10(WIND(3)) + ENDIF + IF (WIND(4) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(4) = ALOG10(WIND(4)) + ENDIF + IF (IGPH .EQ. 10) THEN + YI = ALOG10(YI) + ENDIF + ENDIF +C +C DEFINE NORMALIZATION TRANSFORMATION NUMBER 1. +C + CALL GSWN(1,WIND(1),WIND(2),WIND(3),WIND(4)) + CALL GSVP(1,VIEW(1),VIEW(2),VIEW(3),VIEW(4)) + CALL GSELNT(1) +C +C CALCULATE X AND Y WORLD COORDINATE RANGES. +C + XRANGE = WIND(2) - WIND(1) + YRANGE = WIND(4) - WIND(3) +C +C IF LABELS ARE REQUESTED, INQUIRE AND SAVE TEXT ATTRIBUTES. +C + IF (IXLAB .EQ. 1 .OR. IYLAB .EQ. 1) THEN + CALL GQCHH(IERR,OLDCHH) + CALL GQCHUP(IERR,CHUPX,CHUPY) + CALL GQTXAL(IERR,OLDALH,OLDALV) + CALL GQTXCI (IERR,OTEXCI) + CALL GSTXCI (IGRITX) +C +C EXPAND WINDOW AND VIEWPORT FOR LABELS AND CALCULATE NEW +C X AND Y WORLD COORDINATE RANGES. +C + CALL EXPAND(NWIND) + XRNEW = NWIND(2) - NWIND(1) + YRNEW = NWIND(4) - NWIND(3) +C +C SET CHARACTER HEIGHT (1% OF Y RANGE.) +C + CHARH = SIZX * YRNEW + IF (YMIRRO) THEN + CHARH = -CHARH + ENDIF + CALL GSCHH(CHARH) + ENDIF +C + IF (IGPH .EQ. 0) GOTO 50 +C +C CALCULATE TIC LENGTH. +C +C IF NO LABELS AND TICK4 (OR TICKS) WERE NOT CALLED. +C + IF (MAJX .EQ. 0.) THEN + MAJX = .013 + MINX = .007 + TICMIN = MINX * YRANGE + TICMAJ = MAJX * YRANGE + ELSE +C +C EXPAND WINDOW IF NOT ALREADY EXPANDED. +C (IF LABMOD WAS NOT CALLED BUT TICK4(S) WAS.) +C + IF (IXLAB.NE.1 .AND. IYLAB.NE.1) THEN + CALL EXPAND (NWIND) + XRNEW = NWIND(2) - NWIND(1) + YRNEW = NWIND(4) - NWIND(3) + ENDIF + TICMIN = MINX * YRNEW + TICMAJ = MAJX * YRNEW + ENDIF +C +C **** X-AXIS TICS/GRIDS AND LABELS **** +C +C CALCULATE TIC/GRID INTERVALS ON X AXIS. +C + 50 IF (IXLAB .EQ. -1) GOTO 175 + MINCNT = MINRX + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN + LOGMIN = .FALSE. + XINTM = XRANGE/MX + XINT = XINTM + IF (MINCNT .GT. 1) THEN + XINT = XINT/MINCNT + ENDIF +C +C CALCULATE TOTAL NUMBER OF TICS/GRIDS ON AXIS. +C + XTNUM = MX * MINCNT + IF (MINCNT .EQ. 0) XTNUM = MX + ELSE + XTNUM = 50 + XCUR = 10.**OWIND(1) + MAJDIV = 10 ** MX + IF (MINCNT .LE. 10 .AND. MX .LE. 1) THEN + LOGMIN = .TRUE. + CURMAJ = XCUR + NEXTMA = XCUR * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + MINCNT = 9 + ELSE + LOGMIN = .FALSE. + MINCNT = 1 + ENDIF + ENDIF +C + LGRID = .FALSE. + LOOP = 1 +C +C DETERMINE ORIGIN OF TICK/GRID LINES (Y COORDINATE.) +C + IF (IGPH .NE. 10) THEN + START = WIND(3) + ELSE + START = YI + ENDIF +C + XPOS = WIND(1) + PY(1) = START + TICEND = START + TICMIN + TICBIG = START + TICMAJ +C + PX(1) = XPOS + PX(2) = PX(1) +C +C DRAW LEFT-MOST TICK ON X-AXIS (IF IGPH = 10 AND +C INTERSECTION OF AXES IS NOT AT BOTTOM LEFT OF WINDOW.) +C + IF (IGPH .EQ. 10) THEN + IF (XI .NE. WIND(1)) THEN + PY(2) = TICBIG + CALL GPL(2,PX,PY) + ENDIF +C +C DRAW X-AXIS FOR IGPH = 10 +C + PX(2) = WIND(2) + PY(2) = PY(1) + CALL GPL(2,PX,PY) + PX(2) = PX(1) + ELSE +C +C DRAW Y-AXIS FOR ANY OTHER IGPH (FIRST TICK.) +C + PY(2) = WIND(4) + CALL GPL(2,PX,PY) + ENDIF +C +C TICKS OR GRIDS ? +C + IF (IGPH .EQ. 0 .OR. IGPH .EQ. 1 .OR. IGPH .EQ.2) THEN + PY(2) = WIND(4) + LGRID = .TRUE. + ELSE + PY(2) = TICEND + ENDIF +C + IF (IXLAB .EQ. 1) THEN +C +C IF VERTICAL X-AXIS LABEL ORIENTATION, THEN SET CHAR UP VECTOR +C TO BE VERTICAL AND TEXT ALIGNMENT TO (RIGHT,HALF), +C OTHERWISE TO (CENTER,TOP) +C + IF (YMIRRO) THEN + IF (IXORI .EQ. 1) THEN + CALL GSCHUP(1.,0.) + CALL GSTXAL(3,3) + ELSE + CALL GSCHUP(0.,-1.) + CALL GSTXAL(2,1) + ENDIF + ELSE + IF (IXORI .EQ. 1) THEN + CALL GSCHUP(-1.,0.) + CALL GSTXAL(3,3) + ELSE + CALL GSTXAL(2,1) + ENDIF + ENDIF + IF (XDEC.NE.0. .AND. XDEC.NE.1.) THEN + DEC = XDEC * YRNEW + ELSE + DEC = .02 * YRNEW + ENDIF + IF (XDEC .NE. 1.) THEN + XLAB = START - DEC + ELSE + IF (IGPH .NE. 10) THEN + XLAB = WIND(4)+DEC + ELSE + XLAB = YI+DEC + ENDIF +C +C IF LABELS ARE ON TOP OF THE X-AXIS, SET THE TEXT +C ALIGNMENT TO (LEFT,HALF) IF THE X-AXIS LABELS ARE +C VERTICAL, OTHERWISE TO (CENTER,BASE). +C + IF (IXORI .EQ. 1) THEN + CALL GSTXAL(1,3) + ELSE + CALL GSTXAL(2,4) + ENDIF + ENDIF + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN +C +NOAO +C WRITE(LABEL,XFMT)XPOS + call encode (10, xfmt, label, xpos) +C -NOAO + ELSE +C +NOAO +C WRITE(LABEL,XFMT)XCUR + call encode (10, yfmt, label, xcur) +C -NOAO + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF +C + 80 TCOUNT = 1 +C + DO 100 I = 1,XTNUM + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN + XPOS = XPOS + XINT + ELSE + IF (.NOT. LOGMIN) THEN + XCUR = XCUR * MAJDIV + ELSE + IF (TCOUNT .NE. MINCNT) THEN + XCUR = XCUR + XINT + ELSE + XCUR = XCUR + XINT + CURMAJ = NEXTMA + NEXTMA = CURMAJ * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + IF (XCUR .GT. 10.**OWIND(2)-.1*XINT) THEN + XPOS = WIND(2) + ELSE + XPOS = ALOG10(XCUR) + ENDIF + ENDIF +C + PX(1) = XPOS + PX(2) = XPOS +C +C IF IGPH = 0,1,2,4,5,8 OR 9 AND XPOS=RIGHT AXIS, THEN +C DRAW AXIS, ELSE IF IGPH = 6 OR 10 DRAW TIC AND LABEL. +C + IF (LOGVAL .EQ. 3 .OR. LOGVAL .EQ. 4) EXCUR = 10.**OWIND(2) +C + IF ((((LOGVAL .EQ. 1.OR.LOGVAL.EQ.2) .AND. (I .EQ. XTNUM)) + 1 .OR.((LOGVAL .EQ.4 .OR.LOGVAL .EQ.3).AND.XCUR.GE.EXCUR-.1*XINT)) + 2 .AND.(IGPH.NE.6.AND.IGPH.NE.10)) THEN + IF (LOOP .EQ. 1) THEN + PY(2) = WIND(4) + CALL GPL(2,PX,PY) + IF (IXLAB .EQ. 1) THEN + IF (LOGVAL.EQ.1 .OR. LOGVAL.EQ.2) THEN +C (NOAO) WRITE(LABEL,XFMT) XPOS + call encode (10, xfmt, label, xpos) + ELSE + IF (XCUR .GT. EXCUR+.1*XINT) THEN + GOTO 101 + ELSE +C (NOAO) WRITE(LABEL,XFMT) XCUR + call encode (10, xfmt, label, xcur) + ENDIF + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF + ENDIF + GOTO 101 + ENDIF + IF ((LOGVAL.EQ.4 .OR. LOGVAL.EQ.3) .AND. XCUR.GT.EXCUR+.1*XINT) + 1 GOTO 101 +C +C MINOR TIC/GRID ? +C + IF (TCOUNT .NE. MINCNT .AND. MINCNT .NE. 0) THEN + IF (LGRID) THEN + CALL GSPLCI(IGRIMN) + ENDIF + CALL GPL(2,PX,PY) + IF (LGRID) THEN + CALL GSPLCI(IGRIMJ) + ENDIF + TCOUNT = TCOUNT + 1 +C +C MAJOR TIC/GRID +C + ELSE + IF (.NOT. LGRID) THEN + PY(2) = TICBIG + ENDIF + CALL GPL(2,PX,PY) +C +C LABEL. +C + IF (IXLAB .EQ. 1 .AND. LOOP .EQ. 1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN +C (NOAO) WRITE(LABEL,XFMT)XPOS + call encode (10, xfmt, label, xpos) + ELSE +C (NOAO) WRITE(LABEL,XFMT)XCUR + call encode (10, xfmt, label, xcur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF + TCOUNT = 1 + IF (.NOT. LGRID) THEN + PY(2) = TICEND + ENDIF + ENDIF + IF ((LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 3) .AND. + 1 XCUR .GE. EXCUR-.1*XINT) GOTO 101 + 100 CONTINUE + 101 CONTINUE +C +C TOP X-AXIS TICKS ? +C + IF (LOOP.EQ.1 .AND. (IGPH.EQ.4 .OR. IGPH.EQ.5 .OR. IGPH.EQ.6)) + 1 THEN + START = WIND(4) + TICEND = START - TICMIN + TICBIG = START - TICMAJ + PY(1) = START + PY(2) = TICEND + XPOS = WIND(1) + LOOP = 2 + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ.3) THEN + XCUR = 10.**OWIND(1) + IF (LOGMIN) THEN + CURMAJ = XCUR + NEXTMA = XCUR * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + GOTO 80 + ENDIF +C +C **** Y-AXIS TICS/GRIDS AND LABELS **** +C + 175 IF (IYLAB .EQ. -1) GOTO 999 +C +C CALCULATE Y-AXIS TICS +C + MINCNT = MINRY + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 3) THEN + LOGMIN = .FALSE. + YINTM = YRANGE/MY + YINT = YINTM + IF (MINCNT .GT. 1) THEN + YINT = YINT/MINCNT + ENDIF + YTNUM = MY * MINCNT + IF (MINCNT .EQ. 0) YTNUM = MY + ELSE + YTNUM = 50 + YCUR = 10.**OWIND(3) + MAJDIV = 10 ** MY + IF (MINCNT .LE. 10 .AND. MY .LE. 1) THEN + LOGMIN = .TRUE. + CURMAJ = YCUR + NEXTMA = YCUR * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + MINCNT = 9 + ELSE + LOGMIN = .FALSE. + MINCNT = 1 + ENDIF + ENDIF +C + LGRID = .FALSE. + LOOP = 1 +C +C DETERMINE ORIGIN OF TICK/GRID LINES (X COORDINATE.) +C + IF (IGPH .NE. 10) THEN + START = WIND(1) + ELSE + START = XI + ENDIF +C + YPOS = WIND(3) + PX(1) = START +C +C DETERMINE Y-AXIS TICK LENGTHS. +C + IF (MAJY .EQ. 0.) THEN + MAJY = .013 + MINY = .007 + ENDIF + IF (XRNEW .EQ. 0.) THEN + TICMIN = MINY * XRANGE + TICMAJ = MAJY * XRANGE + ELSE + TICMIN = MINY * XRNEW + TICMAJ = MAJY * XRNEW + ENDIF + TICEND = START + TICMIN + TICBIG = START + TICMAJ +C + PY(1) = YPOS + PY(2) = PY(1) +C +C DRAW BOTTOM-MOST TICK ON Y-AXIS IF (IGPH = 10 +C AND INTERSECTION OF AXES IS NOT AT BOTTOM LEFT +C OF WINDOW.) +C + IF (IGPH .EQ. 10) THEN + IF (YI .NE. WIND(3)) THEN + PX(2) = TICBIG + CALL GPL(2,PX,PY) + ENDIF +C +C DRAW Y-AXIS FOR IGPH = 10 +C + PY(2) = WIND(4) + PX(2) = PX(1) + CALL GPL(2,PX,PY) + PY(2) = PY(1) + ELSE +C +C DRAW X-AXIS FOR ANY OTHER IGPH (FIRST TICK.) +C + PX(2) = WIND(2) + CALL GPL(2,PX,PY) + ENDIF +C +C GRIDS OR TICS ? +C + IF ((IGPH .EQ. 0 .OR. IGPH .EQ. 4).OR. IGPH .EQ. 8) THEN + PX(2) = WIND(2) + LGRID = .TRUE. + ELSE + PX(2) = TICEND + ENDIF +C +C SET TEXT ATTRIBUTES IF Y-AXIS IS TO BE LABELLED. +C + IF (IYLAB .EQ. 1) THEN + IF (IXORI .EQ. 1) THEN + IF (YMIRRO) THEN + CALL GSCHUP(0.,-1.) + ELSE + CALL GSCHUP(0.,1.) + ENDIF + ENDIF +C +C SET TEXT ALIGNMENT TO (RIGHT,HALF) +C + CALL GSTXAL(3,3) +C +C RECALCULATE CHARACTER HEIGHT IF Y-AXIS LABELS ARE OF DIFFERENT +C SIZE FORM X-AXIS LABELS. +C + CHARH = SIZY * YRNEW + IF (YMIRRO) THEN + CHARH = -CHARH + ENDIF + CALL GSCHH(CHARH) + IF (YDEC .NE. 0. .AND. YDEC .NE. 1.) THEN + DEC = YDEC * XRNEW + ELSE + DEC = .02 * XRNEW + ENDIF + IF (YDEC .NE. 1.) THEN + YLAB = START - DEC + ELSE + IF (IGPH .NE. 10) THEN + YLAB = WIND(2)+DEC + ELSE + YLAB = XI+DEC + ENDIF +C +C SET TEXT ALIGNMENT TO (LEFT,HALF) IF LABELLING ON RIGHT OF Y-AXIS. +C + CALL GSTXAL(1,3) + ENDIF + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF +C + 180 TCOUNT = 1 +C + DO 200 I = 1,YTNUM + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 3) THEN + YPOS = YPOS + YINT + ELSE + IF (.NOT. LOGMIN) THEN + YCUR = YCUR * MAJDIV + ELSE + IF (TCOUNT .NE. MINCNT) THEN + YCUR = YCUR + YINT + ELSE + YCUR = YCUR + YINT + CURMAJ = NEXTMA + NEXTMA = CURMAJ * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + IF (YCUR .GT. 10.**OWIND(4)-.1*YINT) THEN + YPOS = WIND(4) + ELSE + YPOS = ALOG10(YCUR) + ENDIF + ENDIF +C + PY(1) = YPOS + PY(2) = YPOS +C +C IF IGPH = 0,1,2,4,5,6 OR 8 AND YPOS = TOP AXIS, THEN +C DRAW AXIS, ELSE IF IGPH = 9 OR 10 DRAW TIC. +C + IF (LOGVAL .EQ. 3 .OR. LOGVAL .EQ. 4) EYCUR = 10.**OWIND(4) +C + IF ((((LOGVAL .EQ. 1.OR.LOGVAL.EQ.3) .AND. (I .EQ. YTNUM)) + 1 .OR.((LOGVAL .EQ.4 .OR.LOGVAL .EQ.2).AND.YCUR.GE.EYCUR-.1*YINT)) + 2 .AND.(IGPH.NE.9.AND.IGPH.NE.10)) THEN + IF (LOOP .EQ. 1) THEN + PX(2) = WIND(2) + CALL GPL(2,PX,PY) + IF (IYLAB .EQ. 1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE + IF (YCUR .GT. EYCUR+.1*YINT) THEN + GOTO 201 + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF + ENDIF + GOTO 201 + ENDIF + IF ((LOGVAL.EQ.4 .OR. LOGVAL.EQ.2) .AND. YCUR.GT.EYCUR+.1*YINT) + 1 GOTO 201 +C +C MINOR TIC/GRID ? +C + IF (TCOUNT .NE. MINCNT .AND. MINCNT .NE. 0) THEN + IF (LGRID) THEN + CALL GSPLCI(IGRIMN) + ENDIF + CALL GPL(2,PX,PY) + IF (LGRID) THEN + CALL GSPLCI(IGRIMJ) + ENDIF + TCOUNT = TCOUNT + 1 +C +C MAJOR TIC/GRID. +C + ELSE + IF (.NOT. LGRID) THEN + PX(2) = TICBIG + ENDIF + CALL GPL(2,PX,PY) +C +C LABEL. +C + IF (IYLAB .EQ. 1 .AND. LOOP .EQ.1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX(YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF + TCOUNT = 1 + IF (.NOT. LGRID) THEN + PX(2) = TICEND + ENDIF + ENDIF + IF ((LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) .AND. + - YCUR .GE. EYCUR-.1*YINT) + 1 GOTO 201 + 200 CONTINUE + 201 CONTINUE +C +C RIGHT Y-AXIS TICKS ? +C + IF (LOOP .EQ. 1 .AND.(IGPH.EQ.1 .OR. IGPH .EQ. 5 .OR. + 1 IGPH .EQ. 9)) THEN + START = WIND(2) + TICEND = START - TICMIN + TICBIG = START - TICMAJ + PX(1) = START + PX(2) = TICEND + YPOS = WIND(3) + LOOP = 2 + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) THEN + YCUR = 10.**OWIND(3) + IF (LOGMIN) THEN + CURMAJ = YCUR + NEXTMA = YCUR * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + GOTO 180 + ENDIF +C +C RESET NORMALIZATION TRANSFORMATION TO WHAT IT WAS UPON ENTRY. +C + IF (ICNT .NE. 0) THEN + CALL GSWN(ICNT,OWIND(1),OWIND(2),OWIND(3),OWIND(4)) + CALL GSVP(ICNT,VIEW(1),VIEW(2),VIEW(3),VIEW(4)) + ENDIF + CALL GSELNT(ICNT) +C +C IF LABELS, RESTORE TEXT ATTRIBUTES. +C + IF (IXLAB .EQ. 1 .OR. IYLAB .EQ. 1) THEN + CALL GSCHH(OLDCHH) + CALL GSCHUP(CHUPX,CHUPY) + CALL GSTXAL(OLDALH,OLDALV) + CALL GSTXCI(OTEXCI) + ENDIF +C +C RESTORE ORIGINAL COLOR. +C + CALL GSPLCI(OCOLI) +C +C RESTORE POLYLINE COLOR ASF TO WHAT IS WAS ON ENTRY. +C + LASF(10) = OTXASF + LASF(3) = OPLASF + CALL GSASF(LASF) +C + 999 RETURN + END + SUBROUTINE GRID(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','GRID','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,0,0,0,0.,0.) + RETURN + END + SUBROUTINE GRIDL(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','GRIDL','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,1,1,0,0.,0.) + RETURN + END + SUBROUTINE PERIM(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','PERIM','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,0,0,5,0.,0.) + RETURN + END + SUBROUTINE PERIML(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','PERIML','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,1,1,5,0.,0.) + RETURN + END + SUBROUTINE HALFAX(MAJRX,MINRX,MAJRY,MINRY,X,Y,IXLAB,IYLAB) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','HALFAX','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB,10,X,Y) + RETURN + END + SUBROUTINE LABMOD(FMTX,FMTY,NUMX,NUMY,ISIZX,ISIZY,IXDEC,IYDEC, + 1 IXOR) +C +C RESETS PARAMETERS FOR TEXT GRAPHICS FROM DEFAULT VALUES. +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + CHARACTER*8 XFMT,YFMT,FMTX,FMTY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','LABMOD','VERSION 01') +C +C +C +NOAO - Blockdata rewritten as run time initialization. +C EXTERNAL GRIDT + call gridt +C -NOAO + XFMT = ' ' + YFMT = ' ' + XFMT = FMTX + YFMT = FMTY +C + CALL GETUSV('XF',IVAL) + XRANGE = 2. ** IVAL + CALL GETUSV('YF', IVAL) + YRANGE = 2. ** IVAL +C +C SIZX AND SIZY ARE COMPUTED TO BE PERCENTAGES OF TOTAL SCREEN +C WIDTH. +C + IF (ISIZX .GT. 3) THEN + SIZX = FLOAT(ISIZX)/XRANGE + ELSEIF (ISIZX .EQ. 3) THEN + SIZX = 24./1024. + ELSEIF (ISIZX .EQ. 2) THEN + SIZX = 16./1024. + ELSEIF (ISIZX .EQ. 1) THEN + SIZX = 12./1024. + ELSE + SIZX = 8./1024. + ENDIF +C + IF (ISIZY .GT. 3) THEN + SIZY = FLOAT(ISIZY)/XRANGE + ELSEIF (ISIZY .EQ. 3) THEN + SIZY = 24./1024. + ELSEIF (ISIZY .EQ. 2) THEN + SIZY = 16./1024. + ELSEIF (ISIZY .EQ. 1) THEN + SIZY = 12./1024. + ELSE + SIZY = 8./1024. + ENDIF +C +C CALCULATE XDEC AND YDEC AS PERCENTAGES OF TOTAL SCREEN WIDTH +C IN PLOTTER ADDRESS UNITS. +C + IF (IXDEC .EQ. 0 .OR. IXDEC .EQ. 1) THEN + YDEC = FLOAT(IXDEC) + ELSE + YDEC = FLOAT(IXDEC)/XRANGE + ENDIF + IF (IYDEC .EQ. 0 .OR. IYDEC .EQ. 1) THEN + XDEC = FLOAT(IYDEC) + ELSE + XDEC = FLOAT(IYDEC)/YRANGE + ENDIF +C + IXORI = IXOR +C + RETURN + END + SUBROUTINE TICK4(LMAJX,LMINX,LMAJY,LMINY) +C +C CHANGES TICK LENGTH FOR EACH AXIS. +C + COMMON /TICK/ MAJX, MINX, MAJY, MINY + REAL MAJX, MINX, MAJY, MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','TICK4','VERSION 01') +C + CALL GETUSV('XF', IVAL) + XRANGE = 2. ** IVAL + CALL GETUSV('YF', IVAL) + YRANGE = 2. ** IVAL +C + MAJX = FLOAT(LMAJX)/YRANGE + MINX = FLOAT(LMINX)/YRANGE + MAJY = FLOAT(LMAJY)/XRANGE + MINY = FLOAT(LMINY)/XRANGE +C + RETURN + END + SUBROUTINE TICKS(LMAJ,LMIN) +C + COMMON /TICK/ MAJX,MINX,MAJY,MINY + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','TICKS','VERSION 01') +C + CALL TICK4(LMAJ,LMIN,LMAJ,LMIN) +C + RETURN + END + SUBROUTINE CHSTR(LABEL,FIRST,LAST) +C +C THIS CALCULATES THE POSITION OF THE FIRST NON-BLANK CHARACTER +C AND THE POSITION OF THE LAST NON-BLANK CHARACTER IN LABEL. +C + INTEGER FIRST, LAST + CHARACTER*15 LABEL +C + DO 100 I = 1,15 + IF (LABEL(I:I) .NE. ' ') GOTO 200 + 100 CONTINUE + 200 FIRST = I + LAST = 15 + IF (FIRST .NE. 15) THEN + DO 300 J = FIRST+1,15 + IF (LABEL(J:J) .EQ. ' ') THEN + LAST = J-1 + GOTO 999 + ENDIF + 300 CONTINUE + 999 CONTINUE + ENDIF + RETURN + END + SUBROUTINE EXPAND(MAXW) +C +C THE WINDOW IS EXPANDED AND THE NEW WORLD COORDINATES ARE +C CALCULATED TO CORRESPOND TO THE MAXIMUM VIEWPORT. +C THE ORIGINAL ASPECT RATIO OF WORLD COORDINATES TO VIEWPORT +C COORDINATES REMAINS THE SAME. UNDER THE NEWLY-DEFINED +C NORMALIZATION TRANSFORMATION, THE WINDOW OF THE ORIGINAL +C NORMALIZATION TRANSFORMATION IS MAPPED TO THE VIEWPORT +C OF THE ORIGINAL NORMALIZATION TRANSFORMATION IN EXACTLY +C THE SAME WAY AS IN THE INITIAL NORMALIZATION TRANSFORMATION. +C + REAL MAXW(4), VIEW(4), WIND(4) + REAL LEFT +C +C INQUIRE CURRENT WINDOW AND VIEWPORT SETTINGS. +C + CALL GQCNTN(IERR,ICNT) + CALL GQNT(ICNT,IERR,WIND,VIEW) +C +C CALCULATE RATIO OF Y WORLD/VIEWPORT COORDINATES. +C + YRATIO = (WIND(4) - WIND(3))/(VIEW(4) - VIEW(3)) +C +C CALCULATE RATIO OF X WORLD/VIEWPORT COORDINATES. +C + XRATIO = (WIND(2) - WIND(1))/(VIEW(2) - VIEW(1)) +C +C GET EXPANDED LOWER LIMIT Y COORDINATE. +C + VBOTTM = VIEW(3) - 0. + BOTTOM = YRATIO * VBOTTM + MAXW(3) = WIND(3) - BOTTOM +C +C GET EXPANDED UPPER LIMIT Y COORDINATE. +C + VTOP = 1. - VIEW(4) + TOP = YRATIO * VTOP + MAXW(4) = WIND(4) + TOP +C +C GET EXPANDED LEFT LIMIT X COORDINATE. +C + VLEFT = VIEW(1) - 0. + LEFT = XRATIO * VLEFT + MAXW(1) = WIND(1) - LEFT +C +C GET EXPANDED RIGHT LIMIT X COORDINATE. +C + VRIGHT = 1. - VIEW(2) + RIGHT = XRATIO * VRIGHT + MAXW(2) = WIND(2) + RIGHT +C +C SET NEW (EXPANDED) NORMALIZATION TRANSFORMATION. +C + CALL GSWN(1,MAXW(1),MAXW(2),MAXW(3),MAXW(4)) + CALL GSVP(1, 0., 1., 0., 1. ) + CALL GSELNT(1) +C + RETURN + END diff --git a/sys/gio/ncarutil/gridt.f b/sys/gio/ncarutil/gridt.f new file mode 100644 index 00000000..eb10ddf1 --- /dev/null +++ b/sys/gio/ncarutil/gridt.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c + noao: block data gridt changed to run time initialization +c BLOCK DATA GRIDT + subroutine gridt +C +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +c +noao: following flag added to prevent initializing more than once + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. +C +c DATA XFMT,YFMT /'(E10.3) ','(E10.3) '/ + XFMT = '(E10.3) ' + YFMT = '(E10.3) ' +c +c DATA SIZX,SIZY / 0.01, 0.01 / + SIZX = 0.01 + SIZY = 0.01 +c +c DATA XDEC,YDEC / 0., 0. / + XDEC = 0. + YDEC = 0. +c +c DATA IXORI / 0 / + IXORI = 0 +c +c DATA MAJX,MINX,MAJY,MINY / 0., 0., 0., 0./ + MAJX = 0. + MINX = 0. + MAJY = 0. + MINY = 0. +c +c DATA IGRIMJ,IGRIMN,IGRITX / 1, 1, 1/ +c+noao: These values changed so major axes and labels are bold + IGRIMJ = 2 + IGRIMN = 1 + IGRITX = 2 +C - noao + END +C REVISION HISTORY--------------- +C---------------------------------------------------------- + diff --git a/sys/gio/ncarutil/hafton.f b/sys/gio/ncarutil/hafton.f new file mode 100644 index 00000000..7d597470 --- /dev/null +++ b/sys/gio/ncarutil/hafton.f @@ -0,0 +1,830 @@ + SUBROUTINE HAFTON (Z,L,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPVAL) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C SUBROUTINE HAFTON (Z,L,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPVAL) +C +C +C DIMENSION OF Z(L,M) +C ARGUMENTS +C +C LATEST REVISION JULY,1984 +C +C PURPOSE HAFTON DRAWS A HALF-TONE PICTURE FROM DATA +C STORED IN A RECTANGULAR ARRAY WITH THE +C INTENSITY IN THE PICTURE PROPORTIONAL TO +C THE DATA VALUE. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZHFTN (Z,M,N) +C +C ASSUMPTIONS: +C .ALL OF THE ARRAY IS TO BE DRAWN. +C .LOWEST VALUE IN Z WILL BE AT LOWEST +C INTENSITY ON READER/PRINTER OUTPUT. +C .HIGHEST VALUE IN Z WILL BE AT +C HIGHEST INTENSITY. +C .VALUES IN BETWEEN WILL APPEAR +C LINEARLY SPACED. +C .MAXIMUM POSSIBLE NUMBER OF +C INTENSITIES ARE USED. +C .THE PICTURE WILL HAVE A PERIMETER +C DRAWN. +C .FRAME WILL BE CALLED AFTER THE +C PICTURE IS DRAWN. +C .Z IS FILLED WITH NUMBERS THAT SHOULD +C BE USED (NO MISSING VALUES). +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL HAFTON (Z,L,M,N,FLO,HI,NLEV, +C NOPT,NPRM,ISPV,SPVAL) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZHFTN M BY N ARRAY TO BE USED TO GENERATE A +C HALF-TONE PLOT. +C +C M +C FIRST DIMENSION OF Z. +C +C N +C SECOND DIMENSION OF Z. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR EZHFTN +C +C ON INPUT Z +C FOR HAFTON THE ORIGIN OF THE ARRAY TO BE PLOTTED. +C +C L +C THE FIRST DIMENSION OF Z IN THE CALLING +C PROGRAM. +C +C M +C THE NUMBER OF DATA VALUES TO BE PLOTTED +C IN THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING ALL OF AN +C ARRAY, L = M. +C +C N +C THE NUMBER OF DATA VALUES TO BE PLOTTED +C IN THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C THE VALUE OF Z THAT CORRESPONDS TO THE +C LOWEST INTENSITY. (WHEN NOPT.LT.0, FLO +C CORRESPONDS TO THE HIGHEST INTENSITY.) +C IF FLO=HI=0.0, MIN(Z) WILL BE USED FOR FLO. +C +C HI +C THE VALUE OF Z THAT CORRESPONDS TO THE +C HIGHEST INTENSITY. (WHEN NOPT.LT.0, HI +C CORRESPONDS TO THE LOWEST INTENSITY.) IF +C HI=FLO=0.0, MAX(Z) WILL BE USED FOR HI. +C +C NLEV +C THE NUMBER OF INTENSITY LEVELS DESIRED. +C 16 MAXIMUM. IF NLEV = 0 OR 1, 16 LEVELS +C ARE USED. +C +C NOPT +C FLAG TO CONTROL THE MAPPING OF Z ONTO THE +C INTENSITIES. THE SIGN OF NOPT CONTROLS +C THE DIRECTNESS OR INVERSENESS OF THE +C MAPPING. +C +C . NOPT POSITIVE YIELDS DIRECT MAPPING. +C THE LARGEST VALUE OF Z PRODUCES THE +C MOST DENSE DOTS. ON MECHANICAL PLOTTERS, +C LARGE VALUES OF Z WILL PRODUCE A DARK +C AREA ON THE PAPER. WITH THE FILM +C DEVELOPMENT METHODS USED AT NCAR, +C LARGE VALUES OF Z WILL PRODUCE MANY +C (WHITE) DOTS ON THE FILM, ALSO +C RESULTING IN A DARK AREA ON +C READER-PRINTER PAPER. +C . NOPT NEGATIVE YIELDS INVERSE MAPPING. +C THE SMALLEST VALUES OF Z PRODUCE THE +C MOST DENSE DOTS RESULTING IN DARK +C AREAS ON THE PAPER. +C +C THE ABSOLUTE VALUE OF NOPT DETERMINES THE +C MAPPING OF Z ONTO THE INTENSITIES. FOR +C IABS(NOPT) +C = 0 THE MAPPING IS LINEAR. FOR +C EACH INTENSITY THERE IS AN EQUAL +C RANGE IN Z VALUE. +C = 1 THE MAPPING IS LINEAR. FOR +C EACH INTENSITY THERE IS AN EQUAL +C RANGE IN Z VALUE. +C = 2 THE MAPPING IS EXPONENTIAL. FOR +C LARGER VALUES OF Z, THERE IS A +C LARGER DIFFERENCE IN INTENSITY FOR +C RELATIVELY CLOSE VALUES OF Z. DETAILS +C IN THE LARGER VALUES OF Z ARE DISPLAYED +C AT THE EXPENSE OF THE SMALLER VALUES +C OF Z. +C = 3 THE MAPPING IS LOGRITHMIC, SO +C DETAILS OF SMALLER VALUES OF Z ARE SHOWN +C AT THE EXPENSE OF LARGER VALUES OF Z. +C = 4 SINUSOIDAL MAPPING, SO MID-RANGE VALUES +C OF Z SHOW DETAILS AT THE EXPENSE OF +C EXTREME VALUES OF Z. +C = 5 ARCSINE MAPPING, SO EXTREME VALUES OF +C Z ARE SHOWN AT THE EXPENSE OF MID-RANGE +C VALUES OF Z. +C +C NPRM +C FLAG TO CONTROL THE DRAWING OF A +C PERIMETER AROUND THE HALF-TONE PICTURE. +C +C . NPRM=0: THE PERIMETER IS DRAWN WITH +C TICKS POINTING AT DATA LOCATIONS. +C (SIDE LENGTHS ARE PROPORTIONAL TO NUMBER +C OF DATA VALUES.) +C . NPRM POSITIVE: NO PERIMETER IS DRAWN. THE +C PICTURE FILLS THE FRAME. +C . NPRM NEGATIVE: THE PICTURE IS WITHIN THE +C CONFINES OF THE USER'S CURRENT VIEWPORT +C SETTING. +C +C ISPV +C FLAG TO TELL IF THE SPECIAL VALUE FEATURE +C IS BEING USED. THE SPECIAL VALUE FEATURE +C IS USED TO MARK AREAS WHERE THE DATA IS +C NOT KNOWN OR HOLES ARE WANTED IN THE +C PICTURE. +C +C . ISPV = 0: SPECIAL VALUE FEATURE NOT IN +C USE. SPVAL IS IGNORED. +C . ISPV NON-ZERO: SPECIAL VALUE FEATURE +C IN USE. SPVAL DEFINES THE SPECIAL +C VALUE. WHERE Z CONTAINS THE SPECIAL +C VALUE, NO HALF-TONE IS DRAWN. IF ISPV +C = 0 SPECIAL VALUE FEATURE NOT IN USE. +C SPVAL IS IGNORED. +C = 1 NOTHING IS DRAWN IN SPECIAL VALUE +C AREA. +C = 2 CONTIGUOUS SPECIAL VALUE AREAS ARE +C SURROUNDED BY A POLYGONAL LINE. +C = 3 SPECIAL VALUE AREAS ARE FILLED +C WITH X(S). +C = 4 SPECIAL VALUE AREAS ARE FILLED IN +C WITH THE HIGHEST INTENSITY. +C +C SPVAL +C THE VALUE USED IN Z TO DENOTE MISSING +C VALUES. THIS ARGUMENT IS IGNORED IF +C ISPV = 0. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR HAFTON +C +C NOTE THIS ROUTINE PRODUCES A HUGE NUMBER OF +C PLOTTER INSTRUCTIONS PER PICTURE, AVERAGING +C OVER 100,000 LINE-DRAWS PER FRAME WHEN M = N. +C +C +C ENTRY POINTS EZHFTN, HAFTON, ZLSET, GRAY, BOUND, HFINIT +C +C COMMON BLOCKS HAFT01, HAFT02, HAFT03, HAFT04 +C +C REQUIRED LIBRARY GRIDAL, THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS HALF-TONE PICTURE. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY REWRITE OF PHOMAP ORIGINALLY WRITTEN BY +C M. PERRY OF HIGH ALTITUDE OBSERVATORY, +C NCAR. +C +C ALGORITHM BI-LINEAR INTERPOLATION ON PLOTTER +C (RESOLUTION-LIMITED) GRID OF NORMALIZED +C REPRESENTATION OF DATA. +C +C PORTABILITY ANSI FORTRAN 77. +C +C +C +C INTERNAL PARAMTERSS +C VALUES SET IN BLOCK DATA +C NAME DEFAULT FUNCTION +C ---- ------- ________ +C +C XLT 0.1 LEFT-HAND EDGE OF THE PLOT WHEN NSET=0. (0.0= +C LEFT EDGE OF FRAME, 1.0=RIGHT EDGE OF FRAME.) +C YBT 0.1 BOTTOM EDGE OF THE PLOT WHEN NSET=0. (0.0= +C BOTTOM OF FRAME, 1.0=TOP OF FRAME.) +C SIDE 0.8 LENGTH OF LONGER EDGE OF PLOT (SEE ALSO EXT). +C EXT .25 LENGTHS OF THE SIDES OF THE PLOT ARE PROPOR- +C TIONAL TO M AND N (WHEN NSET=0) EXCEPT IN +C EXTREME CASES, NAMELY, WHEN MIN(M,N)/MAX(M,N) +C IS LESS THAN EXT. THEN A SQUARE PLOT IS PRO- +C DUCED. WHEN A RECTANGULAR PLOT IS PRODUCED, +C THE PLOT IS CENTERED ON THE FRAME (AS LONG AS +C SIDE+2*XLT = SIDE+2*YBT=1., AS WITH THE +C DEFAULTS.) +C ALPHA 1.6 A PARAMETER TO CONTROL THE EXTREMENESS OF THE +C MAPPING FUNCTION SPECIFIED BY NOPT. (FOR +C IABS(NOPT)=0 OR 1, THE MAPPING FUNCTION IS +C LINEAR AND INDEPENDENT OF ALPHA.) FOR THE NON- +C LINEAR MAPPING FUNCTIONS, WHEN ALPHA IS CHANGED +C TO A NUMBER CLOSER TO 1., THE MAPPING FUNCTION +C BECOMES MORE LINEAR; WHEN ALPHA IS CHANGED TO +C A LARGER NUMBER, THE MAPPING FUNCTION BECOMES +C MORE EXTREME. +C MXLEV 16 MAXIMUM NUMBER OF LEVELS. LIMITED BY PLOTTER. +C NCRTG 8 NUMBER OF CRT UNITS PER GRAY-SCALE CELL. +C LIMITED BY PLOTTER. +C NCRTF 1024 NUMBER OF PLOTTER ADDRESS UNITS PER FRAME. +C IL (BELOW) AN ARRAY DEFINING WHICH OF THE AVAILABLE IN- +C TENSITIES ARE USED WHEN LESS THAN THE MAXIMUM +C NUMBER OF INTENSITIES ARE REQUESTED. +C +C +C NLEV INTENSITIES USED +C ____ ________________ +C 2 5,11, +C 3 4, 8,12, +C 4 3, 6,10,13, +C 5 2, 5, 8,11,14, +C 6 1, 4, 7, 9,12,15, +C 7 1, 4, 6, 8,10,12,15, +C 8 1, 3, 5, 7, 9,11,13,15, +C 9 1, 3, 4, 6, 8,10,12,13,15 +C 10 1, 3, 4, 6, 7, 9,10,12,13,15, +C 11 1, 2, 3, 5, 6, 8,10,11,13,14,15, +C 12 1, 2, 3, 5, 6, 7, 9,10,11,13,14,15, +C 13 1, 2, 3, 4, 6, 7, 8, 9,10,12,13,14,15 +C 14 1, 2, 3, 4, 5, 6, 7, 9,10,11,12,13,14,15, +C 15 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, +C 16 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15 +C +C + + SAVE + DIMENSION Z(L,N) ,PX(2) ,PY(2) + DIMENSION ZLEV(16) ,VWPRT(4) ,WNDW(4) + DIMENSION VWPR2(4) ,WND2(4) + CHARACTER*11 IDUMMY +C +C + COMMON /HAFTO1/ I ,J ,INTEN + COMMON /HAFTO2/ GLO ,HA ,NOPTN ,ALPHA , + 1 NSPV ,SP ,ICNST + COMMON /HAFTO3/ XLT ,YBT ,SIDE ,EXT , + 1 IOFFM ,ALPH ,MXLEV ,NCRTG , + 2 NCRTF ,IL(135) + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) +C +NOAO - Blockdata rewritten as run time initialization subroutine +C +C EXTERNAL HFINIT + call hfinit +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','HAFTON','HAFTON','VERSION 1') +C + NPOINT = 0 + ALPHA = ALPH + GLO = FLO + HA = HI + NLEVL = MIN0(IABS(NLEV),MXLEV) + IF (NLEVL .LE. 1) NLEVL = MXLEV + NOPTN = NOPT + IF (NOPTN .EQ. 0) NOPTN = 1 + NPRIM = NPRM + NSPV = MAX0(MIN0(ISPV,4),0) + IF (NSPV .NE. 0) SP = SPVAL + MX = L + NX = M + NY = N + CRTF = NCRTF + MSPV = 0 +C +C SET INTENSITY BOUNDARY LEVELS +C + CALL ZLSET (Z,MX,NX,NY,ZLEV,NLEVL) +C +C SET UP PERIMETER +C + X3 = NX + Y3 = NY + CALL GQCNTN (IERR,NTORIG) + CALL GETUSV('LS',IOLLS) + IF (NPRIM.LT.0) THEN + CALL GQNT (NTORIG,IERR,WNDW,VWPRT) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) + ELSE IF (NPRIM.EQ.0) THEN + X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .GE. EXT) THEN + IF (NX-NY.LT.0) THEN + X2 =SIDE*X3/Y3+XLT + X2 = (AINT(X2*CRTF/FLOAT(NCRTG))*FLOAT(NCRTG))/CRTF + ELSE IF (NX-NY.GT.0) THEN + Y2 = SIDE*Y3/X3+YBT + Y2 = (AINT(Y2*CRTF/FLOAT(NCRTG))*FLOAT(NCRTG))/CRTF + END IF + END IF + ELSE IF (NPRIM.GT.0) THEN + X1 = 0.0 + X2 = 1.0 + Y1 = 0.0 + Y2 = 1.0 + END IF + MX1 = X1*CRTF + MX2 = X2*CRTF + MY1 = Y1*CRTF + MY2 = Y2*CRTF + IF (NPRIM.GT.0) THEN + MX1 = 1 + MY1 = 1 + MX2 = NCRTF + MY2 = NCRTF + END IF +C +C SAVE NORMALIZATION TRANS 1 +C + CALL GQNT (1,IERR,WNDW,VWPRT) +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING FOR USE WITH PERIM +C DRAW PERIMETER IF NPRIM EQUALS 0 +C + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) + IF (NPRIM .EQ. 0) CALL PERIM (NX-1,1,NY-1,1) + IF (ICNST .NE. 0) THEN + CALL GSELNT (0) + CALL WTSTR(XLT*1.1,0.5,'CONSTANT FIELD',2,0,0) + GO TO 132 + END IF +C +C FIND OFFSET FOR REFERENCE TO IL, WHICH IS TRIANGULAR +C + IOFFST = NLEVL*((NLEVL-1)/2)+MOD(NLEVL-1,2)*(NLEVL/2)-1 +C +C OUTPUT INTENSITY SCALE +C + IF (NPRIM .GT. 0) GO TO 112 + LEV = 0 + KX = (1.1*XLT+SIDE)*CRTF + KY = YBT*CRTF + NNX = KX/NCRTG + 109 LEV = LEV+1 +C +NOAO +C The following statement moved from after statement label 111 (CONTINUE) to +C here. Otherwise an extra (unlabelled) grayscale box was being drawn. +C This was (eventually) causing a [floating operand error] on a Sun-3. + IF (LEV .GT. NLEVL) GO TO 112 +C -NOAO + ISUB = IOFFST+LEV + INTEN = IL(ISUB) + IF (NOPTN .LT. 0) INTEN = MXLEV-INTEN + NNY = KY/NCRTG + DO 111 JJ=1,3 + DO 110 II=1,10 + I = NNX+II + J = NNY+JJ + CALL GRAY + 110 CONTINUE + 111 CONTINUE +C +NOAO - FTN internal write rewritten as call to encode. +C WRITE(IDUMMY,'(G11.4)') ZLEV(LEV) + call encode (11, '(g11.4)', idummy, zlev(lev)) +C -NOAO + TKX = KX + TKY = KY+38 + CALL GQNT(1,IERR,WND2,VWPR2) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL WTSTR (TKX,TKY,IDUMMY,0,0,-1) + CALL SET(VWPR2(1),VWPR2(2),VWPR2(3),VWPR2(4), + - WND2(1),WND2(2),WND2(3),WND2(4),1) +C +C ADJUST 38 TO PLOTTER. +C + KY = KY+52 +C +C ADJUST 52 TO PLOTTER. +C + GO TO 109 +C +C STEP THROUGH PLOTTER GRID OF INTENSITY CELLS. +C + 112 IMIN = (MX1-1)/NCRTG+1 + IMAX = (MX2-1)/NCRTG + JMIN = (MY1-1)/NCRTG+1 + JMAX = (MY2-1)/NCRTG + XL = IMAX-IMIN+1 + YL = JMAX-JMIN+1 + XN = NX + YN = NY + LSRT = NLEVL/2 + DO 130 J=JMIN,JMAX +C +C FIND Y FOR THIS J AND Z FOR THIS Y. +C + YJ = (FLOAT(J-JMIN)+.5)/YL*(YN-1.)+1. + LOWY = YJ + YPART = YJ-FLOAT(LOWY) + IF (LOWY .NE. NY) GO TO 113 + LOWY = LOWY-1 + YPART = 1. + 113 IPEN = 0 + ZLFT = Z(1,LOWY)+YPART*(Z(1,LOWY+1)-Z(1,LOWY)) + ZRHT = Z(2,LOWY)+YPART*(Z(2,LOWY+1)-Z(2,LOWY)) + IF (NSPV .EQ. 0) GO TO 114 + IF (Z(1,LOWY).EQ.SP .OR. Z(2,LOWY).EQ.SP .OR. + 1 Z(1,LOWY+1).EQ.SP .OR. Z(2,LOWY+1).EQ.SP) IPEN = 1 + 114 IF (IPEN .EQ. 1) GO TO 117 +C +C FIND INT FOR THIS Z. +C + IF (ZLFT .GT. ZLEV(LSRT+1)) GO TO 116 + 115 IF (ZLFT .GE. ZLEV(LSRT)) GO TO 117 +C +C LOOK LOWER +C + IF (LSRT .LE. 1) GO TO 117 + LSRT = LSRT-1 + GO TO 115 +C +C LOOK HIGHER +C + 116 IF (LSRT .GE. NLEVL) GO TO 117 + LSRT = LSRT+1 + IF (ZLFT .GT. ZLEV(LSRT+1)) GO TO 116 +C +C OK +C + 117 IRHT = 2 + LAST = LSRT + DO 129 I=IMIN,IMAX +C +C FIND X FOR THIS I AND Z FOR THIS X AND Y. +C + IADD = 1 + XI = (FLOAT(I-IMIN)+.5)/XL*(XN-1.)+1. + LOWX = XI + XPART = XI-FLOAT(LOWX) + IF (LOWX .NE. NX) GO TO 118 + LOWX = LOWX-1 + XPART = 1. +C +C TEST FOR INTERPOLATION POSITIONING +C + 118 IF (LOWX .LT. IRHT) GO TO 119 +C +C MOVE INTERPOLATION ONE CELL TO THE RIGHT +C + ZLFT = ZRHT + IRHT = IRHT+1 + ZRHT = Z(IRHT,LOWY)+YPART*(Z(IRHT,LOWY+1)-Z(IRHT,LOWY)) + IF (NSPV .EQ. 0) GO TO 118 + IPEN = 0 + IF (Z(IRHT-1,LOWY).EQ.SP .OR. Z(IRHT,LOWY).EQ.SP .OR. + 1 Z(IRHT-1,LOWY+1).EQ.SP .OR. Z(IRHT,LOWY+1).EQ.SP) + 2 IPEN = 1 + GO TO 118 + 119 IF (IPEN .NE. 1) GO TO 123 +C +C SPECIAL VALUE AREA +C + GO TO (129,120,121,122),NSPV + 120 MSPV = 1 + GO TO 129 + 121 PX(1) = I*NCRTG + PY(1) = J*NCRTG + PX(2) = PX(1)+NCRTG-1 + PY(2) = PY(1)+NCRTG-1 + CALL GPL (2,PX,PY) + PYTMP = PY(1) + PY(1) = PY(2) + PY(2) = PYTMP + CALL GPL (2,PX,PY) +C + GO TO 129 + 122 INTEN = MXLEV + GO TO 128 + 123 ZZ = ZLFT+XPART*(ZRHT-ZLFT) +C +C TEST FOR SAME INT AS LAST TIME. +C + IF (ZZ .GT. ZLEV(LAST+1)) GO TO 126 + 124 IF (ZZ .GE. ZLEV(LAST)) GO TO 127 +C +C LOOK LOWER +C + IF (LAST .LE. 1) GO TO 125 + LAST = LAST-1 + GO TO 124 + 125 IF (ZZ .LT. ZLEV(LAST)) IADD = 0 + GO TO 127 +C +C LOOK HIGHER +C + 126 IF (LAST .GE. NLEVL) GO TO 127 + LAST = LAST+1 + IF (ZZ .GE. ZLEV(LAST+1)) GO TO 126 +C +C OK +C + 127 ISUB = LAST+IOFFST+IADD + INTEN = IL(ISUB) + IF (NOPTN .LT. 0) INTEN = MXLEV-INTEN + 128 CALL GRAY + 129 CONTINUE + 130 CONTINUE +C +C PUT OUT ANY REMAINING BUFFERED POINTS. +C + IF (NPOINT.GT.0) THEN + CALL GQNT(1,IERR,WND2,VWPR2) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL POINTS(XPNT,YPNT,NPOINT,0,0) + CALL SET(VWPR2(1),VWPR2(2),VWPR2(3),VWPR2(4), + - WND2(1),WND2(2),WND2(3),WND2(4),1) + ENDIF +C +C CALL BOUND IF ISPV=2 AND SPECIAL VALUES WERE FOUND. +C + IF (MSPV .EQ. 1) THEN + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) + CALL BOUND (Z,MX,NX,NY,SP) + END IF + 132 CONTINUE +C +C RESTORE NORMALIZATION TRANS 1 AND ORIGINAL NORMALIZATION NUMBER +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL SETUSV('LS',IOLLS) + CALL GSELNT (NTORIG) + RETURN +C + END + SUBROUTINE ZLSET (Z,MX,NX,NY,ZL,NLEVL) + SAVE +C + DIMENSION Z(MX,NY) ,ZL(NLEVL) +C + COMMON /HAFTO2/ GLO ,HA ,NOPTN ,ALPHA , + 1 NSPV ,SP ,ICNST +C + BIG = R1MACH(2) +C +C ZLSET PUTS THE INTENSITY LEVEL BREAK POINTS IN ZL. +C ALL ARGUMENTS ARE AS IN HAFTON. +C + LX = NX + LY = NY + NLEV = NLEVL + NOPT = IABS(NOPTN) + RALPH = 1./ALPHA + ICNST = 0 + IF (GLO.NE.0. .OR. HA.NE.0.) GO TO 106 +C +C FIND RANGE IF NOT KNOWN. +C + GLO = BIG + HA = -GLO + IF (NSPV .NE. 0) GO TO 103 + DO 102 J=1,LY + DO 101 I=1,LX + ZZ = Z(I,J) + GLO = AMIN1(ZZ,GLO) + HA = AMAX1(ZZ,HA) + 101 CONTINUE + 102 CONTINUE + GO TO 106 + 103 DO 105 J=1,LY + DO 104 I=1,LX + ZZ = Z(I,J) + IF (ZZ .EQ. SP) GO TO 104 + GLO = AMIN1(ZZ,GLO) + HA = AMAX1(ZZ,HA) + 104 CONTINUE + 105 CONTINUE +C +C FILL ZL +C + 106 DELZ = HA-GLO + IF (DELZ .EQ. 0.) GO TO 115 + DZ = DELZ/FLOAT(NLEV) + NLEVM1 = NLEV-1 + DO 114 K=1,NLEVM1 + ZNORM = FLOAT(K)/FLOAT(NLEV) + GO TO (107,108,109,110,111),NOPT +C +C NOPT=1 +C + 107 ZL(K) = GLO+FLOAT(K)*DZ + GO TO 114 +C +C NOPT=2 +C + 108 ONORM = (1.-(1.-ZNORM)**ALPHA)**RALPH + GO TO 113 +C +C NOPT=3 +C + 109 ONORM = 1.-(1.-ZNORM**ALPHA)**RALPH + GO TO 113 +C +C NOPT=4 +C + 110 ONORM = .5*(1.-(ABS(ZNORM+ZNORM-1.))**ALPHA)**RALPH + GO TO 112 +C +C NOPT=5 +C + 111 ZNORM2 = ZNORM+ZNORM + IF (ZNORM .GT. .5) ZNORM2 = 2.-ZNORM2 + ONORM = .5*(1.-(1.-ABS(ZNORM2)**ALPHA)**RALPH) + 112 IF (ZNORM .GT. .5) ONORM = 1.-ONORM + 113 ZL(K) = GLO+DELZ*ONORM + 114 CONTINUE + ZL(NLEV) = BIG + RETURN + 115 ICNST = 1 + RETURN + END + SUBROUTINE GRAY +C +C SUBROUTINE GRAY COLORS HALF-TONE CELL (I,J) WITH INTENSITY INTEN. +C THE ROUTINE ASSUMES 8X8 CELL SIZE ON A VIRTUAL SCREEN 1024X1024. +C + DIMENSION IFOT(16) ,JFOT(16) + DIMENSION WNDW(4) ,VWPRT(4) +CCC DIMENSION MX(16) ,MY(16) + COMMON /HAFTO1/ I ,J ,INTEN + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) + SAVE +C + DATA + 1 IFOT(1),IFOT(2),IFOT(3),IFOT(4),IFOT(5),IFOT(6),IFOT(7),IFOT(8)/ + 2 1, 5, 1, 5, 3, 7, 3, 7 / + DATA + 1 IFOT(9),IFOT(10),IFOT(11),IFOT(12),IFOT(13),IFOT(14),IFOT(15)/ + 2 3, 7, 3, 7, 1, 5, 1/, + 3 IFOT(16)/ + 4 5 / +C + DATA + 1 JFOT(1),JFOT(2),JFOT(3),JFOT(4),JFOT(5),JFOT(6),JFOT(7),JFOT(8)/ + 2 1, 5, 5, 1, 3, 7, 7, 3 / + DATA + 1 JFOT(9),JFOT(10),JFOT(11),JFOT(12),JFOT(13),JFOT(14),JFOT(15)/ + 2 1, 5, 5, 1, 3, 7, 7/, + 3 JFOT(16)/ + 4 3 / +C + IF (INTEN) 103,103,101 + 101 I1 = I*8 + J1 = J*8 + IF ((NPOINT+INTEN) .LE.NPTMAX) GO TO 1015 + CALL GQNT(1,IERR,WNDW,VWPRT) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL POINTS(XPNT,YPNT,NPOINT,0,0) + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),1) + NPOINT = 0 + 1015 DO 102 I2=1,INTEN + NPOINT = NPOINT + 1 + XPNT(NPOINT) = I1+IFOT(I2) + YPNT(NPOINT) = J1+JFOT(I2) + 102 CONTINUE + 103 RETURN + END + SUBROUTINE BOUND (Z,MX,NNX,NNY,SSP) + DIMENSION Z(MX,NNY) ,PX(2) ,PY(2) +C +C BOUND DRAWS A POLYGONAL BOUNDRY AROUND ANY SPECIAL-VALUE AREAS IN Z. +C + SAVE + NX = NNX + NY = NNY +C +C VERTICAL LINES +C + SP = SSP + DO 103 IP1=3,NX + I = IP1-1 + PX(1) = I + PX(2) = I + IM1 = I-1 + DO 102 JP1=2,NY + PY(2) = JP1 + J = JP1-1 + PY(1) = J + KLEFT = 0 + IF (Z(IM1,J).EQ.SP .OR. Z(IM1,JP1).EQ.SP) KLEFT = 1 + KCENT = 0 + IF (Z(I,J).EQ.SP .OR. Z(I,JP1).EQ.SP) KCENT = 1 + KRIGT = 0 + IF (Z(IP1,J).EQ.SP .OR. Z(IP1,JP1).EQ.SP) KRIGT = 1 + JUMP = KLEFT*4+KCENT*2+KRIGT+1 + GO TO (102,101,102,102,101,102,102,102,102),JUMP + 101 CALL GPL (2,PX,PY) + 102 CONTINUE + 103 CONTINUE +C +C HORIZONTAL +C + DO 106 JP1=3,NY + J = JP1-1 + PY(1) = J + PY(2) = J + JM1 = J-1 + DO 105 IP1=2,NX + PX(2) = IP1 + I = IP1-1 + PX(1) = I + KLOWR = 0 + IF (Z(I,JM1).EQ.SP .OR. Z(IP1,JM1).EQ.SP) KLOWR = 1 + KCENT = 0 + IF (Z(I,J).EQ.SP .OR. Z(IP1,J).EQ.SP) KCENT = 1 + KUPER = 0 + IF (Z(I,JP1).EQ.SP .OR. Z(IP1,JP1).EQ.SP) KUPER = 1 + JUMP = KLOWR*4+KCENT*2+KUPER+1 + GO TO (105,104,105,105,104,105,105,105,105),JUMP + 104 CALL GPL (2,PX,PY) + 105 CONTINUE + 106 CONTINUE + RETURN + END + SUBROUTINE EZHFTN (Z,M,N) +C + DIMENSION Z(M,N) + SAVE +C +C HALF-TONE PICTURE VIA SHORTEST ARGUMENT LIST. +C ASSUMPTIONS-- +C ALL OF THE ARRAY IS TO BE DRAWN, +C LOWEST VALUE IN Z WILL BE AT LOWEST INTENSITY ON READER/PRINTER +C OUTPUT, HIGHEST VALUE IN Z WILL BE AT HIGHEST INTENSITY, VALUES IN +C BETWEEN WILL APPEAR LINEARLY SPACED, MAXIMUM POSSIBLE NUMBER OF +C INTENSITIES ARE USED, THE PICTURE WILL HAVE A PERIMETER DRAWN, +C FRAME WILL BE CALLED AFTER THE PICTURE IS DRAWN, Z IS FILLED WITH +C NUMBERS THAT SHOULD BE USED (NO UNKNOWN VALUES). +C IF THESE CONDITIONS ARE NOT MET, USE HAFTON. +C EZHFTN ARGUMENTS-- +C Z 2 DIMENSIONAL ARRAY TO BE USED TO GENERATE A HALF-TONE PLOT. +C M FIRST DIMENSION OF Z. +C N SECOND DIMENSION OF Z. +C + DATA FLO,HI,NLEV,NOPT,NPRM,ISPV,SPV/0.0,0.0,0,0,0,0,0.0/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','HAFTON','EZHFTN','VERSION 1') +C + CALL HAFTON (Z,M,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPV) +C +C +NOAO - EZHFTN no longer calls frame. +C CALL FRAME +C -NOAO + RETURN + END +C +C----------------------------------------------------------------------- +C +C REVISION HISTORY--- +C +C JULY 1984 CONVERTED TO FORTAN 77 AND GKS +C +C MARCH 1983 INSTITUTED BUFFERING OF POINTS WITHIN ROUTINE GRAY, +C WHICH DRAMATICALLY REDUCES SIZE OF OUTPUT PLOT CODE, +C METACODE. THIS IN TURN GENERALLY IMPROVES THROUGHPUT +C OF METACODE INTERPRETERS. +C +C FEBRUARY 1979 MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C +C----------------------------------------------------------------------- +C diff --git a/sys/gio/ncarutil/hfinit.f b/sys/gio/ncarutil/hfinit.f new file mode 100644 index 00000000..e64207eb --- /dev/null +++ b/sys/gio/ncarutil/hfinit.f @@ -0,0 +1,229 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data hfinit changed to run time initialization +c BLOCKDATA HFINIT + subroutine hfinit +C + COMMON /HAFTO3/ XLT ,YBT ,SIDE ,EXT, + 1 IOFFM ,ALPH ,MXLEV ,NCRTG , + 2 NCRTF ,IL(135) + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) +C +C INITIALIZATION OF INTERNAL PARAMETERS +C +c DATA XLT, YBT,SIDE,EXT,IOFFM,ALPH,MXLEV,NCRTG,NCRTF/ +c 1 0.102,0.102,.805,.25, 0, 1.6, 16, 8, 1024/ +c +c +noao: following flag added to prevent initializing more than once + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + +c +noao: call to utilbd added to make sure those parameters set by getusv +c have been set before they are retrieved. + call utilbd +c -noao + XLT = 0.102 + YBT = 0.102 + SIDE = .805 + EXT = .25 + IOFFM = 0 + ALPH = 1.6 + MXLEV = 16 + NCRTG = 8 + NCRTF = 1024 +c +c DATA IL(1),IL(2),IL(3),IL(4),IL(5),IL(6),IL(7),IL(8),IL(9),IL(10), +c 1IL(11),IL(12),IL(13),IL(14),IL(15),IL(16),IL(17),IL(18),IL(19), +c 2IL(20),IL(21),IL(22),IL(23),IL(24),IL(25),IL(26),IL(27),IL(28), +c 3IL(29),IL(30),IL(31),IL(32),IL(33),IL(34),IL(35),IL(36),IL(37), +c 4IL(38),IL(39),IL(40),IL(41),IL(42),IL(43),IL(44)/ +c 5 5,11, +c 6 4, 8,12, +c 7 3, 6,10,13, +c 8 2, 5, 8,11,14, +c 9 1, 4, 7, 9,12,15, +c + 1, 4, 6, 8,10,12,15, +c 1 1, 3, 5, 7, 9,11,13,15, +c 2 1, 3, 4, 6, 8, 10, 12, 13, 15/ +c + IL(1) = 5 + IL(2) = 11 + IL(3) = 4 + IL(4) = 8 + IL(5) = 12 + IL(6) = 3 + IL(7) = 6 + IL(8) = 10 + IL(9) = 13 + IL(10) = 2 + IL(11) = 5 + IL(12) = 8 + IL(13) = 11 + IL(14) = 14 + IL(15) = 1 + IL(16) = 4 + IL(17) = 7 + IL(18) = 9 + IL(19) = 12 + IL(20) = 15 + IL(21) = 1 + IL(22) = 4 + IL(23) = 6 + IL(24) = 8 + IL(25) = 10 + IL(26) = 12 + IL(27) = 15 + IL(28) = 1 + IL(29) = 3 + IL(30) = 5 + IL(31) = 7 + IL(32) = 9 + IL(33) = 11 + IL(34) = 13 + IL(35) = 15 + IL(36) = 1 + IL(37) = 3 + IL(38) = 4 + IL(39) = 6 + IL(40) = 8 + IL(41) = 10 + IL(42) = 12 + IL(43) = 13 + IL(44) = 15 +c +c DATA IL(45),IL(46), +c 1IL(47),IL(48),IL(49),IL(50),IL(51),IL(52),IL(53),IL(54),IL(55), +c 2IL(56),IL(57),IL(58),IL(59),IL(60),IL(61),IL(62),IL(63),IL(64), +c 3IL(65),IL(66),IL(67),IL(68),IL(69),IL(70),IL(71),IL(72),IL(73), +c 4IL(74),IL(75),IL(76),IL(77),IL(78),IL(79),IL(80),IL(81),IL(82), +c 5IL(83),IL(84),IL(85),IL(86),IL(87),IL(88),IL(89),IL(90)/ +c 6 1, 3, 4, 6, 7, 9,10,12,13,15, +c 7 1, 2, 3, 5, 6, 8,10,11,13,14,15, +c 8 1, 2, 3, 5, 6, 7, 9,10,11,13,14,15, +c 9 1, 2, 3, 4, 6, 7, 8, 9, 10, 12, 13, 14, 15/ +c + IL(45) = 1 + IL(46) = 3 + IL(47) = 4 + IL(48) = 6 + IL(49) = 7 + IL(50) = 9 + IL(51) = 10 + IL(52) = 12 + IL(53) = 13 + IL(54) = 15 + IL(55) = 1 + IL(56) = 2 + IL(57) = 3 + IL(58) = 5 + IL(59) = 6 + IL(60) = 8 + IL(61) = 10 + IL(62) = 11 + IL(63) = 13 + IL(64) = 14 + IL(65) = 15 + IL(66) = 1 + IL(67) = 2 + IL(68) = 3 + IL(69) = 5 + IL(70) = 6 + IL(71) = 7 + IL(72) = 9 + IL(73) = 10 + IL(74) = 11 + IL(75) = 13 + IL(76) = 14 + IL(77) = 15 + IL(78) = 1 + IL(79) = 2 + IL(80) = 3 + IL(81) = 4 + IL(82) = 6 + IL(83) = 7 + IL(84) = 8 + IL(85) = 9 + IL(86) = 10 + IL(87) = 12 + IL(88) = 13 + IL(89) = 14 + IL(90) = 15 +c +c DATA IL(91), +c 1IL(92),IL(93),IL(94),IL(95),IL(96),IL(97),IL(98),IL(99),IL(100), +c 2IL(101),IL(102),IL(103),IL(104),IL(105),IL(106),IL(107),IL(108), +c 3IL(109),IL(110),IL(111),IL(112),IL(113),IL(114),IL(115),IL(116), +c 4IL(117),IL(118),IL(119),IL(120),IL(121),IL(122),IL(123),IL(124), +c 5IL(125),IL(126),IL(127),IL(128),IL(129),IL(130),IL(131),IL(132), +c 6IL(133),IL(134),IL(135)/ +c 7 1, 2, 3, 4, 5, 6, 7, 9,10,11,12,13,14,15, +c 8 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, +c 9 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15/ +c + IL(91) = 1 + IL(92) = 2 + IL(93) = 3 + IL(94) = 4 + IL(95) = 5 + IL(96) = 6 + IL(97) = 7 + IL(98) = 9 + IL(99) = 10 + IL(100) = 11 + IL(101) = 12 + IL(102) = 13 + IL(103) = 14 + IL(104) = 15 + IL(105) = 1 + IL(106) = 2 + IL(107) = 3 + IL(108) = 4 + IL(109) = 5 + IL(110) = 6 + IL(111) = 7 + IL(112) = 8 + IL(113) = 9 + IL(114) = 10 + IL(115) = 11 + IL(116) = 12 + IL(117) = 13 + IL(118) = 14 + IL(119) = 15 + IL(120) = 0 + IL(121) = 1 + IL(122) = 2 + IL(123) = 3 + IL(124) = 4 + IL(125) = 5 + IL(126) = 6 + IL(127) = 7 + IL(128) = 8 + IL(129) = 9 + IL(130) = 10 + IL(131) = 11 + IL(132) = 12 + IL(133) = 13 + IL(134) = 14 + IL(135) = 15 +c +C SIZE OF THE COORDINATE BUFFERING ARRAYS FOR POINTS BUFFERING. +c DATA NPTMAX/50/ + NPTMAX = 50 +c -noao + END diff --git a/sys/gio/ncarutil/isosrb.f b/sys/gio/ncarutil/isosrb.f new file mode 100644 index 00000000..5c1481a0 --- /dev/null +++ b/sys/gio/ncarutil/isosrb.f @@ -0,0 +1,98 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: blockdata isosrb changed to run time initialization subroutine + subroutine isosrb +c BLOCKDATA ISOSRB +C +C BLOCK DATA +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY, + 1 IS ,ISS ,NP ,CV, + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD, + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX, + 2 IFSY ,FIRST ,IYDIR ,IHX, + 3 IHB ,IHS ,IHV ,IVOLD, + 4 IVAL ,IHRX ,YCHANG ,ITPD, + 5 IHF + COMMON /ISOSR9/ BIG ,IXBIT + COMMON /TEMPR/ RZERO + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF +C + logical first1 + SAVE + data first1 /.true./ + if (.not. first1) then + return + endif + first1 = .false. +c +c DATA LX,NX,NY/8,128,128/ + LX = 8 + NX = 128 + NY = 128 +c +c DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ +c 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + INX(1) = -1 + INX(2) = -1 + INX(3) = 0 + INX(4) = 1 + INX(5) = 1 + INX(6) = 1 + INX(7) = 0 + INX(8) = -1 +c +c DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ +c 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + INY(1) = 0 + INY(2) = 1 + INY(3) = 1 + INY(4) = 1 + INY(5) = 0 + INY(6) = -1 + INY(7) = -1 + INY(8) = -1 +c +c DATA NR/500/ + NR = 500 +c +c DATA NBPW/16/ + NBPW = 16 +c +c DATA IHF/.FALSE./ + IHF = .FALSE. +C +c DATA GENDON /.FALSE./ + GENDON = .FALSE. +c +c DATA RZERO/0./ + RZERO = 0. +C +C +C RX = (NX-1)/SCREEN WIDTH FROM TRN32I +C RY = (NY-1)/SCREEN HEIGHT FROM TRN32I +C +c DATA RX,RY/.00389,.00389/ + RX = .00389 + RY = .00389 +C +c -noao + END diff --git a/sys/gio/ncarutil/isosrf.f b/sys/gio/ncarutil/isosrf.f new file mode 100644 index 00000000..7be532ee --- /dev/null +++ b/sys/gio/ncarutil/isosrf.f @@ -0,0 +1,1696 @@ + SUBROUTINE ISOSRF (T,LU,MU,LV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C DIMENSION OF T(LU,LV,MW),EYE(3),SLAB(MUVWP2,MUVWP2) +C ARGUMENTS +C +C LATEST REVISION DECEMBER 1984 +C +C PURPOSE ISOSRF DRAWS AN APPROXIMATION OF AN ISO-VALUED +C SURFACE FROM A THREE-DIMENSIONAL ARRAY WITH +C HIDDEN LINES REMOVED. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZISOS (T,MU,MV,MW,EYE,SLAB,TISO) +C +C ASSUMPTIONS: +C -- ALL OF THE T ARRAY IS TO BE USED. +C -- IFLAG IS CHOSEN INTERNALLY. +C -- FRAME IS CALLED BY EZISOS. +C +C IF THE ASSUMPTIONS ARE NOT MET, USE +C +C CALL ISOSRF (T,LU,MU,LV,MV,MW,EYE,MUVWP2, +C SLAB,TISO,IFLAG) +C +C ARGUMENTS +C +C ON INPUT T +C THREE DIMENSIONAL ARRAY OF DATA THAT DEFINES +C THE ISO-VALUED SURFACE. +C +C LU +C FIRST DIMENSION OF T IN THE CALLING PROGRAM. +C +C MU +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE U DIRECTION (THE FIRST +C SUBSCRIPT DIRECTION). WHEN PROCESSING THE +C ENTIRE ARRAY, LU = MU (AND LV = MV). +C +C LV +C SECOND DIMENSION OF T IN THE CALLING PROGRAM. +C +C MV +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE V DIRECTION (THE SECOND +C SUBSCRIPT DIRECTION). +C +C MV +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE W DIRECTION (THE THIRD +C SUBSCRIPT DIRECTION). +C +C EYE +C THE POSITION OF THE EYE IN THREE-SPACE. T IS +C CONSIDERED TO BE IN A BOX WITH OPPOSITE +C CORNERS (1,1,1) AND (MU,MV,MW). THE EYE IS +C AT (EYE(1),EYE(2),EYE(3)), WHICH MUST BE +C OUTSIDE THE BOX THAT CONTAINS T. WHILE GAINING +C EXPERIENCE WITH THE ROUTINE, A GOOD CHOICE +C FOR EYE MIGHT BE (5.0*MU,3.5*MV,2.0*MW). +C +C MUVWP2 +C THE MAXIMUM OF (MU,MV,MW)+2; THAT IS, +C MUVWP2 = MAX(MU,MV,MW)+2). +C +C SLAB +C A WORK SPACE USED FOR INTERNAL STORAGE. SLAB +C MUST BE AT LEAST MUVWP2*MUVWP2 WORDS LONG. +C +C TISO +C THE ISO-VALUE USED TO DEFINE THE SURFACE. THE +C SURFACE DRAWN WILL SEPARATE VOLUMES OF T THAT +C HAVE VALUES GREATER THAN OR EQUAL TO TISO FROM +C VOLUMES OF T THAT HAVE VALUES LESS THAN TISO. +C +C IFLAG +C THIS FLAG SERVES TWO PURPOSES. +C . FIRST, THE ABSOLUTE VALUE OF IFLAG +C DETERMINES WHICH TYPES OF LINES ARE DRAWN +C TO APPROXIMATE THE SURFACE. THREE TYPES +C OF LINES ARE CONSIDERED: LINES OF +C CONSTANT U, LINES OF CONSTANT V AND LINES +C OF CONSTANT W. THE FOLLOWING TABLE LISTS +C THE TYPES OF LINES DRAWN. +C +C LINES OF CONSTANT +C ----------------- +C IABS(IFLAG) U V W +C ----------- --- --- --- +C 1 NO NO YES +C 2 NO YES NO +C 3 NO YES YES +C 4 YES NO NO +C 5 YES NO YES +C 6 YES YES NO +C 0, 7 OR MORE YES YES YES +C +C . SECOND, THE SIGN OF IFLAG DETERMINES WHAT +C IS INSIDE AND WHAT IS OUTSIDE, HENCE, +C WHICH LINES ARE VISIBLE AND WHAT IS DONE +C AT THE BOUNDARY OF T. FOR IFLAG: +C +C POSITIVE T VALUES GREATER THAN TISO ARE +C ASSUMED TO BE INSIDE THE SOLID +C FORMED BY THE DRAWN SURFACE. +C NEGATIVE T VALUES LESS THAN TISO ARE +C ASSUMED TO BE INSIDE THE SOLID +C FORMED BY THE DRAWN SURFACE. +C IF THE ALGORITHM DRAWS A CUBE, REVERSE THE +C SIGN OF IFLAG. +C +C ON OUTPUT T,LU,MU,LV,MV,MW,EYE,MUVWP2,TISO AND IFLAG ARE +C UNCHANGED. SLAB HAS BEEN WRITTEN IN. +C +C NOTE . THIS ROUTINE IS FOR LOWER RESOLUTION ARRAYS +C THAN ISOSRFHR. 40 BY 40 BY 40 IS A +C PRACTICAL MAXIMUM. +C . TRANSFORMATIONS CAN BE ACHIEVED BY +C ADJUSTING SCALING STATEMENT FUNCTIONS IN +C ISOSRF, SET3D AND TR32. +C . THE HIDDEN-LINE ALGORITHM IS NOT EXACT, SO +C VISIBILITY ERRORS CAN OCCUR. +C . THREE-DIMENSIONAL PERSPECTIVE CHARACTER +C LABELING OF ISOSRF IS POSSIBLE BY USING +C THE UTILITY PWRZI. FOR A DESCRIPTION OF +C THE USAGE, SEE THE PWRZI DOCUMENTATION. +C +C ENTRY POINTS ISOSRF, EZISOS, SET3D, TRN32I, ZEROSC, +C STCNTR, DRCNTR, TR32, FRSTS, KURV1S, KURV2S, +C FRSTC, FILLIN, DRAWI, ISOSRB, MMASK +C +C COMMON BLOCKS ISOSR1, ISOSR2, ISOSR3, ISOSR4, ISOSR5, +C ISOSR6, ISOSR7, ISOSR8, ISOSR9, TEMPR, +C PWRZ1I +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SURFACE +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED FOR USERS OF ISOSRFHR WITH SMALLER +C ARRAYS. +C +C ALGORITHM CUTS THROUGH THE THREE-DIMENSIONAL ARRAY ARE +C CONTOURED WITH A SMOOTHING CONTOURER WHICH ALSO +C MARKS A MODEL OF THE PLOTTING PLANE. INTERIORS +C OF BOUNDARIES ARE FILLED IN AND THE RESULT IS +C .OR.ED INTO ANOTHER MODEL OF THE PLOTTING PLANE +C WHICH IS USED TO TEST SUBSEQUENT CONTOUR LINES +C FOR VISIBILITY. +C +C TIMING VARIES WIDELY WITH SIZE OF T AND THE VOLUME OF +C THE SPACE ENCLOSED BY THE SURFACE DRAWN. +C +C **NOTE** SPACE REQUIREMENTS CAN BE REDUCED BY +C CHANGING THE SIZE OF THE ARRAYS ISCR, ISCA +C (FOUND IN COMMON ISOSR2), MASK(FOUND IN +C COMMON ISOSR5) AND THE VARIABLE NBPW +C (COMMON ISOSR5). +C ISCR AND ISCA NEED 128X128 BITS. SO ON A +C 64 BIT MACHINE ISCR, ISCA CAN BE +C DIMENSIONED TO (2,128). NBPW SET IN +C SUBROUTINE MMASK SHOULD CONTAIN THE +C NUMBER OF BITS PER WORD YOU WISH TO +C UTILIZE. +C THE DIMENSION OF MASK AND NMASK SHOULD +C EQUAL THE VALUE OF NBPW. +C LS SHOULD BE SET TO THE FIRST DIMENSION +C OF ISCA AND ISCR. +C +C EXAMPLES: +C ON A 60 BIT MACHINE: +C DIMENSION ISCA(4,128), ISCR(4,128) +C DIMENSION MASK(32) +C NBPW = 32 +C ON A 64 BIT MACHINE: +C DIMENSION ISCA(2,128), ISCR(2,128) +C DIMENSION MASK(64) +C NBPW = 64 +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C IREF 1 FLAG TO CONTROL DRAWING OF AXES. +C .IREF=NONZERO DRAW AXES. +C .IREF=ZERO DO NOT DRAW AXES. +C +C + SAVE + DIMENSION T(LU,LV,MW),EYE(3) ,SLAB(MUVWP2,MUVWP2) +C + COMMON /ISOSR1/ ISLBT ,U ,V ,W + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR9/ BIG ,IXBIT +C + LOGICAL GENDON + DATA IREF/1/ +C + AVE(A,B) = (A+B)*.5 +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C +NOAO - Blockdata ISOSRB rewritten as run time initialization +C EXTERNAL ISOSRB + call isosrb +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','ISOSRF','ISOSRF','VERSION 12') + NERR = 0 +C +C 3-SPACE U,V,W,IU,IV,IW,ETC +C 2-SPACE X,Y,IX,IY,ETC +C +C INITIALIZE MASKS +C + IF (.NOT.GENDON) CALL MMASK +C +C SET SHIFT VALUE FOR X,Y PACKING +C +C IF YOUR MACHINE HAS MORE THAN 16 BITS PER WORD THIS CHECK MAY BE +C MODIFIED +C + IF (LU .LE. 256) GO TO 10 + NERR = NERR + 1 + CALL SETER('DIMENSION OF CUBE EXCEEDS 256',NERR,2) + RETURN + 10 DO 20 J=1,30 + IF (LU .LE. 2**(J-1)) GO TO 30 + 20 CONTINUE + 30 IXBIT = J + NU = MU + NUP2 = NU+2 + NV = MV + NVP2 = NV+2 + NW = MW + NWP2 = NW+2 + FNU = NU + FNV = NV + FNW = NW + SU1 = SU(1.) + SV1 = SV(1.) + SW1 = SW(1.) + SUNU = SU(FNU) + SVNV = SV(FNV) + SWNW = SW(FNW) + AVEU = AVE(SU1,SUNU) + AVEV = AVE(SV1,SVNV) + AVEW = AVE(SW1,SWNW) + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) + NUVWP2 = MUVWP2 + TVAL = TISO + NFLAG = IABS(IFLAG) + IF (NFLAG.EQ.0 .OR. NFLAG.GE.8) NFLAG = 7 +C +C SET UP SCALING +C + FACT = -ISIGN(1,IFLAG) + CALL SET3D (EYE,1.,FNU,1.,FNV,1.,FNW) +C +C BOUND LOWER AND LEFT EDGE OF SLAB +C + EDGE = SIGN(BIG,FACT) + DO 40 IUVW=1,NUVWP2 + SLAB(IUVW,1) = EDGE + SLAB(1,IUVW) = EDGE + 40 CONTINUE +C +C SLICES PERPENDICULAR TO U. THAT IS, V W SLICES. T OF CONSTANT U. +C + IF (NFLAG .LT. 4) GO TO 100 + CALL ZEROSC + ISLBT = -1 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 50 IV=2,NVP2 + SLAB(IV,NWP2) = EDGE + 50 CONTINUE + DO 60 IW=2,NWP2 + SLAB(NVP2,IW) = EDGE + 60 CONTINUE +C +C GO THRU 3-D ARRAY IN U DIRECTION. IUEW=IU EITHER WAY. +C PICK IU BASED ON EYEU. +C + DO 90 IUEW=1,NU + IU = IUEW + IF (EYEU .GT. AVEU) IU = NU+1-IUEW + U = IU +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 80 IV=1,NV + DO 70 IW=1,NW + SLAB(IV+1,IW+1) = T(IU,IV,IW) + 70 CONTINUE + 80 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NVP2,NWP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 90 CONTINUE +C +C SLICES PERPENDICULAR TO V. U W SLICES. T OF CONSTANT V. +C + 100 IF (MOD(NFLAG/2,2) .EQ. 0) GO TO 160 + CALL ZEROSC + ISLBT = 0 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 110 IU=2,NUP2 + SLAB(IU,NWP2) = EDGE + 110 CONTINUE + DO 120 IW=2,NWP2 + SLAB(NUP2,IW) = EDGE + 120 CONTINUE +C +C GO THRU T IN V DIRECTION. IVEW=IV EITHER WAY. +C + DO 150 IVEW=1,NV + IV = IVEW + IF (EYEV .GT. AVEV) IV = NV+1-IVEW + V = IV +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 140 IU=1,NU + DO 130 IW=1,NW + SLAB(IU+1,IW+1) = T(IU,IV,IW) + 130 CONTINUE + 140 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NUP2,NWP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 150 CONTINUE +C +C SLICES PERPENDICULAR TO W. U V SLICES. T OF CONSTANT W. +C + 160 IF (MOD(NFLAG,2) .EQ. 0) GO TO 220 + CALL ZEROSC +C + ISLBT = 1 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 170 IU=2,NUP2 + SLAB(IU,NVP2) = EDGE + 170 CONTINUE + DO 180 IV=2,NVP2 + SLAB(NUP2,IV) = EDGE + 180 CONTINUE +C +C GO THRU T IN W DIRECTION. +C + DO 210 IWEW=1,NW + IW = IWEW + IF (EYEW .GT. AVEW) IW = NW+1-IWEW + W = IW +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 200 IU=1,NU + DO 190 IV=1,NV + SLAB(IU+1,IV+1) = T(IU,IV,IW) + 190 CONTINUE + 200 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NUP2,NVP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 210 CONTINUE +C +C DRAW REFERENCE PLANE EDGES AND W AXIS. +C + 220 IF (IREF .EQ. 0) RETURN + CALL TRN32I (SU1,SV1,SW1,XT,YT,DUM,2) + IF (EYEV .LT. SV1) GO TO 240 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 230 IU=2,NU + CALL TRN32I (SU(FLOAT(IU)),SV1,SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 230 CONTINUE + GO TO 250 + 240 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SUNU,SV1,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 250 IF (EYEU .GT. SUNU) GO TO 270 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 260 IV=2,NV + CALL TRN32I (SUNU,SV(FLOAT(IV)),SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 260 CONTINUE + GO TO 280 + 270 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SUNU,SVNV,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 280 IF (EYEV .GT. SVNV) GO TO 300 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 290 IUOW=2,NU + CALL TRN32I (SU(FLOAT(NU-IUOW+1)),SVNV,SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 290 CONTINUE + GO TO 310 + 300 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SVNV,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 310 IF (EYEU .LT. SU1) GO TO 330 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 320 IVOW=2,NV + CALL TRN32I (SU1,SV(FLOAT(NV-IVOW+1)),SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 320 CONTINUE + GO TO 340 + 330 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SV1,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 340 IF (EYEU.LE.SU1 .OR. EYEV.LE.SV1) GO TO 360 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 350 IW=2,NW + CALL TRN32I (SU1,SV1,SW(FLOAT(IW)),XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 350 CONTINUE +C +NOAO - Plotit buffer needs to be flushed before returning. + call plotit (0, 0, 2) +C -NOAO + RETURN + 360 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SV1,SWNW,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) +C +NOAO - Plotit buffer needs to be flushed before returning. + call plotit (0, 0, 2) +C -NOAO + RETURN + END + SUBROUTINE EZISOS (T,MU,MV,MW,EYE,SLAB,TISO) +C + SAVE + DIMENSION T(MU,MV,MW),EYE(3) +C + DATA ANG,PI/.35,3.141592/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','ISOSRF','EZISOS','VERSION 12') +C +C ARGUMENTS DESCRIBED IN ISOSRF +C +C PICK TYPES OF LINES TO DRAW +C + NU = MU + NV = MV + NW = MW + TVAL = TISO + MAX = MAX0(NU,NV,NW)+2 + ATU = NU/2 + ATV = NV/2 + ATW = NW/2 + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) + RU = EYEU-ATU + RV = EYEV-ATV + RW = EYEW-ATW + RU2 = RU*RU + RV2 = RV*RV + RW2 = RW*RW + DU = SQRT(RV2+RW2) + DV = SQRT(RU2+RW2) + DW = SQRT(RU2+RV2) + DR = 1./SQRT(RU2+RV2+RW2) +C +C COMPUTE THE ARCCOSINE +C + TU = DU*DR + ANGU = ATAN(ABS(SQRT(1.-TU*TU)/TU)) + IF (TU .LE. 0.) ANGU = PI-ANGU + TV = DV*DR + ANGV = ATAN(ABS(SQRT(1.-TV*TV)/TV)) + IF (TV .LE. 0.) ANGV = PI-ANGV + TW = DW*DR + ANGW = ATAN(ABS(SQRT(1.-TW*TW)/TW)) + IF (TW .LE. 0.) ANGW = PI-ANGW +C +C BREAK POINT IS ABOUT 20 DEGREES OR ABOUT .35 RADIANS +C + IFLAG = 0 + IF (ANGU .GT. ANG) IFLAG = IFLAG+4 + IF (ANGV .GT. ANG) IFLAG = IFLAG+2 + IF (ANGW .GT. ANG) IFLAG = IFLAG+1 +C +C FIND SIGN OF IFLAG +C + ICNT = 0 + IF (ABS(RU) .LE. ATU) GO TO 30 + IU = 1 + IF (EYEU .GT. ATU) IU = NU + DO 20 IW=1,NW + DO 10 IV=1,NV + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 10 CONTINUE + 20 CONTINUE + 30 IF (ABS(RV) .LE. ATV) GO TO 60 + IV = 1 + IF (EYEV .GT. ATV) IV = NV + DO 50 IW=1,NW + DO 40 IU=1,NU + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 40 CONTINUE + 50 CONTINUE + 60 IF (ABS(RW) .LE. ATW) GO TO 90 + IW = 1 + IF (EYEW .GT. ATW) IW = NW + DO 80 IV=1,NV + DO 70 IU=1,NU + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 70 CONTINUE + 80 CONTINUE + 90 IFLAG = ISIGN(IFLAG,ICNT) + CALL ISOSRF (T,NU,NU,NV,NV,NW,EYE,MAX,SLAB,TVAL,IFLAG) +C +NOAO - Call to frame is suppressed. +C CALL FRAME +C -NOAO + RETURN + END + SUBROUTINE SET3D (EYE,ULO,UHI,VLO,VHI,WLO,WHI) + SAVE + COMMON /TEMPR/ RZERO +C + DIMENSION EYE(3) +C + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 + COMMON /PWRZ1I/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW +C +C + AVE(A,B) = (A+B)*.5 +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C CONSTANTS FOR PWRZ +C + UUMIN = ULO + UUMAX = UHI + VVMIN = VLO + VVMAX = VHI + WWMIN = WLO + WWMAX = WHI + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) +C +C FIND CORNERS IN 2-SPACE FOR 3-SPACE BOX CONTAINING OBJECT +C + ISCALE = 0 + ATU = AVE(SU(UUMIN),SU(UUMAX)) + ATV = AVE(SV(VVMIN),SV(VVMAX)) + ATW = AVE(SW(WWMIN),SW(WWMAX)) + BIGD = 0. + IF (RZERO .LE. 0.) GO TO 10 +C +C RELETIVE SIZE FEATURE IN USE. +C GENERATE EYE POSITION THAT MAKES BOX HAVE MAXIMUM PROJECTED SIZE. +C + ALPHA = -(VVMIN-ATV)/(UUMIN-ATU) + VVEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + UUEYE = VVEYE*ALPHA + VVEYE = VVEYE+ATV + UUEYE = UUEYE+ATU + WWEYE = ATW + CALL TRN32I (ATU,ATV,ATW,UUEYE,VVEYE,WWEYE,1) + CALL TRN32I (UUMIN,VVMIN,ATW,XMIN,DUMM,DUMM,2) + CALL TRN32I (UUMAX,VVMIN,WWMIN,DUMM,YMIN,DUMM,2) + CALL TRN32I (UUMAX,VVMAX,ATW,XMAX,DUMM,DUMM,2) + CALL TRN32I (UUMAX,VVMIN,WWMAX,DUMM,YMAX,DUMM,2) + BIGD = SQRT((UUMAX-UUMIN)**2+(VVMAX-VVMIN)**2+(WWMAX-WWMIN)**2)*.5 + R0 = RZERO + GO TO 20 + 10 CALL TRN32I (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + CALL TRN32I (SU(UUMIN),SV(VVMIN),SW(WWMIN),X1,Y1,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMIN),SW(WWMAX),X2,Y2,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMAX),SW(WWMIN),X3,Y3,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMAX),SW(WWMAX),X4,Y4,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMIN),SW(WWMIN),X5,Y5,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMIN),SW(WWMAX),X6,Y6,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMAX),SW(WWMIN),X7,Y7,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMAX),SW(WWMAX),X8,Y8,DUM,2) + XMIN = AMIN1(X1,X2,X3,X4,X5,X6,X7,X8) + XMAX = AMAX1(X1,X2,X3,X4,X5,X6,X7,X8) + YMIN = AMIN1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) + YMAX = AMAX1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) +C +C ADD RIGHT AMOUNT TO KEEP PICTURE SQUARE +C + 20 WIDTH = XMAX-XMIN + HIGHT = YMAX-YMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 30, 50, 40 + 30 XMIN = XMIN+DIF + XMAX = XMAX-DIF + GO TO 50 + 40 YMIN = YMIN-DIF + YMAX = YMAX+DIF + 50 ISCALE = 1 + CALL TRN32I (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + RETURN + END + SUBROUTINE TRN32I (U,V,W,XT,YT,ZT,IENT) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C ARGUMENTS FOR SET +C U,V,W ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C TRN32 ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. WHEN ISCALE=0, XT AND YT ANR IN THE SAME +C UNITS AS U,V, AND W. WHEN ISCALE'0, XT AND YT +C ARE IN PLOTTER COORDINATES. +C ZT NOT USED. +C + SAVE + COMMON /PWRZ1I/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 +C +C RANGE OF PLOTTER COORDINATES +C +C +C WARNING +C IF PLOTTER MAXIMUM VALUE RANGES (IN X OR Y DIRECTION) FALL BELOW +C 101, THEN CHANGES MUST BE MADE IN SUBROUTINE FRSTC. THE REQUIRED +C CHANGES ARE MARKED BY WARNING COMMENTS IN FRSTC. + DATA NLX,NBY,NRX,NTY/10,10,32760,32760/ + DATA PI/3.1411592/ +C +C STORE THE PARAMETERS OF THE SET CALL FOR USE +C WITH THE TRANSLATE CALL +C +C DECIDE IF SET OR TRANSLATE CALL +C + IF (IENT .NE. 1) GO TO 50 + AU = U + AV = V + AW = W + EU = XT + EV = YT + EW = ZT +C +C +C +C +C + DU = AU-EU + DV = AV-EV + DW = AW-EW + D = SQRT(DU*DU+DV*DV+DW*DW) + COSAL = DU/D + COSBE = DV/D + COSGA = DW/D +C +C COMPUTE THE ARCCOSINE +C + AL = ATAN(ABS(SQRT(1.-COSAL*COSAL)/COSAL)) + IF (COSAL .LE. 0.) AL = PI-AL + BE = ATAN(ABS(SQRT(1.-COSBE*COSBE)/COSBE)) + IF (COSBE .LE. 0.) BE = PI-BE + GA = ATAN(ABS(SQRT(1.-COSGA*COSGA)/COSGA)) + IF (COSGA .LE. 0.) GA = PI-GA + SINGA = SIN(GA) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE W AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + ASSIGN 90 TO JDONE + IF (ISCALE) 10, 30, 10 + 10 X0 = XMIN + Y0 = YMIN + X1 = NLX + Y1 = NBY + X2 = NRX-NLX + Y2 = NTY-NBY + X3 = X2/(XMAX-XMIN) + Y3 = Y2/(YMAX-YMIN) + X4 = NRX + Y4 = NTY + FACT = 1. + IF (BIGD .LE. 0.) GO TO 20 + X0 = -BIGD + Y0 = -BIGD + X3 = X2/(2.*BIGD) + Y3 = Y2/(2.*BIGD) + FACT = R0/D + 20 DELCRT = X2 + ASSIGN 80 TO JDONE + 30 IF (SINGA .LT. 0.0001) GO TO 40 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 40 SINBE = SIN(BE) + R = 1./SINBE + ASSIGN 60 TO JUMP + RETURN +C +C******************** ENTRY TRN32 ************************ +C ENTRY TRN32 (U,V,W,XT,YT,ZT) +C + 50 UU = U + VV = V + WW = W + Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA) + GO TO JUMP,( 60, 70) + 60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R + VV = (EV+Q*(VV-EV)-AV)*R + GO TO JDONE,( 80, 90) + 70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R + VV = (EW+Q*(WW-EW)-AW)*R + GO TO JDONE,( 80, 90) + 80 XT = AMIN1(X4,AMAX1(X1,X1+X3*(FACT*UU-X0))) + YT = AMIN1(Y4,AMAX1(Y1,Y1+Y3*(FACT*VV-Y0))) + RETURN + 90 XT = UU + YT = VV + RETURN + END + SUBROUTINE ZEROSC + SAVE +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) +C +C ZERO BOTH SCRENE MODELS. +C + DO 20 I=1,LX + DO 10 J=1,NY + ISCR(I,J) = 0 + ISCA(I,J) = 0 + 10 CONTINUE + 20 CONTINUE + RETURN + END + SUBROUTINE STCNTR (Z,L,M,N,CONV) +C + SAVE + DIMENSION Z(L,N) +C +C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +C CONV. +C + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR9/ BIG ,IXBIT +C +C PACK X AND Y +C + IPXY(I1,J1) = ISHIFT(I1,IXBIT)+J1 +C + IENTRY = 0 + NP = 0 + CV = CONV +C +C THE FOLLOWING CODE SHOULD BE RE-ENABLED IF THIS ROUTINE IS USED FOR +C GENERAL CONTOURING +C +C ISS=0 +C DO 2 IP1=2,M +C I=IP1-1 +C IF(Z(I,1).GE.CV.OR.Z(IP1,1).LT.CV) GO TO 1 +C IX=IP1 +C IY=1 +C IDX=-1 +C IDY=0 +C IS=1 +C CALL DRLINE(Z,L,M,N) +C 1 IF(Z(IP1,N).GE.CV.OR.Z(I,N).LT.CV) GO TO 2 +C IX=I +C IY=N +C IDX=1 +C IDY=0 +C IS=5 +C CALL DRLINE(Z,L,M,N) +C 2 CONTINUE +C DO 4 JP1=2,N +C J=JP1-1 +C IF(Z(M,J).GE.CV.OR.Z(M,JP1).LT.CV) GO TO 3 +C IX=M +C IY=JP1 +C IDX=0 +C IDY=-1 +C IS=7 +C CALL DRLINE(Z,L,M,N) +C 3 IF(Z(1,JP1).GE.CV.OR.Z(1,J).LT.CV) GO TO 4 +C IX=1 +C IY=J +C IDX=0 +C IDY=1 +C IS=3 +C CALL DRLINE(Z,L,M,N) +C 4 CONTINUE +C + ISS = 1 + DO 40 JP1=3,N + J = JP1-1 + DO 30 IP1=2,M + I = IP1-1 + IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 30 + IXY = IPXY(IP1,J) + IF (NP .EQ. 0) GO TO 20 + DO 10 K=1,NP + IF (IR(K) .EQ. IXY) GO TO 30 + 10 CONTINUE + 20 NP = NP+1 + IF (NP .GT. NR) RETURN + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + CALL DRCNTR (Z,L,M,N) + 30 CONTINUE + 40 CONTINUE + RETURN + END + SUBROUTINE DRCNTR (Z,L,MM,NN) + SAVE +C + DIMENSION Z(L,NN) +C +C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +C + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR9/ BIG ,IXBIT +C + LOGICAL IPEN ,IPENO +C + DATA IOFFP,SPVAL/0,0./ + DATA IPEN,IPENO/.TRUE.,.TRUE./ +C +C PACK X AND Y +C + IPXY(I1,J1) = ISHIFT(I1,IXBIT)+J1 + FX(X1,Y1) = X1 + FY(X1,Y1) = Y1 + C(P11,P21) = (P11-CV)/(P11-P21) +C + M = MM + N = NN + IF (IOFFP .EQ. 0) GO TO 10 + ASSIGN 100 TO JUMP1 + ASSIGN 150 TO JUMP2 + GO TO 20 + 10 ASSIGN 120 TO JUMP1 + ASSIGN 160 TO JUMP2 + 20 IX0 = IX + IY0 = IY + IS0 = IS + IF (IOFFP .EQ. 0) GO TO 30 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL + IPENO = IPEN + 30 IF (IDX .EQ. 0) GO TO 40 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 50 + 40 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 50 IF (IPEN) CALL FRSTS (FX(X,Y),FY(X,Y),1) + 60 IS = IS+1 + IF (IS .GT. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + IF (ISS .NE. 0) GO TO 70 + IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 190 + 70 IF (CV-Z(IX2,IY2)) 80, 80, 90 + 80 IS = IS+4 + IX = IX2 + IY = IY2 + GO TO 60 + 90 IF (IS/2*2 .EQ. IS) GO TO 60 + GO TO JUMP1,(100,120) + 100 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + IF (ISS .NE. 0) GO TO 110 + IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 190 + IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 190 + 110 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. + 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL + 120 IF (IDX .EQ. 0) GO TO 130 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 140 + 130 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 140 GO TO JUMP2,(150,160) + 150 IF (.NOT.IPEN) GO TO 170 + IF (IPENO) GO TO 160 +C +C END OF LINE SEGMENT +C + CALL FRSTS (D1,D2,3) + CALL FRSTS (FX(XOLD,YOLD),FY(XOLD,YOLD),1) +C +C CONTINUE LINE SEGMENT +C + 160 CALL FRSTS (FX(X,Y),FY(X,Y),2) + 170 XOLD = X + YOLD = Y + IF (IS .NE. 1) GO TO 180 + NP = NP+1 + IF (NP .GT. NR) GO TO 190 + IR(NP) = IPXY(IX,IY) + 180 IF (ISS .EQ. 0) GO TO 60 + IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 60 +C +C END OF LINE +C + 190 CALL FRSTS (D1,D2,3) + RETURN + END + SUBROUTINE TR32 (X,Y,MX,MY) + SAVE +C + COMMON /ISOSR1/ ISLBT ,U ,V ,W +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C + XX = X + YY = Y + IF (ISLBT) 10, 20, 30 + 10 CALL TRN32I (SU(U),SV(XX-1.),SW(YY-1.),XT,YT,DUM,2) + GO TO 40 + 20 CALL TRN32I (SU(XX-1.),SV(V),SW(YY-1.),XT,YT,DUM,2) + GO TO 40 + 30 CALL TRN32I (SU(XX-1.),SV(YY-1.),SW(W),XT,YT,DUM,2) + 40 MX = XT + MY = YT + RETURN + END + SUBROUTINE FRSTS (XX,YY,IENT) +C +C THIS IS A SPECIAL VERSION OF THE SMOOTHING DASHED LINE PACKAGE. LINES +C ARE SMOOTHED IN THE SAME WAY, BUT NO SOFTFARE DASHED LINES ARE USED. +C CONDITIONAL PLOTTING ROUTINES ARE CALL WHICH DETERMINE THE VISIBILITY +C OF A LINE SEGMENT BEFORE PLOTTING. +C + SAVE + DIMENSION XSAVE(70) ,YSAVE(70) ,XP(70) ,YP(70) , + 1 TEMP(70) +C + COMMON /ISOSR7/ IENTRY ,IONES +C + DATA NP/150/ + DATA L1/70/ + DATA TENSN/2.5/ + DATA PI/3.14159265358/ + DATA SMALL/128./ +C + AVE(A,B) = .5*(A+B) +C +C DECIDE IF FRSTS,VECTS,LASTS CALL +C + GO TO ( 10, 20, 40),IENT + 10 DEG = 180./PI + X = XX + Y = YY + LASTFL = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 + CALL TR32 (X,Y,MX,MY) +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************* ENTRY VECTS ************************* +C ENTRY VECTS (XX,YY) +C + 20 X = XX + Y = YY +C +C VECTS SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + CALL TR32 (X,Y,MX,MY) +C +CIF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 50 + RETURN +C +C ************************* ENTRY LASTS ************************* +C ENTRY LASTS +C + 40 LASTFL = 1 +C +C LASTS CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C +C IFLAG = 0 OK TO CALL LASTS DIRECTLY +C IFLAG = 1 LASTS WAS JUST CALLED FROM BY VECTS +C IGNORE CALL TO LASTS +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 50 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 70 + IF (N-2) 160,150, 60 + 60 IF (N .GE. 4) GO TO 70 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 110 + 70 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 90 + IF (NSEG .GE. 1) GO TO 80 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 110 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 80 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 110 + 90 IF (NSEG .GE. 1) GO TO 100 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 110 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 100 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 110 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) + IF (IPRD.EQ.0 .AND. NSEG.EQ.0 .AND. S.LT.70.) GO TO 170 + IENTRY = 1 +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 120 + NPRIME = FLOAT(NP)-(S*FLOAT(NP))/(2.*32768.) + IF (S .GE. 32768.) NPRIME = .5*FLOAT(NP) + NPL = FLOAT(NPRIME)*S/32768. + IF (NPL .LT. 2) NPL = 2 + 120 DT = 1./FLOAT(NPL) + IF (NSEG .LE. 0) CALL FRSTC (IFIX(XSAVE(1)),IFIX(YSAVE(1)),1) + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + XSOLD = XSAVE(1) + YSOLD = YSAVE(1) + DO 130 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + CALL FRSTC (IFIX(AVE(XSOLD,XS)),IFIX(AVE(YSOLD,YS)),2) + CALL FRSTC (IFIX(XS),IFIX(YS),2) + XSOLD = XS + YSOLD = YS + 130 CONTINUE + IF (IPRD .NE. 0) GO TO 140 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + CALL FRSTC (IFIX(AVE(XSOLD,XS)),IFIX(AVE(YSOLD,YS)),2) + CALL FRSTC (IFIX(XSV1),IFIX(YSV1),2) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 140 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + 150 CONTINUE + 160 RETURN + 170 N = 0 + RETURN + END + SUBROUTINE FRSTC (MX,MY,IENT) + SAVE +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD , + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX , + 2 IFSY ,FIRST ,IYDIR ,IHX , + 3 IHB ,IHS ,IHV ,IVOLD , + 4 IVAL ,IHRX ,YCHANG ,ITPD , + 5 IHF + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF +C +C +C DRAW LINE TO THE POINT MX,MY +C +C ENTER THE POINT INTO THE CURRENT SCREEN, ISCR, IF THE POINT CONFORMS +C TO THE SHADING ALGORITHM. +C THE POINT IS NOT ENTERED WHEN; +C 1. IT IS THE SAME POINT USED IN THE LAST CALL, RESOLUTION PROBLEM +C 2. IT IS PART OF A HORIZONTAL LINE BUT NOT AN END POINT +C 3. THE ENTIRE CONTOUR RESTS ON A HORIZONTAL PLANE +C +C WHEN DRAWING A HORIZONTAL LINE THREE CONDITIONS EXIST; +C 1. WHEN THE LINE IS A HORIZONTAL STEP ENTER ONLY THE OUTSIDE POINT. +C A HORIZONTAL STEP IS DEFINED BY THE ENTERING AND EXITING Y +C DIRECTION THAT IS THE SAME. +C 2. ENTER BOTH END POINTS OF A HORIZONTAL TURNING POINT. A HORIZONTAL +C TURNING POINT IS A LINE WITH GREATER THAN 1 HORIZONTAL BITS +C AND THE ENTERING AND EXITING Y DIRECTION IS DIFFIRENT. +C 3. WHEN THE ENTIRE CONTOUR IS A HORIZONTAL LINE NO POINTS ARE +C ENTERED. THIS CONDITION IS DETECTED BY THE STATUS OF YCHANG. +C IF IT IS TRUE THEN THE CONTOUR IS NOT A SINGLE HORIZONTAL LINE. +C +C THE PREVIOUS POINT IS ERASED IF IT IS A VERTICAL TURNING POINT. +C A VERTICAL TURNING POINT IS A HORIZONTAL LINE WITH ONLY 1 POINT +C AND THE ENTERING AND EXITING Y DIRECTION DIFFERS.THIS DATA IS +C IN THE VARIABLES IOSLSN-OLD SLOPE AND ISLSGN-NEW SLOPE. +C THE CHANGE IN SLOPE MUST BE -1 TO 1 OR 1 TO -1. +C +C OTHERWISE THE POINT IS ENTERED INTO ISCR. +C +C THE TWO ENTRY POINTS ARE REQUIRED BY THE HARDWARE DRAWING ROUTINES. +C FIRSTC IS USED FOR THE FIRST POINT ON THE CONTOUR. THE REMAINING +C POINTS ON THE SAME CONTOUR ARE ENTERED VIA VECTC. +C + DATA IONE/1/ + AVE(A,B) = (A+B)*.5 +C +C COMPUTE VISIBILITY OF THIS POINT +C +C WARNING +C IF X OR Y PLOTTER MAXIMUM VALUE RANGES FALL BELOW 101 THEN THE +C FOLLOWING TWO STATEMENTS WHICH SET IX AND IY MUST BE CHANGED. +C REPLACE THE CONSTANT 1.0 BY 0.5 IN THE STATEMENTS WHERE THE +C MAXIMUM PLOTTER VALUE IS LESS THAN 101 FOR THAT DIRECTION. THE +C PLOTTER CORDINATE RANGES ARE SET IN SET32. +C + IX = FLOAT(MX-1)*RX+1.0 + NRLX = IX + IY = FLOAT(MY-1)*RY+1.0 + IBIT = NBPW-MOD(IX,NBPW) + IX = IX/NBPW+1 + IVNOW = IAND(ISHIFT(ISCA(IX,IY),1-IBIT),IONE) +C +C DECIDE IF FRSTC OR VECTC CALL +C + IF (IENT .NE. 1) GO TO 10 +C + XOLD = MX + YOLD = MY +C +C +C SET INITIAL VALUES +C + IHF = .FALSE. + IYDIR = 0 + ITPD = 0 + IVAL = 0 + IOSLSN = 0 + IFSX = NRLX + IFSY = IY + LASTV = IVNOW + HBFLAG = .FALSE. + YCHANG = .FALSE. + CALL PLOTIT (IFIX(XOLD),IFIX(YOLD),0) + GO TO 180 +C +C**************************** ENTRY VECTC **************************** +C ENTRY VECTC (MX,MY) +C + 10 XNOW = MX + YNOW = MY + JUMP = IVNOW*2+LASTV+1 + GO TO ( 20, 30, 40, 50),JUMP +C +C BOTH VISIBLE +C + 20 CALL PLOTIT (IFIX(XNOW),IFIX(YNOW),1) + GO TO 50 +C +C JUST TURNED VISIBLE +C + 30 CALL PLOTIT (IFIX(AVE(XNOW,XOLD)),IFIX(AVE(YNOW,YOLD)),0) + GO TO 50 +C +C JUST TURNED INVISIBLE +C + 40 CALL PLOTIT (IFIX(AVE(XNOW,XOLD)),IFIX(AVE(YNOW,YOLD)),1) +C +C BOTH INVISIBLE +C + 50 XOLD = XNOW + YOLD = YNOW + LASTV = IVNOW +C +C TEST FOR RESOLUTION PROBLEM +C + IF (NRLX.EQ.LRLX .AND. IY.EQ.IYOLD) RETURN +C +C TEST FOR HORIZONTAL BITS +C + IF (IYOLD .NE. IY) GO TO 70 +C +C HORIZONTAL BITS DETECTED. SET FLAG AND EXIT. +C THIS AND THE NEXT HORIZONTAL BIT TEST IS NECESSARY FOR ISCR TO +C CONFORM TO THE SHADING ALGORITHM IN SUBROUTINE FILLIN +C +C +C IF HORIZONTAL LINE PREVIOUSLY DETECTED EXIT +C + IF (.NOT.HBFLAG) GO TO 60 +C +C IF END OF CONTOUR ON A HORIZONTAL LINE BRANCH FOR SPECIAL PROCESSING. +C + IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) GO TO 210 + GO TO 200 +C +C SAVE SLOPE PRIOR TO HORIZONTAL LINE +C + 60 IHX = IXOLD + IHB = IBTOLD + IHS = IOSLSN + IOSLSN = 0 + HBFLAG = .TRUE. + IHRX = LRLX + IHV = IVOLD + IF (LRLX.EQ.IFSX .AND. IYOLD.EQ.IFSY) IHF = .TRUE. +C +C THIS IS THE SECOND TRAP FOR END OF CONTOUR ON A HORIZONTAL LINE. +C + IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) GO TO 210 + GO TO 200 +C +C COMPUTE THE SLOPE TO THIS POINT +C + 70 IF (IY-IYOLD) 80, 90,100 + 80 ISLSGN = 1 + GO TO 110 + 90 ISLSGN = 0 + GO TO 120 + 100 ISLSGN = -1 + 110 IF (IYDIR .EQ. 0) IYDIR = ISLSGN + 120 CONTINUE +C +C IF PROCESS REACHES THIS CODE THE CONTOUR IS NOT CONTAINED ON A SINGLE +C HORIZONTAL PLANE, SO RECORD THIS FACT BY SETTING Y CHANGE FLAG. +C + YCHANG = .TRUE. +C +C TEST FOR END OF HORIZONTAL LINE +C + IF (.NOT.HBFLAG) GO TO 160 + HBFLAG = .FALSE. +C +C HORIZONTAL LINE JUST ENDED +C +C TEST FOR REDRAW +C + ITEMP = IAND(ISCR(IXOLD,IYOLD),MASK(IBTOLD)) + IF ((IHV .EQ. 0) .AND. (ITEMP .EQ. 0)) GO TO 130 +C +C REDRAWING ERASE THIS POINT +C + ISCR(IXOLD,IYOLD) = IAND(ISCR(IXOLD,IYOLD),NMASK(IBTOLD)) + ISCR(IHX,IYOLD) = IAND(ISCR(IHX,IYOLD),NMASK(IHB)) + GO TO 170 +C +C TEST FOR STEP PROBLEM +C + 130 IF (IHS .NE. ISLSGN) GO TO 140 +C +C STEP PROBLEM +C + GO TO 170 +C +C TURNING PROBLEM HORIZONTAL LINE IS A TURNING POINT +C + 140 CONTINUE +C +C ENTER THE TURNING POINT ONLY IF IT IS NOT THE SECOND SUCCEEDING +C EVENT IN A ROW +C + ICTPD = 1 + IF (IHRX .GT. NRLX) ICTPD = -1 + IF (ICTPD .NE. ITPD) GO TO 150 + ITPD = 0 +C +C ERASE THE FIRST POINT +C + ISCR(IHX,IYOLD) = IAND(ISCR(IHX,IYOLD),NMASK(IHB)) + GO TO 170 +C +C ENTER THE TURNING POINT +C + 150 CONTINUE + ITPD = ICTPD +C +C ENTER THE SECOND POINT +C + ISCR(IXOLD,IYOLD) = IOR(ISCR(IXOLD,IYOLD),MASK(IBTOLD)) + GO TO 170 +C +C CHECK IF PREVIOUS ENTRY WAS A VERTICAL TURNING POINT. +C IF SO ERASE IT. +C + 160 IF (ISLSGN.EQ.IOSLSN .OR. (IOSLSN.EQ.0 .OR. ISLSGN.EQ.0)) + 1 GO TO 170 + ITPD = 0 + ISCR(IXOLD,IYOLD) = IAND(ISCR(IXOLD,IYOLD),NMASK(IBTOLD)) +C + 170 IOSLSN = ISLSGN +C +C CHECK IF THIS GRID POINT PREVIOUSLY ACTIVATED +C + IVAL = IAND(ISCR(IX,IY),MASK(IBIT)) +C +C IF GRID POINTS ACTIVATED BRANCH +C + IF (IVAL .NE. 0) GO TO 190 +C +C GRID POINT NOT ACTIVATED SET AND EXIT +C + 180 CONTINUE + ISCR(IX,IY) = IOR(ISCR(IX,IY),MASK(IBIT)) + GO TO 200 +C +C THIS POINT IS BEING REDRAWN SO ERASE IT. +C (THIS IS TO CONFORM WITH THE SHADING ALGORITHM, FILLIN. +C HOWEVER IF BACK TO STARTING POINT DO NOT ERASE +C + 190 IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) RETURN + ISCR(IX,IY) = IAND(ISCR(IX,IY),NMASK(IBIT)) +C +C + 200 IXOLD = IX + LRLX = NRLX + IYOLD = IY + IBTOLD = IBIT + IVOLD = IVAL + RETURN +C +C PERFORM THIS OPERATION WHEN A CONTOUR STARTS OR ENDS ON A HORIZONTAL +C LINE. +C + 210 CONTINUE +C +C ERASE THE FIRST POINT OF A CONTOUR WHEN IT IS PART OF A HORIZONTAL +C LINE SEGMENT AND IS NOT THE ENDPOINT OF THE SEGMENT +C + IF (.NOT.IHF) GO TO 220 + ISCR(IX,IY) = IAND(ISCR(IX,IY),NMASK(IBIT)) + 220 CONTINUE +C +C ERASE THE FIRST POINT OF A HORIZONTAL LINE SEGMENT WHEN IT ENDS +C THE CONTOUR AND IS NOT THE HIGHEST LINE SEG ON THS SIDE. +C + IF (.NOT.YCHANG) GO TO 230 + IF (IYDIR .NE. IHS) GO TO 200 + 230 ISCR(IHX,IY) = IAND(ISCR(IHX,IY),NMASK(IHB)) + GO TO 200 + END + SUBROUTINE FILLIN +C + SAVE + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR7/ IENTRY ,IONES +C + IF (IENTRY .EQ. 0) RETURN +C +C THIS IS A SHADING ALGORITHM IT IS USED TO DETERMINE CONTOUR LINES +C THAT ARE HIDDEN BY THE PRESENT LINE. THE ALGORITHM PROCESSES +C HORIZONTAL ROWS. IT ASSUMES THAT THE BIT PATTERN PASSED TO IT +C HAS ONLY BITS SET TO MARK THE START AND END OF SHADING. THE +C ALGORITHM ALSO ASSUMES THAT WHEN AN ON BIT IS ENCOUNTERED THAT A +C CORRESPONDING OFF BIT IS INCLUDED IN THE SAME ROW. +C +C +C PULL OUT ROWS OF THE CONTOUR PATTERN +C + IBVAL = 0 + DO 80 IYNOW=1,NY + DO 40 IXNOW=1,LX +C +C IF NO ACTIVATED BITS BRANCH +C + ICRWD = ISCR(IXNOW,IYNOW) + IF (ICRWD .EQ. 0) GO TO 30 +C +C ACTIVATED BITS IN WORD SET SHADING FLAG +C +C CHECK BIT BY BIT FOR ON/OFF FLAGS +C + DO 20 IB=1,NBPW + IBIT = (NBPW+1)-IB +C +C +C PULL OUT THE CURRENT GRID POINT VALUE +C + IVAL = IAND(ICRWD,MASK(IBIT)) +C +C IF IVAL SET, THIS IS AN ON/OFF FLAG +C + IF (IVAL .EQ. 0) GO TO 10 +C +C FLAG BIT, ALWAYS SET +C + IBVAL = MOD(IBVAL+1,2) + GO TO 20 +C +C SHADE THE SCREEN ACCORDING TO THE STATUS OF IBVAL +C + 10 IF (IBVAL .NE. 0) ICRWD = IOR(ICRWD,MASK(IBIT)) +C + 20 CONTINUE +C +C ZERO OUT THE SCREEN +C + ISCR(IXNOW,IYNOW) = 0 + ISCA(IXNOW,IYNOW) = IOR(ICRWD,ISCA(IXNOW,IYNOW)) + GO TO 40 +C + 30 IF (IBVAL .NE. 0) ISCA(IXNOW,IYNOW) = IONES + 40 CONTINUE +C +C FIX FOR NONCORRECTABLE RUNAWAYS +C + IF (IBVAL .EQ. 0) GO TO 80 + IBVAL = 0 + DO 70 K=1,LX + ITEST = 0 + IF (IYNOW .EQ. 1) GO TO 50 + ITEST = ISCA(K,IYNOW-1) + IF (IYNOW .EQ. NY) GO TO 60 + 50 ITEST = IOR(ITEST,ISCA(K,IYNOW+1)) + 60 ISCA(K,IYNOW) = ITEST + 70 CONTINUE +C + 80 CONTINUE + RETURN + END + SUBROUTINE DRAWI (IXA,IYA,IXB,IYB) +C +C INCLUDED FOR USE BY PWRZ +C + SAVE + CALL FRSTC (IXA,IYA,1) + CALL FRSTC (IXB,IYB,2) + RETURN + END + SUBROUTINE MMASK +C +C MAKE THE MACHINE DEPENDENT MASKS USED IN THE CONTOUR DRAWING +C AND SHADING ALGORITHMS +C + SAVE + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD , + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX , + 2 IFSY ,FIRST ,IYDIR ,IHX , + 3 IHB ,IHS ,IHV ,IVOLD , + 4 IVAL ,IHRX ,YCHANG ,ITPD , + 5 IHF + COMMON /ISOSR9/ BIG ,IXBIT + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF + GENDON = .TRUE. + NBPW = 16 +C +C GET BIGGEST REAL NUMBER +C + BIG = R1MACH(2) +C +C MASKS TO SELECT A SPECIFIC BIT +C + DO 10 K=1,NBPW + MASK(K) = ISHIFT(1,K-1) + 10 CONTINUE +C +C GENERATE THE BIT PATTERN 177777 OCTAL +C + ITEMP1 = 0 + ITEMP = MASK(NBPW) + IST = NBPW-1 + DO 20 K=1,IST + ITEMP1 = IOR(ITEMP,ISHIFT(ITEMP1,-1)) + 20 CONTINUE + MFIX = IOR(ITEMP1,1) +C +C MASKS TO CLEAR A SPECIFIC BIT +C + DO 30 K=1,NBPW + NMASK(K) = IAND(ITEMP1,MFIX) + ITEMP1 = IOR(ISHIFT(ITEMP1,1),1) + 30 CONTINUE + IONES = MFIX + RETURN +C +C REVISION HISTORY--- +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C JANUARY 1979 NEW SHADING ALGORITHM +C MARCH 1979 MADE CODE MACHINE INDEPENDENT AND CONFORM +C TO 66 FORTRAN STANDARD +C JUNE 1979 THIS VERSION PLACED ON ULIB. +C SEPTEMBER 1979 FIXED PROBLEM IN EZISOS DEALING WITH +C DETERMINATION OF VISIBILITY OF W PLANE. +C DECEMBER 1979 FIXED PROBLEM WITH PEN DOWN ON CONTOUR +C INITIALIZATION IN SUBROUTINE FRSTC +C MARCH CHANGED ROUTINE NAMES TRN32I AND DRAW TO +C TRN32I AND DRAWI TO BE CONSISTENT WITH THE +C USAGE OF THE NEW ROUTINE PWRZI. +C JUNE 1980 FIXED PROBLEM WITH ZERO INDEX COMPUTATION IN +C SUBROUTINE FRSTC. ADDED INPUT PARAMETER +C DIMENSION STATEMENT MISSING IN EZISOS. +C FIXED ERROR IN COMPUTATION OF ARCCOSINE +C IN EZISOS AND TRN32I. +C DECEMBER 1984 CONVERTED TO GKS LEVEL 0A AND STANDARD FORTRAN 77 +C----------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/kurv.f b/sys/gio/ncarutil/kurv.f new file mode 100644 index 00000000..1d160b89 --- /dev/null +++ b/sys/gio/ncarutil/kurv.f @@ -0,0 +1,451 @@ + SUBROUTINE KURV1S (N,X,Y,SLOP1,SLOPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DIMENSION OF X(N),Y(N),XP(N),YP(N),TEMP(N) +C ARGUMENTS +C +C LATEST REVISION FEBRUARY 5, 1974 +C +C PURPOSE KURV1S DETERMINES THE PARAMETERS NECESSARY TO +C COMPUTE A SPLINE UNDER TENSION PASSING THROUGH +C A SEQUENCE OF PAIRS +C (X(1),Y(1)),...,(X(N),Y(N)) IN THE PLANE. +C THE SLOPES AT THE TWO ENDS OF THE CURVE MAY BE +C SPECIFIED OR OMITTED. FOR ACTUAL COMPUTATION +C OF POINTS ON THE CURVE IT IS NECESSARY TO CALL +C THE SUBROUTINE KURV2S. +C +C USAGE CALL KURV1S(N,X,Y,SLP1,SLPN,XP,YP,TEMP,S,SIGMA) +C +C ARGUMENTS +C +C ON INPUT N +C IS THE NUMBER OF POINTS TO BE INTERPOLATED +C (N .GE. 2). +C +C X +C IS AN ARRAY CONTAINING THE N X-COORDINATES +C OF THE POINTS. +C +C Y +C IS AN ARRAY CONTAINING THE N Y-COORDINATES +C OF THE POINTS. +C +C SLOP1 AND SLOPN +C CONTAIN THE DESIRED VALUES FOR THE SLOPE OF +C THE CURVE AT (X(1),Y(1)) AND (X(N),Y(N)), +C RESPECTIVELY. THESE QUANTITIES ARE IN +C DEGREES AND MEASURED COUNTER-CLOCKWISE +C FROM THE POSITIVE X-AXIS. IF ISLPSW IS NON- +C ZERO, ONE OR BOTH OF SLP1 AND SLPN MAY BE +C DETERMINED INTERNALLY BY KURV1S. +C +C XP AND YP +C ARE ARRAYS OF LENGTH AT LEAST N. +C +C TEMP +C IS AN ARRAY OF LENGTH AT LEAST N WHICH IS +C USED FOR SCRATCH STORAGE. +C +C SIGMA +C CONTAINS THE TENSION FACTOR. THIS IS +C NON-ZERO AND INDICATES THE CURVINESS DESIRED. +C IF ABS(SIGMA) IS VERY LARGE (E.G., 50.) THE +C RESULTING CURVE IS VERY NEARLY A POLYGONAL +C LINE. A STANDARD VALUE FOR SIGMA IS ABOUT 2. +C +C ISLPSW +C IS AN INTEGER INDICATING WHICH END SLOPES +C HAVE BEEN USER PROVIDED AND WHICH MUST BE +C COMPUTED BY KURV1S. FOR ISLPSW +C = 0 INDICATES BOTH SLOPES ARE PROVIDED, +C = 1 ONLY SLOP1 IS PROVIDED, +C = 2 ONLY SLOPN IS PROVIDED, +C = 3 NEITHER SLOP1 NOR SLOPN IS PROVIDED. +C = 4 NEITHER SLOP1 NOR SLOPN IS PROVIDED, +C BUT SLOP1=SLOPN. IN THIS CASE X(1)= +C X(N), Y(1)=Y(N) AND N.GE.3. +C ON OUTPUT XP AND YP +C CONTAIN INFORMATION ABOUT THE CURVATURE OF +C THE CURVE AT THE GIVEN NODES. +C +C S +C CONTAINS THE POLYGONAL ARCLENGTH OF THE +C CURVE. +C +C N, X, Y, SLP1, SLPN, SIGMA AND ISLPSW ARE +C UNCHANGED. +C +C ENTRY POINTS KURV1S +C +C SPECIAL CONDITIONS NONE +C +C COMMON BLOCKS NONE +C +C I/O NONE +C +C PRECISION SINGLE +C +C REQUIRED ULIB NONE +C ROUTINES +C +C SPECIALIST RUSSELL K. REW, NCAR, BOULDER, COLORADO 80302 +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972. +C +C +C +C + INTEGER N + REAL X(N) ,Y(N) ,XP(N) ,YP(N) , + 1 TEMP(N) ,S ,SIGMA + SAVE +C + DATA PI /3.1415926535897932/ +C + NN = N + JSLPSW = ISLPSW + SLP1 = SLOP1 + SLPN = SLOPN + DEGRAD = PI/180. + NM1 = NN-1 + NP1 = NN+1 + DELX1 = X(2)-X(1) + DELY1 = Y(2)-Y(1) + DELS1 = SQRT(DELX1*DELX1+DELY1*DELY1) + DX1 = DELX1/DELS1 + DY1 = DELY1/DELS1 +C +C DETERMINE SLOPES IF NECESSARY +C + IF (JSLPSW .NE. 0) GO TO 70 + 10 SLPP1 = SLP1*DEGRAD + SLPPN = SLPN*DEGRAD +C +C SET UP RIGHT HAND SIDES OF TRIDIAGONAL LINEAR SYSTEM FOR XP +C AND YP +C + XP(1) = DX1-COS(SLPP1) + YP(1) = DY1-SIN(SLPP1) + + TEMP(1) = DELS1 + SS = DELS1 + IF (NN .EQ. 2) GO TO 30 + DO 20 I=2,NM1 + DELX2 = X(I+1)-X(I) + DELY2 = Y(I+1)-Y(I) + DELS2 = SQRT(DELX2*DELX2+DELY2*DELY2) + DX2 = DELX2/DELS2 + DY2 = DELY2/DELS2 + XP(I) = DX2-DX1 + YP(I) = DY2-DY1 + TEMP(I) = DELS2 + DELX1 = DELX2 + DELY1 = DELY2 + DELS1 = DELS2 + DX1 = DX2 + DY1 = DY2 +C +C ACCUMULATE POLYGONAL ARCLENGTH +C + SS = SS+DELS1 + 20 CONTINUE + 30 XP(NN) = COS(SLPPN)-DX1 + YP(NN) = SIN(SLPPN)-DY1 +C +C DENORMALIZE TENSION FACTOR +C + SIGMAP = ABS(SIGMA)*FLOAT(NN-1)/SS +C +C PERFORM FORWARD ELIMINATION ON TRIDIAGONAL SYSTEM +C + S = SS + DELS = SIGMAP*TEMP(1) + EXPS = EXP(DELS) + SINHS = .5*(EXPS-1./EXPS) + SINHIN = 1./(TEMP(1)*SINHS) + DIAG1 = SINHIN*(DELS*.5*(EXPS+1./EXPS)-SINHS) + DIAGIN = 1./DIAG1 + XP(1) = DIAGIN*XP(1) + YP(1) = DIAGIN*YP(1) + SPDIAG = SINHIN*(SINHS-DELS) + TEMP(1) = DIAGIN*SPDIAG + IF (NN .EQ. 2) GO TO 50 + DO 40 I=2,NM1 + DELS = SIGMAP*TEMP(I) + EXPS = EXP(DELS) + SINHS = .5*(EXPS-1./EXPS) + SINHIN = 1./(TEMP(I)*SINHS) + DIAG2 = SINHIN*(DELS*(.5*(EXPS+1./EXPS))-SINHS) + DIAGIN = 1./(DIAG1+DIAG2-SPDIAG*TEMP(I-1)) + XP(I) = DIAGIN*(XP(I)-SPDIAG*XP(I-1)) + YP(I) = DIAGIN*(YP(I)-SPDIAG*YP(I-1)) + SPDIAG = SINHIN*(SINHS-DELS) + TEMP(I) = DIAGIN*SPDIAG + DIAG1 = DIAG2 + 40 CONTINUE + 50 DIAGIN = 1./(DIAG1-SPDIAG*TEMP(NM1)) + XP(NN) = DIAGIN*(XP(NN)-SPDIAG*XP(NM1)) + YP(NN) = DIAGIN*(YP(NN)-SPDIAG*YP(NM1)) +C +C PERFORM BACK SUBSTITUTION +C + DO 60 I=2,NN + IBAK = NP1-I + XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1) + YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) + 60 CONTINUE + RETURN + 70 IF (NN .EQ. 2) GO TO 100 +C +C IF NO SLOPES ARE GIVEN, USE SECOND ORDER INTERPOLATION ON +C INPUT DATA FOR SLOPES AT ENDPOINTS +C + IF (JSLPSW .EQ. 4) GO TO 90 + IF (JSLPSW .EQ. 2) GO TO 80 + DELNM1 = SQRT((X(NN-2)-X(NM1))**2+(Y(NN-2)-Y(NM1))**2) + DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2) + DELNN = DELNM1+DELN + C1 = (DELNN+DELN)/DELNN/DELN + C2 = -DELNN/DELN/DELNM1 + C3 = DELN/DELNN/DELNM1 + SX = C3*X(NN-2)+C2*X(NM1)+C1*X(NN) + SY = C3*Y(NN-2)+C2*Y(NM1)+C1*Y(NN) +C + SLPN = ATAN2(SY,SX)/DEGRAD + 80 IF (JSLPSW .EQ. 1) GO TO 10 + DELS2 = SQRT((X(3)-X(2))**2+(Y(3)-Y(2))**2) + DELS12 = DELS1+DELS2 + C1 = -(DELS12+DELS1)/DELS12/DELS1 + C2 = DELS12/DELS1/DELS2 + C3 = -DELS1/DELS12/DELS2 + SX = C1*X(1)+C2*X(2)+C3*X(3) + SY = C1*Y(1)+C2*Y(2)+C3*Y(3) +C + SLP1 = ATAN2(SY,SX)/DEGRAD + GO TO 10 + 90 DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2) + DELNN = DELS1+DELN + C1 = -DELS1/DELN/DELNN + C2 = (DELS1-DELN)/DELS1/DELN + C3 = DELN/DELNN/DELS1 + SX = C1*X(NM1)+C2*X(1)+C3*X(2) + SY = C1*Y(NM1)+C2*Y(1)+C3*Y(2) + IF (SX.EQ.0. .AND. SY.EQ.0.) SX = 1. + SLP1 = ATAN2(SY,SX)/DEGRAD + SLPN = SLP1 + GO TO 10 +C +C IF ONLY TWO POINTS AND NO SLOPES ARE GIVEN, USE STRAIGHT +C LINE SEGMENT FOR CURVE +C + 100 IF (JSLPSW .NE. 3) GO TO 110 + XP(1) = 0. + XP(2) = 0. + YP(1) = 0. + YP(2) = 0. +C + SLP1 = ATAN2(Y(2)-Y(1),X(2)-X(1))/DEGRAD + SLPN = SLP1 + RETURN +C + 110 IF (JSLPSW .EQ. 2) + 1 SLP1 = ATAN2(Y(2)-Y(1)-SLPN*(X(2)-X(1)), + 2 X(2)-X(1)-SLPN*(Y(2)-Y(1)))/DEGRAD +C + IF (JSLPSW .EQ. 1) + 1 SLPN = ATAN2(Y(2)-Y(1)-SLP1*(X(2)-X(1)), + 2 X(2)-X(1)-SLP1*(Y(2)-Y(1)))/DEGRAD + GO TO 10 + END + SUBROUTINE KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C +C +C DIMENSION OF X(N),Y(N),XP(N),YP(N) +C ARGUMENTS +C +C LATEST REVISION OCTOBER 22, 1973 +C +C PURPOSE KURV2S PERFORMS THE MAPPING OF POINTS IN THE +C INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE. +C THE SUBROUTINE KURV1S SHOULD BE CALLED EARLIER +C TO DETERMINE CERTAIN NECESSARY PARAMETERS. +C THE RESULTING CURVE HAS A PARAMETRIC +C REPRESENTATION BOTH OF WHOSE COMPONENTS ARE +C SPLINES UNDER TENSION AND FUNCTIONS OF THE +C POLYGONAL ARCLENGTH PARAMETER. +C +C ACCESS CARDS *FORTRAN,S=ULIB,N=KURV +C *COSY +C +C USAGE CALL KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA) +C +C ARGUMENTS +C +C ON INPUT T +C CONTAINS A REAL VALUE OF ABSOLUTE VALUE LESS +C THAN OR EQUAL TO 1. TO BE MAPPED TO A POINT +C ON THE CURVE. THE SIGN OF T IS IGNORED AND +C THE INTERVAL (0.,1.) IS MAPPED ONTO THE +C ENTIRE CURVE. IF T IS NEGATIVE, THIS +C INDICATES THAT THE SUBROUTINE HAS BEEN CALLED +C PREVIOUSLY (WITH ALL OTHER INPUT VARIABLES +C UNALTERED) AND THAT THIS VALUE OF T EXCEEDS +C THE PREVIOUS VALUE IN ABSOLUTE VALUE. WITH +C SUCH INFORMATION THE SUBROUTINE IS ABLE TO +C MAP THE POINT MUCH MORE RAPIDLY. THUS IF THE +C USER SEEKS TO MAP A SEQUENCE OF POINTS ONTO +C THE SAME CURVE, EFFICIENCY IS GAINED BY +C ORDERING THE VALUES INCREASING IN MAGNITUDE +C AND SETTING THE SIGNS OF ALL BUT THE FIRST +C NEGATIVE. +C +C N +C CONTAINS THE NUMBER OF POINTS WHICH WERE +C INTERPOLATED TO DETERMINE THE CURVE. +C +C X AND Y +C ARRAYS CONTAINING THE X- AND Y-COORDINATES +C OF THE INTERPOLATED POINTS. +C +C XP AND YP +C ARE THE ARRAYS OUTPUT FROM KURV1 CONTAINING +C CURVATURE INFORMATION. +C +C S +C CONTAINS THE POLYGONAL ARCLENGTH OF THE +C CURVE. +C +C SIGMA +C CONTAINS THE TENSION FACTOR (ITS SIGN IS +C IGNORED). +C +C NSLPSW +C IS AN INTEGER SWITCH WHICH TURNS ON OR OFF +C THE CALCULATION OF SLP +C NSLPSW +C = 0 INDICATES THAT SLP WILL NOT BE +C CALCULATED +C = 1 SLP WILL BE CALCULATED +C +C THE PARAMETERS N, X, Y, XP, YP, S AND SIGMA +C SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF +C KURV1S. +C +C ON OUTPUT XS AND YS +C CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE +C POINT ON THE CURVE. +C +C SLP +C CONTAINS THE SLOPE OF THE CURVE IN DEGREES AT +C THIS POINT. +C +C T, N, X, Y, XP, YP, S AND SIGMA ARE UNALTERED. +C +C ENTRY POINTS KURV2S +C +C SPECIAL CONDITIONS NONE +C +C COMMON BLOCKS NONE +C +C I/O NONE +C +C PRECISION SINGLE +C +C REQUIRED ULIB NONE +C ROUTINES +C +C SPECIALIST RUSSELL K. REW, NCAR, BOULDER, COLORADO 80302 +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972. +C +C +C +C + INTEGER N + REAL T ,XS ,YS ,X(N) , + 1 Y(N) ,XP(N) ,YP(N) ,S , + 2 SIGMA ,SLP + SAVE +C + DATA PI /3.1415926535897932/ +C +C +C DENORMALIZE SIGMA +C + SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S +C +C STRETCH UNIT INTERVAL INTO ARCLENGTH DISTANCE +C + TN = ABS(T*S) +C +C FOR NEGATIVE T START SEARCH WHERE PREVIOUSLY TERMINATED, +C OTHERWISE START FROM BEGINNING +C + IF (T .LT. 0.) GO TO 10 + DEGRAD = PI/180. + I1 = 2 + XS = X(1) + YS = Y(1) + SUM = 0. + IF (T .LT. 0.) RETURN +C +C DETERMINE INTO WHICH SEGMENT TN IS MAPPED +C + 10 DO 30 I=I1,N + DELX = X(I)-X(I-1) + DELY = Y(I)-Y(I-1) + DELS = SQRT(DELX*DELX+DELY*DELY) + IF (SUM+DELS-TN) 20,40,40 + 20 SUM = SUM+DELS + 30 CONTINUE +C +C IF ABS(T) IS GREATER THAN 1., RETURN TERMINAL POINT ON +C CURVE +C + XS = X(N) + YS = Y(N) + RETURN +C +C SET UP AND PERFORM INTERPOLATION +C + 40 DEL1 = TN-SUM + DEL2 = DELS-DEL1 + EXPS1 = EXP(SIGMAP*DEL1) + SINHD1 = .5*(EXPS1-1./EXPS1) + EXPS2 = EXP(SIGMAP*DEL2) + SINHD2 = .5*(EXPS2-1./EXPS2) + EXPS = EXPS1*EXPS2 + SINHS = .5*(EXPS-1./EXPS) + XS = (XP(I)*SINHD1+XP(I-1)*SINHD2)/SINHS+ + 1 ((X(I)-XP(I))*DEL1+(X(I-1)-XP(I-1))*DEL2)/DELS + YS = (YP(I)*SINHD1+YP(I-1)*SINHD2)/SINHS+ + 1 ((Y(I)-YP(I))*DEL1+(Y(I-1)-YP(I-1))*DEL2)/DELS + I1 = I + IF (NSLPSW .EQ. 0) RETURN + COSHD1 = .5*(EXPS1+1./EXPS1)*SIGMAP + COSHD2 = .5*(EXPS2+1./EXPS2)*SIGMAP + XT = (XP(I)*COSHD1-XP(I-1)*COSHD2)/SINHS+ + 1 ((X(I)-XP(I))-(X(I-1)-XP(I-1)))/DELS + YT = (YP(I)*COSHD1-YP(I-1)*COSHD2)/SINHS+ + 1 ((Y(I)-YP(I))-(Y(I-1)-YP(I-1)))/DELS + SLP = ATAN2(YT,XT)/DEGRAD + RETURN + END diff --git a/sys/gio/ncarutil/mkpkg b/sys/gio/ncarutil/mkpkg new file mode 100644 index 00000000..20b06e09 --- /dev/null +++ b/sys/gio/ncarutil/mkpkg @@ -0,0 +1,51 @@ +# Make the NCAR utilities library libncar.a. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + @sysint + @autograph + @conlib + + conran.f # blockdata for the conrec utility + conbdn.f # blockdata for the conran utility + #conraq.f - Conran, conraq and conras form the "conran" family. + #conras.f - Conran is the only one of the 3 included in "libncar.a"; + # - the others contain duplicate entry points and blockdatas + # - and are not included. + # + conrec.f + conbd.f + #conrcqck.f - Conrcqck, conrcspr and conrec form the "conrec" family. + #conrcspr.f - Conrec is the only one of the 3 included in "libncar.a"; + # - the others contain duplicate entry points and blockdatas + # - and are not included. + #dashchar.f + #dashline.f - Like the "conrec" family above, the "dash" family contains + dashsmth.f #- duplicate entry points and blockdatas. Only dashsmth is + #- included in "libncar.a". The others are redundant. + dashbd.f # blockdata for the dashsmth utility + #dashsupr.f + #ezmapg.f + gridal.f + gridt.f #- blockdata for the gridal utility + hafton.f + hfinit.f #- blockdata for the hafton utility + isosrf.f + isosrb.f #- blockdata for the isosrf utility + kurv.f #- support routines for dashsmth and isosrf + pwrity.f + pwrzi.f + pwrzs.f + pwrzt.f + srface.f + srfabd.f #- blockdata for the srface utility + #strmln.f + threed.f + threbd.f #- blockdata for the threed utility + velvct.f + veldat.f #- blockdata for the velvct utility + ; diff --git a/sys/gio/ncarutil/pwrity.f b/sys/gio/ncarutil/pwrity.f new file mode 100644 index 00000000..5685c9b7 --- /dev/null +++ b/sys/gio/ncarutil/pwrity.f @@ -0,0 +1,604 @@ + SUBROUTINE PWRITY (X,Y,ID,N,ISIZE,ITHETA,ICNT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C LATEST REVISION JULY 1984 +C +C PURPOSE PWRITY IS A CHARACTER PLOTTING ROUTINE. IT HAS +C SOME FEATURES NOT FOUND IN WTSTR, BUT IS NOT AS +C FANCY AS PWRITX. +C +C +C USAGE CALL PWRITY(X,Y,ID,N,ISIZE,ITHETA,ICNT) +C +C ARGUMENTS +C +C ON INPUT X,Y +C POSITIONING COORDINATES FOR THE CHARACTERS TO +C BE DRAWN. X AND Y ARE USER WORLD COORDINATES +C AND ARE SCALED ACCORDING TO THE CURRENT +C NORMALIZATION TRANSFORMATION. ALSO, SEE ICNT. +C +C ID +C CHARACTER STRING TO BE DRAWN. +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS CHOSEN AS +C 1., 1.5, 2., OR 3. TIMES AN 8 PLOTTER +C ADDRESS CHARACTER WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C ITHETA +C ANGLE, IN DEGREES, AT WHICH THE CHARACTERS ARE +C PLOTTED (COUNTER CLOCKWISE FROM THE POSITIVE +C X AXIS.) +C +C ICNT +C CENTERING OPTION: +C = -1 (X,Y) IS THE CENTER OF THE LEFT EDGE +C OF THE FIRST CHARACTER. +C = 0 (X,Y) IS THE CENTER OF THE ENTIRE +C STRING. +C = 1 (X,Y) IS THE CENTER OD THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C ENTRY POINTS PWRY, PWRYSO, PWRYGT, PWRITY, PWRYBD +C +C COMMON BLOCKS PWRCOM +C +C REQUIRED LIBRARY THE SPPS. +C + +C +C I/O PLOTS CHARACTERS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE IN DASHCHAR. +C MADE PORTABLE IN JANUARY 1977 +C FOR USE ON COMPUTER SYSTEMS WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BITS RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JULY, 1984. +C +C ALGORITHM DIGITIZATIONS OF THE CHARACTERS ARE STORED +C NTERNALLY AND ADJUSTED ACCORDING TO X, Y, +C ISIZE AND ICNT, THEN PLOTTED. +C +C TIMING SLOWER THAN WTSTR, FASTER THAN PWRITX. +C +C PORTABILITY FORTRAN +C +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + COMMON /PWRCOM/ USABLE + LOGICAL USABLE + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C + DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LEN IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRY. +C LRES IS THE NUMBER OF BITS OF ACCURACY USED FOR INTEGER INPUT TO +C THE SYSTEM PLOT PACKAGE. +C + DATA NSIZE/46/ +c Variable LEN not used. +c DATA LEN/494/ + DATA LENTRY/.FALSE./ + DATA LRES/15/ + DATA DEGRAD/0.017453293/ + IF (USABLE) GO TO 101 +C +C THIS IS A PWRITY CALL +C + CALL Q8QST4 ('GRAPHX','PWRITY','PWRITY','VERSION 1') + 101 USABLE = .FALSE. +C +C SEE IF THIS IS THE FIRST CALL TO PWRITY. +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRY. +C + CALL PWRYSO (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C +C TRANSFORM THE INPUT COORDINATES TO INTEGER SPACE. +C + 103 CALL FL2INT (X,Y,IX,IY) +C + NN = N + IF (NN .LE. 0) GO TO 113 + FNNM1 = NN-1 + JCNT = ICNT +C +C GET USER SET RESOLUTION. +C + CALL GETUSV ('XF',LXSAVE) + CALL GETUSV ('YF',LYSAVE) +C +C PUT RELATIVE SIZE IN Q. +C + Q = ISIZE + IF (Q .LE. 3.) GO TO 104 + Q = Q/FLOAT(ISHIFT(6,LXSAVE-10)) + GO TO 105 + 104 Q = (1.+.5*(FLOAT(IFIX(Q)+IFIX(Q)/3)))*4./3. + 105 Q = Q*FLOAT(ISHIFT(1,LRES-10)) +C +C CALCULATE COMBINED TRANSFORMATION. +C + THETA = FLOAT(ITHETA)*DEGRAD + CT = Q*COS(THETA) + ST = Q*SIN(THETA) +C +C FIND PLOTTER ADDRESS COORDINATES FOR BEGINNING. +C + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-WHITE*CT+HIGH*.5*ST + YC = YC-WHITE*ST-HIGH*.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCENT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (107,106,108),JCENT + 106 XC = XC-CT*FNNM1*WIDE*.5 + YC = YC-ST*FNNM1*WIDE*.5 + GO TO 109 + 107 XC = XC+CT*WHITE + YC = YC+ST*WHITE + GO TO 109 + 108 XC = XC-CT*WHITE + YC = YC-ST*WHITE + XC = XC-CT*FNNM1*WIDE + YC = YC-ST*FNNM1*WIDE +C +C SET PLOTTER TO STARTING POINT. +C + 109 CALL PLOTIT (IFIX(XC),IFIX(YC),0) +C +C PLOT ALL THE CHARACTERS IN THE INPUT STRING. +C + DO 112 K=1,NN + YB = YC + XB = XC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRYGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C DRAW INDIVIDUAL CHARACTER. +C + L = 0 + 110 ISUB = IPOINT+L + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY + L = L+1 +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 110,112,110 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL PLOTTING ROUTINE. MODE DETERMINED BY OP-CODE. +C + CALL PLOTIT (IFIX(XC+.5),IFIX(YC+.5),IP) + IP = 1 + GO TO 110 + 112 CONTINUE +C + 113 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE PWRYSO (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRYGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN + END + SUBROUTINE PWRY (X,Y,ID,N,SIZE,THETA,ICNT) +C +C PWRY IS AN OLD ENTRY POINT AND HAS BEEN REMOVED - USE PWRITY +C ENTRY POINT +C +C +NOAO - FTN writes and format statements commented out. +C WRITE (I1MACH(4),1001) +C WRITE (I1MACH(4),1002) +C STOP +C +C1001 FORMAT ('1'//////////) +C1002 FORMAT (' ****************************************'/ +C 1 ' * *'/ +C 2 ' * *'/ +C 3 ' * THE ENTRY POINT PWRY IS NO LONGER *'/ +C 4 ' * SUPPORTED. PLEASE USE THE MORE *'/ +C 5 ' * RECENT VERSION PWRITY. *'/ +C 6 ' * *'/ +C 7 ' * *'/ +C 8 ' ****************************************') +C -NOAO + END +C +NOAO - Blockdata rewritten as subroutine +C BLOCKDATA PWRYBD + subroutine pwrybd + COMMON /PWRCOM/ USABLE + LOGICAL USABLE +C DATA USABLE/.FALSE./ + usable = .false. +C -NOAO +C REVISION HISTORY------ +C FEBURARY 1979 CREATED NEW ALGORITHM PWRITY TO REPLACE PWRY +C ADDED REVISION HISTORY +C JUNE 1979 CHANGE ARGUMENT THETA IN PWRITY FROM FLOATING TO +C INTEGER, USING ITHETA AS THE NEW NAME. ITS +C MEANING IS NOW DEGREES INSTEAD OF RADIANS. +C JULY 1984 CONVERTED TO FORTRAN 77 AND GKS +C----------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/pwrzi.f b/sys/gio/ncarutil/pwrzi.f new file mode 100644 index 00000000..d49b9ff5 --- /dev/null +++ b/sys/gio/ncarutil/pwrzi.f @@ -0,0 +1,732 @@ + SUBROUTINE PWRZI (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZI IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C ISOSRF. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C PWRZI WILL NOT WORK WITH ISOSRFHR. +C +C +C USAGE CALL PWRZI (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZI AFTER CALLING +C ISOSRF AND BEFORE CALLING FRAME. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C ISOSRF. +C +C ID +C CHARACTER STRING TO BE DRAWN. ID IS OF TYPE +C CHARACTER . +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER (THE POTENTIAL VALUES FOR +C ITOP ARE THE SAME AS THOSE FOR LINE AS +C GIVEN ABOVE.) NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZI, INITZI, PWRZOI, PWRZGI +C +C COMMON BLOCKS PWRZ1I,PWRZ2I +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRF, THE ERPRT77 PACKAGE, AND THE SPPS +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH ISOSRF. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following variables are used. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZI. +C + DATA NSIZE/46/ +c Variable LNGTH is not used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZI','PWRZI','VERSION 1') +C +C SEE IF THIS IS THE FIRST CALL TO PWRZI +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZI. +C + CALL PWRZOI (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 32. + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)*(2**(15-LX))/6. +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZI (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZI (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZI (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZI (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGI (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZI (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZI (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE INTZI (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2I/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZI (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZI (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1I/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT ,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2I/ X ,Y ,Z + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZI,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZI - LINE OR ITOP IMPROPER IN PWRZI CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32I (XX,YY,ZZ,XT,YT,DUMMY,2) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C + 119 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + RETURN + 120 CALL PLOTIT (IFIX(XT),IFIX(YT),1) + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN ISOSRF +C + CALL DRAWI (IX1,IY1,IX2,IY2) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOI (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGI (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C ISOSRF +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/pwrzs.f b/sys/gio/ncarutil/pwrzs.f new file mode 100644 index 00000000..cfda613e --- /dev/null +++ b/sys/gio/ncarutil/pwrzs.f @@ -0,0 +1,772 @@ + SUBROUTINE PWRZS (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZS IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C SRFACE. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C +C +C USAGE CALL PWRZS (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZS AFTER CALLING +C SRFACE AND BEFORE CALLING FRAME +C NOTE: SRFACE WILL HAVE TO BE CHANGED +C TO SUPPRESS THE FRAME CALL. SEE IFR +C IN SRFACE INTERNAL PARAMETERS. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C SRFACE. +C +C ID +C CHARACTER STRING TO BE DRAWN +C +C N +C THE NUMBER OF CHARACTERS IN ID +C +C ISIZE +C SIZE OF THE CHARACTER +C . IF BETWEEN 0 AND 3 THE FACTOR IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3 IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER. NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZS, INITZS, PWRZOS, PWRZGS +C +C COMMON BLOCKS PWRZ1S,PWRZ2S +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY SRFACE +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH SRFACE. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + DIMENSION VWPRT(4) ,WNDW(4) + LOGICAL LENTRY +c +NOAO: common block added for user control of viewport + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +C +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following are used anywere. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZS. +C + DATA NSIZE/46/ +c Variable LNGTH never used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZS','PWRZS','VERSION 1') +C +C INQUIRE CURRENT NORMALIZATION TRANS NUMBER +C + CALL GQCNTN (IERR,NTORIG) +C +C SAVE NORMALIZATION TRANS 1 AND LOG SCALING FLAG +C + CALL GQNT (1,IERR,WNDW,VWPRT) + CALL GETUSV('LS',IOLLS) +C +C DEFINE NORMALIZATION TRANS 1 FOR USE WITH DRAWS +C +c +NOAO: device viewport now user controlled through common noaovp + call set (vpx1, vpx2, vpy1, vpy2, 1., 1024., 1., 1024., 1) +c CALL SET(0.0,1.0,0.0,1.0,1.0,1024.0,1.0,1024.0,1) +c-NOAO +C +C SEE IF THIS IS THE FIRST CALL TO PWRZS +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZS. +C + CALL PWRZOS (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 2.**(LX-10) + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)/(6.) +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZS (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZS (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZS (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZS (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGS (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZS (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZS (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) +C +C RESTORE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + + WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL GSELNT (NTORIG) + RETURN + END + SUBROUTINE INTZS (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2S/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZS (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZS (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2S/ X ,Y ,Z +c +NOAO: common block added to allow user control of device viewport. + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZS,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZS - LINE OR ITOP IMPROPER IN PWRZS CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32S (XX,YY,ZZ,XT,YT,DUMMY,1) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C +c +NOAO: Remove the assumption that window coordinates 1-1024 map to the +c full plotter metacode range 1-32768 +c + 119 zzxmc = (32768./1023.) * (vpx2 - vpx1) * (xt-1.) + (vpx1 * 32768.) + zzymc = (32768./1023.) * (vpy2 - vpy1) * (yt-1.) + (vpy1 * 32768.) + call plotit (ifix(zzxmc), ifix(zzymc), 0) +c 119 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),0) + RETURN +c + 120 zzxmc = (32768./1023.) * (vpx2 - vpx1) * (xt-1.) + (vpx1 * 32768.) + zzymc = (32768./1023.) * (vpy2 - vpy1) * (yt-1.) + (vpy1 * 32768.) + call plotit (ifix(zzxmc), ifix(zzymc), 1) +c 120 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),1) +c -NOAO + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN SRFACE +C + CALL DRAWS (IX1,IY1,IX2,IY2,1,0) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOS (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGS (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C SRFACE +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/pwrzt.f b/sys/gio/ncarutil/pwrzt.f new file mode 100644 index 00000000..eea2b0d0 --- /dev/null +++ b/sys/gio/ncarutil/pwrzt.f @@ -0,0 +1,731 @@ + SUBROUTINE PWRZT (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZT IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C THREED. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C +C +C USAGE CALL PWRZT (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZT AFTER CALLING +C THREED AND BEFORE CALLING FRAME. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C THREED. +C +C ID +C CHARACTER STRING TO BE DRAWN. ID IS OF TYPE +C CHARACTER . +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER (THE POTENTIAL VALUES FOR +C ITOP ARE THE SAME AS THOSE FOR LINE AS +C GIVEN ABOVE.) NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZT, INITZT, PWRZOT, PWRZGT +C +C COMMON BLOCKS PWRZ1T,PWRZ2T +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY THREED, THE ERPRT77 PACKAGE, AND THE SPPS +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH THREED. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following are used anywhere. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZT. +C + DATA NSIZE/46/ +c Variable LNGTH not used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZT','PWRZT','VERSION 1') +C +C SEE IF THIS IS THE FIRST CALL TO PWRZT +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZT. +C + CALL PWRZOT (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 2.**(LX-10) + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)/(6.) +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZT (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZT (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZT (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZT (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZT (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZT (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE INTZT (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2T/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZT (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZT (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1T/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT ,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2T/ X ,Y ,Z + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZT,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZT - LINE OR ITOP IMPROPER IN PWRZT CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32T (XX,YY,ZZ,XT,YT,DUMMY,2) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C + 119 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),0) + RETURN + 120 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),1) + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN THREED +C + CALL DRAWT (IX1,IY1,IX2,IY2) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOT (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C THREED +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/srfabd.f b/sys/gio/ncarutil/srfabd.f new file mode 100644 index 00000000..25712c27 --- /dev/null +++ b/sys/gio/ncarutil/srfabd.f @@ -0,0 +1,89 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: here is the changed block data +c BLOCKDATA SRFABD + subroutine srfabd +c + integer first, temp + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX, + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT, + 2 NCLA ,THETA ,HSKIRT ,CHI, + 3 CLO ,CINC ,ISPVAL + COMMON /SRFINT/ ISRFMJ ,ISRFMN ,ISRFTX +c +noao: common block added 4NOV85 to allow user control of viewport. + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c-noao +C +c +noao: following flag added to prevent initialization more than once + common /frstfg/ first + SAVE + data temp /1/ + first = temp + if (first .ne. 1) then + return + endif + temp = 0 +c +C +noao: by default, the full device viewport is used + vpx1 = 0.0 + vpx2 = 1.0 + vpy1 = 0.0 + vpy2 = 1.0 +c -noao +C INITIALIZATION OF INTERNAL PARAMETERS +C +c DATA ISPVAL/-999/ + ISPVAL = -999 + +c DATA IFR,ISTP,IROTS,IDRX,IDRY,IDRZ,IUPPER,ISKIRT,NCLA/ +c 1 1, 0, 0, 1, 1, 0, 0, 0, 6/ +c +noao: initial value of ifr changed to 0 to suppress frame advance. This +c function should be performed by the calling procedure. +c -noao + IFR = 0 + ISTP = 0 + IROTS = 0 + IDRX = 1 + IDRY = 1 + IDRZ = 0 + IUPPER = 0 + ISKIRT = 0 + NCLA = 6 + +c DATA THETA,HSKIRT,CHI,CLO,CINC/ +c 1 .02, 0., 0., 0., 0./ + THETA =.02 + HSKIRT = 0. + CHI = 0. + CLO = 0. + CINC = 0. + +c DATA NRSWT/0/ + NRSWT = 0 + +c DATA IOFFP,SPVAL/0,0.0/ + IOFFP = 0 + SPVAL = 0.0 + +C LINE COLOR INDEX +c DATA ISRFMJ/1/ + ISRFMJ = 1 +C +c -noao + END diff --git a/sys/gio/ncarutil/srface.f b/sys/gio/ncarutil/srface.f new file mode 100644 index 00000000..8a5981db --- /dev/null +++ b/sys/gio/ncarutil/srface.f @@ -0,0 +1,1347 @@ + SUBROUTINE SRFACE (X,Y,Z,M,MX,NX,NY,S,STEREO) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DIMENSION OF X(NX),Y(NY),Z(MX,NY),M(2,NX,NY),S(6) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE SRFACE DRAWS A PERSPECTIVE PICTURE OF A +C FUNCTION OF TWO VARIABLES WITH HIDDEN LINES +C REMOVED. THE FUNCTION IS APPROXIMATED BY A +C TWO-DIMENSIONAL ARRAY OF HEIGHTS. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C CALL EZSRFC (Z,M,N,ANGH,ANGV,WORK) +C +C ASSUMPTIONS: +C .THE ENTIRE ARRAY IS TO BE DRAWN, +C .THE DATA IS EQUALLY SPACED (IN THE +C X-Y PLANE), +C .NO STEREO PAIRS, +C .SCALING IS CHOSEN INTERNALLY. +C +C IF THESE ASSUMPTIONS ARE NOT MET USE +C CALL SRFACE (X,Y,Z,M,MX,NX,NY,S, +C STEREO) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZSRFC THE M BY N ARRAY TO BE DRAWN. +C +C M +C THE FIRST DIMENSION OF Z. +C +C N +C THE SECOND DIMENSION OF Z. +C +C ANGH +C ANGLE IN DEGREES IN THE X-Y PLANE TO THE +C LINE OF SIGHT (COUNTER-CLOCK WISE FROM +C THE PLUS-X AXIS). +C +C ANGV +C ANGLE IN DEGREES FROM THE X-Y PLANE TO +C THE LINE OF SIGHT (POSITIVE ANGLES ARE +C ABOVE THE MIDDLE Z, NEGATIVE BELOW). +C +C WORK +C A SCRATCH STORAGE DIMENSIONED AT LEAST +C 2*M*N+M+N. +C +C ON OUTPUT Z, M, N, ANGH, ANGV ARE UNCHANGED. WORK +C FOR EZSRFC HAS BEEN WRITTEN IN. +C +C +C ARGUMENTS +C +C ON INPUT X +C FOR SRFACE A LINEAR ARRAY NX LONG CONTAINING THE X +C COORDINATES OF THE POINTS IN THE SURFACE +C APPROXIMATION. SEE NOTE, BELOW. +C +C Y +C THE LINEAR ARRAY NY LONG CONTAINING THE +C Y COORDINATES OF THE POINTS IN THE +C SURFACE APPROXIMATION. SEE NOTE, BELOW. +C +C Z +C AN ARRAY MX BY NY CONTAINING THE SURFACE +C TO BE DRAWN IN NX BY NY CELLS. +C Z(I,J) = F(X(I),Y(J)). SEE NOTE, BELOW. +C +C M +C SCRATCH ARRAY AT LEAST 2*NX*NY WORDS +C LONG. +C +C MX +C FIRST DIMENSION OF Z. +C +C NX +C NUMBER OF POINTS IN THE X DIRECTION +C IN Z. WHEN PLOTTING AN ENTIRE ARRAY, +C MX=NX. SEE APPENDIX 1 OF THE GRAPHICS +C CHAPTER FOR AN EXPLANATION OF USING THIS +C ARGUMENT LIST TO PROCESS ANY PART OF AN +C ARRAY. +C +C NY +C NUMBER OF POINTS IN THE Y DIRECTION IN Z. +C +C S +C S DEFINES THE LINE OF SIGHT. THE VIEWER'S +C EYE IS AT (S(1), S(2), S(3)) AND THE +C POINT LOOKED AT IS AT (S(4), S(5), S(6)). +C THE EYE SHOULD BE OUTSIDE THE BLOCK WITH +C OPPOSITE CORNERS (X(1), Y(1), ZMIN) AND +C (X(NX), Y(NY), ZMAX) AND THE POINT LOOKED +C AT SHOULD BE INSIDE IT. FOR A NICE +C PERSPECTIVE EFFECT, THE DISTANCE BETWEEN +C THE EYE AND THE POINT LOOKED AT SHOULD BE +C 5 TO 10 TIMES THE SIZE OF THE BLOCK. SEE +C NOTE, BELOW. +C +C STEREO +C FLAG TO INDICATE IF STEREO PAIRS ARE TO +C BE DRAWN. 0.0 MEANS NO STEREO PAIR (ONE +C PICTURE). NON-ZERO MEANS PUT OUT TWO +C PICTURES. THE VALUE OF STEREO IS THE +C RELATIVE ANGLE BETWEEN THE EYES. A VALUE +C OF 1.0 PRODUCES STANDARD SEPARATION. +C NEGATIVE STEREO REVERSES THE LEFT AND +C RIGHT FIGURES. +C +C ON OUTPUT X, Y, Z, MX, NX, NY, S, STEREO ARE +C FOR SRFACE UNCHANGED. M HAS BEEN WRITTEN IN. +C +C NOTES . THE RANGE OF Z COMPARED WITH THE RANGE +C OF X AND Y DETERMINES THE SHAPE OF THE +C PICTURE. THEY ARE ASSUMED TO BE IN THE +C SAME UNITS AND NOT WILDLY DIFFERENT IN +C MAGNITUDE. S IS ASSUMED TO BE IN THE +C SAME UNITS AS X, Y, AND Z. +C . PICTURE SIZE CAN BE MADE RELATIVE TO +C DISTANCE. SEE COMMENTS IN SETR. +C . TRN32S CAN BE USED TO TRANSLATE FROM 3 +C SPACE TO 2 SPACE. SEE COMMENTS THERE. +C . DATA WITH EXTREME DISCONTINUITIES MAY +C CAUSE VISIBILITY ERRORS. IF THIS PROBLEM +C OCCURS, USE A DISTANT EYE POSITION +C AWAY FROM THE +Z AXIS. +C . THE DEFAULT LINE COLOR IS SET TO +C COLOR INDEX 1. IF THE USER WISHES TO +C CHANGE THE LINE COLOR, HE CAN DO SO BY +C DEFINING COLOR INDEX 1 BEFORE CALLING +C SRFACE, OR BY PUTTING THE COMMON BLOCK +C SRFINT IN HIS CALLING PROGRAM AND +C DEFINING AND USING COLOR INDEX ISRFMJ +C (DEFAULTED TO 1 IN BLOCKDATA.) +C +C ENTRY POINTS SRFACE, SRFGK, EZSRFC, SETR, DRAWS, TRN32S, +C CLSET, CTCELL, SRFABD +C +C COMMON BLOCKS PWRZ1S, SRFBLK, SRFINT, SRFIP1 +C +C I/O PLOTS +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY CONVERTED TO FORTRAN 77 AND GKS IN MARCH 1984. +C +C PREPARED FOR SIGGRAPH, AUGUST 1976. +C +C STANDARDIZED IN JANUARY 1973. +C +C WRITTEN IN DECEMBER 1971. REPLACED K.S.+G. +C ALGORITHM CALLED SOLIDS AT NCAR. +C +C +C ALGORITHM HIGHEST SO FAR IS VISIBLE FROM ABOVE. (SEE +C REFERENCE.) +C +C REFERENCE WRIGHT, T.J., A TWO SPACE SOLUTION TO THE +C HIDDEN LINE PROBLEM FOR PLOTTING A FUNCTION +C OF TWO VARIABLES. IEEE TRANS. COMP., +C PP 28-33, JANUARY 1973. +C +C ACCURACY IF THE ENDS OF A LINE SEGMENT ARE VISIBLE, +C THE MIDDLE IS ASSUMED VISIBLE. +C +C TIMING PROPORTIONAL TO NX*NY. +C +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C IFR 1 -1 CALL FRAME FIRST. +C 0 DO NOT CALL FRAME. +C +1 CALL FRAME WHEN DONE. +c +NOAO: The value of ifr has been changed from its default of +1 to 0. +c -NOAO +C +C ISTP 0 STEREO TYPE IF STEREO +C NON-ZERO. +C -1 ALTERNATING FRAMES, +C SLIGHTLY OFFSET (FOR +C MOVIES. IROTS = 0). +C 0 BLANK FRAME BETWEEN +C FOR STEREO SLIDE. +C IROTS = 1). +C +1 BOTH ON SAME FRAME. +C (LEFT PICTURE TO LEFT +C SIDE. IROTS = 0). +C +C IROTS 0 0 +Z IN VERTICAL PLOTTING +C DIRECTION (CINE MODE). +C +1 +Z IN HORIZONTAL +C PLOTTING DIRECTION +C (COMIC MODE). +C +C IDRX 1 +1 DRAW LINES OF CONSTANT +C X. +C 0 DO NOT. +C +C IDRY 1 +1 DRAW LINES OF CONSTANT +C Y. +C 0 DO NOT. +C +C IDRZ 0 +1 DRAW LINES OF CONSTANT +C Z (CONTOUR LINES). +C 0 DO NOT. +C +C IUPPER 0 +1 DRAW UPPER SIDE OF +C SURFACE. +C 0 DRAW BOTH SIDES. +C -1 DRAW LOWER SIDE. +C +C ISKIRT 0 +1 DRAW A SKIRT AROUND THE +C SURFACE. +C BOTTOM = HSKIRT. +C 0 DO NOT. +C +C NCLA 6 APPROXIMATE NUMBER OF +C LEVELS OF CONSTANT Z THAT +C ARE DRAWN IF LEVELS ARE NOT +C SPECIFIED. 40 LEVELS +C MAXIMUM. +C +C THETA .02 ANGLE IN RADIANS BETWEEN +C EYES FOR STEREO PAIRS. +C +C HSKIRT 0. HEIGHT OF SKIRT +C (IF ISKIRT = 1). +C +C CHI 0. HIGHEST LEVEL OF CONSTANT +C Z. +C +C CLO 0. LOWEST LEVEL OF CONSTANT Z. +C +C CINC 0. INCREMENT BETWEEN LEVELS. +C +C [IF CHI, CLO, OR CINC IS ZERO, A NICE +C VALUE IS GENERATED AUTOMATICALLY.] +C +C IOFFP 0 FLAG TO CONTROL USE OF SPECIAL +C VALUE FEATURE. DO NOT HAVE +C BOTH IOFFP=1 AND ISKIRT=1. +C 0 FEATURE NOT IN USE +C +1 FEATURE IN USE. NO LINES +C DRAWN TO DATA POINTS IN Z +C THAT ARE EQUAL TO SPVAL. +C +C SPVAL 0. SPECIAL VALUE USED TO MARK UN- +C KNOWN DATA WHEN IOFFP=1. +C +C +C + DIMENSION X(NX) ,Y(NY) ,Z(MX,NY), M(2,NX,NY), + 1 S(6) + DIMENSION WIN1(4) ,VP1(4) ,LASF(13) + COMMON /SRFINT/ ISRFMJ ,ISRFMN ,ISRFTX +c +NOAO: common block added 4NOV85 to allow user control of viewport + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +c +NOAO: Blockdata srfabd rewritten as run time initialization +c EXTERNAL SRFABD + call srfabd +c -NOAO + CALL Q8QST4 ('GRAPHX','SRFACE','SRFACE','VERSION 01') +C +C THIS DRIVER SAVES THE CURRENT NORMALIZATION TRANSFORMATION +C INFORMATION, DEFINES THE NORMALIZATION TRANSFORMATION +C APPROPRIATE FOR SRFGK, CALLS SRFGK, AND RESTORES THE ORIGINAL +C NORMALIZATION TRANSFORMATION. +C +C GET CURRENT NORMALIZATION TRANSFORMATION NUMBER +C + CALL GQCNTN (IER,NTORIG) +C +C STORE WINDOW AND VIEWPORT OF NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT (NTORIG,IER,WIN1,VP1) + CALL GETUSV('LS',IOLLS) +C +C SET WINDOW AND VIEWPORT FOR SRFGK +C +c CALL SET(0.,1.,0.,1.,1.,1024.,1.,1024.,1) +c +NOAO: viewport limits now stored in common block noaovp + CALL SET(vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) +c -NOAO +C +C SET LINE COLOR TO INDIVIDUAL (SAVE CURRENT SETTING) +C + CALL GQASF (IER,LASF) + LASFSV = LASF(3) + LASF(3) = 1 + CALL GSASF(LASF) +C +C SET LINE COLOR INDEX TO COMMON VARIABLE ISRFMJ (SAVE +C CURRENT SETTING) +C + CALL GQPLCI (IER,LCISV) + CALL GSPLCI (ISRFMJ) +C +C DRAW PLOT +C + CALL SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO) +C +C RESTORE INITIAL LINE COLOR SETTINGS +C + LASF(3) = LASFSV + CALL GSASF(LASF) + CALL GSPLCI (LCISV) +C +C RESTORE ORIGINAL NORMALIZATION TRANSFORMATION +C + CALL SET(VP1(1),VP1(2),VP1(3),VP1(4),WIN1(1),WIN1(2), + - WIN1(3),WIN1(4),IOLLS) + CALL GSELNT (NTORIG) +C + RETURN + END + SUBROUTINE SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO) +C + DIMENSION X(NX) ,Y(NY) ,Z(MX,NY) ,M(2,NX,NY) , + 1 S(6) + DIMENSION MXS(2) ,MXF(2) ,MXJ(2) ,MYS(2), + 1 MYF(2) ,MYJ(2) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT, + 2 NCLA ,THETA ,HSKIRT ,CHI, + 3 CLO ,CINC ,ISPVAL +c +NOAO: + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +C + DATA JF, IF, LY, LX, ICNST /1, 1, 2, 2, 0/ + CALL Q8QST4 ('GRAPHX','SRFACE','SRFGK','VERSION 01') + BIGEST = R1MACH(2) + MMXX = MX + NNXX = NX + NNYY = NY + STER = STEREO + NXP1 = NNXX+1 + NYP1 = NNYY+1 + NLA = NCLA + NSPVAL = ISPVAL + NDRZ = IDRZ + IF (IDRZ .NE. 0) + 1 CALL CLSET (Z,MMXX,NNXX,NNYY,CHI,CLO,CINC,NLA,40,CL,NCL, + 2 ICNST,IOFFP,SPVAL,BIGEST) + IF (IDRZ .NE. 0) NDRZ = 1-ICNST + STHETA = SIN(STER*THETA) + CTHETA = COS(STER*THETA) + RX = S(1)-S(4) + RY = S(2)-S(5) + RZ = S(3)-S(6) + D1 = SQRT(RX*RX+RY*RY+RZ*RZ) + D2 = SQRT(RX*RX+RY*RY) + DX = 0. + DY = 0. + IF (STEREO .EQ. 0.) GO TO 20 + D1 = D1*STEREO*THETA + IF (D2 .GT. 0.) GO TO 10 + DX = D1 + GO TO 20 + 10 AGL = ATAN2(RX,-RY) + DX = D1*COS(AGL) + DY = D1*SIN(AGL) + 20 IROT = IROTS + NPIC = 1 + IF (STER .NE. 0.) NPIC = 2 + FACT = 1. + IF (NRSWT .NE. 0) FACT = RZERO/D1 + IF (ISTP.EQ.0 .AND. STER.NE.0.) IROT = 1 + DO 570 IPIC=1,NPIC + NUPPER = IUPPER + IF (IFR .LT. 0) CALL FRAME +C +C SET UP MAPING FROM FLOATING POINT 3-SPACE TO CRT SPACE. +C + SIGN1 = IPIC*2-3 + EYEX = S(1)+SIGN1*DX + POIX = S(4)+SIGN1*DX + EYEY = S(2)+SIGN1*DY + POIY = S(5)+SIGN1*DY + EYEZ = S(3) + POIZ = S(6) + LL = 0 + XEYE = EYEX + YEYE = EYEY + ZEYE = EYEZ + CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0) + LL = IPIC+2*ISTP+3 + IF (STER .EQ. 0.) LL = 1 + IF (NRSWT .NE. 0) GO TO 100 + XXMIN = X(1) + XXMAX = X(NNXX) + YYMIN = Y(1) + YYMAX = Y(NNYY) + UMIN = BIGEST + VMIN = BIGEST + ZZMIN = BIGEST + UMAX = -UMIN + VMAX = -VMIN + ZZMAX = -ZZMIN + DO 40 J=1,NNYY + DO 30 I=1,NNXX + ZZ = Z(I,J) + IF (IOFFP.EQ.1 .AND. ZZ.EQ.SPVAL) GO TO 30 + ZZMAX = AMAX1(ZZMAX,ZZ) + ZZMIN = AMIN1(ZZMIN,ZZ) + CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1) + UMAX = AMAX1(UMAX,UT) + UMIN = AMIN1(UMIN,UT) + VMAX = AMAX1(VMAX,VT) + VMIN = AMIN1(VMIN,VT) + 30 CONTINUE + 40 CONTINUE + IF (ISKIRT .NE. 1) GO TO 70 + NXSTP = NNXX-1 + NYSTP = NNYY-1 + DO 60 J=1,NNYY,NYSTP + DO 50 I=1,NNXX,NXSTP + CALL TRN32S (X(I),Y(J),HSKIRT,UT,VT,DUMMY,1) + UMAX = AMAX1(UMAX,UT) + UMIN = AMIN1(UMIN,UT) + VMAX = AMAX1(VMAX,VT) + VMIN = AMIN1(VMIN,VT) + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + WIDTH = UMAX-UMIN + HIGHT = VMAX-VMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 80,100, 90 + 80 UMIN = UMIN+DIF + UMAX = UMAX-DIF + GO TO 100 + 90 VMIN = VMIN-DIF + VMAX = VMAX+DIF + 100 XEYE = EYEX + YEYE = EYEY + ZEYE = EYEZ + CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0) + DO 120 J=1,NNYY + DO 110 I=1,NNXX + CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1) + M(1,I,J) = UT + M(2,I,J) = VT + 110 CONTINUE + 120 CONTINUE +C +C INITIALIZE UPPER AND LOWER VISIBILITY ARRAYS +C + DO 130 K=1,1024 + LIMU(K) = 0 + LIML(K) = 1024 + 130 CONTINUE +C +C FIND ORDER TO DRAW LINES +C + NXPASS = 1 + IF (S(1) .GE. X(NNXX)) GO TO 160 + IF (S(1) .LE. X(1)) GO TO 170 + DO 140 I=2,NNXX + LX = I + IF (S(1) .LE. X(I)) GO TO 150 + 140 CONTINUE + 150 MXS(1) = LX-1 + MXJ(1) = -1 + MXF(1) = 1 + MXS(2) = LX + MXJ(2) = 1 + MXF(2) = NNXX + NXPASS = 2 + GO TO 180 + 160 MXS(1) = NNXX + MXJ(1) = -1 + MXF(1) = 1 + GO TO 180 + 170 MXS(1) = 1 + MXJ(1) = 1 + MXF(1) = NNXX + 180 NYPASS = 1 + IF (S(2) .GE. Y(NNYY)) GO TO 210 + IF (S(2) .LE. Y(1)) GO TO 220 + DO 190 J=2,NNYY + LY = J + IF (S(2) .LE. Y(J)) GO TO 200 + 190 CONTINUE + 200 MYS(1) = LY-1 + MYJ(1) = -1 + MYF(1) = 1 + MYS(2) = LY + MYJ(2) = 1 + MYF(2) = NNYY + NYPASS = 2 + GO TO 230 + 210 MYS(1) = NNYY + MYJ(1) = -1 + MYF(1) = 1 + GO TO 230 + 220 MYS(1) = 1 + MYJ(1) = 1 + MYF(1) = NNYY +C +C PUT ON SKIRT ON FRONT SIDE IF WANTED +C + 230 IF (NXPASS.EQ.2 .AND. NYPASS.EQ.2) GO TO 490 + IF (ISKIRT .EQ. 0) GO TO 290 + IN = MXS(1) + IF = MXF(1) + JN = MYS(1) + JF = MYF(1) + IF (NYPASS .NE. 1) GO TO 260 + CALL TRN32S (X(1),Y(JN),HSKIRT,UX1,VX1,DUMMY,1) + CALL TRN32S (X(NNXX),Y(JN),HSKIRT,UX2,VX2,DUMMY,1) + QU = (UX2-UX1)/(X(NNXX)-X(1)) + QV = (VX2-VX1)/(X(NNXX)-X(1)) + YNOW = Y(JN) + DO 240 I=1,NNXX + CALL TRN32S (X(I),YNOW,HSKIRT,RU,RV,DUMMY,1) + CALL DRAWS (IFIX(RU),IFIX(RV),M(1,I,JN),M(2,I,JN),1,0) + 240 CONTINUE + CALL DRAWS (IFIX(UX1),IFIX(VX1),IFIX(UX2),IFIX(VX2),1,1) + IF (IDRY .NE. 0) GO TO 260 + DO 250 I=2,NNXX + CALL DRAWS (M(1,I-1,JN),M(2,I-1,JN),M(1,I,JN),M(2,I,JN),1,1) + 250 CONTINUE + 260 IF (NXPASS .NE. 1) GO TO 290 + CALL TRN32S (X(IN),Y(1),HSKIRT,UY1,VY1,DUMMY,1) + CALL TRN32S (X(IN),Y(NNYY),HSKIRT,UY2,VY2,DUMMY,1) + QU = (UY2-UY1)/(Y(NNYY)-Y(1)) + QV = (VY2-VY1)/(Y(NNYY)-Y(1)) + XNOW = X(IN) + DO 270 J=1,NNYY + CALL TRN32S (XNOW,Y(J),HSKIRT,RU,RV,DUMMY,1) + CALL DRAWS (IFIX(RU),IFIX(RV),M(1,IN,J),M(2,IN,J),1,0) + 270 CONTINUE + CALL DRAWS (IFIX(UY1),IFIX(VY1),IFIX(UY2),IFIX(VY2),1,1) + IF (IDRX .NE. 0) GO TO 290 + DO 280 J=2,NNYY + CALL DRAWS (M(1,IN,J-1),M(2,IN,J-1),M(1,IN,J),M(2,IN,J),1,1) + 280 CONTINUE +C +C PICK PROPER ALGORITHM +C + 290 LI = MXJ(1) + MI = MXS(1)-LI + NI = IABS(MI-MXF(1)) + LJ = MYJ(1) + MJ = MYS(1)-LJ + NJ = IABS(MJ-MYF(1)) +C +C WHEN LINE OF SIGHT IS NEARER TO PARALLEL TO THE X AXIS, +C HAVE J LOOP OUTER-MOST, OTHERWISE HAVE I LOOP OUTER-MOST. +C + IF (ABS(RX) .LE. ABS(RY)) GO TO 360 + IF (ISKIRT.NE.0 .OR. NYPASS.NE.1) GO TO 310 + I = MXS(1) + DO 300 J=2,NNYY + CALL DRAWS (M(1,I,J-1),M(2,I,J-1),M(1,I,J),M(2,I,J),0,1) + 300 CONTINUE + 310 DO 350 II=1,NNXX + I = MI+II*LI + IPLI = I+LI + IF (NYPASS .EQ. 1) GO TO 320 + K = MYS(1) + L = MYS(2) + IF (IDRX .NE. 0) + 1 CALL DRAWS (M(1,I,K),M(2,I,K),M(1,I,L),M(2,I,L),1,1) + IF (NDRZ.NE.0 .AND. II.NE.NI) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI),K) + 320 DO 340 JPASS=1,NYPASS + LJ = MYJ(JPASS) + MJ = MYS(JPASS)-LJ + NJ = IABS(MJ-MYF(JPASS)) + DO 330 JJ=1,NJ + J = MJ+JJ*LJ + JPLJ = J+LJ + IF (IDRX.NE.0 .AND. JJ.NE.NJ) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,JPLJ), + 2 M(2,I,JPLJ),1,1) + IF (I.NE.MXF(1) .AND. IDRY.NE.0) + 1 CALL DRAWS (M(1,IPLI,J),M(2,IPLI,J),M(1,I,J), + 2 M(2,I,J),1,1) + IF (NDRZ.NE.0 .AND. JJ.NE.NJ .AND. II.NE.NNXX) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI), + 2 MIN0(J,J+LJ)) + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE + GO TO 430 + 360 IF (ISKIRT.NE.0 .OR. NXPASS.NE.1) GO TO 380 + J = MYS(1) + DO 370 I=2,NNXX + CALL DRAWS (M(1,I-1,J),M(2,I-1,J),M(1,I,J),M(2,I,J),0,1) + 370 CONTINUE + 380 DO 420 JJ=1,NNYY + J = MJ+JJ*LJ + JPLJ = J+LJ + IF (NXPASS .EQ. 1) GO TO 390 + K = MXS(1) + L = MXS(2) + IF (IDRY .NE. 0) + 1 CALL DRAWS (M(1,K,J),M(2,K,J),M(1,L,J),M(2,L,J),1,1) + IF (NDRZ.NE.0 .AND. JJ.NE.NJ) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,K,MIN0(J,J+LJ)) + 390 DO 410 IPASS=1,NXPASS + LI = MXJ(IPASS) + MI = MXS(IPASS)-LI + NI = IABS(MI-MXF(IPASS)) + DO 400 II=1,NI + I = MI+II*LI + IPLI = I+LI + IF (IDRY.NE.0 .AND. II.NE.NI) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,IPLI,J), + 2 M(2,IPLI,J),1,1) + IF (J.NE.MYF(1) .AND. IDRX.NE.0) + 1 CALL DRAWS (M(1,I,JPLJ),M(2,I,JPLJ),M(1,I,J), + 2 M(2,I,J),1,1) + IF (NDRZ.NE.0 .AND. II.NE.NI .AND. JJ.NE.NNYY) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI), + 2 MIN0(J,J+LJ)) + 400 CONTINUE + 410 CONTINUE + 420 CONTINUE + 430 IF (ISKIRT .EQ. 0) GO TO 520 +C +C FIX UP IF SKIRT IS USED WITH LINES ONE WAY. +C + IF (IDRX .NE. 0) GO TO 460 + DO 450 IPASS=1,NXPASS + IF (NXPASS .EQ. 2) IF = 1+(IPASS-1)*(NNXX-1) + DO 440 J=2,NNYY + CALL DRAWS (M(1,IF,J-1),M(2,IF,J-1),M(1,IF,J),M(2,IF,J), + 1 1,0) + 440 CONTINUE + 450 CONTINUE + 460 IF (IDRY .NE. 0) GO TO 520 + DO 480 JPASS=1,NYPASS + IF (NYPASS .EQ. 2) JF = 1+(JPASS-1)*(NNYY-1) + DO 470 I=2,NNXX + CALL DRAWS (M(1,I-1,JF),M(2,I-1,JF),M(1,I,JF),M(2,I,JF), + 1 1,0) + 470 CONTINUE + 480 CONTINUE + GO TO 520 +C +C ALL VISIBLE IF VIEWED FROM DIRECTLY ABOVE OR BELOW. +C + 490 IF (NUPPER.GT.0 .AND. S(3).LT.S(6)) GO TO 520 + IF (NUPPER.LT.0 .AND. S(3).GT.S(6)) GO TO 520 + NUPPER = 1 + IF (S(3) .LT. S(6)) NUPPER = -1 + DO 510 I=1,NNXX + DO 500 J=1,NNYY + IF (IDRX.NE.0 .AND. J.NE.NNYY) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,J+1),M(2,I,J+1), + 2 1,0) + IF (IDRY.NE.0 .AND. I.NE.NNXX) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I+1,J),M(2,I+1,J), + 2 1,0) + IF (IDRZ.NE.0 .AND. I.NE.NNXX .AND. J.NE.NNYY) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,I,J) + 500 CONTINUE + 510 CONTINUE + 520 IF (STER .EQ. 0.) GO TO 560 + IF (ISTP) 540,530,550 + 530 CALL FRAME + 540 CALL FRAME + GO TO 570 + 550 IF (IPIC .NE. 2) GO TO 570 + 560 IF (IFR .GT. 0) CALL FRAME + 570 CONTINUE + RETURN + END + SUBROUTINE EZSRFC (Z,M,N,ANGH,ANGV,WORK) + DIMENSION Z(M,N) ,WORK(1) +C +C WORK(2*M*N+M+N) +C +C PERSPECTIVE PICTURE OF A SURFACE STORED IN A TWO DIMENSIONAL ARRAY +C VIA A VERY SHORT ARGUMENT LIST. +C +C ASSUMPTIONS-- +C THE ENTIRE ARRAY IS TO BE DRAWN, +C THE DATA IS EQUALLY SPACED (IN THE X-Y PLANE), +C NO STEREO PAIRS. +C IF THESE ASSUMPTIONS ARE NOT MET USE SRFACE. +C +C ARGUMENTS-- +C Z THE 2 DIMENSIONAL ARRAY TO BE DRAWN. +C M THE FIRST DIMENSION OF Z. +C N THE SECOND DIMENSION OF Z. +C ANGH ANGLE IN DEGREES IN THE X-Y PLANE TO THE LINE OF SIGHT +C (COUNTER-CLOCK WISE FROM THE PLUS-X AXIS). +C ANGV ANGLE IN DEGREES FROM THE X-Y PLANE TO THE LINE OF SIGHT +C (POSITIVE ANGLES ARE ABOVE THE MIDDLE Z, NEGATIVE BELOW). +C WORK A SCRATCH STORAGE DIMENSIONED AT LEAST 2*M*N+M+N. +C + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 NOFFP ,NSPVAL ,SPV ,BIGEST + DIMENSION S(6) + DATA S(4),S(5),S(6)/0.0,0.0,0.0/ +C +C FACT1 IS THE PERSPECTIVE RATIO AND IS DEFINED TO BE THE RATIO +C MAXIMUM(LENGTH,WIDTH)/HEIGHT +C +C FACT2 IS THE RATIO (LENGTH OF LINE OF SIGHT)/MAXIMUM(LENGTH,WIDTH) +C + DATA FACT1,FACT2/2.0,5.0/ + BIGEST = R1MACH(2) +C +C FIND RANGE OF Z +C + MX = M + NY = N + ANG1 = ANGH*3.14159265358979/180. + ANG2 = ANGV*3.14159265358979/180. + FLO = BIGEST + HI = -FLO + DO 20 J=1,NY + DO 10 I=1,MX + IF (NOFFP.EQ.1 .AND. Z(I,J).EQ.SPV) GO TO 10 + HI = AMAX1(Z(I,J),HI) + FLO = AMIN1(Z(I,J),FLO) + 10 CONTINUE + 20 CONTINUE +C +C SET UP LINEAR X AND Y ARRAYS FOR SRFACE +C + DELTA = (HI-FLO)/(AMAX0(MX,NY)-1.)*FACT1 + XMIN = -(FLOAT(MX/2)*DELTA+FLOAT(MOD(MX+1,2))*DELTA) + YMIN = -(FLOAT(NY/2)*DELTA+FLOAT(MOD(NY+1,2))*DELTA) + DO 30 I=1,MX + WORK(I) = XMIN+FLOAT(I-1)*DELTA + 30 CONTINUE + DO 40 J=1,NY + K = MX+J + WORK(K) = YMIN+FLOAT(J-1)*DELTA + 40 CONTINUE +C +C SET UP EYE POSITION +C + FACTE = (HI-FLO)*FACT1*FACT2 + CANG2 = COS(ANG2) + S(1) = FACTE*CANG2*COS(ANG1) + S(2) = FACTE*CANG2*SIN(ANG1) + S(3) = FACTE*SIN(ANG2)+(FLO+HI)*.5 +C +C READY +C + CALL SRFACE (WORK(1),WORK(MX+1),Z,WORK(K+1),MX,MX,NY,S,0.) + RETURN + END + SUBROUTINE SETR (XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,R0) +C +C THIS ROUTINE ESTABLISHES CERTAIN CONSTANTS SO THAT SRFACE +C PRODUCES A PICTURE WHOSE SIZE CHANGES WITH RESPECT TO THE +C VIEWERS DISTANCE FROM THE OBJECT. IT CAN ALSO BE USED +C WHEN MAKING A MOVIE OF AN OBJECT EVOLVING IN TIME TO KEEP +C IT POSITIONED PROPERLY ON THE SCREEN, SAVING COMPUTER TIME +C IN THE BARGIN. CALL IT WITH R0 NEGATIVE TO TURN OFF THIS +C FEATURE. +C PARAMETERS +C XMIN,XMAX - RANGE OF X ARRAY THAT WILL BE PASSED TO SRFACE. +C YMIN,YMAX - SAME IDEA, BUT FOR Y. +C ZMIN,ZMAX - SAME IDEA, BUT FOR Z. IF A MOVIE IS BEING +C MADE OF AN EVOLVING Z ARRAY, ZMIN AND ZMAX +C SHOULD CONTAIN RANGE OF THE UNION OF ALL THE Z +C ARRAYS. THEY NEED NOT BE EXACT. +C R0 - DISTANCE BETWEEN OBSERVER AND POINT LOOKED AT +C WHEN THE PICTURE IS TO FILL THE SCREEN WHEN +C VIEWED FROM THE DIRECTION WHICH MAKES THE PIC- +C TURE BIGGEST. IF R0 IS NOT POSITIVE, THEN THE +C RELATIVE SIZE FEATURE IS TURNED OFF, AND SUB- +C SEQUENT PICTURES WILL FILL THE SCREEN. +C + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ +C +C + CALL Q8QST4 ('GRAPHX','SRFACE','SETR','VERSION 01') + IF (R0) 10, 10, 20 + 10 NRSWT = 0 + RETURN + 20 NRSWT = 1 + XXMIN = XMIN + XXMAX = XMAX + YYMIN = YMIN + YYMAX = YMAX + ZZMIN = ZMIN + ZZMAX = ZMAX + RZERO = R0 + LL = 0 + XAT = (XXMAX+XXMIN)*.5 + YAT = (YYMAX+YYMIN)*.5 + ZAT = (ZZMAX+ZZMIN)*.5 + ALPHA = -(YYMIN-YAT)/(XXMIN-XAT) + YEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + XEYE = YEYE*ALPHA + YEYE = YEYE+YAT + XEYE = XEYE+XAT + ZEYE = ZAT + CALL TRN32S (XAT,YAT,ZAT,XEYE,YEYE,ZEYE,0) + XMN = XXMIN + XMX = XXMAX + YMN = YYMIN + YMX = YYMAX + ZMN = ZZMIN + ZMX = ZZMAX + CALL TRN32S (XMN,YMN,ZAT,UMN,DUMMY,DUMMIE,1) + CALL TRN32S (XMX,YMN,ZMN,DUMMY,VMN,DUMMIE,1) + CALL TRN32S (XMX,YMX,ZAT,UMX,DUMMY,DUMMIE,1) + CALL TRN32S (XMX,YMN,ZMX,DUMMY,VMX,DUMMIE,1) + UMIN = UMN + UMAX = UMX + VMIN = VMN + VMAX = VMX + BIGD = SQRT((XXMAX-XXMIN)**2+(YYMAX-YYMIN)**2+(ZZMAX-ZZMIN)**2)*.5 + RETURN + END + SUBROUTINE DRAWS (MX1,MY1,MX2,MY2,IDRAW,IMARK) +C +C THIS ROUTINE DRAWS THE VISIBLE PART OF THE LINE CONNECTING +C (MX1,MY1) AND (MX2,MY2). IF IDRAW .NE. 0, THE LINE IS DRAWN. +C IF IMARK .NE. 0, THE VISIBILITY ARRAY IS MARKED. +C + LOGICAL VIS1 ,VIS2 + DIMENSION PXS(2) ,PYS(2) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DATA STEEP/5./ + DATA MX, MY /0, 0/ +C +c +NOAO: Blockdata srfabd rewritten as run time initialization +c EXTERNAL SRFABD + call srfabd +c -NOAO +C MAKE LINE LEFT TO RIGHT. +C + MMX1 = MX1 + MMY1 = MY1 + MMX2 = MX2 + MMY2 = MY2 + IF (MMX1.EQ.NSPVAL .OR. MMX2.EQ.NSPVAL) RETURN + IF (MMX1 .GT. MMX2) GO TO 10 + NX1 = MMX1 + NY1 = MMY1 + NX2 = MMX2 + NY2 = MMY2 + GO TO 20 + 10 NX1 = MMX2 + NY1 = MMY2 + NX2 = MMX1 + NY2 = MMY1 + 20 IF (NUPPER .LT. 0) GO TO 180 +C +C CHECK UPPER VISIBILITY. +C + VIS1 = NY1 .GE. (LIMU(NX1)-1) + VIS2 = NY2 .GE. (LIMU(NX2)-1) +C +C VIS1 AND VIS2 TRUE MEANS VISIBLE. +C + IF (VIS1 .AND. VIS2) GO TO 120 +C +C VIS1 AND VIS2 FALSE MEANS INVISIBLE. +C + IF (.NOT.(VIS1 .OR. VIS2)) GO TO 180 +C +C FIND CHANGE POINT. +C + IF (NX1 .EQ. NX2) GO TO 110 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + NX1P1 = NX1+1 + FNY1 = NY1 + IF (VIS1) GO TO 60 + DO 30 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .GT. LIMU(K)) GO TO 40 + 30 CONTINUE + 40 IF (ABS(DY) .GE. STEEP) GO TO 90 + 50 NX1 = MX + NY1 = MY + GO TO 120 + 60 DO 70 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .LT. LIMU(K)) GO TO 80 + 70 CONTINUE + 80 IF (ABS(DY) .GE. STEEP) GO TO 100 + NX2 = MX-1 + NY2 = MY + GO TO 120 + 90 IF (LIMU(MX) .EQ. 0) GO TO 50 + NX1 = MX + NY1 = LIMU(NX1) + GO TO 120 + 100 NX2 = MX-1 + NY2 = LIMU(NX2) + GO TO 120 + 110 IF (VIS1) NY2 = MIN0(LIMU(NX1),LIMU(NX2)) + IF (VIS2) NY1 = MIN0(LIMU(NX1),LIMU(NX2)) + 120 IF (IDRAW .EQ. 0) GO TO 150 +C +C DRAW VISIBLE PART OF LINE. +C + IF (IROT) 130,140,130 + 130 CONTINUE + PXS(1) = FLOAT(NY1) + PXS(2) = FLOAT(NY2) + PYS(1) = FLOAT(1024-NX1) + PYS(2) = FLOAT(1024-NX2) + CALL GPL (2,PXS,PYS) + GO TO 150 + 140 CONTINUE + PXS(1) = FLOAT(NX1) + PXS(2) = FLOAT(NX2) + PYS(1) = FLOAT(NY1) + PYS(2) = FLOAT(NY2) + CALL GPL (2,PXS,PYS) + 150 IF (IMARK .EQ. 0) GO TO 180 + IF (NX1 .EQ. NX2) GO TO 170 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + FNY1 = NY1 + DO 160 K=NX1,NX2 + LTEMP = FNY1+FLOAT(K-NX1)*DY + IF (LTEMP .GT. LIMU(K)) LIMU(K) = LTEMP + 160 CONTINUE + GO TO 180 + 170 LTEMP = MAX0(NY1,NY2) + IF (LTEMP .GT. LIMU(NX1)) LIMU(NX1) = LTEMP + 180 IF (NUPPER) 190,190,370 +C +C SAME IDEA AS ABOVE, BUT FOR LOWER SIDE. +C + 190 IF (MMX1 .GT. MMX2) GO TO 200 + NX1 = MMX1 + NY1 = MMY1 + NX2 = MMX2 + NY2 = MMY2 + GO TO 210 + 200 NX1 = MMX2 + NY1 = MMY2 + NX2 = MMX1 + NY2 = MMY1 + 210 VIS1 = NY1 .LE. (LIML(NX1)+1) + VIS2 = NY2 .LE. (LIML(NX2)+1) + IF (VIS1 .AND. VIS2) GO TO 310 + IF (.NOT.(VIS1 .OR. VIS2)) GO TO 370 + IF (NX1 .EQ. NX2) GO TO 300 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + NX1P1 = NX1+1 + FNY1 = NY1 + IF (VIS1) GO TO 250 + DO 220 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .LT. LIML(K)) GO TO 230 + 220 CONTINUE + 230 IF (ABS(DY) .GE. STEEP) GO TO 280 + 240 NX1 = MX + NY1 = MY + GO TO 310 + 250 DO 260 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .GT. LIML(K)) GO TO 270 + 260 CONTINUE + 270 IF (ABS(DY) .GE. STEEP) GO TO 290 + NX2 = MX-1 + NY2 = MY + GO TO 310 + 280 IF (LIML(MX) .EQ. 1024) GO TO 240 + NX1 = MX + NY1 = LIML(NX1) + GO TO 310 + 290 NX2 = MX-1 + NY2 = LIML(NX2) + GO TO 310 + 300 IF (VIS1) NY2 = MAX0(LIML(NX1),LIML(NX2)) + IF (VIS2) NY1 = MAX0(LIML(NX1),LIML(NX2)) + 310 IF (IDRAW .EQ. 0) GO TO 340 + IF (IROT) 320,330,320 + 320 CONTINUE + PXS(1) = FLOAT(NY1) + PXS(2) = FLOAT(NY2) + PYS(1) = FLOAT(1024-NX1) + PYS(2) = FLOAT(1024-NX2) + CALL GPL (2,PXS,PYS) + GO TO 340 + 330 CONTINUE + PXS(1) = FLOAT(NX1) + PXS(2) = FLOAT(NX2) + PYS(1) = FLOAT(NY1) + PYS(2) = FLOAT(NY2) + CALL GPL (2,PXS,PYS) + 340 IF (IMARK .EQ. 0) GO TO 370 + IF (NX1 .EQ. NX2) GO TO 360 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + FNY1 = NY1 + DO 350 K=NX1,NX2 + LTEMP = FNY1+FLOAT(K-NX1)*DY + IF (LTEMP .LT. LIML(K)) LIML(K) = LTEMP + 350 CONTINUE + RETURN + 360 LTEMP = MIN0(NY1,NY2) + IF (LTEMP .LT. LIML(NX1)) LIML(NX1) = LTEMP + 370 RETURN + END + SUBROUTINE TRN32S (X,Y,Z,XT,YT,ZT,IFLAG) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C IFLAG=0 ARGUMENTS +C X,Y,Z ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C IFLAG=1 ARGUMENTS +C X,Y,Z ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. +C USE IFIX(XT) AND IFIX(YT) IN GPL CALLS. +C ZT NOT USED. +C IF LL (IN COMMON) =0 XT AND YT ARE IN THE SAME SCALE AS X, Y, AND Z. +C + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DIMENSION NLU(7) ,NRU(7) ,NBV(7) ,NTV(7) +C +C SAVE INSERTED BY BEN DOMENICO 9/8/85 BECAUSE OF ASSUMPTION THAT +C JUMP, JUMP2, AND JUMP3 ARE PRESERVED BETWEEN CALLS. +C THERE MAY BE OTHER SUCH ASSUMPTIONS AS WELL. +C + SAVE +C +C PICTURE CORNER COORDINATES FOR LL=1 +C + DATA NLU(1),NRU(1),NBV(1),NTV(1)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=2 +C + DATA NLU(2),NRU(2),NBV(2),NTV(2)/ 10, 924, 50, 964/ +C +C PICTURE CORNER COORDINATES FOR LL=3 +C + DATA NLU(3),NRU(3),NBV(3),NTV(3)/ 100,1014, 50, 964/ +C +C PICTURE CORNER COORDINATES FOR LL=4 +C + DATA NLU(4),NRU(4),NBV(4),NTV(4)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=5 +C + DATA NLU(5),NRU(5),NBV(5),NTV(5)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=6 +C + DATA NLU(6),NRU(6),NBV(6),NTV(6)/ 10, 512, 256, 758/ +C +C PICTURE CORNER COORDINATES FOR LL=7 +C + DATA NLU(7),NRU(7),NBV(7),NTV(7)/ 512,1014, 256, 758/ +C +C STORE THE PARAMETERS OF THE SET32 CALL FOR USE WHEN +C TRN32 IS CALLED. +C + IF (IFLAG) 40, 10, 40 + 10 CONTINUE + ASSIGN 60 TO JUMP3 + IF (IOFFP .EQ. 1) ASSIGN 50 TO JUMP3 + AX = X + AY = Y + AZ = Z + EX = XT + EY = YT + EZ = ZT +C +C AS MUCH COMPUTATION AS POSSIBLE IS DONE DURING EXECUTION +C THIS ROUTINE WHEN IFLAG=0 BECAUSE CALLS IN THAT MODE ARE INFREQUENT. +C + DX = AX-EX + DY = AY-EY + DZ = AZ-EZ + D = SQRT(DX*DX+DY*DY+DZ*DZ) + COSAL = DX/D + COSBE = DY/D + COSGA = DZ/D + SINGA = SQRT(1.-COSGA*COSGA) + ASSIGN 120 TO JUMP2 + IF (LL .EQ. 0) GO TO 20 + ASSIGN 100 TO JUMP2 + DELCRT = NRU(LL)-NLU(LL) + U0 = UMIN + V0 = VMIN + U1 = NLU(LL) + V1 = NBV(LL) + U2 = NRU(LL)-NLU(LL) + V2 = NTV(LL)-NBV(LL) + U3 = U2/(UMAX-UMIN) + V3 = V2/(VMAX-VMIN) + U4 = NRU(LL) + V4 = NTV(LL) + IF (NRSWT .EQ. 0) GO TO 20 + U0 = -BIGD + V0 = -BIGD + U3 = U2/(2.*BIGD) + V3 = V2/(2.*BIGD) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE Z AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE Z AXIS, THE 3-SPACE Y AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE Z AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + 20 IF (SINGA .LT. 0.0001) GO TO 30 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 30 SINBE = SQRT(1.-COSBE*COSBE) + R = 1./SINBE + ASSIGN 80 TO JUMP + RETURN + 40 CONTINUE + XX = X + YY = Y + ZZ = Z + GO TO JUMP3,( 50, 60) + 50 IF (ZZ .EQ. SPVAL) GO TO 110 + 60 Q = D/((XX-EX)*COSAL+(YY-EY)*COSBE+(ZZ-EZ)*COSGA) + GO TO JUMP,( 70, 80) + 70 XX = ((EX+Q*(XX-EX)-AX)*COSBE-(EY+Q*(YY-EY)-AY)*COSAL)*R + YY = (EZ+Q*(ZZ-EZ)-AZ)*R + GO TO 90 + 80 XX = ((EZ+Q*(ZZ-EZ)-AZ)*COSAL-(EX+Q*(XX-EX)-AX)*COSGA)*R + YY = (EY+Q*(YY-EY)-AY)*R + 90 GO TO JUMP2,(100,120) +c + NOAO: Clipping is done at the gio level and is unnecessary here. The +c following statements were preventing labels from being positioned properly +c at the edges of the surface plot, even when the viewport had been reset. + 100 xx = u1 + u3 * (fact * xx - u0) + yy = v1 + v3 * (fact * yy - v0) +c 100 XX = AMIN1(U4,AMAX1(U1,U1+U3*(FACT*XX-U0))) +c YY = AMIN1(V4,AMAX1(V1,V1+V3*(FACT*YY-V0))) +c -NOAO + GO TO 120 + 110 XX = NSPVAL + YY = NSPVAL +C + 120 XT = XX + YT = YY + RETURN + END + SUBROUTINE CLSET (Z,MX,NX,NY,CHI,CLO,CINC,NLA,NLM,CL,NCL,ICNST, + 1 IOFFP,SPVAL,BIGEST) + DIMENSION Z(MX,NY) ,CL(NLM) + DATA KK /0/ +C +C CLSET PUTS THE VALUS OF THE CONTOUR LEVELS IN CL +C + ICNST = 0 + GLO = CLO + HA = CHI + FANC = CINC + CRAT = NLA + IF (HA-GLO) 10, 20, 50 + 10 GLO = HA + HA = CLO + GO TO 50 + 20 GLO = BIGEST + HA = -GLO + DO 40 J=1,NY + DO 30 I=1,NX + IF (IOFFP.EQ.1 .AND. Z(I,J).EQ.SPVAL) GO TO 30 + GLO = AMIN1(Z(I,J),GLO) + HA = AMAX1(Z(I,J),HA) + 30 CONTINUE + 40 CONTINUE + 50 IF (FANC) 60, 70, 90 + 60 CRAT = -FANC + 70 FANC = (HA-GLO)/CRAT + IF (FANC) 140,140, 80 + 80 P = 10.**(IFIX(ALOG10(FANC)+500.)-500) + FANC = AINT(FANC/P)*P + 90 IF (CHI-CLO) 110,100,110 + 100 GLO = AINT(GLO/FANC)*FANC + HA = AINT(HA/FANC)*FANC + 110 DO 120 K=1,NLM + CC = GLO+FLOAT(K-1)*FANC + IF (CC .GT. HA) GO TO 130 + KK = K + CL(K) = CC + 120 CONTINUE + 130 NCL = KK + RETURN + 140 ICNST = 1 + RETURN + END + SUBROUTINE CTCELL (Z,MX,NX,NY,M,I0,J0) +C +C CTCELL COMPUTES LINES OF CONSTANT Z (CONTOUR LINES) IN ONE +C CELL OF THE ARRAY Z FOR THE SRFACE PACKAGE. +C Z,MX,NX,NY ARE THE SAME AS IN SRFACE. +C M BY THE TIME CTCELL IS FIRST CALLED, M CONTAINS +C THE TWO-SPACE PLOTTER LOCATION OF EACH Z POINT. +C U(Z(I,J))=M(1,I,J). V(Z(I,J))=M(2,I,J) +C I0,J0 THE CELL Z(I0,J0) TO Z(I0+1,J0+1) IS THE ONE TO +C BE CONTOURED. +C + DIMENSION Z(MX,NY) ,M(2,NX,NY) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DATA IDUB/0/ + R(HO,HU) = (HO-CV)/(HO-HU) + I1 = I0 + I1P1 = I1+1 + J1 = J0 + J1P1 = J1+1 + H1 = Z(I1,J1) + H2 = Z(I1,J1P1) + H3 = Z(I1P1,J1P1) + H4 = Z(I1P1,J1) + IF (IOFFP .NE. 1) GO TO 10 + IF (H1.EQ.SPVAL .OR. H2.EQ.SPVAL .OR. H3.EQ.SPVAL .OR. + 1 H4.EQ.SPVAL) RETURN + 10 IF (AMIN1(H1,H2,H3,H4) .GT. CL(NCL)) RETURN + DO 110 K=1,NCL +C +C FOR EACH CONTOUR LEVEL, DESIDE WHICH OF THE 16 BASIC SIT- +C UATIONS EXISTS, THEN INTERPOLATE IN TWO-SPACE TO FIND THE +C END POINTS OF THE CONTOUR LINE SEGMENT WITHIN THIS CELL. +C + CV = CL(K) + K1 = (IFIX(SIGN(1.,H1-CV))+1)/2 + K2 = (IFIX(SIGN(1.,H2-CV))+1)/2 + K3 = (IFIX(SIGN(1.,H3-CV))+1)/2 + K4 = (IFIX(SIGN(1.,H4-CV))+1)/2 + JUMP = 1+K1+K2*2+K3*4+K4*8 + GO TO (120, 30, 50, 60, 70, 20, 80, 90, 90, 80, + 1 40, 70, 60, 50, 30,110),JUMP + 20 IDUB = 1 + 30 RA = R(H1,H2) + MUA = FLOAT(M(1,I1,J1))+RA*FLOAT(M(1,I1,J1P1)-M(1,I1,J1)) + MVA = FLOAT(M(2,I1,J1))+RA*FLOAT(M(2,I1,J1P1)-M(2,I1,J1)) + RB = R(H1,H4) + MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1)) + MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1)) + GO TO 100 + 40 IDUB = -1 + 50 RA = R(H2,H1) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1)) + RB = R(H2,H3) + MUB = FLOAT(M(1,I1,J1P1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1)) + MVB = FLOAT(M(2,I1,J1P1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1)) + GO TO 100 + 60 RA = R(H2,H3) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1)) + RB = R(H1,H4) + MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1)) + MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1)) + GO TO 100 + 70 RA = R(H3,H2) + MUA = FLOAT(M(1,I1P1,J1P1))+ + 1 RA*FLOAT(M(1,I1,J1P1)-M(1,I1P1,J1P1)) + MVA = FLOAT(M(2,I1P1,J1P1))+ + 1 RA*FLOAT(M(2,I1,J1P1)-M(2,I1P1,J1P1)) + RB = R(H3,H4) + MUB = FLOAT(M(1,I1P1,J1P1))+ + 1 RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1)) + MVB = FLOAT(M(2,I1P1,J1P1))+ + 1 RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1)) + IDUB = 0 + GO TO 100 + 80 RA = R(H2,H1) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1)) + RB = R(H3,H4) + MUB = FLOAT(M(1,I1P1,J1P1))+ + 1 RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1)) + MVB = FLOAT(M(2,I1P1,J1P1))+ + 1 RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1)) + GO TO 100 + 90 RA = R(H4,H1) + MUA = FLOAT(M(1,I1P1,J1))+RA*FLOAT(M(1,I1,J1)-M(1,I1P1,J1)) + MVA = FLOAT(M(2,I1P1,J1))+RA*FLOAT(M(2,I1,J1)-M(2,I1P1,J1)) + RB = R(H4,H3) + MUB = FLOAT(M(1,I1P1,J1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1P1,J1)) + MVB = FLOAT(M(2,I1P1,J1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1P1,J1)) + IDUB = 0 + 100 CALL DRAWS (MUA,MVA,MUB,MVB,1,0) + IF (IDUB) 90,110, 70 + 110 CONTINUE + 120 RETURN + END diff --git a/sys/gio/ncarutil/strmln.f b/sys/gio/ncarutil/strmln.f new file mode 100644 index 00000000..411caed8 --- /dev/null +++ b/sys/gio/ncarutil/strmln.f @@ -0,0 +1,957 @@ + SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) +C +C DIMENSION OF U(IMAX,JPTSY) , V(IMAX,JPTSY) , +C ARGUMENTS WORK(2*IMAX*JPTSY) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE STRMLN DRAWS A STREAMLINE REPRESENTATION OF +C THE FLOW FIELD. THE REPRESENTATION IS +C INDEPENDENT OF THE FLOW SPEED. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZSTRM (U,V,WORK,IMAX,JMAX) +C +C ASSUMPTIONS: +C --THE WHOLE ARRAY IS TO BE PROCESSED. +C --THE ARRAYS ARE DIMENSIONED +C U(IMAX,JMAX) , V(IMAX,JMAX) AND +C WORK(2*IMAX*JMAX). +C --WINDOW AND VIEWPORT ARE TO BE CHOSEN +C BY STRMLN. +C --PERIM IS TO BE CALLED. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY, +C NSET,IER) +C +C THE USER MUST CALL FRAME IN THE CALLING +C ROUTINE. +C +C THE USER MAY CHANGE VARIOUS INTERNAL +C PARAMETERS VIA COMMON BLOCKS. SEE BELOW. +C +C ARGUMENTS +C +C ON INPUT U, V +C TWO DIMENSIONAL ARRAYS CONTAINING THE +C VELOCITY FIELDS TO BE PLOTTED. +C (NOTE: IF THE U AND V COMPONENTS +C ARE, FOR EXAMPLE, DEFINED IN CARTESIAN +C COORDINATES AND THE USER WISHES TO PLOT THEM +C ON A DIFFERENT PROJECTION (I.E., STEREO- +C GRAPHIC), THEN THE APPROPRIATE +C TRANSFORMATION MUST BE MADE TO THE U AND V +C COMPONENTS VIA THE FUNCTIONS FU AND FV +C (LOCATED IN DRWSTR). +C +C WORK +C USER PROVIDED WORK ARRAY. THE DIMENSION +C OF THIS ARRAY MUST BE .GE. 2*IMAX*JPTSY. +C CAUTION: THIS ROUTINE DOES NOT CHECK THE +C SIZE OF THE WORK ARRAY. +C +C IMAX +C THE FIRST DIMENSION OF U AND V IN THE +C CALLING PROGRAM. (X-DIRECTION) +C +C IPTSX +C THE NUMBER OF POINTS TO BE PLOTTED IN THE +C FIRST SUBSCRIPT DIRECTION. (X-DIRECTION) +C +C JPTSY +C THE NUMBER OF POINTS TO BE PLOTTED IN THE +C SECOND SUBSCRIPT DIRECTION. (Y-DIRECTION) +C +C NSET +C FLAG TO CONTROL SCALING +C > 0 STRMLN ASSUMES THAT THE WINDOW +C AND VIEWPORT HAVE BEEN SET BY THE +C USER IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING INSTRUCTIONS +C GENERATED BY STRMLN. PERIM IS NOT +C CALLED. +C = 0 STRMLN WILL ESTABLISH THE WINDOW AND +C VIEWPORT TO PROPERLY SCALE THE +C PLOTTING INSTRUCTIONS TO THE STANDARD +C CONFIGURATION. PERIM IS CALLED TO DRAW +C THE BORDER. +C < 0 STRMLN ESTABLISHES THE WINDOW +C AND VIEWPORT SO AS TO PLACE THE +C STREAMLINES WITHIN THE LIMITS +C OF THE USER'S WINDOW. PERIM IS +C NOT CALLED. +C +C ON OUTPUT ONLY THE IER ARGUMENT MAY BE CHANGED. ALL +C OTHER ARGUMENTS ARE UNCHANGED. +C +C +C IER +C = 0 WHEN NO ERRORS ARE DETECTED +C = -1 WHEN THE ROUTINE IS CALLED WITH ICYC +C .NE. 0 AND THE DATA ARE NOT CYCLIC +C (ICYC IS AN INTERNAL PARAMETER +C DESCRIBED BELOW); IN THIS CASE THE +C ROUTINE WILL DRAW THE +C STREAMLINES WITH THE NON-CYCLIC +C INTERPOLATION FORMULAS. +C +C ENTRY POINTS STRMLN, DRWSTR, EZSTRM, GNEWPT, CHKCYC +C +C COMMON BLOCKS STR01, STR02, STR03, STR04 +C +C REQUIRED LIBRARY GRIDAL, GBYTES, AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C I/O DRAWS STREAMLINES +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN 1979. +C CONVERTED TO FORTRAN 77 AND GKS IN JUNE 1984. +C +C PORTABILITY FORTRAN 77 +C +C ALGORITHM WIND COMPONENTS ARE NORMALIZED TO THE VALUE +C OF DISPL. THE LEAST SIGNIFICANT TWO +C BITS OF THE WORK ARRAY ARE +C UTILIZED AS FLAGS FOR EACH GRID BOX. FLAG 1 +C INDICATES WHETHER ANY STREAMLINE HAS +C PREVIOUSLY PASSED THROUGH THIS BOX. FLAG 2 +C INDICATES WHETHER A DIRECTIONAL ARROW HAS +C ALREADY APPEARED IN A BOX. JUDICIOUS USE +C OF THESE FLAGS PREVENTS OVERCROWDING OF +C STREAMLINES AND DIRECTIONAL ARROWS. +C EXPERIENCE INDICATES THAT A FINAL PLEASING +C PICTURE IS PRODUCED WHEN STREAMLINES ARE +C INITIATED IN THE CENTER OF A GRID BOX. THE +C STREAMLINES ARE DRAWN IN ONE DIRECTION THEN +C IN THE OPPOSITE DIRECTION. +C +C REFERENCE THE TECHNIQUES UTILIZED HERE ARE DESCRIBED +C IN AN ARTICLE BY THOMAS WHITTAKER (U. OF +C WISCONSIN) WHICH APPEARED IN THE NOTES AND +C CORRESPONDENCE SECTION OF MONTHLY WEATHER +C REVIEW, JUNE 1977. +C +C TIMING HIGHLY VARIABLE +C IT DEPENDS ON THE COMPLEXITY OF THE +C FLOW FIELD AND THE PARAMETERS: DISPL, +C DISPC , CSTOP , INITA , INITB , ITERC , +C AND IGFLG. (SEE BELOW FOR A DISCUSSION +C OF THESE PARAMETERS.) IF ALL VALUES +C ARE DEFAULT, THEN A SIMPLE LINEAR +C FLOW FIELD FOR A 40 X 40 GRID WILL +C TAKE ABOUT 0.4 SECONDS ON THE CRAY1-A; +C A FAIRLY COMPLEX FLOW FIELD WILL TAKE ABOUT +C 1.5 SECONDS ON THE CRAY1-A. +C +C +C INTERNAL PARAMETERS +C +C NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C EXT 0.25 LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO +C IPTSX AND JPTSY EXCEPT IN +C THE CASE WHEN MIN(IPTSX,JPT +C / MAX(IPTSX,JPTSY) .LT. EXT; +C IN THAT CASE A SQUARE +C GRAPH IS PLOTTED. +C +C SIDE 0.90 LENGTH OF LONGER EDGE OF +C PLOT. (SEE ALSO EXT.) +C +C XLT 0.05 LEFT HAND EDGE OF THE PLOT. +C (0.0 = LEFT EDGE OF FRAME) +C (1.0 = RIGHT EDGE OF FRAME) +C +C YBT 0.05 BOTTOM EDGE OF THE PLOT. +C (0.0 = BOTTOM ; 1.0 = TOP) +C +C (YBT+SIDE AND XLT+SIDE MUST +C BE .LE. 1. ) +C +C INITA 2 USED TO PRECONDITION GRID +C BOXES TO BE ELIGIBLE TO +C START A STREAMLINE. +C FOR EXAMPLE, A VALUE OF 4 +C MEANS THAT EVERY FOURTH +C GRID BOX IS ELIGIBLE ; A +C VALUE OF 2 MEANS THAT EVERY +C OTHER GRID BOX IS ELIGIBLE. +C (SEE INITB) +C +C INITB 2 USED TO PRECONDITION GRID +C BOXES TO BE ELIGIBLE FOR +C DIRECTION ARROWS. +C IF THE USER CHANGES THE +C DEFAULT VALUES OF INITA +C AND/OR INITB, IT SHOULD +C BE DONE SUCH THAT +C MOD(INITA,INITB) = 0 . +C FOR A DENSE GRID TRY +C INITA=4 AND INITB=2 TO +C REDUCE THE CPU TIME. +C +C AROWL 0.33 LENGTH OF DIRECTION ARROW. +C FOR EXAMPLE, 0.33 MEANS +C EACH DIRECTIONAL ARROW WILL +C TAKE UP A THIRD OF A GRID +C BOX. +C +C ITERP 35 EVERY 'ITERP' ITERATIONS +C THE STREAMLINE PROGRESS +C IS CHECKED. +C +C ITERC -99 THE DEFAULT VALUE OF THIS +C PARAMETER IS SUCH THAT +C IT HAS NO EFFECT ON THE +C CODE. WHEN SET TO SOME +C POSITIVE VALUE, THE PROGRAM +C WILL CHECK FOR STREAMLINE +C CROSSOVER EVERY 'ITERC' +C ITERATIONS. (THE ROUTINE +C CURRENTLY DOES THIS EVERY +C TIME IT ENTERS A NEW GRID +C BOX.) CAUTION: WHEN +C THIS PARAMETER IS ACTIVATED +C CPU TIME WILL INCREASE. +C +C IGFLG 0 A VALUE OF ZERO MEANS THAT +C THE SIXTEEN POINT BESSEL +C INTERPOLATION FORMULA WILL +C BE UTILIZED WHERE POSSIBLE; +C WHEN NEAR THE GRID EDGES, +C QUADRATIC AND BI-LINEAR +C INTERPOLATION WILL BE +C USED. THIS MIXING OF +C INTERPOLATION SCHEMES CAN +C SOMETIMES CAUSE SLIGHT +C RAGGEDNESS NEAR THE EDGES +C OF THE PLOT. IF IGFLG.NE.0, +C THEN ONLY THE BILINEAR +C INTERPOLATION FORMULA +C IS USED; THIS WILL GENERALLY +C RESULT IN SLIGHTLY FASTER +C PLOT TIMES BUT A LESS +C PLEASING PLOT. +C +C IMSG 0 IF ZERO, THEN NO MISSING +C U AND V COMPONENTS ARE +C PRESENT. +C IF .NE. 0, STRMLN WILL +C UTILIZE THE +C BI-LINEAR INTERPOLATION +C SCHEME AND TERMINATE IF +C ANY DATA POINTS ARE MISSING. +C +C UVMSG 1.E+36 VALUE ASSIGNED TO A MISSING +C POINT. +C +C ICYC 0 ZERO MEANS THE DATA ARE +C NON-CYCLIC IN THE X +C DIRECTION. +C IF .NE 0, THE +C CYCLIC INTERPOLATION +C FORMULAS WILL BE USED. +C (NOTE: EVEN IF THE DATA +C ARE CYCLIC IN X LEAVING +C ICYC = 0 WILL DO NO HARM.) +C +C DISPL 0.33 THE WIND SPEED IS +C NORMALIZED TO THIS VALUE. +C (SEE THE DISCUSSION BELOW.) +C +C DISPC 0.67 THE CRITICAL DISPLACEMENT. +C IF AFTER 'ITERP' ITERATIONS +C THE STREAMLINE HAS NOT +C MOVED THIS DISTANCE, THE +C STREAMLINE WILL BE +C TERMINATED. +C +C CSTOP 0.50 THIS PARAMETER CONTROLS +C THE SPACING BETWEEN +C STREAMLINES. THE CHECKING +C IS DONE WHEN A NEW GRID +C BOX IS ENTERED. +C +C DISCUSSION OF ASSUME A VALUE OF 0.33 FOR DISPL. THIS +C DISPL,DISPC MEANS THAT IT WILL TAKE THREE STEPS TO MOVE +C AND CSTOP ACROSS ONE GRID BOX IF THE FLOW WAS ALL IN THE +C X DIRECTION. IF THE FLOW IS ZONAL, THEN A +C LARGER VALUE OF DISPL IS IN ORDER. +C IF THE FLOW IS HIGHLY TURBULENT, THEN +C A SMALLER VALUE IS IN ORDER. NOTE: THE SMALLER +C DISPL, THE MORE THE CPU TIME. A VALUE +C OF 2 TO 4 TIMES DISPL IS A REASONABLE VALUE +C FOR DISPC. DISPC SHOULD ALWAYS BE GREATER +C THAN DISPL. A VALUE OF 0.33 FOR CSTOP WOULD +C MEAN THAT A MAXIMUM OF THREE STREAM- +C LINES WILL BE DRAWN PER GRID BOX. THIS MAX +C WILL NORMALLY ONLY OCCUR IN AREAS OF SINGULAR +C POINTS. +C +C *************************** +C ANY OR ALL OF THE ABOVE +C PARAMETERS MAY BE CHANGED +C BY UTILIZING COMMON BLOCKS +C STR02 AND/OR STR03 +C *************************** +C +C UXSML 1.E-50 THE SMALLEST REAL NUMBER +C ON THE HOST COMPUTER. THIS +C IS SET AUTOMATICALLY BY +C R1MACH. +C +C NCHK 750 THIS PARAMETER IS LOCATED +C IN DRWSTR. IT SPECIFIES THE +C LENGTH OF THE CIRCULAR +C LISTS USED FOR CHECKING +C FOR STRMLN CROSSOVERS. +C FOR MOST PLOTS THIS NUMBER +C MAY BE REDUCED TO 500 +C OR LESS AND THE PLOTS WILL +C NOT BE ALTERED. +C +C ISKIP NUMBER OF BITS TO BE +C SKIPPED TO GET TO THE +C LEAST TWO SIGNIFICANT BITS +C IN A FLOATING POINT NUMBER. +C THE DEFAULT VALUE IS SET TO +C I1MACH(5) - 2 . THIS VALUE +C MAY HAVE TO BE CHANGED +C DEPENDING ON THE TARGET +C COMPUTER, SEE SUBROUTINE +C DRWSTR. +C +C +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) , + 1 WORK(1) + DIMENSION WNDW(4) ,VWPRT(4) +C + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR02/ EXT , SIDE , XLT , YBT + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP +C + SAVE +C + EXT = 0.25 + SIDE = 0.90 + XLT = 0.05 + YBT = 0.05 +C + INITA = 2 + INITB = 2 + AROWL = 0.33 + ITERP = 35 + ITERC = -99 + IGFLG = 0 + ICYC = 0 + IMSG = 0 +C +NOAO +C UVMSG = 1.E+36 + uvmsg = 1.E+16 +C -NOAO + DISPL = 0.33 + DISPC = 0.67 + CSTOP = 0.50 +C +C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'STRMLN', 'VERSION 01') +C + IER = 0 +C +C LOAD THE COMMUNICATION COMMON BLOCK WITH PARAMETERS +C + IS = 1 + IEND = IPTSX + JS = 1 + JEND = JPTSY + IEND1 = IEND-1 + JEND1 = JEND-1 + IEND2 = IEND-2 + JEND2 = JEND-2 + XNX = FLOAT(IEND-IS+1) + XNY = FLOAT(JEND-JS+1) + ICYC1 = ICYC + IGFL1 = IGFLG + IMSG1 = 0 +C +C IF ICYC .NE. 0 THEN CHECK TO MAKE SURE THE CYCLIC CONDITION EXISTS. +C + IF (ICYC1.NE.0) CALL CHKCYC (U,V,IMAX,JPTSY,IER) +C +C SAVE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER +C + CALL GQCNTN ( IERR,NTORIG ) +C +C SET UP SCALING +C + IF (NSET) 10 , 20 , 60 + 10 CALL GETUSV ( 'LS' , ITYPE ) + CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) + CALL GETUSV('LS',IOLLS) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) + X3 = IS + X4 = IEND + Y3 = JS + Y4 = JEND + GO TO 55 +C + 20 ITYPE = 1 + X1 = XLT + X2 = (XLT+SIDE) + Y1 = YBT + Y2 = (YBT+SIDE) + X3 = IS + X4 = IEND + Y3 = JS + Y4 = JEND + IF (AMIN1(XNX,XNY)/AMAX1(XNX,XNY).LT.EXT) GO TO 50 + IF (XNX-XNY) 30, 50, 40 + 30 X2 = (SIDE*(XNX/XNY) + XLT) + GO TO 50 + 40 Y2 = (SIDE*(XNY/XNX) + YBT) + 50 CONTINUE +C +C CENTER THE PLOT +C + DX = 0.25*( 1. - (X2-X1) ) + DY = 0.25*( 1. - (Y2-Y1) ) + X1 = (XLT+DX) + X2 = (X2+DX ) + Y1 = (YBT+DY) + Y2 = (Y2+DY ) +C + 55 CONTINUE +C +C SAVE NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT ( 1,IERR,WNDW,VWPRT ) +C +C DEFINE AND SELECT NORMALIZATION TRANS, SET LOG SCALING +C + CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,ITYPE) +C + IF (NSET.EQ.0) CALL PERIM (1,0,1,0) +C + 60 CONTINUE +C +C DRAW THE STREAMLINES +C . BREAK THE WORK ARRAY INTO TWO PARTS. SEE DRWSTR FOR FURTHER +C . COMMENTS ON THIS. +C + CALL DRWSTR (U,V,WORK(1),WORK(IMAX*JPTSY+1),IMAX,JPTSY) +C +C RESET NORMALIATION TRANSFORMATION 1 TO ORIGINAL VALUES +C + IF (NSET .LE. 0) THEN + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + ENDIF + CALL GSELNT (NTORIG) +C + RETURN + END + SUBROUTINE DRWSTR (U,V,UX,VY,IMAX,JPTSY) +C + PARAMETER (NCHK=750) +C +C THIS ROUTINE DRAWS THE STREAMLINES. +C . THE XCHK AND YCHK ARRAYS SERVE AS A CIRCULAR LIST. THEY +C . ARE USED TO PREVENT LINES FROM CROSSING ONE ANOTHER. +C +C THE WORK ARRAY HAS BEEN BROKEN UP INTO TWO ARRAYS FOR CLARITY. THE +C . TOP HALF OF WORK (CALLED UX) WILL HAVE THE NORMALIZED (AND +C . POSSIBLY TRANSFORMED) U COMPONENTS AND WILL BE USED FOR BOOK +C . KEEPING. THE LOWER HALF OF THE WORK ARRAY (CALLED VY) WILL +C . CONTAIN THE NORMALIZED (AND POSSIBLY TRANSFORMED) V COMPONENTS. +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) + 1 , UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP + COMMON /STR04/ XCHK(NCHK) ,YCHK(NCHK) , NUMCHK , UXSML +C +C + SAVE +C +C STATEMENT FUNCTIONS FOR SPATIAL AND VELOCITY TRANSFORMATIONS. +C . (IF THE USER WISHES OTHER TRANSFORMATIONS REPLACE THESE STATEMENT +C . FUNCTIONS WITH THE APPROPRIATE NEW ONES, OR , IF THE TRANSFORMA- +C . TIONS ARE COMPLICATED DELETE THESE STATEMENT FUNCTIONS +C . AND ADD EXTERNAL ROUTINES WITH THE SAME NAMES TO DO THE TRANS- +C . FORMING.) +C + FX(X,Y) = X + FY(X,Y) = Y + FU(X,Y) = X + FV(X,Y) = Y +C +C INITIALIZE +C + ISKIP = I1MACH(5) - 2 + ISKIP1 = ISKIP + 1 + UXSML = R1MACH(1) +C +C + NUMCHK = NCHK + LCHK = 1 + ICHK = 1 + XCHK(1) = 0. + YCHK(1) = 0. + KFLAG = 0 + IZERO = 0 + IONE = 1 + ITWO = 2 +C +C +C COMPUTE THE X AND Y NORMALIZED (AND POSSIBLY TRANSFORMED) +C . DISPLACEMENT COMPONENTS (UX AND VY). +C + DO 40 J=JS,JEND + DO 30 I=IS,IEND + IF (U(I,J).EQ.0. .AND. V(I,J).EQ.0.) GO TO 10 + UX(I,J) = FU(U(I,J),V(I,J)) + VY(I,J) = FV(U(I,J),V(I,J)) + CON = DISPL/SQRT(UX(I,J)*UX(I,J) + VY(I,J)*VY(I,J)) + UX(I,J) = CON*UX(I,J) + VY(I,J) = CON*VY(I,J) +C + IF(UX(I,J) .EQ. 0.) UX(I,J) = CON*FU(UXSML,V(I,J)) +C + GO TO 20 + 10 CONTINUE +C +C BOOKKEEPING IS DONE IN THE LEAST SIGNIFICANT BITS OF THE UX ARRAY. +C . WHEN UX(I,J) IS EXACTLY ZERO THIS CAN PRESENT SOME PROBLEMS. +C . TO GET AROUND THIS PROBLEM SET IT TO SOME VERY SMALL NUMBER. +C + UX(I,J) = FU(UXSML,0.) + VY(I,J) = 0. +C +C MASK OUT THE LEAST SIGNIFICANT TWO BITS AS FLAGS FOR EACH GRID BOX +C . A GRID BOX IS ANY REGION SURROUNDED BY FOUR GRID POINTS. +C . FLAG 1 INDICATES WHETHER ANY STREAMLINE HAS PREVIOUSLY PASSED +C . THROUGH THIS BOX. +C . FLAG 2 INDICATES WHETHER ANY DIRECTIONAL ARROW HAS ALREADY +C . APPEARED IN THIS BOX. +C . JUDICIOUS USE OF THESE FLAGS PREVENTS OVERCROWDING OF +C . STREAMLINES AND DIRECTIONAL ARROWS. +C + 20 CALL SBYTES( UX(I,J) , IZERO , ISKIP , 2 , 0 , 1 ) +C + IF (MOD(I,INITA).NE.0 .OR. MOD(J,INITA).NE.0) + 1 CALL SBYTES( UX(I,J) , IONE , ISKIP1, 1 , 0 , 1 ) + IF (MOD(I,INITB).NE.0 .OR. MOD(J,INITB).NE.0) + 1 CALL SBYTES( UX(I,J) , IONE , ISKIP , 1 , 0 , 1 ) +C + 30 CONTINUE + 40 CONTINUE +C + 50 CONTINUE +C +C START A STREAMLINE. EXPERIENCE HAS SHOWN THAT A PLEASING PICTURE +C . WILL BE PRODUCED IF NEW STREAMLINES ARE STARTED ONLY IN GRID +C . BOXES THAT PREVIOUSLY HAVE NOT HAD OTHER STREAMLINES PASS THROUGH +C . THEM. AS LONG AS A REASONABLY DENSE PATTERN OF AVAILABLE BOXES +C . IS INITIALLY PRESCRIBED, THE ORDER OF SCANNING THE GRID PTS. FOR +C . AVAILABLE BOXES IS IMMATERIAL +C +C FIND AN AVAILABLE BOX FOR STARTING A STREAMLINE +C + IF (KFLAG.NE.0) GO TO 90 + DO 70 J=JS,JEND1 + DO 60 I=IS,IEND1 + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( IAND( IUX , IONE ) .EQ. IZERO ) GO TO 80 + 60 CONTINUE + 70 CONTINUE +C +C MUST BE NO AVAILABLE BOXES FOR STARTING A STREAMLINE +C + GO TO 190 + 80 CONTINUE +C +C INITILIZE PARAMETERS FOR STARTING A STREAMLINE +C . TURN THE BOX OFF FOR STARTING A STREAMLINE +C . CHECK TO SEE IF THIS BOX HAS MISSING DATA (IMSG.NE.0). IF SO , +C . FIND A NEW STARTING BOX +C + CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) + IF ( IMSG.EQ.0) GO TO 85 + IF (U(I,J).EQ.UVMSG .OR. U(I,J+1).EQ.UVMSG .OR. + 1 U(I+1,J).EQ.UVMSG .OR. U(I+1,J+1).EQ.UVMSG) GO TO 50 +C + 85 ISAV = I + JSAV = J + KFLAG = 1 + PLMN1 = +1. + GO TO 100 + 90 CONTINUE +C +C COME TO HERE TO DRAW IN THE OPPOSITE DIRECTION +C + KFLAG = 0 + PLMN1 = -1. + I = ISAV + J = JSAV + 100 CONTINUE +C +C INITIATE THE DRAWING SEQUENCE +C . START ALL STREAMLINES IN THE CENTER OF A BOX +C + NBOX = 0 + ITER = 0 + IF (KFLAG.NE.0) ICHKB = ICHK+1 + IF (ICHKB.GT.NUMCHK) ICHKB = 1 + X = FLOAT(I)+0.5 + Y = FLOAT(J)+0.5 + XBASE = X + YBASE = Y + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,0) + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( (KFLAG.EQ.0) .OR. (IAND( IUX , ITWO ) .NE. 0 ) ) GO TO 110 +C +C GRID BOX MUST BE ELIGIBLE FOR A DIRECTIONAL ARROW +C + CALL GNEWPT (UX,VY,IMAX,JPTSY) + MFLAG = 1 + GO TO 160 +C + 110 CONTINUE +C +C PLOT LOOP +C . CHECK TO SEE IF THE STREAMLINE HAS ENTERED A NEW GRID BOX +C + IF (I.NE.IFIX(X) .OR. J.NE.IFIX(Y)) GO TO 120 +C +C MUST BE IN SAME BOX CALCULATE THE DISPLACEMENT COMPONENTS +C + CALL GNEWPT (UX,VY,IMAX,JPTSY) +C +C UPDATE THE POSITION AND DRAW THE VECTOR +C + X = X+PLMN1*DELX + Y = Y+PLMN1*DELY + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,1) + ITER = ITER+1 +C +C CHECK STREAMLINE PROGRESS EVERY 'ITERP' OR SO ITERATIONS +C + IF (MOD(ITER,ITERP).NE.0) GO TO 115 + IF (ABS(X-XBASE).LT.DISPC .AND. ABS(Y-YBASE).LT.DISPC ) GO TO 50 + XBASE = X + YBASE = Y + GO TO 110 + 115 CONTINUE +C +C SHOULD THE CIRCULAR LISTS BE CHECKED FOR STREAMLINE CROSSOVER +C + IF ( (ITERC.LT.0) .OR. (MOD(ITER,ITERC).NE.0) ) GO TO 110 +C +C MUST WANT THE CIRCULAR LIST CHECKED +C + GO TO 130 + 120 CONTINUE +C +C MUST HAVE ENTERED A NEW GRID BOX CHECK FOR THE FOLLOWING : +C . (1) ARE THE NEW POINTS ON THE GRID +C . (2) CHECK FOR MISSING DATA IF MSG DATA FLAG (IMSG) HAS BEEN SET. +C . (3) IS THIS BOX ELIGIBLE FOR A DIRECTIONAL ARROW +C . (4) LOCATION OF THIS ENTRY VERSUS OTHER STREAMLINE ENTRIES +C + NBOX = NBOX+1 +C +C CHECK (1) +C + IF (IFIX(X).LT.IS .OR. IFIX(X).GT.IEND1) GO TO 50 + IF (IFIX(Y).LT.JS .OR. IFIX(Y).GT.JEND1) GO TO 50 +C +C CHECK (2) +C + IF ( IMSG.EQ.0) GO TO 125 + II = IFIX(X) + JJ = IFIX(Y) + IF (U(II,JJ).EQ.UVMSG .OR. U(II,JJ+1).EQ.UVMSG .OR. + 1 U(II+1,JJ).EQ.UVMSG .OR. U(II+1,JJ+1).EQ.UVMSG) GO TO 50 + 125 CONTINUE +C +C CHECK (3) +C + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( IAND( IUX , ITWO ) .NE. 0) GO TO 130 + MFLAG = 2 + GO TO 160 + 130 CONTINUE +C +C CHECK (4) +C + DO 140 LOC=1,LCHK + IF (ABS( X-XCHK(LOC) ).GT.CSTOP .OR. + 1 ABS( Y-YCHK(LOC) ).GT.CSTOP) GO TO 140 + LFLAG = 1 + IF (ICHKB.LE.ICHK .AND. LOC.GE.ICHKB .AND. LOC.LE.ICHK) LFLAG = 2 + IF (ICHKB.GE.ICHK .AND. (LOC.GE.ICHKB .OR. LOC.LE.ICHK)) LFLAG = 2 + IF (LFLAG.EQ.1) GO TO 50 + 140 CONTINUE + LCHK = MIN0(LCHK+1,NUMCHK) + ICHK = ICHK+1 + IF (ICHK.GT.NUMCHK) ICHK = 1 + XCHK(ICHK) = X + YCHK(ICHK) = Y + I = IFIX(X) + J = IFIX(Y) + CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) + IF (NBOX.LT.5) GO TO 150 + ICHKB = ICHKB+1 + IF (ICHKB.GT.NUMCHK) ICHKB = 1 + 150 CONTINUE + GO TO 110 +C + 160 CONTINUE +C +C THIS SECTION DRAWS A DIRECTIONAL ARROW BASED ON THE MOST RECENT DIS- +C . PLACEMENT COMPONENTS ,DELX AND DELY, RETURNED BY GNEWPT. IN EARLIE +C . VERSIONS THIS WAS A SEPARATE SUBROUTINE (CALLED DRWDAR). IN THAT +C . CASE ,HOWEVER, FX AND FY WERE DEFINED EXTERNAL SINCE THESE +C . FUNCTIONS WERE USED BY BOTH DRWSTR AND DRWDAR. IN ORDER TO +C . MAKE ALL DEFAULT TRANSFORMATIONS STATEMENT FUNCTIONS I HAVE +C . PUT DRWDAR HERE AND I WILL USE MFLAG TO RETURN TO THE CORRECT +C . LOCATION IN THE CODE. +C + IF ( (DELX.EQ.0.) .AND. (DELY.EQ.0.) ) GO TO 50 +C + CALL SBYTES( UX(I,J) ,IONE , ISKIP , 1 ,0 , 1 ) + D = ATAN2(-DELX,DELY) + D30 = D+0.5 + 170 YY = -AROWL*COS(D30)+Y + XX = +AROWL*SIN(D30)+X + CALL FL2INT (FX(XX,YY),FY(XX,YY),IFXX,IFYY) + CALL PLOTIT (IFXX,IFYY,1) + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,0) + IF (D30.LT.D) GO TO 180 + D30 = D-0.5 + GO TO 170 + 180 IF (MFLAG.EQ.1) GO TO 110 + IF (MFLAG.EQ.2) GO TO 130 +C + 190 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE GNEWPT (UX,VY,IMAX,JPTSY) +C +C INTERPOLATION ROUTINE TO CALCULATE THE DISPLACEMANT COMPONENTS +C . THE PHILOSPHY HERE IS TO UTILIZE AS MANY POINTS AS POSSIBLE +C . (WITHIN REASON) IN ORDER TO OBTAIN A PLEASING AND ACCURATE PLOT. +C . INTERPOLATION SCHEMES DESIRED BY OTHER USERS MAY EASILY BE +C . SUBSTITUTED IF DESIRED. +C + DIMENSION UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP +C + SAVE +C +C FDLI - DOUBLE LINEAR INTERPOLATION FORMULA +C FBESL - BESSEL 16 PT INTERPOLATION FORMULA ( MOST USED FORMULA ) +C FQUAD - QUADRATIC INTERPOLATION FORMULA +C + FDLI(Z,Z1,Z2,Z3,DX,DY) = (1.-DX)*((1.-DY)*Z +DY*Z1) + 1 + DX *((1.-DY)*Z2+DY*Z3) + FBESL(Z,ZP1,ZP2,ZM1,DZ)=Z+DZ*(ZP1-Z+0.25*(DZ-1.)*((ZP2-ZP1-Z+ZM1) + 1 +0.666667*(DZ-0.5)*(ZP2-3.*ZP1+3.*Z-ZM1))) + FQUAD(Z,ZP1,ZM1,DZ)=Z+0.5*DZ*(ZP1-ZM1+DZ*(ZP1-2.*Z+ZM1)) +C + DX = X-AINT(X) + DY = Y-AINT(Y) +C + IF( IMSG.NE.0.OR.IGFLG.NE.0) GO TO 20 +C + IM1 = I-1 + IP2 = I+2 +C +C DETERMINE WHICH INTERPOLATION FORMULA TO USE DEPENDING ON I,J LOCATION +C . THE FIRST CHECK IS FOR I,J IN THE GRID INTERIOR. +C + IF (J.GT.JS .AND. J.LT.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) + 1 GO TO 30 + IF (J.EQ.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) GO TO 40 + IF (J.EQ.JS) GO TO 20 +C + IF (ICYC1.EQ.1) GO TO 10 +C +C MUST NOT BE CYCLIC +C + IF (I.EQ.IS) GO TO 20 + IF (I.EQ.IEND1) GO TO 50 + GO TO 20 + 10 CONTINUE +C +C MUST BE CYCLIC IN THE X DIRECTION +C + IF (I.EQ.IS .AND. J.LT.JEND1) GO TO 12 + IF (I.EQ.IEND1 .AND. J.LT.JEND1) GO TO 14 + IF (J.EQ.JEND1 .AND. I.EQ.IS) GO TO 16 + IF (J.EQ.JEND1 .AND. I.EQ.IEND1) GO TO 18 + GO TO 20 + 12 IM1 = IEND1 + GO TO 30 + 14 IP2 = IS+1 + GO TO 30 + 16 IM1 = IEND1 + GO TO 40 + 18 IP2 = IS+1 + GO TO 40 +C + 20 CONTINUE +C +C DOUBLE LINEAR INTERPOLATION FORMULA. THIS SCHEME WORKS AT ALL POINTS +C . BUT THE RESULTING STREAMLINES ARE NOT AS PLEASING AS THOSE DRAWN +C . BY FBESL OR FQUAD. CURRENTLY THIS IS USED AT THIS IS UTILIZED +C . ONLY AT CERTAIN BOUNDARY POINTS OR IF IGFLG IS NOT EQUAL TO ZERO. +C + DELX = FDLI (UX(I,J),UX(I,J+1),UX(I+1,J),UX(I+1,J+1),DX,DY) + DELY = FDLI (VY(I,J),VY(I,J+1),VY(I+1,J),VY(I+1,J+1),DX,DY) + RETURN + 30 CONTINUE +C +C USE A 16 POINT BESSEL INTERPOLATION SCHEME +C + UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) + UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) + UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) + UJP2 = FBESL (UX(I,J+2),UX(I+1,J+2),UX(IP2,J+2),UX(IM1,J+2),DX) + DELX = FBESL (UJ,UJP1,UJP2,UJM1,DY) + VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) + VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) + VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) + VJP2 = FBESL (VY(I,J+2),VY(I+1,J+2),VY(IP2,J+2),VY(IM1,J+2),DX) + DELY = FBESL (VJ,VJP1,VJP2,VJM1,DY) + RETURN + 40 CONTINUE +C +C 12 POINT INTERPOLATION SCHEME APPLICABLE TO ONE ROW FROM TOP BOUNDARY +C + UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) + UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) + UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) + DELX = FQUAD (UJ,UJP1,UJM1,DY) + VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) + VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) + VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) + DELY = FQUAD (VJ,VJP1,VJM1,DY) + RETURN + 50 CONTINUE +C +C 9 POINT INTERPOLATION SCHEME FOR USE IN THE NON-CYCLIC CASE +C . AT I=IEND1 ; JS.LT.J AND J.LE.JEND1 +C + UJP1 = FQUAD (UX(I,J+1),UX(I+1,J+1),UX(IM1,J+1),DX) + UJ = FQUAD (UX(I,J),UX(I+1,J),UX(IM1,J),DX) + UJM1 = FQUAD (UX(I,J-1),UX(I+1,J-1),UX(IM1,J-1),DX) + DELX = FQUAD (UJ,UJP1,UJM1,DY) + VJP1 = FQUAD (VY(I,J+1),VY(I+1,J+1),VY(IM1,J+1),DX) + VJ = FQUAD (VY(I,J),VY(I+1,J),VY(IM1,J),DX) + VJM1 = FQUAD (VY(I,J-1),VY(I+1,J-1),VY(IM1,J-1),DX) + DELY = FQUAD (VJ,VJP1,VJM1,DY) + RETURN + END + SUBROUTINE EZSTRM(U,V,WORK,IMAX,JMAX) +C + DIMENSION U(IMAX,JMAX) ,V(IMAX,JMAX) ,WORK(1) +C + SAVE +C +C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'EZSTRM', 'VERSION 01') +C + CALL STRMLN(U,V,WORK,IMAX,IMAX,JMAX,0,IER) + RETURN + END + SUBROUTINE CHKCYC (U,V,IMAX,JPTSY,IER) +C +C CHECK FOR CYCLIC CONDITION +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 +C + SAVE + DO 10 J=JS,JEND + IF (U(IS,J).NE.U(IEND,J)) GO TO 20 + IF (V(IS,J).NE.V(IEND,J)) GO TO 20 + 10 CONTINUE +C +C MUST BE CYCLIC +C + RETURN + 20 CONTINUE +C +C MUST NOT BE CYCLIC +C . CHANGE THE PARAMETER AND SET IER = -1 +C + ICYC1 = 0 + IER = -1 + RETURN +C +C------------------------------------------------------------------ +C REVISION HISTORY +C +C OCTOBER 1979 FIRST ADDED TO ULIB +C +C OCTOBER 1980 ADDED BUGS SECTION +C +C JUNE 1984 REMOVED STATEMENT FUNCTIONS ANDF AND ORF, +C CONVERTED TO FORTRAN77 AND GKS. +C------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/sysint/README b/sys/gio/ncarutil/sysint/README new file mode 100644 index 00000000..38d7b6f8 --- /dev/null +++ b/sys/gio/ncarutil/sysint/README @@ -0,0 +1,2 @@ +SYSINT - This directory contains the System Interface Routines needed +for implementing the GKS based NCAR plotting utilities. diff --git a/sys/gio/ncarutil/sysint/fencode.x b/sys/gio/ncarutil/sysint/fencode.x new file mode 100644 index 00000000..1e2e37d5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/fencode.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_FORMAT 11 + +# FENCD -- Format a real variable and return as a spp character string. +# A packed format string is passed as an input argument to define how the +# number is to be encoded. The format of the format string is: +# format string = "(cW.D)" +# where c is one of [EFGI], and where W and D are the field width and +# number of decimal places or precision, respectively. + +procedure fencd (nchars, f_format, spp_outstr, rval) + +int nchars # desired number of output chars +char f_format[SZ_FORMAT] # SPP string containing format +char spp_outstr[nchars+1] # SPP string containing encoded number +real rval # value to be encoded + +char fmtchar, outstr[MAX_DIGITS], spp_format[SZ_FORMAT+1] +int ip, op, stridxs() +real x + +begin + # Encode format string for SPRINTF, format "%w.d". Start copying + # Fortran format at char 3, which should follow the EFGI char. + + spp_format[1] = '%' + op = 2 + + if (f_format[1] != '(') + call fatal (1, "Missing lparen in Ncar ENCODE format") + for (ip=3; f_format[ip] != ')' && f_format[ip] != EOS; ip=ip+1) { + spp_format[op] = f_format[ip] + op = op + 1 + } + + # Now add the SPP format character. EFG are the same for sprintf as + # as for Fortran. The integer format is 'd' for decimal in SPP. + + fmtchar = f_format[2] + if (IS_UPPER(fmtchar)) + fmtchar = TO_LOWER (fmtchar) + + switch (fmtchar) { + case 'e', 'f', 'g': + spp_format[op] = fmtchar + case 'i': + spp_format[op] = 'd' + default: + call fatal (1, "Unknown Ncar ENCODE format code") + } + op = op + 1 + spp_format[op] = EOS + x = rval + if (rval > 0) + x = -x + + # Now encode the user supplied variable and return it as a spp + # string. + + iferr { + call sprintf (outstr, MAX_DIGITS, spp_format) + call pargr (x) + } then + call erract (EA_FATAL) + + # Let's try adding a "+" prefix to positive numbers to set if that + # makes nicer plots. Sep86 - This was not a good idea - changed to + # a blank. + + op = stridxs ("-", outstr) + if (rval > 0 && op > 0) + outstr[op] = ' ' + + call strcpy (outstr, spp_outstr, SZ_LINE) +end diff --git a/sys/gio/ncarutil/sysint/fulib.x b/sys/gio/ncarutil/sysint/fulib.x new file mode 100644 index 00000000..1951f26c --- /dev/null +++ b/sys/gio/ncarutil/sysint/fulib.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FULIB -- Print an error message processed by fortran routine uliber. + +procedure fulib (errcode, upkmsg, msglen) + +int errcode +char upkmsg[ARB] # unpacked string +int msglen # number of chars in string + +pointer sp, sppmsg + +begin + call smark (sp) + call salloc (sppmsg, SZ_LINE, TY_CHAR) + + # Construct error message string + call sprintf (Memc[sppmsg], SZ_LINE, "ERROR %d IN %s\n") + call pargi (errcode) + call pargstr (upkmsg) + + # Call error with the constructed message + iferr (call error (errcode, Memc[sppmsg])) + call erract (EA_WARN) + + call sfree (sp) +end diff --git a/sys/gio/ncarutil/sysint/gbytes.x b/sys/gio/ncarutil/sysint/gbytes.x new file mode 100644 index 00000000..b129ffbc --- /dev/null +++ b/sys/gio/ncarutil/sysint/gbytes.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GBYTES -- Locally implemented bit unpacker for the NCAR extended metacode +# translator. 3 may 84 cliff stoll +# Required for the ncar/gks vdi metacode generator. +# +# Essentially this routine accepts an array which is a packed series of bits. +# [array BUFIN], and unpacks them into an array [array BUFOUT]. Received +# integer INDEX is the beginning bit in BUFIN where information is to be +# placed. INDEX is zero indexed. Received integer argument SIZE is the +# number of bits in each "information packet". Received argument SKIP is the +# number of bits to skip between bit packets. For more info, see page 4 of +# the NCAR "Implementaton details for the new metafile translator, version 1.0" + +procedure gbytes (bufin, bufout, index, size, skip, count) + +int bufout[ARB], bufin[ARB], index, size, skip, count +int pack +int offset +int bitupk() # Iraf function to unpack bits + +begin + for (pack = 1; pack <= count ; pack = pack+1) { + # Offset is a bit offset into the input buffer bufin. + # (offset is 1- indexed; INDEX is zero indexed) + + offset = (size + skip) * (pack - 1) + index + 1 + bufout(pack) = bitupk(bufin, offset, size) + } +end diff --git a/sys/gio/ncarutil/sysint/ishift.x b/sys/gio/ncarutil/sysint/ishift.x new file mode 100644 index 00000000..580996c0 --- /dev/null +++ b/sys/gio/ncarutil/sysint/ishift.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ISHIFT -- integer shift. To be used for calls to ISHIFT in NCAR routines. + +int procedure ishift (in_word, n) + +int in_word, n +int new_word, bit, index, i +int bitupk() + +begin + if (n > NBITS_INT) + call error (0, "n > NBITS_INT in ishift") + if (n < 0) + # Right end-off shift + new_word = bitupk (in_word, abs(n) + 1, NBITS_INT - abs(n)) + else { + # Left circular shift (rotate) + do i = 1, NBITS_INT { + index = n + i + if (index > NBITS_INT) + index = mod ((n + i), NBITS_INT) + bit = bitupk (in_word, i, 1) + call bitpak (bit, new_word, index, 1) + } + } + + return (new_word) +end + + +# IAND -- AND two integers. + +int procedure iand (a, b) + +int a, b +int and() + +begin + return (and (a, b)) +end + + +# IOR -- OR two integers. + +int procedure ior (a, b) + +int a, b +int or() + +begin + return (or (a, b)) +end diff --git a/sys/gio/ncarutil/sysint/mkpkg b/sys/gio/ncarutil/sysint/mkpkg new file mode 100644 index 00000000..f3ba6fb5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/mkpkg @@ -0,0 +1,16 @@ +# Make the system interface for libncar.a. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + support.f + fencode.x + fulib.x + ishift.x + gbytes.x + sbytes.x + spps.f + ; diff --git a/sys/gio/ncarutil/sysint/sbytes.x b/sys/gio/ncarutil/sysint/sbytes.x new file mode 100644 index 00000000..4d4094c3 --- /dev/null +++ b/sys/gio/ncarutil/sysint/sbytes.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# SBYTES -- Locally implemented bit packer for the NCAR extended metacode +# translator. 3 may 84 cliff stoll +# Required for the ncar/gks vdi metacode generator. +# +# Essentially this routine accepts an array of "information packets" +# [array BUFIN], and packs them into a packed array [array BUFOUT] +# received integer argument INDEX points to the beginning bit in BUFOUT +# where information is to be placed. INDEX is zero indexed. +# received integer argument SIZE is the number of bits in each "information +# packet. received argument SKIP is the number of bits to skip between +# bit packets. For more info, see page 6 of the NCAR "Implementaton +# details for the new metafile translator, version 1.0" +# bufin is stuffed into bufout + +procedure sbytes (bufout, bufin, index, size, skip, count) + +int bufout[ARB], bufin[ARB], index, size, skip, count +int metacode_word_length +int pack +int offset + +data metacode_word_length / 16 / + +begin + if (metacode_word_length != NBITS_SHORT) + call error ( 0, " bad metacode word length in SBYTES") + + for (pack = 1; pack <= count; pack = pack + 1) { + # Offset is a bit offset into the output buffer bufout. + # (offset is 1- indexed; INDEX is zero indexed) + # see page 58 of IRAF system interface book + + offset = (size + skip) * (pack - 1) + index + 1 + call bitpak (bufin[pack], bufout, offset, size) + } +end diff --git a/sys/gio/ncarutil/sysint/spps.f b/sys/gio/ncarutil/sysint/spps.f new file mode 100644 index 00000000..4a394d9e --- /dev/null +++ b/sys/gio/ncarutil/sysint/spps.f @@ -0,0 +1,1797 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C + FUNCTION CFUX (RX) +C +C Given an x coordinate RX in the fractional system, CFUX(RX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CFUX=WD(I)+(RX-VP(1))/(VP(2)-VP(1))*(WD(3-I)-WD(I)) + IF (LL.GE.3) CFUX=10.**CFUX + RETURN + END + FUNCTION CFUY (RY) +C +C Given a y coordinate RY in the fractional system, CFUY(RY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CFUY=WD(I)+(RY-VP(3))/(VP(4)-VP(3))*(WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CFUY=10.**CFUY + RETURN + END + FUNCTION CMFX (IX) +C +C Given an x coordinate IX in the metacode system, CMFX(IX) is an x +C coordinate in the fractional system. +C + CMFX=FLOAT(IX)/32767. + RETURN + END + FUNCTION CMFY (IY) +C +C Given a y coordinate IY in the metacode system, CMFY(IY) is a y +C coordinate in the fractional system. +C + CMFY=FLOAT(IY)/32767. + RETURN + END + FUNCTION CMUX (IX) +C +C Given an x coordinate IX in the metacode system, CMUX(IX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CMUX=WD(I)+(FLOAT(IX)/32767.-VP(1))/(VP(2)-VP(1))*(WD(3-I)-WD(I)) + IF (LL.GE.3) CMUX=10.**CMUX + RETURN + END + FUNCTION CMUY (IY) +C +C Given a y coordinate IY in the metacode system, CMUY(IY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CMUY=WD(I)+(FLOAT(IY)/32767.-VP(3))/(VP(4)-VP(3))*(WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CMUY=10.**CMUY + RETURN + END + FUNCTION CPFX (IX) +C +C Given an x coordinate IX in the plotter system, CPFX(IX) is an x +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + CPFX=FLOAT(IX-1)/(2.**MX-1.) + RETURN + END + FUNCTION CPFY (IY) +C +C Given a y coordinate IY in the plotter system, CPFY(IY) is a y +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + CPFY=FLOAT(IY-1)/(2.**MY-1.) + RETURN + END + FUNCTION CPUX (IX) +C +C Given an x coordinate IX in the plotter system, CPUX(IX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CPUX=WD(I)+(FLOAT(IX-1)/(2.**MX-1.)-VP(1))/(VP(2)-VP(1))* + + (WD(3-I)-WD(I)) + IF (LL.GE.3) CPUX=10.**CPUX + RETURN + END + FUNCTION CPUY (IY) +C +C Given a y coordinate IY in the plotter system, CPUY(IY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CPUY=WD(I)+(FLOAT(IY-1)/(2.**MY-1.)-VP(3))/(VP(4)-VP(3))* + + (WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CPUY=10.**CPUY + RETURN + END + FUNCTION CUFX (RX) +C +C Given an x coordinate RX in the user system, CUFX(RX) is an x +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + CUFX=(RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1) + ELSE + CUFX=(ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1) + ENDIF + RETURN + END + FUNCTION CUFY (RY) +C +C Given a y coordinate RY in the user system, CUFY(RY) is a y +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + CUFY=(RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3) + ELSE + CUFY=(ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3) + ENDIF + RETURN + END + FUNCTION KFMX (RX) +C +C Given an x coordinate RX in the fractional system, KFMX(RX) is an x +C coordinate in the metacode system. +C + KFMX=IFIX(RX*32767.) + RETURN + END + FUNCTION KFMY (RY) +C +C Given a y coordinate RY in the fractional system, KFMY(RY) is a y +C coordinate in the metacode system. +C + KFMY=IFIX(RY*32767.) + RETURN + END + FUNCTION KFPX (RX) +C +C Given an x coordinate RX in the fractional system, KFPX(RX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KFPX=1+IFIX(RX*(2.**MX-1.)) + RETURN + END + FUNCTION KFPY (RY) +C +C Given a y coordinate RY in the fractional system, KFPY(RY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KFPY=1+IFIX(RY*(2.**MX-1.)) + RETURN + END + FUNCTION KMPX (IX) +C +C Given an x coordinate IX in the metacode system, KMPX(IX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KMPX=1+IFIX((2.**MX-1.)*FLOAT(IX)/32767.) + RETURN + END + FUNCTION KMPY (IY) +C +C Given a y coordinate IY in the metacode system, KMPY(IY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KMPY=1+IFIX((2.**MY-1.)*FLOAT(IY)/32767.) + RETURN + END + FUNCTION KPMX (IX) +C +C Given an x coordinate IX in the plotter system, KPMX(IX) is an x +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KPMX=IFIX(32767.*FLOAT(IX-1)/(2.**MX-1.)) + RETURN + END + FUNCTION KPMY (IY) +C +C Given a y coordinate IY in the plotter system, KPMY(IY) is a y +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KPMY=IFIX(32767.*FLOAT(IY-1)/(2.**MY-1.)) + RETURN + END + FUNCTION KUMX (RX) +C +C Given an x coordinate RX in the user system, KUMX(RX) is an x +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + KUMX=IFIX(((RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))* + + 32767.) + ELSE + KUMX=IFIX(((ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+ + + VP(1))*32767.) + ENDIF + RETURN + END + FUNCTION KUMY (RY) +C +C Given a y coordinate RY in the user system, KUMY(RY) is a y +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + KUMY=IFIX(((RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))* + + 32767.) + ELSE + KUMY=IFIX(((ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+ + + VP(3))*32767.) + ENDIF + RETURN + END + FUNCTION KUPX (RX) +C +C Given an x coordinate RX in the user system, KUPX(RX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + KUPX=1+IFIX(((RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))* + + (2.**MX-1.)) + ELSE + KUPX=1+IFIX(((ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+ + + VP(1))*(2.**MX-1.)) + ENDIF + RETURN + END + FUNCTION KUPY (RY) +C +C Given a y coordinate RY in the user system, KUPY(RY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + KUPY=1+IFIX(((RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))* + + (2.**MY-1.)) + ELSE + KUPY=1+IFIX(((ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+ + + VP(3))*(2.**MY-1.)) + ENDIF + RETURN + END + SUBROUTINE CLSGKS +C +C IU(6), in IUTLCM, is the current metacode unit number. +C + COMMON /IUTLCM/ IU(100) +C +C Deactivate the metacode workstation, close the workstation, and +C close GKS. +C + CALL GDAWK (IU(6)) + CALL GCLWK (IU(6)) + CALL GCLKS +C + RETURN +C + END + SUBROUTINE CURVE (PX,PY,NP) +C + DIMENSION PX(NP),PY(NP) +C +C CURVE draws the curve defined by the points (PX(I),PY(I)), for I = 1 +C to NP. All coordinates are stated in the user coordinate system. +C +C Define arrays to hold converted point coordinates when it becomes +C necessary to draw the curve piecewise. +C + DIMENSION QX(10),QY(10) +C +C If NP is less than or equal to zero, there's nothing to do. +C + IF (NP.LE.0) RETURN +C +C If NP is exactly equal to 1, just draw a point. +C + IF (NP.EQ.1) THEN + CALL POINT (PX(1),PY(1)) +C +C Otherwise, draw the curve. +C + ELSE +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Save the current SET parameters. +C + CALL GETSET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C +C If the mapping defined by the last SET call was non-reversed and +C linear in both x and y, a single polyline will suffice. +C + IF (F5.LT.F6.AND.F7.LT.F8.AND.LL.EQ.1) THEN + CALL GPL (NP,PX,PY) +C +C Otherwise, piece the line together out of smaller chunks, converting +C the coordinates for each chunk as directed by the last SET call. +C + ELSE + DO 102 IP=1,NP,9 + NQ=MIN0(10,NP-IP+1) + IF (NQ.GE.2) THEN + DO 101 IQ=1,NQ + QX(IQ)=CUFX(PX(IP+IQ-1)) + QY(IQ)=CUFY(PY(IP+IQ-1)) + 101 CONTINUE + CALL SET (F1,F2,F3,F4,F1,F2,F3,F4,1) + CALL GPL (NQ,QX,QY) + CALL SET (F1,F2,F3,F4,F5,F6,F7,F8,LL) + END IF + 102 CONTINUE + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX(NP),PY(NP)) +C + END IF +C +C Done. +C + RETURN +C + END + SUBROUTINE FL2INT (PX,PY,IX,IY) +C +C Given the user coordinates PX and PY of a point, FL2INT returns the +C metacode coordinates IX and IY of that point. +C +C Declare the common block containing the user state variables LL, MI, +C MX, and MY. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Declare arrays in which to retrieve the variables defining the current +C window and viewport. +C + DIMENSION WD(4),VP(4) +C +C Get the variables defining the current window and viewport. +C + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) +C +C Compute IX. +C + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + IX=IFIX(((PX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))*32767.) + ELSE + IX=IFIX(((ALOG10(PX)-WD(I))/(WD(3-I)-WD(I))* + + (VP(2)-VP(1))+VP(1))*32767.) + ENDIF +C +C Compute IY. +C + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + IY=IFIX(((PY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))*32767.) + ELSE + IY=IFIX(((ALOG10(PY)-WD(I))/(WD(7-I)-WD(I))* + + (VP(4)-VP(3))+VP(3))*32767.) + ENDIF +C +C Done. +C + RETURN +C + END +C +C +NOAO - name conflict +C +C SUBROUTINE FLUSH + subroutine mcflsh +C +C - NOAO +C +C FLUSH currently does nothing except flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Done. +C + RETURN +C + END + SUBROUTINE FRAME +C +C FRAME is intended to advance to a new frame. The GKS version clears +C all open workstations. +C +C First, flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C +NOAO - Initialize utilbd 'first' flag for next plot + call initut +C +C - NOAO +C Get the number of open workstations. If there are none, we're done. +C + CALL GQOPWK (0,IE,NO,ID) + IF (NO.EQ.0) RETURN +C +C Otherwise, clear the open workstations. +C + DO 101 I=1,NO + CALL GQOPWK (I,IE,NO,ID) + CALL GCLRWK (ID,1) + 101 CONTINUE +C +C Done. +C + RETURN +C + END + SUBROUTINE FRSTPT (PX,PY) +C +C Given the user coordinates PX and PY of a point, FRSTPT generates a +C pen-up move to that point. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),0) +C +C Done. +C + RETURN +C + END + SUBROUTINE GETSET (VL,VR,VB,VT,WL,WR,WB,WT,LF) +C +C GETSET returns to its caller the current values of the parameters +C defining the mapping from the user system to the fractional system +C (in GKS terminology, the mapping from world coordinates to normalized +C device coordinates). +C +C VL, VR, VB, and VT define the viewport (in the fractional system), WL, +C WR, WB, and WT the window (in the user system), and LF the nature of +C the mapping, according to the following table: +C +C 1 - x linear, y linear +C 2 - x linear, y logarithmic +C 3 - x logarithmic, y linear +C 4 - x logarithmic, y logarithmic +C +C Declare the common block containing the linear-log and mirror-imaging +C flags. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Define variables to receive the GKS viewport and window. +C + DIMENSION VP(4),WD(4) +C +C Retrieve the number of the current GKS normalization transformation. +C + CALL GQCNTN (IE,NT) +C +C Retrieve the definition of that normalization transformation. +C + CALL GQNT (NT,IE,WD,VP) +C +C Pass the viewport definition to the caller. +C + VL=VP(1) + VR=VP(2) + VB=VP(3) + VT=VP(4) +C +C Pass the linear/log flag and a (possibly modified) window definition +C to the caller. +C + LF=LL +C + IF (LL.EQ.1.OR.LL.EQ.2) THEN + WL=WD(1) + WR=WD(2) + ELSE + WL=10.**WD(1) + WR=10.**WD(2) + END IF +C + IF (MI.GE.3) THEN + WW=WL + WL=WR + WR=WW + END IF +C + IF (LL.EQ.1.OR.LL.EQ.3) THEN + WB=WD(3) + WT=WD(4) + ELSE + WB=10.**WD(3) + WT=10.**WD(4) + END IF +C + IF (MI.EQ.2.OR.MI.GE.4) THEN + WW=WB + WB=WT + WT=WW + END IF +C + RETURN +C + END + SUBROUTINE GETSI (IX,IY) +C +C Return to the user the parameters which determine the assumed size of +C the target plotter and therefore determine how user coordinates are +C to be mapped into plotter coordinates. +C +C Declare the common block containing the scaling information. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Set the user variables. + + IX=MX + IY=MY +C + RETURN +C + END + SUBROUTINE GETUSV (VN,IV) + CHARACTER*(*) VN +C +C This subroutine retrieves the current values of the utility state +C variables. VN is the character name of the variable and IV is +C its value. +C +C The labelled common block IUTLCM contains all of the utility state +C variables. +C + COMMON /IUTLCM/IU(100) +C +C Check for the linear-log scaling variable. +C + IF (VN(1:2).EQ.'LS') THEN + IV=IU(1) +C +C Check for the variable specifying the mirror-imaging of the axes. +C + ELSE IF (VN(1:2).EQ.'MI') THEN + IV=IU(2) +C +C Check for the variable specifying the resolution of the plotter in x. +C + ELSE IF (VN(1:2).EQ.'XF') THEN + IV=IU(3) +C +C Check for the variable specifying the resolution of the plotter in x. +C + ELSE IF (VN(1:2).EQ.'YF') THEN + IV=IU(4) +C +C Check for the variable specifying the size of the pen-move buffer. +C + ELSE IF (VN(1:2).EQ.'PB') THEN + IV=IU(5) +C +C Check for the variable specifying the metacode unit. +C + ELSE IF (VN(1:2).EQ.'MU') THEN + IV=IU(6) +C +C Check for one of the variables specifying color and intensity. +C + ELSE IF (VN(1:2).EQ.'IR') THEN + IV=IU(7) +C + ELSE IF (VN(1:2).EQ.'IG') THEN + IV=IU(8) +C + ELSE IF (VN(1:2).EQ.'IB') THEN + IV=IU(9) +C + ELSE IF (VN(1:2).EQ.'IN') THEN + IV=IU(10) +C +C Check for the variable specifying the current color index. +C + ELSE IF (VN(1:2).EQ.'II') THEN + IV=IU(11) +C +C Check for the variable specifying the maximum color index. +C + ELSE IF (VN(1:2).EQ.'IM') THEN + IV=IU(12) +C +C Check for the variable specifying the line width scale factor. +C + ELSE IF (VN(1:2).EQ.'LW') THEN + IV=IU(13) +C +C Check for the variable specifying the marker size scale factor. +C + ELSE IF (VN(1:2).EQ.'MS') THEN + IV=IU(14) +C +C Otherwise, the variable name is unknown. +C + ELSE + CALL SETER ('GETUSV - UNKNOWN VARIABLE NAME IN CALL',1,2) +C + ENDIF +C + RETURN +C + END + SUBROUTINE LINE (X1,Y1,X2,Y2) +C +C Draw a line connecting the point (X1,Y1) to the point (X2,Y2), in the +C user coordinate system. +C + CALL PLOTIF (CUFX(X1),CUFY(Y1),0) + CALL PLOTIF (CUFX(X2),CUFY(Y2),1) + RETURN + END + SUBROUTINE MXMY (IX,IY) +C +C Return to the user the coordinates of the current pen position, in the +C plotter coordinate system. +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system. +C + COMMON /PLTCM/ JX,JY +C +C Declare the common block containing the user state variables LL, MI, +C MX, and MY. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Return to the user the plotter-system equivalents of the values in +C the metacode system. +C + IX=1+IFIX((2.**MX-1.)*FLOAT(JX)/32767.) + IY=1+IFIX((2.**MY-1.)*FLOAT(JY)/32767.) +C +C Done. +C + RETURN +C + END +C +C + NOAO - Following subroutine +C SUBROUTINE OPNGKS +C +C IU(6), in IUTLCM, is the current metacode unit number. +C +C COMMON /IUTLCM/ IU(100) +C +C Force all required BLOCKDATA's to load. +C +C EXTERNAL GKSBD,G01BKD,UERRBD,UTILBD +C +C GKS buffer size (a dummy for NCAR GKS.) +C +C DATA ISZ /0/ +C +C Open GKS, define a workstation, and activate the workstation. +C +C CALL GOPKS (6,ISZ) +C CALL GOPWK (IU(6),2,1) +C CALL GACWK (IU(6)) +C +C RETURN +C +C + NOAO +C +C END + SUBROUTINE PLOTIF (FX,FY,IP) +C +C Move the pen to the point (FX,FY), in the fractional cooordinate +C system. If IP is zero, do a pen-up move. If IP is one, do a pen-down +C move. If IP is two, flush the buffer. +C +C The variable IU(5), in the labelled common block IUTLCM, specifies +C the size of the pen-move buffer (between 2 and 50). +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables implementing the buffering +C of pen moves. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system, for MXMY. +C + COMMON /PLTCM/ JX,JY +C +C Force loading of the block data routine which initializes the contents +C of the common blocks. +C +C EXTERNAL UTILBD +C +C VP and WD hold viewport and window parameters obtained, when needed, +C from GKS. +C + DIMENSION VP(4),WD(4) +C +C + NOAO - block data utilbd has been rewritten as a run time initialization +C + call utilbd +C +C - NOAO +C Check for out-of-range values of the pen parameter. +C + IF (IP.LT.0.OR.IP.GT.2) THEN + CALL SETER ('PLOTIF - ILLEGAL VALUE FOR IPEN',1,2) + END IF +C +C If a buffer flush is requested, jump. +C + IF (IP.EQ.2) GO TO 101 +C +C Limit the given coordinates to the legal fractional range. +C + GX=AMAX1(0.,AMIN1(1.,FX)) + GY=AMAX1(0.,AMIN1(1.,FY)) +C +C Set JX and JY for a possible call to MXMY. +C + JX=KFMX(GX) + JY=KFMY(GY) +C +C If the current move is a pen-down move, or if the last one was, bump +C the pointer into the coordinate arrays and, if the current move is +C a pen-up move, make a new entry in the array IF, which records the +C positions of the pen-up moves. Note that we never get two pen-up +C moves in a row, which means that IF need be dimensioned only half as +C large as QX and QY. +C + IF (IP.NE.0.OR.IF(NF).NE.NQ) THEN + NQ=NQ+1 + IF (IP.EQ.0) THEN + NF=NF+1 + IF(NF)=NQ + END IF + END IF +C +C Save the coordinates of the point, in the fractional coordinate +C system. +C + QX(NQ)=GX + QY(NQ)=GY +C +C If the point-coordinate buffer is full, dump the buffers; otherwise, +C return. +C + IF (NQ.LT.IU(5)) RETURN +C +C Dump the buffers. If NQ is one, there's nothing to dump. All that's +C there is a single pen-up move. +C + 101 IF (NQ.LE.1) RETURN +C +C Get NT, the number of the current transformation, and, if it is not +C zero, modify the current transformation so that we can use fractional +C coordinates (normalized device coordinates, in GKS terms). +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Dump out a series of polylines, each one defined by a pen-up move and +C a series of pen-down moves. +C + DO 102 I=1,NF-1 + CALL GPL (IF(I+1)-IF(I),QX(IF(I)),QY(IF(I))) + 102 CONTINUE + IF (IF(NF).NE.NQ) CALL GPL (NQ-IF(NF)+1,QX(IF(I)),QY(IF(I))) +C +C Put the current transformation back the way it was. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Move the last pen position to the beginning of the buffer and pretend +C there was a pen-up move to that position. +C + QX(1)=QX(NQ) + QY(1)=QY(NQ) + NQ=1 + IF(1)=1 + NF=1 +C +C Done. +C + RETURN +C + END + SUBROUTINE PLOTIT (IX,IY,IP) +C +C Move the pen to the point (IX,IY), in the metacode coordinate system. +C If IP is zero, do a pen-up move. If IP is one, do a pen-down move. +C If IP is two, flush the buffer. (For the sake of efficiency, the +C moves are buffered; "CALL PLOTIT (0,0,0)" will also flush the buffer.) +C +C The variable IU(5), in the labelled common block IUTLCM, specifies +C the size of the pen-move buffer (between 2 and 50). +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables implementing the buffering +C of pen moves. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system, for MXMY. +C + COMMON /PLTCM/ JX,JY +C +C Force loading of the block data routine which initializes the contents +C of the common blocks. +C +C EXTERNAL UTILBD +C +C VP and WD hold viewport and window parameters obtained, when needed, +C from GKS. +C + DIMENSION VP(4),WD(4) +C +C + NOAO - Blockdata utilbd has been rewritten as a run time initialization +C + call utilbd +C +C - NOAO +C Check for out-of-range values of the pen parameter. +C + IF (IP.LT.0.OR.IP.GT.2) THEN + CALL SETER ('PLOTIT - ILLEGAL VALUE FOR IPEN',1,2) + END IF +C +C If a buffer flush is requested, jump. +C + IF (IP.EQ.2) GO TO 101 +C +C Limit the given coordinates to the legal metacode range. +C + JX=MAX0(0,MIN0(32767,IX)) + JY=MAX0(0,MIN0(32767,IY)) +C +C If the current move is a pen-down move, or if the last one was, bump +C the pointer into the coordinate arrays and, if the current move is +C a pen-up move, make a new entry in the array IF, which records the +C positions of the pen-up moves. Note that we never get two pen-up +C moves in a row, which means that IF need be dimensioned only half as +C large as QX and QY. +C + IF (IP.NE.0.OR.IF(NF).NE.NQ) THEN + NQ=NQ+1 + IF (IP.EQ.0) THEN + NF=NF+1 + IF(NF)=NQ + END IF + END IF +C +C Save the coordinates of the point, in the fractional coordinate +C system. +C + QX(NQ)=FLOAT(JX)/32767. + QY(NQ)=FLOAT(JY)/32767. +C +C If all three arguments were zero, or if the point-coordinate buffer +C is full, dump the buffers; otherwise, return. +C + IF (IX.EQ.0.AND.IY.EQ.0.AND.IP.EQ.0) GO TO 101 + IF (NQ.LT.IU(5)) RETURN +C +C Dump the buffers. If NQ is one, there's nothing to dump. All that's +C there is a single pen-up move. +C + 101 IF (NQ.LE.1) RETURN +C +C Get NT, the number of the current transformation, and, if it is not +C zero, modify the current transformation so that we can use fractional +C coordinates (normalized device coordinates, in GKS terms). +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Dump out a series of polylines, each one defined by a pen-up move and +C a series of pen-down moves. +C + DO 102 I=1,NF-1 + CALL GPL (IF(I+1)-IF(I),QX(IF(I)),QY(IF(I))) + 102 CONTINUE + IF (IF(NF).NE.NQ) CALL GPL (NQ-IF(NF)+1,QX(IF(I)),QY(IF(I))) +C +C Put the current transformation back the way it was. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Move the last pen position to the beginning of the buffer and pretend +C there was a pen-up move to that position. +C + QX(1)=QX(NQ) + QY(1)=QY(NQ) + NQ=1 + IF(1)=1 + NF=1 +C +C Done. +C + RETURN +C + END + SUBROUTINE POINT (PX,PY) +C +C Draws a point at (PX,PY), defined in the user coordinate system. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),0) + CALL PLOTIF (CUFX(PX),CUFY(PY),1) + RETURN + END + SUBROUTINE POINTS (PX,PY,NP,IC,IL) + DIMENSION PX(NP),PY(NP) +C +C Marks the points at positions in the user coordinate system defined +C by ((PX(I),PY(I)),I=1,NP). If IC is zero, each point is marked with +C a simple point. If IC is positive, each point is marked with the +C single character defined by the FORTRAN-77 function CHAR(IC). If IC +C is negative, each point is marked with a GKS polymarker of type -IC. +C If IL is non-zero, a curve is also drawn, connecting the points. +C +C Define arrays to hold converted point coordinates when it becomes +C necessary to mark the points a few at a time. +C + DIMENSION QX(10),QY(10) +C +C Define an array to hold the aspect source flags which may need to be +C retrieved from GKS. +C + DIMENSION LA(13) + CHARACTER*1 CHRTMP +C +C If the number of points is zero or negative, there's nothing to do. +C + IF (NP.LE.0) RETURN +C +C Otherwise, flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Retrieve the parameters from the last SET call. +C + CALL GETSET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C +C If a linear-linear, non-mirror-imaged, mapping is being done and the +C GKS polymarkers can be used, all the points can be marked with a +C single polymarker call and joined, if requested, by a single polyline +C call. +C + IF (F5.LT.F6.AND.F7.LT.F8.AND.LL.EQ.1.AND.IC.LE.0) THEN + CALL GQASF (IE,LA) + IF (LA(4).EQ.0) THEN + CALL GQPMI (IE,IN) + CALL GSPMI (MAX0(-IC,1)) + CALL GPM (NP,PX,PY) + CALL GSPMI (IN) + ELSE + CALL GQMK (IE,IN) + CALL GSMK (MAX0(-IC,1)) + CALL GPM (NP,PX,PY) + CALL GSMK (IN) + END IF + IF (IL.NE.0.AND.NP.GE.2) CALL GPL (NP,PX,PY) +C +C Otherwise, things get complicated. We have to do batches of nine +C points at a time. (Actually, we convert ten coordinates at a time, +C so that the curve joining the points, if any, won't have gaps in it.) +C + ELSE +C +C Initially, we have to reset either the polymarker index or the text +C alignment, depending on how we're marking the points. +C + IF (IC.LE.0) THEN + CALL GQASF (IE,LA) + IF (LA(4).EQ.0) THEN + CALL GQPMI (IE,IN) + CALL GSPMI (MAX0(-IC,1)) + ELSE + CALL GQMK (IE,IN) + CALL GSMK (MAX0(-IC,1)) + END IF + ELSE + CALL GQTXAL (IE,IH,IV) + CALL GSTXAL (2,3) + END IF +C +C Loop through the points by nines. +C + DO 104 IP=1,NP,9 +C +C Fill the little point coordinate arrays with up to ten values, +C converting them from the user system to the fractional system. +C + NQ=MIN0(10,NP-IP+1) + MQ=MIN0(9,NQ) + DO 102 IQ=1,NQ + QX(IQ)=CUFX(PX(IP+IQ-1)) + QY(IQ)=CUFY(PY(IP+IQ-1)) + 102 CONTINUE +C +C Change the SET call to allow the use of fractional coordinates. +C + CALL SET (F1,F2,F3,F4,F1,F2,F3,F4,1) +C +C Crank out either a polymarker or a set of characters. +C + IF (IC.LE.0) THEN + CALL GPM (MQ,QX,QY) + ELSE + DO 103 IQ=1,MQ + CHRTMP = CHAR(IC) + CALL GTX (QX(IQ),QY(IQ),CHRTMP) + 103 CONTINUE + END IF + IF (IL.NE.0.AND.NQ.GE.2) CALL GPL (NQ,QX,QY) +C +C Put the SET parameters back the way they were. +C + CALL SET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C + 104 CONTINUE +C +C Finally, we put either the polymarker index or the text alignment +C back the way it was. +C + IF (IC.LE.0) THEN + IF (LA(4).EQ.0) THEN + CALL GSPMI (IN) + ELSE + CALL GSMK (IN) + END IF + ELSE + CALL GSTXAL (IH,IV) + END IF +C + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX(NP),PY(NP)) +C +C Done. +C + RETURN +C + END + SUBROUTINE PWRIT (PX,PY,CH,NC,IS,IO,IC) + CHARACTER*(*) CH +C +C PWRIT is called to draw a character string in a specified position. +C It is just like WTSTR, but has one extra argument. NC is the number +C of characters to be written from the string CH. +C + CALL WTSTR (PX,PY,CH(1:NC),IS,IO,IC) +C +C Done. +C + RETURN +C + END + SUBROUTINE SET (VL,VR,VB,VT,WL,WR,WB,WT,LF) +C +C SET allows the user to change the current values of the parameters +C defining the mapping from the user system to the fractional system +C (in GKS terminology, the mapping from world coordinates to normalized +C device coordinates). +C +C VL, VR, VB, and VT define the viewport (in the fractional system), WL, +C WR, WB, and WT the window (in the user system), and LF the nature of +C the mapping, according to the following table: +C +C 1 - x linear, y linear +C 2 - x linear, y logarithmic +C 3 - x logarithmic, y linear +C 4 - x logarithmic, y logarithmic +C +C Declare the common block containing the linear-log and mirror-imaging +C flags. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Set the GKS viewport for transformation 1. +C + CALL GSVP (1,VL,VR,VB,VT) +C +C Set the utility state variable controlling linear-log mapping. +C + LL=MAX0(1,MIN0(4,LF)) +C +C Set the GKS window for transformation 1. +C + IF (WL.LT.WR) THEN + MI=1 + QL=WL + QR=WR + ELSE + MI=3 + QL=WR + QR=WL + END IF +C + IF (WB.LT.WT) THEN + QB=WB + QT=WT + ELSE + MI=MI+1 + QB=WT + QT=WB + END IF +C + IF (LL.EQ.1) THEN + CALL GSWN (1,QL,QR,QB,QT) + ELSE IF (LL.EQ.2) THEN + CALL GSWN (1,QL,QR,ALOG10(QB),ALOG10(QT)) + ELSE IF (LL.EQ.3) THEN + CALL GSWN (1,ALOG10(QL),ALOG10(QR),QB,QT) + ELSE + CALL GSWN (1,ALOG10(QL),ALOG10(QR),ALOG10(QB),ALOG10(QT)) + END IF +C +C Select transformation 1 as the current one. +C + CALL GSELNT (1) +C + RETURN +C + END + SUBROUTINE SETI (IX,IY) +C +C Allows the user to set the parameters which determine the assumed size +C of the target plotter and therefore determine how user coordinates are +C to be mapped into plotter coordinates. +C +C Declare the common block containing the scaling information. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Transfer the user's values into the common block. +C + MX=MAX0(1,MIN0(15,IX)) + MY=MAX0(1,MIN0(15,IY)) +C + RETURN +C + END + SUBROUTINE SETUSV (VN,IV) + CHARACTER*(*) VN +C +C This subroutine sets the values of various utility state variables. +C VN is the name of the variable and IV is its value. +C +C The labelled common block IUTLCM contains all of the utility state +C variables. +C + COMMON /IUTLCM/ IU(100) +C +C Define an array in which to get the GKS aspect source flags. +C + DIMENSION LF(13) +C +C Check for the linear-log scaling variable, which can take on these +C values: +C +C 1 = X linear, Y linear +C 2 = X linear, Y log +C 3 = X log , Y linear +C 4 = X log , Y log +C + IF (VN(1:2).EQ.'LS') THEN + IF (IV.LT.1.OR.IV.GT.4) THEN + CALL SETER ('SETUSV - LOG SCALE VALUE OUT OF RANGE',2,2) + END IF + IU(1)=IV +C +C Check for the mirror-imaging variable, which can take on these +C values: +C +C 1 = X normal , Y normal +C 2 = X normal , Y reversed +C 3 = X reversed, Y normal +C 4 = X reversed, Y reversed +C + ELSE IF (VN(1:2).EQ.'MI') THEN + IF (IV.LT.1.OR.IV.GT.4) THEN + CALL SETER ('SETUSV - MIRROR-IMAGING VALUE OUT OF RANGE',3,2) + END IF + IU(2)=IV +C +C Check for the scale factor setting the resolution of the plotter in +C the x direction. +C + ELSE IF (VN(1:2).EQ.'XF') THEN + IF (IV.LT.1.OR.IV.GT.15) THEN + CALL SETER ('SETUSV - X RESOLUTION OUT OF RANGE',4,2) + END IF + IU(3)=IV +C +C Check for the scale factor setting the resolution of the plotter in +C the y direction. +C + ELSE IF (VN(1:2).EQ.'YF') THEN + IF (IV.LT.1.OR.IV.GT.15) THEN + CALL SETER ('SETUSV - Y RESOLUTION OUT OF RANGE',5,2) + END IF + IU(4)=IV +C +C Check for the variable specifying the size of the pen-move buffer. +C + ELSE IF (VN(1:2).EQ.'PB') THEN + IF (IV.LT.2.OR.IV.GT.50) THEN + CALL SETER ('SETUSV - PEN-MOVE BUFFER SIZE OUT OF RANGE',6,2) + END IF + CALL PLOTIF (0.,0.,2) + IU(5)=IV +C +C Check for a metacode unit number. +C + ELSE IF (VN(1:2).EQ.'MU') THEN + IF (IV.LE.0) THEN + CALL SETER ('SETUSV - METACODE UNIT NUMBER ILLEGAL',7,2) + END IF +C +C For the moment (1/11/85), we have to deactivate and close the old +C workstation and open and activate a new one. This does allow the +C user to break up his metacode output. It does not necessarily allow +C for the resumption of output to a previously-written metacode file. +C + CALL GDAWK (IU(6)) + CALL GCLWK (IU(6)) + IU(6)=IV + CALL GOPWK (IU(6),2,1) + CALL GACWK (IU(6)) +C +C If, in the future, it becomes possible to have more than one metacode +C workstation open at once, the following code can be used instead. +C +C CALL GDAWK (IU(6)) +C IU(6)=IV +C CALL GQOPWK (0,IE,NO,ID) +C IF (NO.NE.0) THEN +C DO 101 I=1,NO +C CALL GQOPWK (I,IE,NO,ID) +C IF (ID.EQ.IU(6)) GO TO 102 +C 101 CONTINUE +C END IF +C CALL GOPWK (IU(6),2,1) +C 102 CALL GAWK (IU(6)) +C +C Check for one of the variables setting color and intensity. +C + ELSE IF (VN(1:2).EQ.'IR') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF RED INTENSITY',8,2) + END IF + IU(7)=IV +C + ELSE IF (VN(1:2).EQ.'IG') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF GREEN INTENSITY',9,2) + END IF + IU(8)=IV +C + ELSE IF (VN(1:2).EQ.'IB') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF BLUE INTENSITY',10,2) + END IF + IU(9)=IV +C + ELSE IF (VN(1:2).EQ.'IN') THEN + IF (IV.LT.0.OR.IV.GT.10000) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF INTENSITY',11,2) + END IF + IU(10)=IV +C +C Assign the intensity-controlling variables to local variables with +C simple, meaningful names. +C + IR=IU(7) + IG=IU(8) + IB=IU(9) + IN=IU(10) + II=IU(11) + IM=IU(12) +C +C Compute the floating-point red, green, and blue intensities. +C + FR=FLOAT(IR)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. + FG=FLOAT(IG)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. + FB=FLOAT(IB)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. +C +C Dump the pen-move buffer before changing anything. +C + CALL PLOTIF (0.,0.,2) +C +C Set the aspect source flags for all the color indices to "individual". +C + CALL GQASF (IE,LF) + LF( 3)=1 + LF( 6)=1 + LF(10)=1 + LF(13)=1 + CALL GSASF (LF) +C +C Pick a new color index and use it for polylines, polymarkers, text, +C and areas. +C + II=MOD(II,IM)+1 + IU(11)=II + CALL GSPLCI (II) + CALL GSPMCI (II) + CALL GSTXCI (II) + CALL GSFACI (II) +C +C Now, redefine the color for that color index on each open workstation. +C + CALL GQOPWK (0,IE,NO,ID) +C + DO 103 I=1,NO + CALL GQOPWK (I,IE,NO,ID) + CALL GSCR (ID,II,FR,FG,FB) + 103 CONTINUE +C +C Check for variable resetting the color index. +C + ELSE IF (VN(1:2).EQ.'II') THEN + IF (IV.LT.1.OR.IV.GT.IU(12)) THEN + CALL SETER ('SETUSV - ILLEGAL COLOR INDEX',12,2) + END IF + IU(11)=IV +C + CALL PLOTIF (0.,0.,2) +C + CALL GQASF (IE,LF) + LF( 3)=1 + LF( 6)=1 + LF(10)=1 + LF(13)=1 + CALL GSASF (LF) +C + CALL GSPLCI (IV) + CALL GSPMCI (IV) + CALL GSTXCI (IV) + CALL GSFACI (IV) +C +C Check for the variable limiting the values of color index used. +C + ELSE IF (VN(1:2).EQ.'IM') THEN + IF (IV.LT.1) THEN + CALL SETER ('SETUSV - ILLEGAL MAXIMUM COLOR INDEX',13,2) + END IF + IU(12)=IV +C +C Check for the variable setting the current line width scale factor. +C + ELSE IF (VN(1:2).EQ.'LW') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL LINE WIDTH SCALE FACTOR',14,2) + END IF + IU(13)=IV +C +C Dump the pen-move buffer before changing anything. +C + CALL PLOTIF (0.,0.,2) +C +C Set the aspect source flag for linewidth scale factor to "individual". +C + CALL GQASF (IE,LF) + LF(2)=1 + CALL GSASF (LF) +C +C Redefine the line width scale factor. +C + CALL GSLWSC (FLOAT(IV)/1000.) +C +C Check for the variable setting the current marker size scale factor. +C + ELSE IF (VN(1:2).EQ.'MS') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL MARKER SIZE SCALE FACTOR',15,2) + END IF + IU(14)=IV +C +C Set aspect source flag for marker size scale factor to "individual". +C + CALL GQASF (IE,LF) + LF(5)=1 + CALL GSASF (LF) +C +C Redefine the marker size scale factor. +C + CALL GSMKSC (FLOAT(IV)/1000.) +C +C Otherwise, the variable name is unknown. +C + ELSE + CALL SETER ('SETUSV - UNKNOWN VARIABLE NAME IN CALL',1,2) +C + ENDIF + RETURN + END + SUBROUTINE VECTOR (PX,PY) +C +C Draw a vector (line segment) from the current pen position to the new +C pen position (PX,PY), in the user coordinate system, and then make +C (PX,PY) the current pen position. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),1) + RETURN + END + SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC) +C +C WTSTR is called to draw a character string in a specified position. +C +C PX and PY specify, in user coordinates, the position of a point +C relative to which a character string is to be positioned. +C +C CH is the character string to be written. +C +C IS is the desired size of the characters to be used, stated as a +C character width in the plotter coordinate system. The values 0, 1, +C 2, and 3 mean 8, 12, 16, and 24, respectively. +C +C IO is the desired orientation angle, in degrees counterclockwise from +C a horizontal vector pointing to the right. +C +C IC specifies the desired type of centering. A negative value puts +C (PX,PY) in the center of the left end of the character string, a zero +C puts (PX,PY) in the center of the whole string, and a positive value +C puts (PX,PY) in the center of the right end of the character string. +C + CHARACTER*(*) CH +C +C Define arrays in which to save the current viewport and window. +C + DIMENSION VP(4),WD(4) +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Compute the coordinates of (PX,PY) in the fractional coordinate +C system (normalized device coordinates). +C + XN=CUFX(PX) + YN=CUFY(PY) +C +C Save the current window and, if necessary, redefine it so that we can +C use normalized device coordinates. +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Save current character height, text path, character up vector, and +C text alignment. +C + CALL GQCHH (IE,OS) + CALL GQTXP (IE,IP) + CALL GQCHUP (IE,UX,UY) + CALL GQTXAL (IE,IX,IY) +C +C Define the character height. (The final scale factor is derived from +C the default font.) +C + CALL GETUSV ('YF',MY) + YS=FLOAT(2**MY) + IF (IS.GE.0.AND.IS.LE.3) THEN + CS=FLOAT(8+4*IS+4*(IS/3))/YS + ELSE + CS=AMIN1(FLOAT(IS),YS)/YS + ENDIF +C + CS=CS*25.5/27. +C +C + NOAO - make character size readable with IRAF font + cs = cs * 2.0 +C +C - NOAO + + CALL GSCHH(CS) +C +C Define the text path. +C + CALL GSTXP (0) +C +C Define the character up vector. +C + JO=MOD(IO,360) + IF (JO.EQ.0) THEN + CALL GSCHUP (0.,1.) + ELSE IF (JO.EQ.90) THEN + CALL GSCHUP (-1.,0.) + ELSE IF (JO.EQ.180) THEN + CALL GSCHUP (0.,-1.) + ELSE IF (JO.EQ.270) THEN + CALL GSCHUP (1.,0.) + ELSE IF (JO.GT.0.AND.JO.LT.180) THEN + CALL GSCHUP (-1.,1./TAN(FLOAT(JO)*3.1415926/180.)) + ELSE + CALL GSCHUP (1.,-1./TAN(FLOAT(JO)*3.1415926/180.)) + ENDIF +C +C Define the text alignment. +C + CALL GSTXAL (IC+2,3) +C +C Plot the characters. +C + CALL GTX (XN,YN,CH) +C +C Restore the original text attributes. +C + CALL GSCHH (OS) + CALL GSTXP (IP) + CALL GSCHUP (UX,UY) + CALL GSTXAL (IX,IY) +C +C Restore the window definition. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX,PY) +C +C Done. +C + RETURN +C + END +c + NOAO - blockdata utilbd changed to run time initialization + subroutine utilbd +c BLOCKDATA UTILBD +C + logical first +C The common block IUTLCM contains integer utility variables which are +C user-settable by the routine SETUSV and user-retrievable by the +C routine GETUSV. +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables realizing the buffering +C scheme used by PLOTIT/F for pen moves. The dimension of QX and QY must +C be an even number greater than or equal to the value of IU(5). The +C dimension of IF must be half that of QX and QY. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C point to which a pen move was requested by a call to PLOTIT/F. +C + COMMON /PLTCM/ JX,JY +C +C IU(1) contains the log scaling parameter, which may take on the +C following possible values: +C +C 1 = linear-linear +C 2 = log-linear +C 3 = linear-log +C 4 = log-log +C +c DATA IU(1) / 1 / + IU(1) = 1 +C +C IU(2) specifies the mirror-imaging of the x and y axes, as follows: +C +C 1 = x normal, y normal +C 2 = x normal, y reversed +C 3 = x reversed, y normal +C 4 = x reversed, y reversed +C +c +NOAO - logical parameter first inserted to avoid clobbering initialization + data first /.true./ + if (.not. first) return + first = .false. +c -NOAO +c DATA IU(2) / 1 / + IU(2) = 1 +C +C IU(3) specifies the assumed resolution of the plotter in the x +C direction. Plotter x coordinates are assumed to lie between 1 and +C 2**IU(3), inclusive. +C +c DATA IU(3) / 10 / + IU(3) = 10 +C +C IU(4) specifies the assumed resolution of the plotter in the y +C direction. Plotter y coordinates are assumed to lie between 1 and +C 2**IU(4), inclusive. +C +c DATA IU(4) / 10 / + IU(4) = 10 +C +C IU(5) specifies the size of the buffers used by PLOTIT/F. Its value +C must be greater than or equal to 2 and not greater than the dimension +C of the variables QX and QY. Using the value 2 effectively turns off +C the buffering. +C +c DATA IU(5) / 50 / + IU(5) = 50 +C +C IU(6) specifies the current metacode unit, which is machine-dependent. +C At NCAR, the value "1" currently (1/11/85) causes metacode to be +C written on the file "GMETA". Eventually, it will cause output to be +C written on unit number 1. At that point, the value, on the Cray at +C least, should be changed to "4H$PLT", so that output will come out on +C the old familiar dataset. +C +c DATA IU(6) / 1 / + IU(6) = 1 +C +C IU(7), IU(8), IU(9), and IU(10) specify color and intensity, in the +C following way (letting IR=IU(7), IG=IU(8), IB=IU(9), and IN=IU(10)): +C +C The red intensity is IR/(IR+IG+IB)*IN/10000. +C The green intensity is IG/(IR+IG+IB)*IN/10000. +C The blue intensity is IB/(IR+IG+IB)*IN/10000. +C +C The GKS calls to set these intensities are executed in response to a +C "CALL SETUSV ('IN',IN)", using the existing values of IR, IG, and IB. +C Thus, to completely determine the color and the intensity, the user +C must execute four calls, as follows: +C +C CALL SETUSV ('IR',IR) +C CALL SETUSV ('IG',IG) +C CALL SETUSV ('IB',IB) +C CALL SETUSV ('IN',IN) +C +C The default values create a white line at .8 x maximum intensity. +C +c DATA IU(7) / 1 / +c DATA IU(8) / 1 / +c DATA IU(9) / 1 / + IU(7) = 1 + IU(8) = 1 + IU(9) = 1 +C +c DATA IU(10) / 8000 / + IU(10) = 8000 +C +C IU(11) and IU(12) specify, respectively, the last color index used +C and the maximum number of color indices it is permissible to use. +C +c DATA IU(11) / 0 / +c DATA IU(12) / 1 / + IU(11) = 0 + IU(12) = 1 +C +C IU(13)/1000 specifies the current line width scale factor. +C +c DATA IU(13) / 1000 / + IU(13) = 1000 +C +C IU(14)/1000 specifies the current marker size scale factor. +C +c DATA IU(14) / 1000 / + IU(14) = 1000 +C +C IU(15) through IU(100) are currently undefined. +C +C Initialization for the routine PLOTIT/F: For values of I between 1 and +C NQ, (QX(I),QY(I)) is a point to which a pen move has been requested +C by a past call to PLOTIT/F. The coordinates are stated in the fractional +C coordinate system. For values of I between 1 and NF, IF(I) is the +C index, in QX and QY, of the coordinates of a point to which a pen-up +C move was requested. NQ and NF are never allowed to be less than one. +C +c DATA NQ,QX(1),QY(1),NF,IF(1) / 1 , 0. , 0. , 1 , 1 / + NQ = 1 + QX(1) = 0. + QY(1) = 0. + NF = 1 + IF(1) = 1 +C +C JX and JY are the coordinates, in the metacode system, of the last +C point to which a pen move was requested by a call to PLOTIT/F. +C +c DATA JX,JY / 0 , 0 / + JX = 0 + JY = 0 +C +c -NOAO + return +c + entry initut + first = .true. + END diff --git a/sys/gio/ncarutil/sysint/support.f b/sys/gio/ncarutil/sysint/support.f new file mode 100644 index 00000000..84d11ba5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/support.f @@ -0,0 +1,581 @@ + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C +C +C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS +C TO BE CREATED. +C ASH SEE IOFFD. +C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE +C MAGNITUDE OF VALU IS TO BE CREATED. +C .1 .LE. ABS(VALU) .LE. 99999.49999... +C OR VALUE .EQ. 0.0. THE LABEL CREATED +C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING +C ON THE MAGNITUDE OF VALU. SEE IOUT. +C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT +C THE MAGNITUDE OF VALU IS TO BE CREATED. +C ASH IS USED AS THE NORMALIZATION FACTOR. +C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR +C VALU .EQ. 0.0. THE LABEL CREATED SHOULD +C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE +C MAGNITUDE OF ASH*VALU. SEE IOUT. +C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO +C LEADING BLANKS. SEE NC. +C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE +C 1 TO 5. +C + SAVE + CHARACTER*11 IFMT + CHARACTER*(*) IOUT +C +C IFMT MUST HOLD 11 CHARACTERS +C + VAL = VALU + IF (IOFFD .NE. 0) GO TO 103 + IF (VAL) 101,104,101 + 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000 + V = VAL + NS = MAX0(4,MIN0(6,LOG+2)) + ND = MIN0(3,MAX0(0,2-LOG)) +c IF (VAL.LT.0) NS = NS + 1 +c + NOAO - replacing ftn i/o for iraf implementation +c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')' + 102 continue + ifmt(1:6) = '(f . )' + ifmt(3:3) = char (ns + ichar ('0')) + ifmt(5:5) = char (nd + ichar ('0')) +c WRITE (IOUT,IFMT) V + call encode (ns, ifmt, iout, v) + NC = NS +c + NOAO +c The following statement was making 5 digit labels (+4800) come out +c truncated (+480) and it has been commented out. +c IF (LOG.GE.3) NC = NC - 1 +c - NOAO + RETURN + 103 NS = 4 + IF (VAL.LT.0.) NS=5 + IF (VAL.EQ.0.) NS=2 + ND = 0 + V = VAL*ASH + LOG = 100 + GO TO 102 + 104 iout(1:3) = '0.0' + nc = 3 +c 104 NS = 3 +c ND = 1 +c LOG = -100 +c V = 0. +c GO TO 102 +C +C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')') +C + END +C + SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL) + + INTEGER SZFMT, SZBUF + PARAMETER (SZFMT=11) + PARAMETER (SZBUF=15) + + CHARACTER*(*) FTNFMT + CHARACTER*(*) FTNOUT + INTEGER*2 SPPFMT(SZFMT), SPPOUT(SZBUF) + +C UNPACK THE FORTRAN CHARACTER STRING, CALL FENCD TO ACTUALLY ENCODE THE +C OUTPUT STRING, THEN PACK THE OUTPUT STRING INTO A FORTRAN STRING FOR RETURN +C + CALL F77UPK (FTNFMT, SPPFMT, SZFMT) + CALL FENCD (NCHARS, SPPFMT, SPPOUT, RVAL) + CALL F77PAK (SPPOUT, FTNOUT, NCHARS) + + END +C +C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES +C FOLLOWS THIS PACKAGE DESCRIPTION. +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR +C HANDLING PACKAGE. +C +C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN +C THE SAME MANNER AS THEIR SIMILARLY NAMED +C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT +C FOR ROUTINE SETER, THE CALLING SEQUENCES +C OF THESE ROUTINES ARE THE SAME AS FOR +C THEIR PORT COUNTERPARTS. +C ERPRT77 ENTRY PORT ENTRY +C ------------- ---------- +C ENTSR ENTSRC +C RETSR RETSRC +C NERRO NERROR +C ERROF ERROFF +C SETER SETERR +C EPRIN EPRINT +C FDUM FDUMP +C +C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES. +C +C PRECISION NOT APPLICABLE +C +C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON +C FILES NCAR'S CRAY MACHINES. +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER, +C COLORADO BY FRED CLARE OF THE SCIENTIFIC +C COMPUTING DIVISION BY ADAPTING THE NON- +C PROPRIETARY, ERROR HANDLING ROUTINES +C FROM THE PORT LIBRARY OF BELL LABS. +C +C PORTABILITY FULLY PORTABLE +C +C REFERENCES SEE THE MANUAL +C PORT MATHEMATICAL SUBROUTINE LIBRARY +C ESPECIALLY "ERROR HANDLING" IN SECTION 2 +C OF THE INTRODUCTION, AND THE VARIOUS +C SUBROUTINE DESCRIPTIONS. +C ****************************************************************** +C +C SUBBROUTINE ENTSR(IROLD,IRNEW) +C +C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND +C SETS A NEW ONE. IT ALSO CHECKS THE ERROR +C STATE, AND IF THERE IS AN ACTIVE ERROR +C STATE A MESSAGE IS PRINTED. +C +C USAGE CALL ENTSR(IROLD,IRNEW) +C +C ARGUMENTS +C +C ON INPUT IRNEW +C VALUE SPECIFIED BY USER FOR ERROR +C RECOVERY +C = 0 LEAVES RECOVERY UNCHANGED +C = 1 GIVES RECOVERY +C = 2 TURNS RECOVERY OFF +C +C ON OUTPUT IROLD +C RECEIVES THE CURRENT VALUE OF THE ERROR +C RECOVERY MODE +C +C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE +C MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IRNEW. +C 2 - CALLED WHILE IN AN ERROR STATE. +C ****************************************************************** +C +C SUBROUTINE RETSR(IROLD) +C +C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN +C BY THE INPUT ARGUMENT. A TEST IS THEN MADE +C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH +C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN +C ERROR MESSAGE AND TERMINATES THE RUN. +C +C BY CONVENTION, RETSR IS USED UPON EXIT +C FROM A SUBROUTINE TO RESTORE THE PREVIOUS +C RECOVERY MODE STATUS STORED BY ROUTINE +C ENTSR IN IROLD. +C +C USAGE CALL RETSR(IROLD) +C +C ARGUMENTS +C +C ON INPUT IROLD +C = 1 SETS FOR RECOVERY +C = 2 SETS FOR NONRECOVERY +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE, +C THE MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IROLD. +C ****************************************************************** +C +C INTEGER FUNCTION NERRO(NERR) +C +C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY) +C OR ZERO IF THE PROGRAM IS NOT IN THE +C ERROR STATE. +C +C USAGE N = NERRO(NERR) +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NERR +C CURRENT VALUE OF THE ERROR NUMBER +C ****************************************************************** +C SUBROUTINE ERROF +C +C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE +C ERROR NUMBER TO ZERO +C +C USAGE CALL ERROF +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE SETER(MESSG,NERR,IOPT) +C +C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING +C ON THE OPTIONS STATED BELOW, PRINTS A +C MESSAGE AND PROVIDES A DUMP. +C +C +C USAGE CALL SETER(MESSG,NERR,IOPT) +C +C ARGUMENTS +C +C ON INPUT MESSG +C HOLLERITH STRING CONTAINING THE MESSAGE +C ASSOCIATED WITH THE ERROR +C +C NERR +C THE NUMBER TO ASSIGN TO THE ERROR +C +C IOPT +C = 1 FOR A RECOVERABLE ERROR +C = 2 FOR A FATAL ERROR +C +C IF IOPT = 1 AND THE USER IS IN ERROR +C RECOVERY MODE, SETERR SIMPLY REMEMBERS +C THE ERROR MESSAGE, SETS THE ERROR NUMBER +C TO NERR, AND RETURNS. +C +C IF IOPT = 1 AND THE USER IS NOT IN ERROR +C RECOVERY MODE, SETERR PRINTS THE ERROR +C MESSAGE AND TERMINATES THE RUN. +C +C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR +C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN. +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT +C TO ANY VALUE OTHER THAN 1 OR 2. +C ****************************************************************** +C +C SUBROUTINE EPRIN +C +C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE +C PROGRAM IS IN THE ERROR STATE; OTHERWISE +C NOTHING IS PRINTED. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE FDUM +C +C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES +C AS A PLACEHOLDER FOR A SYMBOLIC DUMP +C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO +C PROVIDE SUCH A ROUTINE. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** + SUBROUTINE ENTSR(IROLD,IRNEW) +C + LOGICAL TEMP + IF (IRNEW.LT.0 .OR. IRNEW.GT.2) + 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2) +C + TEMP = IRNEW.NE.0 + IROLD = I8SAV(2,IRNEW,TEMP) +C +C IF HAVE AN ERROR STATE, STOP EXECUTION. +C + IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER + 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2) +C + RETURN +C + END + SUBROUTINE RETSR(IROLD) +C + IF (IROLD.LT.1 .OR. IROLD.GT.2) + 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2) +C + ITEMP=I8SAV(2,IROLD,.TRUE.) +C +C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. +C + IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + END + INTEGER FUNCTION NERRO(NERR) +C + NERRO=I8SAV(1,0,.FALSE.) + NERR=NERRO + RETURN +C + END + SUBROUTINE ERROF +C + I=I8SAV(1,0,.TRUE.) + RETURN +C + END + SUBROUTINE SETER(MESSG,NERR,IOPT) +C + CHARACTER*(*) MESSG + COMMON /UERRF/IERF +C +C THE UNIT FOR ERROR MESSAGES IS I1MACH(4) +C +c + NOAO - blockdata uerrbd changed to runtime initialization subroutine +C FORCE LOAD OF BLOCKDATA +C +c EXTERNAL UERRBD + call uerrbd +c - NOAO + IF (IERF .EQ. 0) THEN + IERF = I1MACH(4) + ENDIF +C + NMESSG = LEN(MESSG) + IF (NMESSG.GE.1) GO TO 10 +C +C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9000) +c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.') + call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80) +c - NOAO + GO TO 60 +C + 10 CONTINUE + IF (NERR.NE.0) GO TO 20 +C +C CANNOT TURN THE ERROR STATE OFF USING SETER. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9001) +c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/ +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/) + call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80) + call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80) +c - NOAO + CALL E9RIN(MESSG,NERR,.TRUE.) + ITEMP=I8SAV(1,1,.TRUE.) + GO TO 50 +C +C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. +C + 20 CONTINUE + IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30 +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9002) +c9002 FORMAT(' ERROR 3 IN SETER -', +c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'// +c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///) + call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80) + call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80) +c - NOAO + CALL EPRIN + CALL E9RIN(MESSG,NERR,.TRUE.) + GO TO 50 +C +C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. +C + 30 CALL E9RIN(MESSG,NERR,.TRUE.) +C + IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 +C +C MUST HAVE IOPT = 1 OR 2. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9003) +c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'// +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) + call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80) + call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80) +c - NOAO + GO TO 50 +C +C TEST FOR RECOVERY. +C + 40 CONTINUE + IF (IOPT.EQ.2) GO TO 50 +C + IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + 50 CALL EPRIN + 60 CALL FDUM +c STOP +C + END + SUBROUTINE EPRIN +C + CHARACTER*1 MESSG +C + CALL E9RIN(MESSG,1,.FALSE.) + RETURN +C + END + SUBROUTINE E9RIN(MESSG,NERR,SAVE) +C +C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, +C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . +C + CHARACTER*(*) MESSG + CHARACTER*113 MESSGP + INTEGER NERRP + LOGICAL SAVE + COMMON /UERRF/IERF + SAVE MESSGP,NERRP +C +C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE +C +C +C START WITH NO PREVIOUS MESSAGE. +C + DATA MESSGP/'1'/ + DATA NERRP/0/ +C + IF (.NOT.SAVE) GO TO 20 +C +C SAVE THE MESSAGE. +C + NERRP=NERR + MESSGP = MESSG +C + GO TO 30 +C + 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30 +C +C PRINT THE MESSAGE. +C +c + NOAO - FTN write rewritten as call to uliber +c WRITE(IERF,9000) NERRP,MESSGP +c9000 FORMAT(' ERROR ',I4,' IN ',A113) + call uliber (nerrp, messgp, 113) +C + 30 RETURN +C + END + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) +C +C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C +C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C + LOGICAL SET + INTEGER LERROR, LRECOV + SAVE LERROR,LRECOV +C +C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. +C + DATA LERROR/0/ , LRECOV/2/ + IF (ISW .EQ. 1) THEN + I8SAV = LERROR + IF (SET) LERROR = IVALUE + ELSE IF (ISW .EQ. 2) THEN + I8SAV = LRECOV + IF (SET) LRECOV = IVALUE + ENDIF + RETURN + END + SUBROUTINE FDUM +C +C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED +C + RETURN + END +C + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) +C +C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH +C INFORMATION ABOUT THE CIRCUMSTANCES OF A +C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING +C TAPE FOR LATER PROCESSING. +C +C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE +C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH +C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT +C MONITORS USE OF NCAR ROUTINES WITH LOCAL +C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL +C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE +C DELETED FROM ALL NSSL ROUTINES. +C + CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION +C + RETURN + END +c + NOAO - Blockdata uerrbd rewritten as a runtime initialization subroutine +c BLOCKDATA UERRBD + subroutine uerrbd +c + COMMON /UERRF/IERF +C DEFAULT ERROR UNIT +c DATA IERF/0/ + IERF= 0 + END +c -NOAO + subroutine uliber (errcode, pkerrmsg, msglen) + + character*80 pkerrmsg + integer errcode, msglen + integer*2 sppmsg(81) + integer SZLINE + parameter (SZLINE=80) + +c unpack the fortran character string, call fulib to output the string. +c + call f77upk (pkerrmsg, sppmsg, SZLINE) + call fulib (errcode, sppmsg, msglen) + + end diff --git a/sys/gio/ncarutil/tests/README b/sys/gio/ncarutil/tests/README new file mode 100644 index 00000000..d74bb65f --- /dev/null +++ b/sys/gio/ncarutil/tests/README @@ -0,0 +1,2 @@ +This directory contains test routines for the NCAR utilities. The files +ending with "t.f" are the NCAR supplied fortran test routines. diff --git a/sys/gio/ncarutil/tests/auto10t.f b/sys/gio/ncarutil/tests/auto10t.f new file mode 100644 index 00000000..26109f4f --- /dev/null +++ b/sys/gio/ncarutil/tests/auto10t.f @@ -0,0 +1,262 @@ + SUBROUTINE XMPL10 +C +C Define the data arrays. +C + REAL XDRA(1201),YDRA(1201) +C +C Fill the data arrays. The independent variable represents time during +C the year (a hypothetical year with equal-length months) and is set up +C so that the minor ticks can be lengthened to delimit the months; the +C major ticks, though shortened to invisibility, will determine where +C the labels go. +C + DO 101 I=1,1201 + XDRA(I)=FLOAT(I-51) + YDRA(I)=COSH(FLOAT(I-601)/202.) + 101 CONTINUE +C +C Change the labels on the bottom and left axes. +C + CALL ANOTAT ('MONTHS OF THE YEAR$','ROMAN NUMERALS$',0,0,0,0) +C +C Fix the minimum and maximum values on both axes and prevent AUTOGRAPH +C from using rounded values at the ends of the axes. +C + CALL AGSETF ('X/MIN.',-50.) + CALL AGSETF ('X/MAX.',1150.) + CALL AGSETI ('X/NICE.',0) +C + CALL AGSETF ('Y/MIN.',1.) + CALL AGSETF ('Y/MAX.',10.) + CALL AGSETI ('Y/NICE.',0) +C +C Specify the spacing between major tick marks on all axes. Note that +C the AUTOGRAPH dummy routine AGCHNL is supplanted (below) by one which +C supplies dates for the bottom axis and Roman numerals for the left +C axis in place of the numeric labels one would otherwise get. +C + CALL AGSETI (' LEFT/MAJOR/TYPE.',1) + CALL AGSETI (' RIGHT/MAJOR/TYPE.',1) + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',1) + CALL AGSETI (' TOP/MAJOR/TYPE.',1) +C + CALL AGSETF (' LEFT/MAJOR/BASE.', 1.) + CALL AGSETF (' RIGHT/MAJOR/BASE.', 1.) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',100.) + CALL AGSETF (' TOP/MAJOR/BASE.',100.) +C +C Suppress minor ticks on the left and right axes. +C + CALL AGSETI (' LEFT/MINOR/SPACING.',0) + CALL AGSETI (' RIGHT/MINOR/SPACING.',0) +C +C On the bottom and top axes, put one minor tick between each pair of +C major ticks, shorten the major ticks to invisibility, and lengthen +C the minor ticks. The net effect is to make the minor ticks delimit +C the beginning and end of each month, while the major ticks, though +C invisible, cause the names of the months to be where we want them. +C + CALL AGSETI ('BOTTOM/MINOR/SPACING.',1) + CALL AGSETI (' TOP/MINOR/SPACING.',1) +C + CALL AGSETF ('BOTTOM/MAJOR/INWARD. ',0.) + CALL AGSETF ('BOTTOM/MINOR/INWARD. ',.015) + CALL AGSETF (' TOP/MAJOR/INWARD. ',0.) + CALL AGSETF (' TOP/MINOR/INWARD. ',.015) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,1201,'EXAMPLE 10 (MODIFIED NUMERIC LABELS)$') +C +c STOP +C + END + SUBROUTINE AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) +C + CHARACTER*(*) CHRM,CHRE +C +C The routine AGCHNL is called by AGAXIS just after it has set up the +C character strings comprising a numeric label along an axis. The +C default version does nothing. A user may supply his own version to +C change the numeric labels. For each numeric label, this routine is +C called twice by AGAXIS - once to determine how much space will be +C required when the label is actually drawn and once just before it +C is actually drawn. The arguments are as follows: +C +C - IAXS is the number of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axes, respectively. +C The value of IAXS must not be altered. +C +C - VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C - CHRM, on entry, is a character string containing the mantissa of the +C numeric label, as it will appear if AGCHNL makes no changes. If the +C numeric label includes a "times" symbol, it will be represented by +C a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C - MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C - NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C - IPXM, on entry, is zero if there is no "times" symbol in CHRM; if it +C is non-zero, it is the index of the appropriate character position +C in CHRM. If AGCHNL changes the position of the "times" symbol in +C CHRM, removes it, or adds it, the value of IPXM must be changed. +C +C - CHRE, on entry, is a character string containing the exponent of the +C numeric label, as it will appear if AGCHNL makes no changes. CHRE +C may be modified. +C +C - MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C - NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C Define the names of the months for use on the bottom axis. +C + CHARACTER*3 MONS(12) + DATA MONS / 'JAN','FEB','MAR','APR','MAY','JUN', + + 'JUL','AUG','SEP','OCT','NOV','DEC'/ +C +C Modify the numeric labels on the left axis. +C + IF (IAXS.EQ.1) THEN + CALL AGCORN (IFIX(VILS),CHRM,NCIM) + IPXM=0 + NCIE=0 +C +C Modify the numeric labels on the bottom axis. +C + ELSE IF (IAXS.EQ.3) THEN + IMON=IFIX(VILS+.5)/100+1 + CHRM(1:3)=MONS(IMON) + NCIM=3 + IPXM=0 + NCIE=0 + END IF +C +C Done. +C + RETURN +C + END + SUBROUTINE AGCORN (NTGR,BCRN,NCRN) +C + CHARACTER*(*) BCRN +C +C This routine receives an integer in NTGR and returns its Roman-numeral +C equivalent - NCRN characters - in the character variable BCRN. It +C only works for integers within a limited range and it does some rather +C unorthodox things (like using zero and minus). +C +C ICH1, ICH5, and IC10 are character variables used for the single-unit, +C five-unit, and ten-unit symbols at a given level. +C + CHARACTER*1 ICH1,ICH5,IC10 +C +C Treat numbers outside the range (-4000,+4000) as infinites. +C + IF (IABS(NTGR).GE.4000) THEN + IF (NTGR.GT.0) THEN + NCRN=5 + BCRN(1:5)='(INF)' + ELSE + NCRN=6 + BCRN(1:6)='(-INF)' + END IF + RETURN + END IF +C +C Use the symbol '0' for the zero. The Romans never had it so good. +C + IF (NTGR.EQ.0) THEN + NCRN=1 + BCRN(1:1)='0' + RETURN + END IF +C +C Zero the character counter. +C + NCRN=0 +C +C Handle negative integers by prefixing a minus sign. +C + IF (NTGR.LT.0) THEN + NCRN=NCRN+1 + BCRN(NCRN:NCRN)='-' + END IF +C +C Initialize some constants. We'll check for thousands first. +C + IMOD=10000 + IDIV=1000 + ICH1='M' +C +C Find out how many thousands (hundreds, tens, units) there are and jump +C to the proper code block for each case. +C + 101 INTG=MOD(IABS(NTGR),IMOD)/IDIV +C + GO TO (107,104,104,104,102,103,103,103,103,106) , INTG+1 +C +C Four - add ICH1 followed by ICH5. +C + 102 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 +C +C Five through eight - add ICH5, followed by INTG-5 ICH1's. +C + 103 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH5 +C + INTG=INTG-5 + IF (INTG.LE.0) GO TO 107 +C +C One through three - add that many ICH1's. +C + 104 DO 105 I=1,INTG + NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 + 105 CONTINUE +C + GO TO 107 +C +C Nine - add ICH1, followed by IC10. +C + 106 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 + NCRN=NCRN+1 + BCRN(NCRN:NCRN)=IC10 +C +C If we're done, exit. +C + 107 IF (IDIV.EQ.1) RETURN +C +C Otherwise, tool up for the next digit and loop back. +C + IMOD=IMOD/10 + IDIV=IDIV/10 + IC10=ICH1 +C + IF (IDIV.EQ.100) THEN + ICH5='D' + ICH1='C' + ELSE IF (IDIV.EQ.10) THEN + ICH5='L' + ICH1='X' + ELSE + ICH5='V' + ICH1='I' + END IF +C + GO TO 101 +C + END diff --git a/sys/gio/ncarutil/tests/autograph.x b/sys/gio/ncarutil/tests/autograph.x new file mode 100644 index 00000000..3c2ccb14 --- /dev/null +++ b/sys/gio/ncarutil/tests/autograph.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include +include + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +procedure t_autograph() + +char device[SZ_FNAME], command[SZ_LINE] +int ierror, wkid, junk, cmd +int ctoi() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tautog (ierror) + if (ierror == 0) + call eprintf ("Test successful\n") + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/autographt.f b/sys/gio/ncarutil/tests/autographt.f new file mode 100644 index 00000000..25b14518 --- /dev/null +++ b/sys/gio/ncarutil/tests/autographt.f @@ -0,0 +1,186 @@ + SUBROUTINE TAUTOG (IERROR) +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C AUTOGRAPH AND TO TEST AUTOGRAPH ON A +C SIMPLE PROBLEM +C +C USAGE CALL TAUTOG (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN ERROR PARAMETER +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C AUTOGRAPH TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS WRITTEN ON UNIT 6. +C +C IN ADDITION, FOUR (4) LABELLED FRAMES +C CONTAINING THE TWO-DIMENSIONAL PLOTS ARE +C PRODUCED ON THE MACHINE GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY AUTOGRAPH +C FILES +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN IN APRIL, 1979 AND +C CONVERTED TO FORTRAN 77 AND GKS IN FEBRUARY +C 1985. +C +C ALGORITHM TAUTOG COMPUTES DATA FOR AUTOGRAPH SUBROUTINES +C +C EZY, EZXY, EZMY, AND EZMXY, +C +C AND CALLS EACH OF THESE ROUTINES TO PRODUCE +C ONE PLOT EACH. +C +C ON THREE OF THE PLOTS, TAUTOG USES THE +C AUTOGRAPH CONTROL PARAMETER ROUTINES +C AGSETF, AGSETI, AND AGSETP TO SPECIFY +C Y-AXIS LABELS OR INTRODUCE LOG SCALING. +C +C PORTABILITY FORTRAN 77 +C + REAL X(21) ,Y1D(21) ,Y2D(21,5) +C +C X CONTAINS THE ABSCISSA VALUES FOR THE PLOTS PRODUCED BY EZXY AND +C EZMXY, Y1D CONTAINS THE ORDINATE VALUES FOR THE PLOTS PRODUCED BY +C EZXY AND EZY, AND Y2D CONTAINS THE ORDINATE VALUES FOR THE PLOTS +C PRODUCED BY EZMY AND EZMXY. +C +C +C +C +C FILL Y1D ARRAY FOR ENTRY EZY +C + DO 10 I=1,21 + Y1D(I) = EXP(-.1*FLOAT(I))*COS(FLOAT(I)*.5) + 10 CONTINUE +C +C ENTRY EZY PLOTS THE CONTENTS OF Y1D AS A FUNCTION OF THE INTEGERS +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZY ENTRY OF AUTOGRAPH +C + CALL EZY (Y1D(1),21,'DEMONSTRATING EZY ENTRY OF AUTOGRAPH$') +C + +C +C +C +C FILL X AND Y1D ARRAYS FOR ENTRY EZXY +C + DO 20 I=1,21 + X(I) = FLOAT(I-1)*.314 + Y1D(I) = X(I)+COS(X(I))*2.0 + 20 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C X+COS(X)*2 +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','X+COS(X)*2$') +C +C ENTRY EZXY PLOTS CONTENTS OF X-ARRAY VS. Y1D-ARRAY +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZXY ENTRY OF AUTOGRAPH +C + CALL EZXY (X,Y1D,21,'DEMONSTRATING EZXY ENTRY IN AUTOGRAPH$') +C +C +C +C +C FILL Y2D ARRAY FOR ENTRY EZMY +C + DO 40 I=1,21 + T = .5*FLOAT(I-1) + DO 30 J=1,5 + Y2D(I,J) = EXP(-.5*T)*COS(T)/FLOAT(J) + 30 CONTINUE + 40 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C EXP(-X/2)*COS(X)*SCALE +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','EXP(-X/2)*COS(X)*SCALE$') +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C ALPHABETIC SET OF DASHED LINE PATTERNS IS TO BE USED. +C + CALL AGSETI('DASH/SELECTOR.',-1) +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C GRAPH DRAWN IS TO BE LOGARITHMIC IN THE X-AXIS. +C + CALL AGSETI('X/LOGARITHMIC.',1) +C +C ENTRY EZMY PLOTS MULTIPLE ARRAYS AS A FUNCTION OF THE INTEGERS +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZMY ENTRY OF AUTOGRAPH +C + CALL EZMY (Y2D,21,5,10,'DEMONSTRATING EZMY ENTRY OF AUTOGRAPH$') +C +C +C +C +C FILL Y2D ARRAY FOR EZMXY +C + DO 60 I=1,21 + DO 50 J=1,5 + Y2D(I,J) = X(I)**J+COS(X(I)) + 50 CONTINUE + 60 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C X**J+COS(X) +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','X**J+COS(X)$') +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C ALPHABETIC SET OF DASHED LINE PATTERNS IS TO BE USED. +C + CALL AGSETI('DASH/SELECTOR.',-1) +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE GRAPH +C IS TO BE LINEAR IN THE X-AXIS AND LOGARITHMIC IN THE Y-AXIS. +C + CALL AGSETI('X/LOGARITHMIC.',0) + CALL AGSETI('Y/LOGARITHMIC.',1) +C +C ENTRY EZMXY PLOTS MULTIPLE ARRAYS AS A FUNCTION OF A SINGLE +C X ARRAY (OR MANY X ARRAYS) +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH +C + CALL EZMXY (X,Y2D,21,5,21, + + 'DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH$') +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +c1001 FORMAT (' AUTOGRAPH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/conran.x b/sys/gio/ncarutil/tests/conran.x new file mode 100644 index 00000000..11a4ab0d --- /dev/null +++ b/sys/gio/ncarutil/tests/conran.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONRAN -- test NCAR contour routine CONRAN. + +procedure t_conran () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconan (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else { + call printf ("Test was not successful. ierror = %d\n") + call pargi (error_code) + } + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrant.f b/sys/gio/ncarutil/tests/conrant.f new file mode 100644 index 00000000..a144de35 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrant.f @@ -0,0 +1,97 @@ + SUBROUTINE TCONAN (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAN, THE STANDARD ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C THIS SAME SUBROUTINE CAN BE USED TO PRODUCE +C DEMO PLOTS OF THE SMOOTH VERSION OF CONRAN +C BY LOADING DASHSMTH INSTEAD OF DASHCHAR. +C +C USAGE CALL TCONAN (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAN LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAN TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAN +C FILES CONTERP +C CONCOM +C +C LANGUAGE FORTRAN77 +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAN TERMINATED +C NORMALLY. +C +C PORTABILITY ANSI FORTRAN77 STANDARD +C +C COMMON /RANINT/ IRANMJ, IRANMN, IRANTX +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAN +C + DIMENSION WK(221),IWK(744),SCR(1600) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ + call conbdn +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAN',29, 0) +C + CALL CONRAN(XD,YD,ZD,NDP,WK,IWK,SCR) +C + RETURN + END diff --git a/sys/gio/ncarutil/tests/conraq.x b/sys/gio/ncarutil/tests/conraq.x new file mode 100644 index 00000000..d0480e97 --- /dev/null +++ b/sys/gio/ncarutil/tests/conraq.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONRAQ -- test NCAR contour routine CONRAQ. + +procedure t_conraq () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconaq (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conraqt.f b/sys/gio/ncarutil/tests/conraqt.f new file mode 100644 index 00000000..dbf211aa --- /dev/null +++ b/sys/gio/ncarutil/tests/conraqt.f @@ -0,0 +1,139 @@ + SUBROUTINE TCONAQ (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAQ, THE QUICK ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C USAGE CALL TCONAQ (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE. +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAQ LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAQ TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAQ +C FILES CONTERP +C +C LANGUAGE FORTRAN77 +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAQ TERMINATED +C NORMALLY. +C + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX +C +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAQ +C + DIMENSION WK(221),IWK(744) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ +C +C SET PORT ERROR HANDLING ROUTINE TO RECOVERY MODE +C + CALL ENTSR(IROLD,1) +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAQ',29) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C SET OPTION TO DISPLAY THE TRIANGULATION +C + CALL CONOP1('TRI=ON') +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C CALL CONRAQ TO CONTOUR DATA +C + CALL CONRAQ(XD,YD,ZD,NDP,WK,IWK) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C +C CALL FRAME, CONRAQ WILL NOT DO THIS +C +cCALL NEWFM +C +C PRINT MESSAGE EVERYTHING OK +C +c WRITE(6,10) +c10 FORMAT(1X,'CONRAQ TEST SUCCESSFUL, SEE PLOT TO VERIFY', +c 1' PERFORMANCE') +C +C + RETURN +C +C IF ERROR CALL THE PORT ERROR PRINT ROUTINE. +C THIS CALL IS NOT NECESSARY UNLESS YOU ARE IN RECOVER MODE. +C IF YOU ARE NOT IN RECOVER MODE THE ERROR MESSAGE WILL BE PRINTED +C AUTOMATICALLY. +C + 100 CALL EPRIN + RETURN +C + END diff --git a/sys/gio/ncarutil/tests/conras.x b/sys/gio/ncarutil/tests/conras.x new file mode 100644 index 00000000..d2b48dc2 --- /dev/null +++ b/sys/gio/ncarutil/tests/conras.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONRAS -- test NCAR contour routine CONRAS. + +procedure t_conras () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconas (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrast.f b/sys/gio/ncarutil/tests/conrast.f new file mode 100644 index 00000000..c4f3ab12 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrast.f @@ -0,0 +1,147 @@ + SUBROUTINE TCONAS (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAS, THE SUPER ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C USAGE CALL TCONAS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAS LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAS TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAS +C FILES CONTERP +C CONCOM +C DASHSUPR +C +C SPECIALIST FOR INFORMATION ABOUT THIS ROUTINE OR THE +C ULIB CONRAS PACKAGE, CONTACT THE SPECIALIST +C NAMED IN THE ULIB CONRAS PACKAGE. +C +C LANGUAGE FORTRAN +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAS TERMINATED +C NORMALLY. +C +C PORTABILITY ANSI STANDARD +C +C +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAS +C + DIMENSION WK(221),IWK(744),SCR(1600) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ +C +C SET PORT ERROR HANDLING ROUTINE TO RECOVERY MODE +C + CALL ENTSR(IROLD,1) +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAS',29,0) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C SET OPTION TO DISPLAY THE TRIANGULATION +C + CALL CONOP1('TRI=ON') +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C CALL CONRAS TO CONTOUR DATA +C + CALL CONRAS(XD,YD,ZD,NDP,WK,IWK,SCR) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C +C CALL FRAME, CONRAS WILL NOT DO THIS +C +c CALL NEWFM +C +C PRINT MESSAGE EVERYTHING OK +C +c WRITE(6,10) +c10 FORMAT(1X,'CONRAS TEST SUCCESSFUL, SEE PLOT TO VERIFY ', +c 1'PERFORMANCE') +C +C + RETURN +C +C IF ERROR CALL THE PORT ERROR PRINT ROUTINE. +C THIS CALL IS NOT NECESSARY UNLESS YOU ARE IN RECOVER MODE. +C IF YOU ARE NOT IN RECOVER MODE THE ERROR MESSAGE WILL BE PRINTED +C AUTOMATICALLY. +C + 100 CALL EPRIN + RETURN +C + END diff --git a/sys/gio/ncarutil/tests/conrcqckt.f b/sys/gio/ncarutil/tests/conrcqckt.f new file mode 100644 index 00000000..d9d2f827 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcqckt.f @@ -0,0 +1,114 @@ + SUBROUTINE TCNQCK (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECQCK AND TO TEST CONRECQCK ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNQCK (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECQCK TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNQCK CALLS SUBROUTINES EZCNTR, CONREC, AND +C PWRIT TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/.4267/, TY/.9765/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECQCK +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECQCK', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECQCK +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECQCK', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' CONRECQCK TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C +C--------------------------------------------------------------------- +C REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND GKS +C +C--------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/tests/conrcsmtht.f b/sys/gio/ncarutil/tests/conrcsmtht.f new file mode 100644 index 00000000..735d109a --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcsmtht.f @@ -0,0 +1,122 @@ + SUBROUTINE TCNSMT (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECSMTH AND TO TEST CONRECSMTH ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNSMT (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECSMTH TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNSMT CALLS SUBROUTINES EZCNTR, CONREC, AND +C WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C +c DATA TX/0.42676/, TY/0.97656/ + TX = 0.42676 + TY = 0.97656 +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMAIZATION TRANS NUMBER TO WRITE TITLES +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c 1001 FORMAT (' CONRECSMTH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C +C +C--------------------------------------------------------------------- +C +C REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND GKS +C +C--------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/tests/conrcsprt.f b/sys/gio/ncarutil/tests/conrcsprt.f new file mode 100644 index 00000000..484d1ccc --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcsprt.f @@ -0,0 +1,110 @@ + SUBROUTINE TCNSUP (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECSUPR AND TO TEST CONRECSUPR ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNSUP (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECSUPR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNSUP CALLS SUBROUTINES EZCNTR, CONREC, AND +C WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4219/, TY/0.9765/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSUPR +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSUPR', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. ALSO THE LABELLING OF THE HIGHS AND LOWS IS SUPRESSED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSUPR +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSUPR', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,-1,0) + CALL NEWFM +C + WRITE (6,1001) + RETURN +C + 1001 FORMAT (' CONRECSUPR TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/conrec.x b/sys/gio/ncarutil/tests/conrec.x new file mode 100644 index 00000000..2d9adfe5 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrec.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONREC -- test NCAR contour routine CONREC. + +procedure t_conrec () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconre (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrect.f b/sys/gio/ncarutil/tests/conrect.f new file mode 100644 index 00000000..401aad9b --- /dev/null +++ b/sys/gio/ncarutil/tests/conrect.f @@ -0,0 +1,118 @@ + SUBROUTINE TCONRE (nplot, IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONREC AND TO TEST CONREC ON A SINGLE +C PROBLEM +C +C USAGE CALL TCONRE (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONREC TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCONRE CALL SUBROUTINES EZCNTR, CONREC, AND +C PWRIT TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY FORTRAN77 +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C +C DATA TX/.3955/, TY/.9765/ + data tx/.4267/, ty/.97/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION NUMBER 0 +C + CALL GSELNT ( 0 ) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONREC +C +c +noao: flag added to plot either EZCNTR or CONREC + if (nplot .eq. 1) then + CALL WTSTR ( TX, TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONREC',2,0,0 ) + CALL EZCNTR (Z,21,25) + endif +c -noao +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONREC +C +c +noao: flag added to plot either EZCNTR of CONREC + if (nplot .eq. 2) then + CALL WTSTR ( TX ,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONREC',2,0,0 ) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) + endif +c -noao +c CALL NEWFM +C +C WRITE (6,1001) + RETURN +C +C1001 FORMAT (' CONREC TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashchar.x b/sys/gio/ncarutil/tests/dashchar.x new file mode 100644 index 00000000..77430f37 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashchar.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routine DASHCHAR + +procedure t_dashchar() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tdashc (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/dashchart.f b/sys/gio/ncarutil/tests/dashchart.f new file mode 100644 index 00000000..fa583b84 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashchart.f @@ -0,0 +1,145 @@ + SUBROUTINE TDASHC (IERROR) +C +C LATEST REVISION MAY 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHCHAR +C AND TO TEST DASHCHAR ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHC (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHCHAR TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHCHAR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHC UTILIZES THE SOFTWARE DASHCHAR +C SUBROUTINES DASHDB, DASHDC, FRSTD, VECTD, +C LINED AND CURVED TO DRAW FIVE CURVES ON ONE +C PICTURE USING FIVE DIFFERENT DASHCHAR +C PATTERNS. EACH CURVE IS CENTERED ABOUT +C SOLID AXIS LINES AND LABELLED WITH THE +C CHARACTER REPRESENTATION OF THE DASHCHAR +C PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY-IMPLEMENTED SUPPORT +C ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHCHAR PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHCHAR') + CALL GTX (.5,.015,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C +c + noao: no need for clearing terminal +c CALL NEWFM +c - noao +C + IERROR = 0 +C WRITE (6,1001) +C + RETURN +C +C +C1001 FORMAT (' DASHCHAR TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashlinet.f b/sys/gio/ncarutil/tests/dashlinet.f new file mode 100644 index 00000000..c857428c --- /dev/null +++ b/sys/gio/ncarutil/tests/dashlinet.f @@ -0,0 +1,138 @@ + SUBROUTINE TDASHL (IERROR) +C +C LATEST REVISION APRIL 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHLINE +C AND TO TEST DASHLINE ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHL (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHLINE TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHLINE +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHL UTILIZES THE SOFTWARE DASHLINE +C SUBROUTINES DASHDB, FRSTD, VECTD, LINED AND +C CURVED TO DRAW FIVE CURVES ON ONE PICTURE +C USING FIVE DIFFERENT DASHLINE PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE BINARY REPRESENTATION OF THE +C DASHLINE PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C COORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) ,IPAT(5) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED +C SUPPORT ROUTINES) ARE USED. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C +C ARRAY IPAT CONTAINS 5 DIFFERENT 16-BIT DASH PATTERNS. THE PATTERNS +C CONSTRUCTED WITH BOOLEAN OPERATIONS AS ABOVE. +C THE BINARY REPRESENTATIONS OF THE PATTERNS ARE +C 0001110001111111 +C 1111000011110000 +C 1111110011111100 +C 1111111100000000 +C 1111111111111100 +C + IPAT(1) = IOR (ISHIFT ( 3647,1), 1) + IPAT(2) = ISHIFT (30840,1) + IPAT(3) = ISHIFT (32382,1) + IPAT(4) = ISHIFT (32640,1) + IPAT(5) = ISHIFT (32766,1) +C + DO 70 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LINED (.109,ORG,.891,ORG) + CALL DASHDB (IPAT(K)) +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 10 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 10 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE BINARY REPRESENTATION OF +C THE DASHLINE PATTERN +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.09 + GO TO ( 20, 30, 40, 50, 60),K + 20 CALL GTX (.1,ORY,'IPAT=0001110001111111') + GO TO 70 + 30 CALL GTX (.1,ORY,'IPAT=1111000011110000') + GO TO 70 + 40 CALL GTX (.1,ORY,'IPAT=1111110011111100') + GO TO 70 + 50 CALL GTX (.1,ORY,'IPAT=1111111100000000') + GO TO 70 + 60 CALL GTX (.1,ORY,'IPAT=1111111111111100') +C + 70 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHLINE') +C +C ADVANCE FRAME +C + CALL NEWFM +C + IERROR = 0 + WRITE (6,1001) +C + RETURN +C + 1001 FORMAT (' DASHLINE TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashsmth.x b/sys/gio/ncarutil/tests/dashsmth.x new file mode 100644 index 00000000..4bca9807 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsmth.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routine DASHSMTH + +procedure t_dashsmth() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tdashs (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/dashsmtht.f b/sys/gio/ncarutil/tests/dashsmtht.f new file mode 100644 index 00000000..147d5139 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsmtht.f @@ -0,0 +1,144 @@ + SUBROUTINE TDASHS (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHSMTH +C AND TO TEST DASHSMTH ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHSMTH TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHSMTH +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHS UTILIZES THE SOFTWARE DASHSMTH +C SUBROUTINES DASHDB, DASHDC, FRSTD, +C VECTD, LASTD, LINED AND CURVED TO +C DRAW FIVE CURVES ON ONE PICTURE USING +C FIVE DIFFERENT DASHSMTH PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE CHARACTER REPRESENTATION OF +C THE DASHSMTH PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED SUPPORT +C ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LASTD + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHSMTH PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHSMTH') + CALL GTX (.5,.015,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +c 1001 FORMAT (' DASHSMTH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashsuprt.f b/sys/gio/ncarutil/tests/dashsuprt.f new file mode 100644 index 00000000..f35c9c8b --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsuprt.f @@ -0,0 +1,151 @@ + SUBROUTINE TDASHP (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHSUPR +C AND TO TEST DASHSUPR ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHP (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHSUPR TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHSUPR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHP UTILIZES THE SOFTWARE DASHSUPR +C SUBROUTINES DASHDB, DASHDC, FRSTD, +C VECTD, LASTD, LINED AND CURVED TO +C DRAW FIVE CURVES ON ONE PICTURE USING +C FIVE DIFFERENT DASHSMTH PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE CHARACTER REPRESENTATION OF +C THE DASHSUPR PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C RESET INITIALIZES THE MODEL PICTURE ARRAY AND SHOULD BE CALLED WITH +C EACH NEW FRAME AND BEFORE THE OTHER SUBROUTINES OF THE DASHSUPR +C PACKAGE. +C + CALL RESET +C +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED PLOT PACKAGE +C SUPPORT ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LASTD + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHSMTH PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHSUPR') + CALL GTX (.5,.013,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C + CALL NEWFM +C + IERROR = 0 + WRITE (6,1001) +C + RETURN +C + 1001 FORMAT (' DASHSUPR TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/ezconrec.x b/sys/gio/ncarutil/tests/ezconrec.x new file mode 100644 index 00000000..afb0775c --- /dev/null +++ b/sys/gio/ncarutil/tests/ezconrec.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_EZCONREC -- test NCAR contour routine EZCNTR. + +procedure t_ezconrec () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconre (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/ezhafton.x b/sys/gio/ncarutil/tests/ezhafton.x new file mode 100644 index 00000000..e1cbbc2c --- /dev/null +++ b/sys/gio/ncarutil/tests/ezhafton.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +procedure t_ezhafton + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call zhafto (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezhaftont.f b/sys/gio/ncarutil/tests/ezhaftont.f new file mode 100644 index 00000000..b3fcee3b --- /dev/null +++ b/sys/gio/ncarutil/tests/ezhaftont.f @@ -0,0 +1,123 @@ + SUBROUTINE ZHAFTO (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C EZHAFTON AND TO TEST HAFTON ON A SINGLE +C PROBLEM +C +C USAGE CALL ZHAFTO (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C HAFTON TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE +C HALF-TONE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE IF THE +C TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY HAFTON +C FILES +C +C LANGUAGE ANSI FORTRAN 77 +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C THAFTO CALLS SUBROUTINES EZHFTN AND HAFTON TO +C DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z. +C +C PORTABILITY ANSI STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE LEFT EDGE OF THE TITLE STRING. +C + DATA TX/0.0762/, TY/0.9769/ +C +C SPECIFY SOME ARGUMENT VALUES FOR ROUTINE HAFTON. +C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI +C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV +C SPECIFIES THE NUMBER OF UNIQUE LEVELS BETWEEN FLO AND FHI, THE +C ABSOLUTE VALUE OF NOPT DETERMINES THE MAPPING OF Z ONTO THE +C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR +C INVERSNESS OF THE MAPPING. +C + DATA FLO/-4.0/, FHI/4.0/, NLEV/8/, NOPT/-3/ +C +C + SAVE +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE +C + CALL GSELNT (0) +C +C +C +C ENTRY EZHFTN REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON',2,0,-1) + CALL EZHFTN (Z,21,25) +C +C ENTRY HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON +C +c CALL GSELNT (0) +c CALL WTSTR (TX,TY, +c 1 'DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON',2,0,-1) +c CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' HAFTON TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/ezisosrf.x b/sys/gio/ncarutil/tests/ezisosrf.x new file mode 100644 index 00000000..21257526 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezisosrf.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine EZISOSRF + +procedure t_ezisos() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tisosr (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezmapg.x b/sys/gio/ncarutil/tests/ezmapg.x new file mode 100644 index 00000000..d2f7dce1 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapg.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine SUPMAP of the EZMAPG utility. + +procedure t_ezmapg() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsupma (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezmapgt.f b/sys/gio/ncarutil/tests/ezmapgt.f new file mode 100644 index 00000000..fab53ce0 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapgt.f @@ -0,0 +1,318 @@ + SUBROUTINE TSUPMA (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF THE +C SUPMAP AND MAPDRW ENTRYS OF EZMAPG. +C +C USAGE CALL TSUPMA (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0 IF THE TEST WAS SUCCESSFUL +C = 1 OTHERWISE +C +C I/O IF EACH CALL TO ROUTINE SUPMAP RESULTS IN +C A NORMAL SUPMAP EXIT, THE MESSAGE +C SUPMAP TEST SUCCESSFUL . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED ON UNIT 6. +C +C TEN CONTINENTAL OUTLINE PLOTS, EACH +C RESULTING FROM A DIFFERENT SPECIFIED +C PROJECTION, ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY EZMAPG +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM SUBROUTINE TSUPMA CALLS ROUTINE SUPMAP ONCE +C FOR EACH OF THE NINE PROJECTION TYPES +C IN SUPMAP. SPECIFICALLY, THESE ARE +C STEREOGRAPHIC +C ORTHOGRAPHIC +C LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS +C LAMBERT EQUAL AREA +C GNOMONIC +C AZIMUTHAL EQUIDISTANT +C CYLINDRICAL EQUIDISTANT +C MERCATOR +C MOLLWEIDE TYPE +C THE ROUTINE THEN DEMONSTRATES THE SATELLITE VIEW +C PROJECTION. +C +C HISTORY WRITTEN OCTOBER, 1976 +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C COMMON BLOCK FOR SATELLITE VIEW PROJECTION +C + COMMON /SATMAP/ SL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT PLOTTER GRID +C WHERE THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX +C AND TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.5/, TY/0.9765/ +C +C INITIALIZE ERROR FLAG +C + IERROR = 0 +C +C CHECK PERFORMANCE CRITERION +C SPECIFY PARAMETERS BEFORE EACH SUPMAP CALL +C + IPROJ = 1 + POLAT = 80. + POLONG = -160. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 +C +C SELECT NORMALIZATION TRANS 0 TO WRITE TITLE +C + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: STEREOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c CALL NEWFM + IF (IER .EQ. 0) GO TO 10 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 10 CONTINUE +C +C + IPROJ = 2 + POLAT = 60. + POLONG = -120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: ORTHOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 20 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 20 CONTINUE +C +C + IPROJ = -3 + POLAT = 45. + POLONG = -100. + ROT = 45. + PL1 = 50. + PL2 = -130. + PL3 = 20. + PL4 = -75. + JLTS = 2 + JGRID = 10 + IUSOUT = 1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT CONFORMAL CONIC PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance is handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 30 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 30 CONTINUE +C +C + IPROJ = 4 + POLAT = 20. + POLONG = -40. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT EQUAL AREA PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance is handled by calling routine +c CALL NEWFM +c -nooa + IF (IER .EQ. 0) GO TO 40 +C +C SUPMAP TEST UNSUCCESSFUL +C +C WRITE (6,1001) IPROJ + IERROR = 1 + 40 CONTINUE +C +C + IPROJ = 5 + POLAT = 0. + POLONG = 0. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: GNOMONIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 50 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 50 CONTINUE +C +C + IPROJ = 6 + POLAT = -20. + POLONG = 40. + JGRID = 5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: AZIMUTHAL EQUIDISTANT PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 60 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 60 CONTINUE +C +C + IPROJ = 8 + POLAT = -40. + POLONG = 80. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: CYLINDRICAL EQUIDISTANT PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 70 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 70 CONTINUE +C +C + IPROJ = 9 + POLAT = -60. + POLONG = 120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MERCATOR PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 80 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 80 CONTINUE +C +C + IPROJ = 10 + POLAT = -80. + POLONG = 160. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MOLLWEIDE TYPE PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 90 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 90 CONTINUE +C +C DEMONSTRATION OF SATELLITE VIEW PROJECTION +C + SL = 6.5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'EZMAPG DEMONSTRATION: SATELLITE VIEW PROJECTION', + 2 2,0,0) + CALL MAPROJ('OR',0.0,-135.0,0.0) + CALL MAPSET('MA',0.0,0.0,0.0,0.0) + CALL MAPDRW +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao +C +C +c IF (IERROR .EQ. 0) WRITE (6,1002) +c IF (IERROR .EQ. 1) WRITE (6,1003) + RETURN +C +C +c1001 FORMAT (' SUPMAP RETURNED ERROR FLAG',' IPROJ=',I4/) +c1002 FORMAT(' SUPMAP TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +c1003 FORMAT (' SUPMAP TEST UNSUCCESSFUL') +C + END diff --git a/sys/gio/ncarutil/tests/ezmapt.f b/sys/gio/ncarutil/tests/ezmapt.f new file mode 100644 index 00000000..330fe6e2 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapt.f @@ -0,0 +1,300 @@ + SUBROUTINE TSUPMA (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF THE +C SUPMAP AND MAPDRW ENTRYS OF EZMAPG. +C +C USAGE CALL TSUPMA (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0 IF THE TEST WAS SUCCESSFUL +C = 1 OTHERWISE +C +C I/O IF EACH CALL TO ROUTINE SUPMAP RESULTS IN +C A NORMAL SUPMAP EXIT, THE MESSAGE +C SUPMAP TEST SUCCESSFUL . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED ON UNIT 6. +C +C TEN CONTINENTAL OUTLINE PLOTS, EACH +C RESULTING FROM A DIFFERENT SPECIFIED +C PROJECTION, ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY EZMAPG +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM SUBROUTINE TSUPMA CALLS ROUTINE SUPMAP ONCE +C FOR EACH OF THE NINE PROJECTION TYPES +C IN SUPMAP. SPECIFICALLY, THESE ARE +C STEREOGRAPHIC +C ORTHOGRAPHIC +C LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS +C LAMBERT EQUAL AREA +C GNOMONIC +C AZIMUTHAL EQUIDISTANT +C CYLINDRICAL EQUIDISTANT +C MERCATOR +C MOLLWEIDE TYPE +C THE ROUTINE THEN DEMONSTRATES THE SATELLITE VIEW +C PROJECTION. +C +C HISTORY WRITTEN OCTOBER, 1976 +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C COMMON BLOCK FOR SATELLITE VIEW PROJECTION +C + COMMON /SATMAP/ SL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT PLOTTER GRID +C WHERE THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX +C AND TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.5/, TY/0.9765/ +C +C INITIALIZE ERROR FLAG +C + IERROR = 0 +C +C CHECK PERFORMANCE CRITERION +C SPECIFY PARAMETERS BEFORE EACH SUPMAP CALL +C + IPROJ = 1 + POLAT = 80. + POLONG = -160. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 +C +C SELECT NORMALIZATION TRANS 0 TO WRITE TITLE +C + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: STEREOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 10 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 10 CONTINUE +C +C + IPROJ = 2 + POLAT = 60. + POLONG = -120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: ORTHOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 20 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 20 CONTINUE +C +C + IPROJ = -3 + POLAT = 45. + POLONG = -100. + ROT = 45. + PL1 = 50. + PL2 = -130. + PL3 = 20. + PL4 = -75. + JLTS = 2 + JGRID = 10 + IUSOUT = 1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT CONFORMAL CONIC PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 30 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 30 CONTINUE +C +C + IPROJ = 4 + POLAT = 20. + POLONG = -40. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = 0 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT EQUAL AREA PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 40 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 40 CONTINUE +C +C + IPROJ = 5 + POLAT = 0. + POLONG = 0. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: GNOMONIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 50 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 50 CONTINUE +C +C + IPROJ = 6 + POLAT = -20. + POLONG = 40. + JGRID = 5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: AZIMUTHAL EQUIDISTANT PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 60 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 60 CONTINUE +C +C + IPROJ = 8 + POLAT = -40. + POLONG = 80. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: CYLINDRICAL EQUIDISTANT PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 70 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 70 CONTINUE +C +C + IPROJ = 9 + POLAT = -60. + POLONG = 120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MERCATOR PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 80 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 80 CONTINUE +C +C + IPROJ = 10 + POLAT = -80. + POLONG = 160. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MOLLWEIDE TYPE PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 90 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 90 CONTINUE +C +C DEMONSTRATION OF SATELLITE VIEW PROJECTION +C + SL = 6.5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'EZMAPG DEMONSTRATION: SATELLITE VIEW PROJECTION', + 2 2,0,0) + CALL MAPROJ('OR',0.0,-135.0,0.0) + CALL MAPSET('MA',0.0,0.0,0.0,0.0) + CALL MAPDRW + CALL FRAME +C +C + IF (IERROR .EQ. 0) WRITE (6,1002) + IF (IERROR .EQ. 1) WRITE (6,1003) + RETURN +C +C + 1001 FORMAT (' SUPMAP RETURNED ERROR FLAG',' IPROJ=',I4/) + 1002 FORMAT(' SUPMAP TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') + 1003 FORMAT (' SUPMAP TEST UNSUCCESSFUL') +C + END diff --git a/sys/gio/ncarutil/tests/ezsurface.x b/sys/gio/ncarutil/tests/ezsurface.x new file mode 100644 index 00000000..75abf061 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezsurface.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine EZSRF. + +procedure t_ezsurface() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsrfac (1, error_code) + if (error_code == 0) + call printf ("Test of EZSRF successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezvelvect.x b/sys/gio/ncarutil/tests/ezvelvect.x new file mode 100644 index 00000000..aeb5a5ab --- /dev/null +++ b/sys/gio/ncarutil/tests/ezvelvect.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routines EZVELVEC + +procedure t_ezvelvect() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tvelvc (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezytst.x b/sys/gio/ncarutil/tests/ezytst.x new file mode 100644 index 00000000..b3ac1cb1 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezytst.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include +include + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +task ezytst = t_ezytst + +procedure t_ezytst() + +char device[SZ_FNAME], title[SZ_LINE] +int wkid, i +real y_vector[512] +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + # Construct vector to be plotted + do i = 1, 512 + y_vector[i] = i + + call strcpy ("TIMING TEST: 512 POINT VECTOR$", title, SZ_LINE) + call ezy (y_vector(1), 512, 'Timing Test: 512 Point Vector$') + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/hafton.x b/sys/gio/ncarutil/tests/hafton.x new file mode 100644 index 00000000..63795b22 --- /dev/null +++ b/sys/gio/ncarutil/tests/hafton.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +procedure t_hafton + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call thafto (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/haftont.f b/sys/gio/ncarutil/tests/haftont.f new file mode 100644 index 00000000..b4cfe017 --- /dev/null +++ b/sys/gio/ncarutil/tests/haftont.f @@ -0,0 +1,123 @@ + SUBROUTINE THAFTO (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C HAFTON AND TO TEST HAFTON ON A SINGLE +C PROBLEM +C +C USAGE CALL THAFTO (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C HAFTON TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE +C HALF-TONE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE IF THE +C TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY HAFTON +C FILES +C +C LANGUAGE ANSI FORTRAN 77 +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C THAFTO CALLS SUBROUTINES EZHFTN AND HAFTON TO +C DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z. +C +C PORTABILITY ANSI STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE LEFT EDGE OF THE TITLE STRING. +C + DATA TX/0.0762/, TY/0.9769/ +C +C SPECIFY SOME ARGUMENT VALUES FOR ROUTINE HAFTON. +C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI +C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV +C SPECIFIES THE NUMBER OF UNIQUE LEVELS BETWEEN FLO AND FHI, THE +C ABSOLUTE VALUE OF NOPT DETERMINES THE MAPPING OF Z ONTO THE +C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR +C INVERSNESS OF THE MAPPING. +C + DATA FLO/-4.0/, FHI/4.0/, NLEV/8/, NOPT/-3/ +C +C + SAVE +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE +C +c CALL GSELNT (0) +C +C +C +C ENTRY EZHFTN REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON +C +c CALL WTSTR (TX,TY, +c 1 'DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON',2,0,-1) +c CALL EZHFTN (Z,21,25) +C +C ENTRY HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON +C + CALL GSELNT (0) + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON',2,0,-1) + CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' HAFTON TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/isosrf.x b/sys/gio/ncarutil/tests/isosrf.x new file mode 100644 index 00000000..1216db50 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrf.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine ISOSRFHR + +procedure t_isosrf() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tisosr (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/isosrfhrt.f b/sys/gio/ncarutil/tests/isosrfhrt.f new file mode 100644 index 00000000..1d8fb249 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrfhrt.f @@ -0,0 +1,165 @@ + SUBROUTINE TISOHR (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ISOSRFHR PACKAGE +C +C USAGE CALL TISOHR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES +C =1 OTHERWISE +C +C I/O THIS ROUTINE REQUIRES UNIT IUNIT FOR SCRATCH +C PURPOSES. USERS SHOULD PUT THE UNITS LABELLED +C COMMON (SEE BELOW) IN THE CALLING PROGRAM, +C AND ALSO SET THE VALUE OF THE COMMON VARIABLE +C IUNIT IN THE CALLING PROGRAM. +C +C IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES THE MESSAGE +C ISOSRFHR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C ALSO, A SAMPLE PLOT IS +C PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. ONE MUST EXAMINE THIS PLOT +C TO DETERMINE IF THE ROUTINES HAVE +C EXECUTED CORRECTLY. +C +C COMMON BLOCKS UNITS +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRFHR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM THIS SUBROUTINE USES THE ROUTINES IN +C THE PACKAGE ISOSRFHR TO DRAW A PERSPECTIVE +C DRAWING OF TWO INTERLOCKING DOUGHNUTS +C +C PORTABILITY ANSI STANDARD +C +C + DIMENSION EYE(3) ,S(4) ,IS2(4,200) , + 1 ST1(81,51,2) ,IOBJS(81,51) + COMMON /UNITS/ IUNIT +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA IX/448/, IY/990/ +C +C +C DEFINE THE EYE POSITION +C + DATA EYE(1), EYE(2), EYE(3) / 200., 250., 250. / +C +C DEFINE THE OVERALL DIMENSION OF THE BOX CONTAINING THE OBJECTS +C + DATA NU, NV, NW / 51, 81, 51 / +C +C SPECIFY THE DIMENSIONS OF THE MODEL OF THE IMAGE PLANE +C + DATA LX, NX, NY / 4, 180, 180 / +C +C SPECIFY CRT COORDINATES OF THE AREA WHERE THE PICTURE +C IS TO BE DRAWN +C + DATA S(1),S(2),S(3),S(4)/ 10.,1010.,10.,1010./ + DATA MV / 81 / +C +C SPECIFY THE LARGE AND SMALL RADII FOR THE INDIVIDUAL DOUGHNUTS +C + DATA RBIG1,RBIG2,RSML1,RSML2/ 20., 20., 6., 6. / +C + SAVE +C +C CALL THE INITIALIZATION ROUTINE +C + CALL INIT3D (EYE,NU,NV,NW,ST1,LX,NY,IS2,IUNIT,S) +C +C INITIALIZE THE ERRROR FLAG +C + IERROR = 1 +C +C CREATE AND PLOT DATA FOR TWO INTERLOCKING DOUGHNUTS +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 70 IBKWDS=1,NU + I = NU+1-IBKWDS +C +C CREATE THE I-TH CROSS SECTION IN THE U DIRECTION OF THE +C THREE-DIMENSIONAL ARRAY AND STORE IN IOBJS AS ZEROS AND ONES +C + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + TEMP = AMIN1(FIMID**2+FJP1**2+FKP1**2-RSML1**2, + 1 FKMID**2+FIP2**2+FJP2**2-RSML2**2) + IF (TEMP .LE. 0.) IOBJS(J,K) = 1 + IF (TEMP .GT. 0.) IOBJS(J,K) = 0 + 10 CONTINUE + 20 CONTINUE +C +C SET PROPER WORDS TO 1 FOR DRAWING AXES +C + IF (I .NE. 1) GO TO 50 + DO 30 K=1,NW + IOBJS(1,K) = 1 + 30 CONTINUE + DO 40 J=1,NV + IOBJS(J,1) = 1 + 40 CONTINUE + GO TO 60 + 50 CONTINUE + IOBJS(1,1) = 1 + 60 CONTINUE +C +C CALL THE DRAW AND REMEMBER ROUTINE FOR THIS SLAB +C + CALL DANDR (NV,NW,ST1,LX,NX,NY,IS2,IUNIT,S,IOBJS,MV) + 70 CONTINUE +C +C TITLE THE PLOT +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = PAU2FX(IX) + YC = PAU2FY(IY) + CALL WTSTR(XC,YC,'DEMONSTRATION PLOT FOR ISOSRFHR',2,0,0) + CALL GSELNT(ICN) +C +C ADVANCE THE PLOTTING DEVICE +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRFHR TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/isosrft.f b/sys/gio/ncarutil/tests/isosrft.f new file mode 100644 index 00000000..1e99e02e --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrft.f @@ -0,0 +1,137 @@ + SUBROUTINE TISOSR (nplot, IERROR) +C +C LATEST REVISION DECEMBER 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ISOSRF AND TO TEST ISOSRF ON A SINGLE PROBLEM +C +C USAGE CALL TISOSR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C ISOSRF TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS WRITTEN ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE SAMPLE +C PLOTS ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRF FROM ULIB LIBRARY +C FILES +C +C LANGUAGE STANDARD FORTRAN77 +C +C HISTORY WRITTEN BY MEMBERS OF THE +C SCIENTIFIC COMPUTING DIVISION OF NCAR, +C BOULDER COLORADO +C +C ALGORITHM A FUNCTION OF THREE VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A THREE DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE CALLS EZISOS AND ISOSRF TO DRAW ISO- +C VALUED SURFACE PLOTS OF THE FUNCTION. +C +C PORTABILITY ANSI STANDARD +C +C + SAVE + DIMENSION T(21,31,19),SLAB(33,33),EYE(3) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + REAL IX,IY + DATA IX/.44/, IY/.95/ +C + DATA NU,NV,NW/21,31,19/ + DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./ + DATA TISO/0./ + DATA MUVWP2/33/ + DATA IFLAG/-7/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 30 I=1,NU + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + T(I,J,K) = AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1- + 1 RSML1*RSML1, + 2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C DEFINE EYE POSITION +C + EYE(1) = 100. + EYE(2) = 150. + EYE(3) = 125. +C +C LABEL THE PLOT TO BE DRAWN BY EZISOS +C + if (nplot .eq. 1) then + CALL GSELNT(0) + CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY EZISOS OF ISOSRF', + 1 2,0,0) +C +C TEST EZISOS +C + CALL EZISOS (T,NU,NV,NW,EYE,SLAB,TISO) + endif +C +C LABEL THE PLOT TO BE DRAWN BY ISOSRF +C + if (nplot .eq. 2) then + CALL GSELNT(0) + CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY ISOSRF OF ISOSRF', + 1 2,0,0) +C +C TEST ISOSRF WITH SUBARRAY OF T +C + MU=NU/2 + MV=NV/2 + MW=NW/2 + MUVWP2=MAX0(MU,MV,MW)+2 + CALL ISOSRF(T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG) + endif +c CALL FRAME +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRF TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/mkpkg b/sys/gio/ncarutil/tests/mkpkg new file mode 100644 index 00000000..79beff4f --- /dev/null +++ b/sys/gio/ncarutil/tests/mkpkg @@ -0,0 +1,65 @@ +# Make the x_ncartest.e executable for testing the NCAR utilities. + #conraq.x + #conraqt.f + #conras.x + #conrast.f + #conrcqckt.f + #conrcsmtht.f + #conrcsprt.f + #dashchar.x + #dashchart.f + #dashlinet.f + #dashsuprt.f + #ezmapg.x + #ezmapgt.f + #ezmapt.f + #isosrfhrt.f + +$update libpkg.a +$omake x_ncartest.x +$link x_ncartest.o libpkg.a -lncar -lgks -o /tmp2/newncar/x_ncartest.e +$exit + +libpkg.a: + auto10t.f + autograph.x + autographt.f + conran.x + conrant.f + conrec.x + conrect.f + dashsmth.x + dashsmtht.f + ezconrec.x + ezhafton.x + ezhaftont.f + ezisosrf.x + ezsurface.x + ezvelvect.x + ezytst.x + hafton.x + haftont.f + isosrf.x + isosrft.f + oldauto.x + oldautot.f + preal.x + pwrity.x + pwrityt.f + pwrzit.f + pwrzs.x + pwrzst.f + pwrztt.f + srfacet.f + srftest.x + srftestd.x + strmln.x + strmlnt.f + surface.x + threed.x + threed2.x + threed2t.f + threedt.f + velvctt.f + velvect.x + ; diff --git a/sys/gio/ncarutil/tests/oldauto.x b/sys/gio/ncarutil/tests/oldauto.x new file mode 100644 index 00000000..90287803 --- /dev/null +++ b/sys/gio/ncarutil/tests/oldauto.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include +include + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +procedure t_oldauto() + +char device[SZ_FNAME], command[SZ_LINE] +int error_code, wkid +int ctoi() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call exmpl1 + call exmpl2 + call exmpl3 + call exmpl4 + call exmpl5 + call exmpl6 + call exmpl7 + call exmpl8 + # call exmpl9 + call xmpl11 + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/oldautot.f b/sys/gio/ncarutil/tests/oldautot.f new file mode 100644 index 00000000..168d5f37 --- /dev/null +++ b/sys/gio/ncarutil/tests/oldautot.f @@ -0,0 +1,833 @@ + SUBROUTINE EXMPL1 +C +C Define the data array. +C + REAL YDRA(1001) +C +C Fill the data array. +C + DO 101 I=1,1001 + X=FLOAT(I)/20. + YDRA(I)=10.*(X-1.)*(X-11.)*(X-21.)*(X-31.)*(X-41.)*(X-51.) + + +2.E7*(FRAN()-.5) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZY. +C + CALL EZY (YDRA,1001,'EXAMPLE 1 (EZY)$') +C +c STOP +C + END + FUNCTION FRAN() +C +C Random-number generator. +C + DATA X / 2.7182818 / + SAVE X + X=AMOD(9821.*X+.211327,1.) + FRAN=X + RETURN + END + SUBROUTINE BNDARY +C +C Routine to draw the plotter-frame edge. +C + CALL PLOTIT ( 0, 0,0) + CALL PLOTIT (32767, 0,1) + CALL PLOTIT (32767,32767,1) + CALL PLOTIT ( 0,32767,1) + CALL PLOTIT ( 0, 0,1) + RETURN + END +c + SUBROUTINE EXMPL2 +C +C Define the data arrays. +C + REAL XDRA(4001),YDRA(4001) +C +C Fill the data arrays. +C + DO 101 I=1,4001 + THETA=.0015707963267949*FLOAT(I-1) + RHO=SIN(2.*THETA)+.05*SIN(64.*THETA) + XDRA(I)=RHO*COS(THETA) + YDRA(I)=RHO*SIN(THETA) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,4001,'EXAMPLE 2 (EZXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL3 +C +C Define the data array. +C + REAL YDRA(100,2) +C +C Fill the data array. +C + DO 101 I=1,100 + YDRA(I,1)=COS(3.14159265358979*FLOAT(I)/25.)*FLOAT(I)**2 + YDRA(I,2)=COS(3.14159265358979*FLOAT(I)/25.)*10.**(.04*FLOAT(I)) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMY. +C + CALL EZMY (YDRA,100,2,100,'EXAMPLE 3 (EZMY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL4 +C +C Define the data arrays. +C + REAL XDRA(201),YDRA(201,10) +C +C Fill the data arrays. +C + DO 102 I=1,201 + XDRA(I)=-1.+.02*FLOAT(I-1) + IF (I.GT.101) XDRA(I)=2.-XDRA(I) + DO 101 J=1,10 + YDRA(I,J)=FLOAT(J)*SQRT(1.000000000001-XDRA(I)**2)/10. + IF (I.GT.101) YDRA(I,J)=-YDRA(I,J) + 101 CONTINUE + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,201,10,201,'EXAMPLE 4 (EZMXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL5 +C +C Define the data arrays. +C + REAL XDRA(401,6),YDRA(401,6) +C +C Compute required constants. +C + PI=3.14159265358979 + PID200=PI/200. + PITTWO=2.*PI + PIT2D3=2.*PI/3. + PIT4D3=4.*PI/3. + RADOSC=SQRT(3.)/3. + RADOLC=SQRT(3.)/2. + BSSCLL=ATAN(SQRT(12.)/6.) + BSSCUL=ATAN(SQRT(143.)/7.) + BSLCLL=ATAN(SQRT(143.)/17.) + BSLCUL=ATAN(SQRT(2.0)) +C +C Fill the data arrays. +C + DO 101 I=1,401 + THETA=PID200*FLOAT(I-1) + XDRA(I,1)= -.5+RADOSC*COS(THETA) + YDRA(I,1)= RADOSC*SIN(THETA) + IF (ABS(THETA ).GE.BSSCLL.AND. + + ABS(THETA ).LE.BSSCUL) XDRA(I,1)=1.E36 + IF (ABS(THETA-PITTWO).GE.BSSCLL.AND. + + ABS(THETA-PITTWO).LE.BSSCUL) XDRA(I,1)=1.E36 + XDRA(I,2)= .5+RADOSC*COS(THETA) + YDRA(I,2)= RADOSC*SIN(THETA) + IF (ABS(THETA-PIT2D3).GE.BSSCLL.AND. + + ABS(THETA-PIT2D3).LE.BSSCUL) XDRA(I,2)=1.E36 + XDRA(I,3)= RADOSC*COS(THETA) + YDRA(I,3)=RADOLC+RADOSC*SIN(THETA) + IF (ABS(THETA-PIT4D3).GE.BSSCLL.AND. + + ABS(THETA-PIT4D3).LE.BSSCUL) XDRA(I,3)=1.E36 + XDRA(I,4)= -.5+RADOLC*COS(THETA) + YDRA(I,4)= RADOLC*SIN(THETA) + IF (ABS(THETA ).GE.BSLCLL.AND. + + ABS(THETA ).LE.BSLCUL) XDRA(I,4)=1.E36 + IF (ABS(THETA-PITTWO).GE.BSLCLL.AND. + + ABS(THETA-PITTWO).LE.BSLCUL) XDRA(I,4)=1.E36 + XDRA(I,5)= .5+RADOLC*COS(THETA) + YDRA(I,5)= RADOLC*SIN(THETA) + IF (ABS(THETA-PIT2D3).GE.BSLCLL.AND. + + ABS(THETA-PIT2D3).LE.BSLCUL) XDRA(I,5)=1.E36 + XDRA(I,6)= RADOLC*COS(THETA) + YDRA(I,6)=RADOLC+RADOLC*SIN(THETA) + IF (ABS(THETA-PIT4D3).GE.BSLCLL.AND. + + ABS(THETA-PIT4D3).LE.BSLCUL) XDRA(I,6)=1.E36 + 101 CONTINUE +C +C Specify subscripting of XDRA and YDRA. +C + CALL AGSETI ('ROW.',2) +C +C Make sure grid shape is such that one unit in x = one unit in y. +C + CALL AGSETF ('GRID/SHAPE.',2.) +C +C Turn off background, then turn labels back on. +C + CALL AGSETF ('BACKGROUND.',4.) + CALL AGSETI ('LABEL/CONTROL.',2) +C +C Turn off left label. +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LABEL/SUPPRESSION FLAG.',1) +C +C Change text of bottom label. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','PURITY, BODY, AND FLAVOR$') +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,401,6,401,'EXAMPLE 5 (EZMXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL6 +C +C Define the data arrays. +C + REAL XDRA(501),YDRA(501) +C + CHARACTER*35 GLAB + CHARACTER*23 BACK(4) + CHARACTER*12 LNLG(4) + character*1 tmp +C Define the graph-window parameter array. +C + REAL GWND (4,4) +C + DATA (GWND(I,1),I=1,4) / 0.0 , 0.5 , 0.5 , 1.0 / + DATA (GWND(I,2),I=1,4) / 0.5 , 1.0 , 0.5 , 1.0 / + DATA (GWND(I,3),I=1,4) / 0.0 , 0.5 , 0.0 , 0.5 / + DATA (GWND(I,4),I=1,4) / 0.5 , 1.0 , 0.0 , 0.5 / +C +C Define variables used in setting up informational labels on the graph. +C +C + DATA BACK(1) / '(PERIMETER BACKGROUND)$' / + DATA BACK(2) / '(GRID BACKGROUND)$ ' / + DATA BACK(3) / '(HALF-AXIS BACKGROUND)$' / + DATA BACK(4) / '(NO BACKGROUND)$ ' / +C + DATA LNLG(1) / 'LINEAR$' / + DATA LNLG(2) / 'LOGARITHMIC$' / +C +C Fill the data arrays. +C + DO 101 I=1,501 + THETA=.031415926535898*FLOAT(I-1) + XDRA(I)=500.+.9*FLOAT(I-1)*COS(THETA) + YDRA(I)=500.+.9*FLOAT(I-1)*SIN(THETA) + 101 CONTINUE +C +C +C Do four graphs on the same frame, using different backgrounds. +C + DO 102 IGRF = 1,4 +C +C Suppress the frame advance. +C + CALL AGSETI ('FRAME.',2) +C +C Position the graph window. +C + CALL AGSETP ('GRAPH WINDOW.',GWND(1,IGRF),4) +C +C Declare the background type. +C + CALL AGSETI ('BACKGROUND TYPE.',IGRF) +C +C Setting the background type may have turned the informational labels +C off. In that case, turn them back on. +C + IF (IGRF.EQ.4) CALL AGSETI ('LABEL/CONTROL.',2) +C +C Set up parameters determining the linear/log nature of the axes. +C + ILLX=(IGRF-1)/2 + ILLY=MOD(IGRF-1,2) +C +C Declare the linear/log nature of the graph. +C + CALL AGSETI ('X/LOGARITHMIC.',ILLX) + CALL AGSETI ('Y/LOGARITHMIC.',ILLY) +C +C Change the x- and y-axis labels to reflect the linear/log nature of +C the graph. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.',LNLG(ILLX+1)) +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.',LNLG(ILLY+1)) +C +C Set up the label for the top of the graph. +C +c WRITE (GLAB,1001) IGRF,BACK(IGRF) + glab(1:35) = 'EXAMPLE 6- ' + glab(11:11) = char (igrf + ichar ('0')) + glab(13:35) = back (igrf) +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,501,GLAB) +C + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Advance the frame. +C + CALL FRAME +C +c STOP +C +C Format for encode. +C +c1001 FORMAT ('EXAMPLE 6-',I1,' ',A23) + END +c + SUBROUTINE EXMPL7 +C +C Define the data arrays and the dash-pattern array. +C + REAL XDRA(101),YDRA(101,9) + CHARACTER*28 DSHP(9) +C +C Declare the type of the dash-pattern-name generator. +C + CHARACTER*16 AGDSHN +C +C Fill the data arrays and the dash pattern array. +C + DO 101 I=1,101 + XDRA(I)=-90.+1.8*FLOAT(I-1) + 101 CONTINUE +C + DO 103 J=1,9 +c WRITE (DSHP(J),1001) J + dshp(j) = '$$$$$$$$$$$$$$$$$$$$$ J = ' + dshp(j)(27:27) = char (j + ichar ('0')) + FJ=J + DO 102 I=1,101 + YDRA(I,J)=3.*FJ-(FJ/2700.)*XDRA(I)**2 + 102 CONTINUE + 103 CONTINUE +C +C Turn on windowing. (Some curves run outside the curve window.) +C + CALL AGSETI ('WINDOWING.',1) +C +C Move the edges of the curve window (grid). +C + CALL AGSETF ('GRID/LEFT.' ,.10) + CALL AGSETF ('GRID/RIGHT.' ,.90) + CALL AGSETF ('GRID/BOTTOM.',.10) + CALL AGSETF ('GRID/TOP.' ,.85) +C +C Set the x and y minimum and maximum. +C + CALL AGSETF ('X/MINIMUM.',-90.) + CALL AGSETF ('X/MAXIMUM.',+90.) + CALL AGSETF ('Y/MINIMUM.', 0.) + CALL AGSETF ('Y/MAXIMUM.', 18.) +C +C Set left axis parameters. +C + CALL AGSETI ('LEFT/MAJOR/TYPE.',1) + CALL AGSETF ('LEFT/MAJOR/BASE.',3.) + CALL AGSETI ('LEFT/MINOR/SPACING.',2) +C +C Set right axis parameters. +C + CALL AGSETI ('RIGHT/FUNCTION.',1) + CALL AGSETF ('RIGHT/NUMERIC/TYPE.',1.E36) +C +C Set bottom axis parameters. +C + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',1) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',15.) + CALL AGSETI ('BOTTOM/MINOR/SPACING.',2) +C +C Set top axis parameters. +C + CALL AGSETI ('TOP/FUNCTION.',1) + CALL AGSETF ('TOP/NUMERIC/TYPE.',1.E36) +C +C Set up the dash patterns to be used. +C + CALL AGSETI ('DASH/SELECTOR.',9) + CALL AGSETI ('DASH/LENGTH.',28) + DO 104 I=1,9 + CALL AGSETC (AGDSHN(I),DSHP(I)) + 104 CONTINUE +C +C Set up the left label. +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','HEIGHT (KILOMETERS)$') +C +C Set up the right label. +C + CALL AGSETC ('LABEL/NAME.','R') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','PRESSURE (TONS/SQUARE FURLONG)$') +C +C Set up the bottom labels. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','LATITUDE (DEGREES)$') +C + CALL AGSETC ('LABEL/NAME.','SP') + CALL AGSETF ('LABEL/BASEPOINT/X.',.000001) + CALL AGSETF ('LABEL/BASEPOINT/Y.',0.) + CALL AGSETF ('LABEL/OFFSET/Y.',-.015) + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','SP$') +C + CALL AGSETC ('LABEL/NAME.','NP') + CALL AGSETF ('LABEL/BASEPOINT/X.',.999999) + CALL AGSETF ('LABEL/BASEPOINT/Y.',0.) + CALL AGSETF ('LABEL/OFFSET/Y.',-.015) + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','NP$') +C +C Set up the top label. +C + CALL AGSETC ('LABEL/NAME.','T') + CALL AGSETI ('LINE/NUMBER.',80) + CALL AGSETC ('LINE/TEXT.','DISTANCE FROM EQUATOR (MILES)$') + CALL AGSETI ('LINE/NUMBER.',90) + CALL AGSETC ('LINE/TEXT.',' $') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','LINES OF CONSTANT INCRUDESCENCE$') + CALL AGSETI ('LINE/NUMBER.',110) + CALL AGSETC ('LINE/TEXT.','EXAMPLE 7 (EZMXY)$') +C +C Set up centered (box 6) label. +C + CALL AGSETC ('LABEL/NAME.','EQUATOR') + CALL AGSETI ('LABEL/ANGLE.',90) + CALL AGSETI ('LINE/NUMBER.',0) + CALL AGSETC ('LINE/TEXT.','EQUATOR$') +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,101,9,101,0) +C +c STOP +C +C Format for encode above. +C +c1001 FORMAT ('$$$$$$$$$$$$$$$$$$$$$''J''=''',I1,'''') +C + END +c + SUBROUTINE EXMPL8 +C +C Define the data arrays. +C + REAL XDRA(101),YDRA(4,101) +C +C Fill the data arrays. +C + DO 101 I=1,101 + XDRA(I)=-3.14159265358979+.062831853071796*FLOAT(I-1) + 101 CONTINUE +C + DO 103 I=1,4 + FLTI=I + BASE=2.*FLTI-1. + DO 102 J=1,101 + YDRA(I,J)=BASE+.75*SIN(-3.14159265358979+.062831853071796* + + FLTI*FLOAT(J-1)) + 102 CONTINUE + 103 CONTINUE +C +C Change the line-end character to a period. +C + CALL AGSETC ('LINE/END.','.') +C +C Specify labels for x and y axes. +C + CALL ANOTAT ('SINE FUNCTIONS OF T.','T.',0,0,0,0) +C +C Use a half-axis background. +C + CALL AGSETI ('BACKGROUND.',3) +C +C Move x axis to the zero point on the y axis. +C + CALL AGSETF ('BOTTOM/INTERSECTION/USER.',0.) +C +C Specify base value for spacing of major ticks on x axis. +C + CALL AGSETF ('BOTTOM/MAJOR/BASE.',1.) +C +C Run major ticks on x axis to edge of curve window. +C + CALL AGSETF ('BOTTOM/MAJOR/INWARD.',1.) + CALL AGSETF ('BOTTOM/MAJOR/OUTWARD.',1.) +C +C Position x axis minor ticks. +C + CALL AGSETI ('BOTTOM/MINOR/SPACING.',9) +C +C Run the y axis backward. +C + CALL AGSETI ('Y/ORDER.',1) +C +C Run plots full-scale in y. +C + CALL AGSETI ('Y/NICE.',0) +C +C Have AUTOGRAPH scale x and y data the same. +C + CALL AGSETF ('GRID/SHAPE.',.01) +C +C Use the alphabetic set of dashed-line patterns. +C + CALL AGSETI ('DASH/SELECTOR.',-1) +C +C Tell AUTOGRAPH how the data arrays are dimensioned. +C + CALL AGSETI ('ROW.',-1) +C +C Reverse the roles of the x and y arrays. +C + CALL AGSETI ('INVERT.',1) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the curves. +C + CALL EZMXY (XDRA,YDRA,4,4,101,'EXAMPLE 8.') +C +c STOP +C + END +c +C SUBROUTINE EXMPL9 +CC +CC Define the data arrays. +CC +C DIMENSION XDAT(400),YDAT(400) +CC +CC Fill the data arrays. +CC +C DO 101 I=1,400 +C XDAT(I)=(FLOAT(I)-1.)/399. +C 101 CONTINUE +CC +C CALL GENDAT (YDAT( 1),200,200,1,3,3,+.01,+10.) +C CALL GENDAT (YDAT(201),200,200,1,3,3,-10.,-.01) +CC +CC The y data ranges over both positive and negative values. It is +CC desired that both ranges be represented on the same graph and that +CC each be shown logarithmically, ignoring values in the range -.01 to +CC +.01, in which we're not interested. First we map each y datum into +CC its absolute value (.01 if the absolute value is too small). Then we +CC take the base-10 logarithm, add 2.0001 (so as to be sure of getting a +CC positive number), and re-attach the original sign. We can plot the +CC resulting y data on a linear y axis. +CC +C DO 102 I=1,400 +C YDAT(I)=SIGN(ALOG10(AMAX1(ABS(YDAT(I)),.01))+2.0001,YDAT(I)) +C 102 CONTINUE +CC +CC In order that the labels on the y axis should show the original values +CC of the y data, we change the user-system-to-label-system mapping on +CC both y axes and force major ticks to be spaced logarithmically in the +CC label system (which will be defined by the subroutine AGUTOL in such +CC a way as to re-create numbers in the original range). +CC +C CALL AGSETI ('LEFT/FUNCTION.',1) +C CALL AGSETI ('LEFT/MAJOR/TYPE.',2) +CC +C CALL AGSETI ('RIGHT/FUNCTION.',1) +C CALL AGSETI ('RIGHT/MAJOR/TYPE.',2) +CC +CC Change the label on the left axis to reflect what's going on. +CC +C CALL AGSETC ('LABEL/NAME.','L') +C CALL AGSETI ('LINE/NUMBER.',100) +C CALL AGSETC ('LINE/TEXT.','LOG SCALING, POSITIVE AND NEGATIVE$') +CC +CC Draw a boundary around the edge of the plotter frame. +CC +Cc CALL BNDARY +CC +CC Draw the curve. +CC +C CALL EZXY (XDAT,YDAT,400,'EXAMPLE 9$') +CC +Cc STOP +CC +C END +Cc +C SUBROUTINE GENDAT (DATA,IDIM,M,N,MLOW,MHGH,DLOW,DHGH) +CC +CC This is a routine to generate test data for two-dimensional graphics +CC routines. Given an array "DATA", dimensioned "IDIM x 1", it fills +CC the sub-array ((DATA(I,J),I=1,M),J=1,N) with a two-dimensional field +CC of data having approximately "MLOW" lows and "MHGH" highs, a minimum +CC value of exactly "DLOW" and a maximum value of exactly "DHGH". +CC +CC "MLOW" and "MHGH" are each forced to be greater than or equal to 1 +CC and less than or equal to 25. +CC +CC The function used is a sum of exponentials. +CC +C DIMENSION DATA(IDIM,1),CCNT(3,50) +CC +C FOVM=9./FLOAT(M) +C FOVN=9./FLOAT(N) +CC +C NLOW=MAX0(1,MIN0(25,MLOW)) +C NHGH=MAX0(1,MIN0(25,MHGH)) +C NCNT=NLOW+NHGH +CC +C DO 101 K=1,NCNT +C CCNT(1,K)=1.+(FLOAT(M)-1.)*FRAN() +C CCNT(2,K)=1.+(FLOAT(N)-1.)*FRAN() +C IF (K.LE.NLOW) THEN +C CCNT(3,K)=-1. +C ELSE +C CCNT(3,K)=+1. +C END IF +C 101 CONTINUE +CC +C DMIN=+1.E36 +C DMAX=-1.E36 +C DO 104 J=1,N +C DO 103 I=1,M +C DATA(I,J)=.5*(DLOW+DHGH) +C DO 102 K=1,NCNT +C DATA(I,J)=DATA(I,J) + .5 * (DHGH-DLOW) * CCNT(3,K) * +C + EXP( - ( ( FOVM*(FLOAT(I)-CCNT(1,K)) )**2 + +C + ( FOVN*(FLOAT(J)-CCNT(2,K)) )**2 ) ) +C 102 CONTINUE +C DMIN=AMIN1(DMIN,DATA(I,J)) +C DMAX=AMAX1(DMAX,DATA(I,J)) +C 103 CONTINUE +C 104 CONTINUE +CC +C DO 106 J=1,N +C DO 105 I=1,M +C DATA(I,J)=(DATA(I,J)-DMIN)/(DMAX-DMIN)*(DHGH-DLOW)+DLOW +C 105 CONTINUE +C 106 CONTINUE +CC +C RETURN +CC +C END +Cc +C SUBROUTINE XMPL10 +C RETURN +C END +Cc + SUBROUTINE XMPL11 +C +C Create a sort of histogram. +C + REAL XDRA(249),YDRA(249),WORK(204),IWRK(204) +C +C Fill the data arrays. First, we define the histogram outline. This +C will be used in the call to FILL which fills in the area under the +C histogram. +C + XDRA(1)=0. + YDRA(1)=0. +C + DO 101 I=2,100,2 + XDRA(I )=XDRA(I-1) + YDRA(I )=EXP(-16.*(FLOAT(I/2)/50.-.51)**2)+.1*FRAN() + XDRA(I+1)=XDRA(I-1)+.02 + YDRA(I+1)=YDRA(I) + 101 CONTINUE +C + XDRA(102)=1. + YDRA(102)=0. +C +C Then, we define lines separating the vertical boxes from each other. +C + NDRA=102 +C + DO 102 I=3,99,2 + XDRA(NDRA+1)=1.E36 + YDRA(NDRA+1)=1.E36 + XDRA(NDRA+2)=XDRA(I) + YDRA(NDRA+2)=0. + XDRA(NDRA+3)=XDRA(I) + YDRA(NDRA+3)=AMIN1(YDRA(I),YDRA(I+1)) + NDRA=NDRA+3 + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Suppress the frame advance. +C + CALL AGSETI ('FRAME.',2) +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,249,'EXAMPLE 11 (HISTOGRAM)$') +C +C Use the XLIB routine FILL to fill the area defined by the data. Note +C that FILL is not a part of the AUTOGRAPH package. +C +c CALL FILLOP ('AN',45) +c CALL FILLOP ('SP',128) +c CALL FILL (XDRA,YDRA,102,WORK,204,IWRK,204) +C +C Advance the frame. +C +c CALL FRAME +C +c STOP +C + END +c + SUBROUTINE EXMPLF +C +C Define the data array. +C + DIMENSION XYCD(226) +C +C Fill the data array. +C +c READ 1001 , XYCD +C + DO 101 I=1,226 + IF (XYCD(I).EQ.1.E36) GO TO 101 + XYCD(I)=2.**((XYCD(I)-15.)/2.5) + 101 CONTINUE +C +C Specify log/log plot. +C + CALL DISPLA (0,0,4) +C +C Bump the line-maximum parameter past 42. +C + CALL AGSETI ('LINE/MAXIMUM.',50) +C +C Specify x- and y-axis labels, grid background. +C + CALL ANOTAT ('LOGARITHMIC, BASE 2, EXPONENTIAL LABELING$', + + 'LOGARITHMIC, BASE 2, NO-EXPONENT LABELING$',2,0,0,0) +C +C Specify the graph label. +C + CALL AGSETC ('LABEL/NAME.','T') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','FINAL EXAMPLE$') +C +C Specify x-axis ticks and labels. +C + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',3) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',2.) + CALL AGSETI ('BOTTOM/NUMERIC/TYPE.',2) + CALL AGSETI ('BOTTOM/MINOR/SPACING.',4) +c CALL AGSETI ('BOTTOM/MINOR/PATTERN.',125252B) +C +C Specify y-axis ticks and labels. +C + CALL AGSETI ('LEFT/MAJOR/TYPE.',3) + CALL AGSETF ('LEFT/MAJOR/BASE.',2.) + CALL AGSETI ('LEFT/NUMERIC/TYPE.',3) + CALL AGSETI ('LEFT/MINOR/SPACING.',4) +c CALL AGSETI ('LEFT/MINOR/PATTERN.',125252B) +C +C Compute secondary control parameters. +C + CALL AGSTUP (XYCD(1),1,0,113,2,XYCD(2),1,0,113,2) +C +C Draw the background. +C + CALL AGBACK +C +C Draw the curve twice to make it darker. +C + CALL AGCURV (XYCD(1),2,XYCD(2),2,113,1) + CALL AGCURV (XYCD(1),2,XYCD(2),2,113,1) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Advance the frame. +C +c CALL FRAME +C +c STOP +C +C Format. +C +c1001 FORMAT (14E5.0) +C + END +C 1.8 2.1 2.7 1.6 4.2 1.5 5.7 1.9 6.3 2.9 6.5 4.7 6.0 6.7 +C 5.6 8.6 5.4 10.7 5.6 13.1 4.8 11.2 3.7 9.7 1E36 1E36 7.0 8.2 +C 7.7 10.6 8.2 12.6 8.2 14.3 8.0 15.3 7.7 15.6 7.5 15.1 7.4 14.0 +C 7.6 12.3 7.7 10.7 7.9 8.9 8.2 7.3 8.5 4.6 8.5 7.3 8.6 9.3 +C 8.8 10.2 9.1 10.5 9.4 10.1 9.6 9.1 9.9 7.8 10.3 6.9 11.1 7.0 +C 11.7 7.8 12.0 8.6 12.3 10.0 12.5 11.5 12.4 12.7 12.2 13.0 11.9 12.6 +C 11.7 11.7 11.6 10.5 11.7 9.3 12.0 8.6 12.5 8.6 13.0 9.0 13.8 10.1 +C 14.3 11.1 1E36 1E36 18.5 23.4 18.2 23.5 17.8 23.2 17.2 22.6 16.8 21.8 +C 16.0 20.2 15.8 19.5 16.0 19.3 16.6 19.6 17.8 20.6 17.3 19.1 16.9 17.3 +C 16.6 16.0 16.6 14.5 16.8 13.7 17.1 13.1 17.8 13.2 18.4 14.0 19.2 15.5 +C 19.8 16.8 20.3 18.0 20.9 20.1 21.1 18.9 21.1 17.4 21.1 18.9 21.2 19.7 +C 1.5 20.5 21.8 20.8 22.0 20.4 22.1 19.6 22.3 18.7 22.6 18.4 23.1 18.9 +C 23.6 20.0 24.1 21.7 24.7 22.9 25.3 23.9 24.7 22.9 24.4 21.6 24.4 20.6 +C 24.7 20.2 25.2 20.7 25.6 21.5 26.0 22.9 26.4 24.5 26.7 25.9 26.8 27.9 +C 26.6 30.0 26.4 30.3 26.2 30.0 25.7 28.0 25.5 26.1 25.3 24.9 25.3 23.9 +C 25.4 22.9 25.9 22.5 26.6 22.4 27.4 23.1 28.2 24.0 29.0 25.0 30.1 26.4 +C 1E36 1E36 diff --git a/sys/gio/ncarutil/tests/preal.x b/sys/gio/ncarutil/tests/preal.x new file mode 100644 index 00000000..79d33218 --- /dev/null +++ b/sys/gio/ncarutil/tests/preal.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +procedure preal (tval, rval) + +char tval[ARB] +real rval + +begin + call eprintf ("%s %.4f\n") + call pargstr (tval) + call pargr (rval) +end diff --git a/sys/gio/ncarutil/tests/pwrity.x b/sys/gio/ncarutil/tests/pwrity.x new file mode 100644 index 00000000..3b5c1437 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrity.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routines PWRITY + +procedure t_pwrity() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tpwry (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/pwrityt.f b/sys/gio/ncarutil/tests/pwrityt.f new file mode 100644 index 00000000..5b033933 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrityt.f @@ -0,0 +1,90 @@ + SUBROUTINE TPWRY (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ENTRY PWRITY OF PWRITY AND +C TO TEST PWRITY ON A SIMPLE PROBLEM +C +C USAGE CALL TPWRY (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRITY TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS WRITTEN TO UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING +C CHARACTER STRING PLOTS IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. IN ORDER TO +C DETERMINE WHETHER THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRITY +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TPWRY CALLS PWRITY TO PLOT VARIOUS CHARACTER +C STRINGS USING DIFFERENT PARAMETERS. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C INITIALIZE THE ERROR PARAMETER. +C + IERROR = 0 +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL GSVP (1, 0.0, 1.0, 0.0, 1.0) + CALL GSWN (1, 1.0, 1024.0, 1.0, 1024.0) + CALL GSELNT (1) + CALL SETUSV ('LS',1) +C +C LABEL FRAME +C + CALL PWRITY(512.0,950.0, + 1 'DEMONSTRATION PLOT FOR PWRITY', + 2 29,2,0,0) +C +C TEST PWRITY FOR DIFFERENT SIZE CHARACTERS. +C + CALL PWRITY (10.0,900.0,'SIZE TEST',9,0,0,-1) + CALL PWRITY (10.0,850.0,'SIZE TEST',9,1,0,-1) + CALL PWRITY (10.0,775.0,'SIZE TEST',9,2,0,-1) + CALL PWRITY (10.0,675.0,'SIZE TEST',9,3,0,-1) + CALL PWRITY (10.0,525.0,'SIZE TEST',9,4,0,-1) + CALL PWRITY (10.0,375.0,'SIZE TEST',9,5,0,-1) +C +C TEST PWRITY FOR DIFFERENT CHARACTER ORIENTATIONS. +C + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,0*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,1*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,2*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,3*90,-1) +C +C TEST CENTERING OPTIONS FOR PWRITY. +C + CALL PWRITY (512.0,160.0,'CENTR TEST',10,2,0,0) + CALL PWRITY (512.0,85.0,'CENTR TEST',10,2,0,-1) + CALL PWRITY (512.0,235.0,'CENTR TEST',10,2,0,1) +c +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c 1001 FORMAT (' PWRITY TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrzit.f b/sys/gio/ncarutil/tests/pwrzit.f new file mode 100644 index 00000000..7c96e926 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzit.f @@ -0,0 +1,132 @@ + SUBROUTINE TPWRZI (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZI IN CONJUNCTION WITH ISOSRF +C +C USAGE CALL TPWRZI (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRZI TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING THE SAMPLE +C PLOT IS PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZI, ISOSRF +C FILES +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM A FUNCTION OF THREE VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A THREE DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE THEN CALLS ISOSRF TO DRAW AN +C ISO-VALUED SURFACE PLOT OF THE FUNCTION, +C THEN PWRZI IS CALLED THREE TIMES TO +C LABEL THE FRONT, SIDE, AND BACK OF THE +C PICTURE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C + DIMENSION T(21,31,19),SLAB(33,33),EYE(3) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4375/, TY/0.9667/ +C + DATA NU,NV,NW/21,31,19/ + DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./ + DATA TISO/0./ + DATA MUVWP2/33/ + DATA IFLAG/-7/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 30 I=1,NU + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + T(I,J,K) = AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1- + 1 RSML1*RSML1, + 2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C DEFINE EYE POSITION +C + EYE(1) = 100. + EYE(2) = 150. + EYE(3) = 125. +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C +C LABEL THE PLOT +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR PWRZI',2,0,0) +C +C TEST ISOSRF WITH SUBARRAY OF T +C + MU = NU/2 + MV = NV/2 + MW = NW/2 + MUVWP2 = MAX0(MU,MV,MW)+2 + CALL ISOSRF (T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO, + 1 IFLAG) + ISIZE = 35 + CALL PWRZI (5.,16.,.5,'FRONT',5,ISIZE,-1,3,0) + CALL PWRZI (11.,7.5,.5,'SIDE',4,ISIZE,2,-1,0) + CALL PWRZI (5.,1.,5.,' BACK BACK BACK BACK BACK',25,ISIZE,-1,3,0) + CALL SETUSV ('XF',10) + CALL SETUSV ('YF',10) + CALL NEWFM + IERROR = 0 +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' PWRZI TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrzs.x b/sys/gio/ncarutil/tests/pwrzs.x new file mode 100644 index 00000000..f2eeec96 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzs.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routines PWRZS + +procedure t_przs() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tpwrzs (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/pwrzst.f b/sys/gio/ncarutil/tests/pwrzst.f new file mode 100644 index 00000000..4067ed86 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzst.f @@ -0,0 +1,127 @@ + SUBROUTINE TPWRZS (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZS IN CONJUNCTION WITH SRFACE. +C +C USAGE CALL TPWRZS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST WAS SUCCESSFUL, THE MESSAGE +C +C PWRZS TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING THE SAMPLE +C PLOT IS PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZS, SRFACE +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM A FUNCTION OF TWO VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A TWO DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE CALLS SRFACE TO DRAW A SURFACE +C REPRESENTATION OF THE ARRAY VALUES, AND THEN +C PWRZS IS CALLED THREE TIMES TO LABEL THE +C FRONT, SIDE, AND BACK OF THE PICTURE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C + DIMENSION Z(20,30) ,X(20) ,Y(30) ,MM(20,30,2), + 1 S(6) +C +C LOAD THE SRFACE COMMON BLOCK, NEEDED TO SURPRESS NEWFM CALL +C + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT , + 2 NCLA ,THETA ,HSKIRT ,CHI , + 3 CLO ,CINC ,ISPVAL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND +C TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4375/, TY/0.9667/ +C +C SPECIFY GRID LOOP INDICES, AND LINE OF SIGHT +C + DATA M/20/, N/30/ + DATA S/4.,5.,3.,0.,0.,0./ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C DEFINE FUNCTION VALUES AND STORE IN Z +C + DO 10 I=1,M + X(I) = -1.+FLOAT(I-1)/FLOAT(M-1)*2. + 10 CONTINUE + DO 20 J=1,N + Y(J) = -1.+FLOAT(J-1)/FLOAT(N-1)*2. + 20 CONTINUE + DO 40 J=1,N + DO 30 I=1,M + Z(I,J) = EXP(-2.*SQRT(X(I)**2+Y(J)**2)) + 30 CONTINUE + 40 CONTINUE +C +C SET SRFACE PARAMETERS TO SURPRESS FRAME CALL AND DRAW CONTOURS + call srfabd +C + IFR = 0 + IDRZ = 1 +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C LABEL THE PLOT +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR PWRZS',2,0,0) +C +C DRAW SURFACE PLOT +C + CALL SRFACE (X,Y,Z,MM,M,M,N,S,0.) +C +C PUT PWRZS LABELS ON PICTURE +C + ISIZE = 35 + CALL PWRZS (0.,1.1,0.,'FRONT',5,ISIZE,-1,3,0) + CALL PWRZS (1.1,0.,0.,'SIDE',4,ISIZE,2,-1,0) + CALL PWRZS (0.,-1.1,.2,' BACK BACK BACK BACK BACK',25,ISIZE,-1, + 1 3,0) +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C +C RESTORE SRFACE PARAMETERS TO DEFAULT +C + IFR = 1 + IDRZ = 0 +C + RETURN +C +C +c1001 FORMAT (' PWRZS TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrztt.f b/sys/gio/ncarutil/tests/pwrztt.f new file mode 100644 index 00000000..dcf43638 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrztt.f @@ -0,0 +1,116 @@ + SUBROUTINE TPWRZT (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZT IN CONJUNCTION WITH THREED. +C +C USAGE CALL TPWRZT (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRZT TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C CHARACTER PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZT, THREED +C FILES +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM TPWRZT CALLS SUBROUTINES SET3 AND LINE3 FROM +C THE ULIB THREED PACKAGE TO ESTABLISH THE +C THREE SPACE-TO-TWO SPACE TRANSFORMATION +C AND TO DRAW AXIS LINES. TPWRZT NEXT CALLS +C SUBROUTINE PWRZT FROM THE ULIB THREED +C PACKAGE TO LABEL THE AXES FOR A THREE SPACE +C PLOT. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C EYE CONTAINS THE (U,V,Z) COORDINATE OF THE EYE POSITION +C + REAL EYE(3) + DATA EYE(1), EYE(2), EYE(3) /3.5, 3.0, 5.0/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C SUBROUTINE SET3 ESTABLISHES THE MAPPING OF THREE SPACE COORDINATES +C ONTO THE GRAPHICS DEVICE COORDINATE SYSTEM. +C + CALL SET3 (.1,.9,.1,.9,0.,1.,0.,1.,0.,1.,EYE) +C +C THE FOLLOWING THREE CALLS TO LINE3 DRAW THE THREE SPACE AXES +C + CALL LINE3 (0.,0.,0.,0.,0.,1.) + CALL LINE3 (0.,0.,0.,0.,1.,0.) + CALL LINE3 (0.,0.,0.,1.,0.,0.) +C +C SUBROUTINE PWRZ IS USED TO LABEL EACH OF THE AXES AND THE PLOT +C ON INPUT TO PWRZ, +C THE FIRST THREE PARAMETERS AND ICNT DETERMINE THE POSITION OF THE +C CHARACTER STRING. +C ISIZE DETERMINES THE CHARACTER SIZE. +C LINE AND ITOP DETERMINE THE DIRECTION AND PLANE OF THE CHARACTERS. +C +C + ICNT = 0 + ISIZE = 30 + LINE = 2 + ITOP = 3 + CALL PWRZT (0.,.5,.1,'V-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = -1 + ITOP = 3 + CALL PWRZT (.5,0.,.1,'U-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = 3 + ITOP = -2 + CALL PWRZT (0.,.1,.5,'Z-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = 2 + ITOP = -1 + ISIZE = 30 + ICNT = -1 + CALL PWRZT (.5,.2,0.,'DEMONSTRATION OF PWRZT WITH THREED', + 1 34,ISIZE,LINE,ITOP,ICNT) +C +C A CALL TO NEWFM INDICATES THAT THE PICTURE IS COMPLETE +C + CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +C +C +c1001 FORMAT (' PWRZT TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/srf.com b/sys/gio/ncarutil/tests/srf.com new file mode 100644 index 00000000..d1b4288c --- /dev/null +++ b/sys/gio/ncarutil/tests/srf.com @@ -0,0 +1,4 @@ +int ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, ncla, hskirt, ispval +real theta, chi, clo, cinc +common /srfip1/ ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, + ncla, theta, hskirt, chi, clo, cinc, ispval diff --git a/sys/gio/ncarutil/tests/srfacet.f b/sys/gio/ncarutil/tests/srfacet.f new file mode 100644 index 00000000..4e5bad00 --- /dev/null +++ b/sys/gio/ncarutil/tests/srfacet.f @@ -0,0 +1,150 @@ + SUBROUTINE TSRFAC (nplot, IERROR) +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C SRFACE AND TO TEST SRFACE ON A SINGLE +C PROBLEM +C +C USAGE CALL TSRFAC (IERROR) +C +C ARGUMENTS +c +noao: additional input parameter +c nplot +c = 1, EZSRF is demonstrated +c = 2, SRFACE is demonstrated +c +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C SRFACE TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, TWO FRAMES CONTAINING THE +C SURFACE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE +C IF THE TEST WAS SUCCESSFUL, IT IS +C NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY SRFACE +C FILES +C +C LANGUAGE FORTRAN +C +C HISTORY FIRST WRITTEN IN APRIL 1979, CONVERTED TO +C FORTRAN 77 AND GKS IN MARCH 1984. +C +C ALGORITHM THE FUNCTION +C +C Z(X,Y) = .25*(X + Y + 1./((X-.1)**2+Y**2+.09) +C - 1./((X+.1)**2+Y**2+.09)) +C +C IS EVALUATED FOR +C X = -1. TO 1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO 1.2 IN INCREMENTS OF .1. +C TSRFAC CALLS SUBROUTINES EZSRFC AND SRFACE +C ONCE. EACH CALL PRODUCES A SURFACE PLOT +C OF THE ARRAY Z. +C +C PORTABILITY ANSI FORTRAN 77 +C +C XX CONTAINS THE X-DIRECTION COORDINATE VALUES FOR Z(X,Y), YY CONTAINS +C THE Y-DIRECTION COORDINATE VALUES FOR Z(X,Y), Z CONTAINS THE FUNCTION +C VALUES, S CONTAINS VALUES FOR THE LINE OF SIGHT FOR ENTRY SRFACE, +C WORK IS A WORK ARRAY, ANGH CONTAINS THE ANGLE IN DEGREES IN THE X-Y +C PLANE TO THE LINE OF SIGHT, ANGV CONTAINS THE ANGLE IN DEGREES FROM +C THE X-Y PLANE TO THE LINE OF SIGHT. +C + REAL XX(21) ,YY(25) ,Z(21,25) ,S(6) , + 1 WORK(1096) +C + DATA S(1), S(2), S(3), S(4), S(5), S(6)/ + 1 -8.0, -6.0, 3.0, 0.0, 0.0, 0.0/ +C + DATA ANGH/45./, ANGV/15./ +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0. TO 1., THE VALUES CX AND CY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA CX/.405/, CY/.97/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL XX AND YY COORDINATE ARRAYS AND Z FUNCTION VALUE ARRAY +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + XX(I) = X + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + YY(J) = Y + Z(I,J) = (X+Y+1./((X-.1)**2+Y**2+.09)- + 1 1./((X+.1)**2+Y**2+.09))*.25 + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C EZSRFC DEMO +C +C LABEL THE PLOT FOR ENTRY EZSRFC +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE STRING CENTER +C AND IN THE VERTICAL CENTER +C + CALL GSTXAL(2,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.016) +C +C PLOT CHARACTERS +C + if (nplot .eq. 1) then + CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR EZSRFC ENTRY OF SRFACE') + CALL EZSRFC (Z,21,25,ANGH,ANGV,WORK) + endif +C +C +C SRFACE DEMO +C +C LABEL THE PLOT FOR ENTRY SRFACE +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE STRING CENTER +C AND IN THE VERTICAL CENTER +C + CALL GSTXAL(2,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.016) +C +C PLOT CHARACTERS +C + if (nplot .eq. 2) then + CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR SRFACE ENTRY OF SRFACE') + CALL SRFACE (XX,YY,Z,WORK,21,21,25,S,0.) + endif +C +c WRITE (6,1001) +C + RETURN +C +C1001 FORMAT (' SRFACE TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/srftest.x b/sys/gio/ncarutil/tests/srftest.x new file mode 100644 index 00000000..cf1496b7 --- /dev/null +++ b/sys/gio/ncarutil/tests/srftest.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +procedure srf_test() + +char temp[SZ_LINE] +real z[20,30], x[20], y[30], s[6] +int mm[20,30,2] +real tx, ty +int i, j, m, n, isize +real xt, yt, dum + +int ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, ncla, hskirt, ispval +real theta, chi, clo, cinc +common /srfip1/ ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, + ncla, theta, hskirt, chi, clo, cinc, ispval + +begin + # Some initialization that was originally in data statements: + tx = 0.4375 + ty = 0.9667 + m = 20 + n = 30 + s[1] = 4.0 + s[2] = 5.0 + s[3] = 3.0 + s[4] = 0.0 + s[5] = 0.0 + s[6] = 0.0 + + # Define function values and store in z + DO I=1,M + X(I) = -1.+FLOAT(I-1)/FLOAT(M-1)*2. + + DO J=1,N + Y(J) = -1.+FLOAT(J-1)/FLOAT(N-1)*2. + + DO J=1,N { + DO I=1,M + Z(I,J) = EXP(-2.*SQRT(X(I)**2+Y(J)**2)) + } + + # Initialize block data before changing parameters. + call srfabd + + IFR = 0 + IDRZ = 1 + + CALL GSELNT (0) + call f77pak ("DEMONSTRATION PLOT FOR PWRZS", temp, SZ_LINE) + CALL WTSTR (TX,TY,temp,2,0,0) + + CALL SRFACE (X,Y,Z,MM,M,M,N,S,0.) +# +# PUT PWRZS LABELS ON PICTURE +# + ISIZE = 35 + call f77pak ("FRONT", temp, SZ_LINE) + CALL PWRZS (0.,1.1,0.,temp,5,ISIZE,-1,3,0) + call f77pak ("SIDE", temp, SZ_LINE) + CALL PWRZS (1.1,0.,0.,temp,4,ISIZE,2,-1,0) + call f77pak (" BACK BACK BACK BACK BACK", temp, SZ_LINE) + CALL PWRZS (0.,-1.1,.2,temp,25,ISIZE,-1,3,0) +# +# RESTORE SRFACE PARAMETERS TO DEFAULT +# + IFR = 1 + IDRZ = 0 +end diff --git a/sys/gio/ncarutil/tests/srftestd.x b/sys/gio/ncarutil/tests/srftestd.x new file mode 100644 index 00000000..8c22ff92 --- /dev/null +++ b/sys/gio/ncarutil/tests/srftestd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task srftest = t_srftest + +define DUMMY 6 + +# Rewrite of pwrzs.t.f in spp to check things out. + +procedure t_srftest() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call srf_test() + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/strmln.x b/sys/gio/ncarutil/tests/strmln.x new file mode 100644 index 00000000..2835d211 --- /dev/null +++ b/sys/gio/ncarutil/tests/strmln.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine STRMLN + +procedure t_strmln() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tstrml (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/strmlnt.f b/sys/gio/ncarutil/tests/strmlnt.f new file mode 100644 index 00000000..f2b40c69 --- /dev/null +++ b/sys/gio/ncarutil/tests/strmlnt.f @@ -0,0 +1,101 @@ + SUBROUTINE TSTRML (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ROUTINE STRMLN. +C +C USAGE CALL TSTRML (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINE STRMLN. +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINE +C STRMLN THE MESSAGE +C STRMLN TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM ROUTINE TSTRML CALLS ROUTINE STRMLN TO +C PRODUCE A PLOT REPRESENTING THE FLOW AND +C MAGNITUDE OF A VECTOR FIELD. +C +C PORTABILITY FORTRAN77 +C +C +C + REAL U(21,25) ,V(21,25) ,WRK(1050) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/.5/,TY/.9765/ +C +C SET DIMENSIONS +C + DATA NH,NV/21,25/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SPECIFY HORIZONTAL AND VERTICAL VECTOR COMPONENTS U AND V ON +C THE RECTANGULAR GRID +C + TPIMX = 2.*3.14/FLOAT(NH) + TPJMX = 2.*3.14/FLOAT(NV) + DO 20 J=1,NV + DO 10 I=1,NH + U(I,J) = SIN(TPIMX*(FLOAT(I)-1.)) + V(I,J) = SIN(TPJMX*(FLOAT(J)-1.)) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C CALL WTSTR FOR STRMLN PLOT TITLE +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR ROUTINE STRMLN',2, + 1 0,0) +C +C DEFINE NORMALIZATION TRANSFORMATION 1, AND SET UP LOG SCALING +C + CALL GSVP ( 1, 0.1, 0.9, 0.1, 0.9 ) + CALL GSWN ( 1, 1.0, 21., 1.0, 25. ) + CALL SETUSV ( 'LS' , 1 ) +C +C SELECT NORMALIZATION TRANSFORMATION 1 +C + CALL GSELNT (1) +C +C DRAW PERIMETER +C +c CALL PERIM(1,0,1,0) +C +C CALL STRMLN FOR VECTOR FIELD STREAMLINES PLOT +C + CALL STRMLN (U,V,WRK,NH,NH,NV,0,IER) +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' STRMLN TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/surface.x b/sys/gio/ncarutil/tests/surface.x new file mode 100644 index 00000000..07b25e9a --- /dev/null +++ b/sys/gio/ncarutil/tests/surface.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routines SRFACE. + +procedure t_surface() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsrfac (2, error_code) + if (error_code == 0) + call printf ("Test of SRFACE successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed.x b/sys/gio/ncarutil/tests/threed.x new file mode 100644 index 00000000..a22d51da --- /dev/null +++ b/sys/gio/ncarutil/tests/threed.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine THREED + +procedure t_threed() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tthree (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed2.x b/sys/gio/ncarutil/tests/threed2.x new file mode 100644 index 00000000..224fd2c3 --- /dev/null +++ b/sys/gio/ncarutil/tests/threed2.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine THREED with extra test program tst3d2 + +procedure t_threed2() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tst3d2 () + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed2t.f b/sys/gio/ncarutil/tests/threed2t.f new file mode 100644 index 00000000..baaa8f78 --- /dev/null +++ b/sys/gio/ncarutil/tests/threed2t.f @@ -0,0 +1,26 @@ + subroutine tst3d2 () + real eye(3) + dimension u(50), v(50), w(50) + data eye /5., -10., 4./ + isiz = 36 + xs = 90. / 1024. + xe = 1010. / 1024. + ys = 90. / 1024. + ye = 1010. / 1024. + call tick43 (24, 16, 24, 16, 24, 16) +c call set3 (90, 1010, 90, 1010, 0., 2., -1., 1., 0., 1., eye) + call set3 (xs, xe, ys, ye, 0., 2., -1., 1., 0., 1., eye) + do 1 i = 1, 50 + u(i) = float(i) * .04 + v(i) = sin (u(i) * 6.) * float (80 - i) / 80. + w(i) = .5 + sin (u(i) *3.141592) * .5 + 1 continue + call perim3 (2,5,1,5,1,0.) + call perim3 (2,5,1,5,2,-1.) + call perim3 (2,5,2,5,3,0.) + call pwrzt (2.1, -1., 0., 3hU->, 3, isiz, 1,3,-1) + call pwrzt (0., 1.1, 0., 3hV->, 3, isiz, 2,3,0) + call pwrzt (0., -1., 1.1, 2hW , 2, isiz, 3, -1, 0) + call fence3 (u, v, w, 50, 3, 0.) + end + diff --git a/sys/gio/ncarutil/tests/threedt.f b/sys/gio/ncarutil/tests/threedt.f new file mode 100644 index 00000000..0cb6532d --- /dev/null +++ b/sys/gio/ncarutil/tests/threedt.f @@ -0,0 +1,129 @@ + SUBROUTINE TTHREE (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ROUTINE THREED. +C +C USAGE CALL TTHREE (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINE THREED. +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINE +C THREED THE MESSAGE +C THREED TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN NOVEMBER 1976 +C CONVERTED TO GKS AND FORTRAN 77 JULY 1984 +C +C ALGORITHM ROUTINE TTHREE CALLS SET3 TO ESTABLISH A +C MAPPING BETWEEN THE PLOTTER ADDRESSES AND +C THE USER'S VOLUME, AND TO INDICATE THE +C COORDINATES OF THE EYE POSITION FROM +C WHICH THE LINES TO BE DRAWN ARE VIEWED. +C NEXT, THE VOLUME PERIMETERS AND ASSOCIATED +C TICK MARKS ARE DRAWN BY CALLS TO PERIM3. +C THEN THE LINES ARE DRAWN. THESE ARE +C CERTAIN LATITUDES AND LONGITUDES OF A +C SPHERE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C +C + REAL EYE(3),X(31),Y(31),Z(31) +C +C SPECIFY ARGUMENT VALUES TO BE USED BY ROUTINE SET3. ON AN +C ABSTRACT PLOTTER WITH AN ADDRESS RANGE OF 0. TO 1. IN EACH +C COORDINATE DIRECTION, THE VALUES RXA, RXB, RYA, AND RYB +C DEFINE THE PORTION OF THE ADDRESS SPACE TO BE USED IN MAKING +C THE PLOT. UC, UD, VC, VD, WC, WD DEFINE A VOLUME IN USER +C COORDINATES WHICH IS TO BE MAPPED ONTO THE PORTION OF THE +C VIEWING SURFACE AS SPECIFIED BY RXA, RXB, RYA, AND RYB. +C + DATA RXA/0.097656/, RXB/0.90236/, RYA/0.097656/, RYB/0.90236/ + DATA UC/-1./, UD/1./, VC/-1./, VD/1./, WC/-1./, WD/1./ + DATA EYE(1),EYE(2),EYE(3)/10.,6.,3./ + DATA TX/0.4374/, TY/0.9570/ +C +C DEFINE PI + DATA PI/3.1415926535898/ +C +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C CALL SET3 TO ESTABLISH A MAPPING BETWEEN THE PLOTTER ADDRESSES +C AND THE USER'S VOLUME, AND TO INDICATE THE COORDINATES OF THE +C EYE POSITION FROM WHICH THE LINES TO BE DRAWN ARE VIEWED. +C + CALL SET3(RXA,RXB,RYA,RYB,UC,UD,VC,VD,WC,WD,EYE) +C +C CALL PERIM3 TO DRAW PERIMETER LINES AND TICK MARKS +C + CALL PERIM3(2,5,1,10,1,-1.) + CALL PERIM3(4,2,1,1,2,-1.) + CALL PERIM3(2,10,4,5,3,-1.) +C +C DEFINE AND DRAW LATITUDINAL LINES ON THE SPHERE OF RADIUS ONE +C HAVING CENTER (0.,0.,0.) +C + DO 10 J=1,18 + THETA = FLOAT(J)*PI/9. + CT = COS(THETA) + ST = SIN(THETA) + DO 20 K=1,31 + PHI = FLOAT(K-16)*PI/30. + Z(K) = SIN(PHI) + CP = COS(PHI) + X(K) = CT*CP + Y(K) = ST*CP + 20 CONTINUE + CALL CURVE3(X,Y,Z,31) + 10 CONTINUE +C +C DEFINE AND DRAW LONGITUDINAL LINES ON THE SPHERE OF RADIUS ONE +C HAVING CENTER (0.,0.,0.) +C + DO 30 K=1,5 + PHI = FLOAT(K-3)*PI/6. + SP = SIN(PHI) + CP = COS(PHI) + DO 40 J=1,31 + TUETA = FLOAT(J-1)*PI/15. + X(J) = COS(TUETA)*CP + Y(J) = SIN(TUETA)*CP + Z(J) = SP + 40 CONTINUE + CALL CURVE3(X,Y,Z,31) + 30 CONTINUE +C +C CALL WTSTR FOR THREED PLOT TITLE +C + CALL WTSTR(TX,TY,'DEMONSTRATION PLOT FOR ROUTINE THREED',2,0,0) + call pwrzt (1.,0.,-1.,'DEMONSTRATION PLOT FOR ROUTINE THREED', 37, + * 2, 2, 3, 0) +C +c CALL NEWFM +C + IERROR = 0 +c WRITE(6,1001) + RETURN +C +c1001 FORMAT(' THREED TEST SUCCESSFUL', 24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') + END diff --git a/sys/gio/ncarutil/tests/velvctt.f b/sys/gio/ncarutil/tests/velvctt.f new file mode 100644 index 00000000..36e22d28 --- /dev/null +++ b/sys/gio/ncarutil/tests/velvctt.f @@ -0,0 +1,126 @@ + SUBROUTINE TVELVC (nplot, IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C SUBROUTINES VELVCT AND EZVEC. +C +C USAGE CALL TVELVC (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINES VELVCT AND EZVEC +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINES +C VELVCT AND EZVEC THE MESSAGE +C VELVCT TEST SUCCESSFUL . . . SEE PLOTS TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN NOVEMBER 1976 +C +C ALGORITHM ROUTINE TVELVC CALLS ROUTINES EZVEC AND +C VELVCT ONCE. EACH CALL PRODUCES A PLOT +C REPRESENTING A VECTOR FIELD. THE VECTOR +C FIELD IS OBTAINED FROM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09), +C BY USING THE DIRECTION OF THE Z GRADIENT +C VECTORS AND THE LOGARITHM OF THE ABSOLUTE +C VALUE OF THE COMPONENTS. +C +C +C +C + DIMENSION U(21,25) ,V(21,25) +C +C SPECIFY COORDS FOR PLOT TITLES +C + DATA IX/94/,IY/1000/ +C +C SPECIFY SOME OF THE ARGUMENTS IN VELVCT CALLING SEQUENCE +C + DATA FLO/0./,HI/0./,NSET/0/,LENGTH/0/,ISPV/0/,SPV/0./ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SPECIFY VELOCITY FIELD FUNCTIONS U AND V +C + M = 21 + N = 25 + DO 20 I=1,M + X = .1*FLOAT(I-11) + DO 10 J=1,N + Y = .1*FLOAT(J-13) + DZDX = 1.-2.*(X-.10)/((X-.10)**2+Y**2+.09)**2+ + 1 2.*(X+.10)/((X+.10)**2+Y**2+.09)**2 + DZDY = 1.-2.*Y/((X-.10)**2+Y**2+.09)**2+ + 1 2.*Y/((X+.10)**2+Y**2+.09)**2 + UVMAG = ALOG(SQRT(DZDX*DZDX+DZDY*DZDY)) + UVDIR = ATAN2(DZDY,DZDX) + U(I,J) = UVMAG*COS(UVDIR) + V(I,J) = UVMAG*SIN(UVDIR) + 10 CONTINUE + 20 CONTINUE +C +C CALL WTSTR FOR EZVEC PLOT TITLE +C +c +noao: flag used to plot either velvct or ezvec + if (nplot .eq. 1) then + CALL GQCNTN(IERR,ICN) + CALL GSELNT(0) +c X = PAU2FX(IX) + x = cpux (ix) +c Y = PAU2FY(IY) + y = cpuy (iy) + CALL WTSTR (X,Y,'DEMONSTRATION PLOT FOR ENTRY EZVEC OF VELVCT', + 1 2,0,-1) + CALL GSELNT(ICN) +C +C CALL EZVEC FOR VELOCITY FIELD PLOT +C + CALL EZVEC (U,V,M,N) + endif +c -noao +C +C CALL VELVCT FOR VELOCITY FIELD PLOT +C +c +noao: flag used to plot either velvct or ezvec + if (nplot .eq. 2) then + CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C CALL WTSTR FOR VELVCT PLOT TITLE +C + CALL GQCNTN(IERR,ICN) + CALL GSELNT(0) +c X = PAU2FX(IX) + x = cpux (ix) +c Y = PAU2FY(IY) + y = cpuy (iy) + CALL WTSTR (X,Y, + 1 'DEMONSTRATION PLOT FOR ENTRY VELVCT OF VELVCT',2, + 2 0,-1) + CALL GSELNT(ICN) + endif +c -noao +c +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' VELVCT TEST SUCCESSFUL',24X, +c 1 'SEE PLOTS TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/velvect.x b/sys/gio/ncarutil/tests/velvect.x new file mode 100644 index 00000000..d09f1c08 --- /dev/null +++ b/sys/gio/ncarutil/tests/velvect.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routines VELVEC + +procedure t_velvect() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tvelvc (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/x_ncartest.x b/sys/gio/ncarutil/tests/x_ncartest.x new file mode 100644 index 00000000..cc8b727f --- /dev/null +++ b/sys/gio/ncarutil/tests/x_ncartest.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# These tasks temporarily deleted: conraq = t_conraq, conras = t_conras, + #ezmapg = t_ezmapg, + +task conran = t_conran, + autograph = t_autograph, + oldauto = t_oldauto, + dashsmth = t_dashsmth, + pwrzs = t_przs, + srface = t_surface, + ezsrface = t_ezsurface, + conrec = t_conrec, + ezconrec = t_ezconrec, + hafton = t_hafton, + isosrf = t_isosrf, + ezisosrf = t_ezisos, + ezhafton = t_ezhafton, + pwrity = t_pwrity, + threed = t_threed, + threed2 = t_threed2, + velvec = t_velvect, + ezvelvec = t_ezvelvect, + strmln = t_strmln diff --git a/sys/gio/ncarutil/threbd.f b/sys/gio/ncarutil/threbd.f new file mode 100644 index 00000000..5dbce5e0 --- /dev/null +++ b/sys/gio/ncarutil/threbd.f @@ -0,0 +1,56 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data threbd changed to run time initialization + subroutine threbd +c BLOCKDATA THREBD + COMMON /TEMPR/ RZERO + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN, + 1 YMAX ,BIGD ,R0 ,NLX, + 2 NBY ,NRX ,NTY + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV, + 1 TMAGW ,TMINW + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX +c +noao: following flag added to prevent over-initialization + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + +c DATA RZERO/0./ + RZERO = 0. +c +c DATA NLX,NBY,NRX,NTY/10,10,1010,1010/ + NLX = 10 + NBY = 10 + NRX = 1010 + NTY = 1010 +c +c DATA TMAGU,TMINU,TMAGV,TMINV,TMAGW,TMINW/12.,8.,12.,8.,12.,8./ + TMAGU = 12. + TMINU = 8. + TMAGV = 12. + TMINV = 8. + TMAGW = 12. + TMINW = 8. +c +c DATA ITHRMJ,ITHRMN,ITHRTX/ 1,1,1/ + ITHRMJ = 2 + ITHRMN = 1 + ITHRTX = 1 +c +c -noao + END diff --git a/sys/gio/ncarutil/threed.f b/sys/gio/ncarutil/threed.f new file mode 100644 index 00000000..3b5061f4 --- /dev/null +++ b/sys/gio/ncarutil/threed.f @@ -0,0 +1,826 @@ + SUBROUTINE SET3 (XA,XB,YA,YB,ULO,UHI,VLO,VHI,WLO,WHI,EYE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C THREE-DIMENSIONAL LINE DRAWING PACKAGE +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE THREED IS A PACKAGE OF SUBROUTINES THAT +C PROVIDES LINE DRAWING CAPABILITIES IN +C THREE-SPACE. +C +C USAGE EACH ENTRY POINT IN THIS PACKAGE IS +C DESCRIBED BELOW. +C +C SET3 (XA,XB,YA,YB,UC,UD,VC,VD,WC,WD,EYE) +C +C XA, XB, YA, YB DEFINE THE PORTION OF THE +C PLOTTING SURFACE INTO WHICH THE USER'S +C PLOT WILL BE PLACED. THESE VALUES SHOULD +C BE IN THE RANGE 0. TO 1. FOR EXAMPLE, IF +C ONE WANTS THE PLOT TO OCCUPY THE MAXIMUM +C PLOTTING SURFACE, SET XA=0., YA=0., XB=1., +C YB=1.; IF ONE WANTS THE PLOT TO APPEAR IN +C THE LOWER LEFT CORNER OF THE PLOTTING +C SURFACE, SET XA=0., YA=0., XB=.5, YB=.5 . +C +C UC, UD, VC, VD, WC, AND WD DEFINE A +C VOLUME IN USER-COORDINATE SPACE WHICH +C WILL BE TRANSFORMED ONTO THE PLOTTING +C SURFACE DEFINED BY XA, XB, YA, YB. +C +C EYE IS AN ARRAY, 3 WORDS LONG, CONTAINING THE +C U, V, AND W COORDINATES OF THE EYE POSITION. +C ALL LINES IN THE PLOT ARE DRAWN AS VIEWED +C FROM THE EYE. EYE IS SPECIFIED IN USER +C COORDINATES AND SHOULD BE OUTSIDE THE BOX +C DEFINED BY UC, UD, VC, VC, WC, AND WD. +C +C CURVE3 (U,V,W,N) +C +C DRAWS A CURVE THROUGH N POINTS. THE +C POINTS ARE DEFINED BY THE LINEAR ARRAYS +C U, V, AND W WHICH ARE DIMENSIONED N OR +C GREATER. +C +C LINE3 (UA,VA,WA,UB,VB,WB) +C +C DRAWS A LINE CONNECTING THE COORDINATES +C (UA,VA,WA) AND (UB,VB,WB). +C +C FRST3 (U,V,W) +C +C POSITIONS THE PEN TO (U,V,W). +C +C VECT3 (U,V,W) +C +C DRAWS A LINE BETWEEN THE CURRENT PEN +C POSITION AND THE POINT (U,V,W). THE +C CURRENT PEN POSITION BECOMES (U,V,W). +C NOTE THAT A CURVE CAN BE DRAWN BY USING +C A FRST3 CALL FOLLOWED BY A SEQUENCE OF +C VECT3 CALLS. +C +C POINT3 (U,V,W) +C +C PLOTS A POINT AT (U,V,W) . +C +C PERIM3 (MAGR1,MINR1,MAGR2,MINR2,IWHICH,VAR) +C +C DRAWS A PERIMETER WITH TICK MARKS. +C +C IWHICH DESIGNATES THE NORMAL VECTOR TO THE +C PERIMETER DRAWN (1=U, 2=V, 3=W). +C +C VAR IS THE VALUE ON THE AXIS SPECIFIED BY +C INWHICH WHERE THE PERIMETER IS TO BE DRAWN. +C +C MAGR1 AND MAGR2 SPECIFY THE +C NUMBER OF MAJOR TICK MARKS TO BE DRAWN IN +C THE TWO COORDINATE DIRECTIONS. +C +C MINR1 AND MINR2 SPECIFY THE NUMBER +C OF MINOR TICKS BETWEEN EACH MAJOR TICK. +C +C MAGR1, MAGR2, MINR1 AND MINR2 +C ARE SPECIFIED BY THE NUMBER +C OF DIVISIONS(HOLES), NOT THE NUMBER OF +C TICKS. SO IF MAGR1=1, THERE WOULD BE NO +C MAJOR DIVISIONS. +C +C TICK43 (MAGU,MINU,MAGV,MINV,MAGW,MINW) +C +C TICK43 ALLOWS PROGRAM CONTROL OF TICK +C MARK LENGTH IN SUBROUTINE PERIM3. +C MAGU, MAGV, MAGW SPECIFY THE LENGTH, +C IN PLOTTER ADDRESS UNITS OF MAJOR +C DIVISION TICK MARKS ON THE U, V, AND W +C AXES. MINU, MINV, MINW SPECIFY THE LENGTH, +C IN PLOTTER ADDRESS UNITS OF MINOR +C DIVISION TICK MARKS ON THE U, V, AND +C W AXES. +C +C FENCE3 (U,V,W,N,IOREN,BOT) +C +C THIS ENTRY IS USED TO DRAW A LINE IN THREE- +C SPACE AS WELL AS A "FENCE" BETWEEN THE +C LINE AND A PLANE NORMAL TO ONE OF THE +C COORDINATE AXES. +C +C THE ARGUMENTS U, V, W AND N +C ARE THE SAME AS FOR CURVE, DESCRIBED ABOVE. +C +C IOREN SPECIFIES THE DIRECTION IN WHICH THE +C FENCE LINES ARE TO BE DRAWN (1 INDICATES +C PARALLEL TO THE U-AXIS, 2 INDICATES PARALLEL +C TO THE V-AXIS, AND 3 INDICATES PARALLEL TO +C TO THE W-AXIS.) +C +C BOT SPECIFIES WHERE THE BOTTOM OF THE FENCE +C IS TO BE DRAWN. +C IF THE FENCE LINES ARE TO BE DRAWN PARALLEL +C TO THE W-AXIS, AND BOT=2., THEN THE BOTTOM +C OF THE FENCE WOULD BE THE PLANE W=2. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTES . FOR DRAWING CHARACTERS IN CONJUNCTION +C WITH THREED, USE THE COMPANION ROUTINE +C PWRZT. +C +C ENTRY POINTS FENCE3, TRN32T, FRST3, VECT3, LIN3, +C POINT3, CURVE3, PSYM3, PERIM3, LINE3W, +C DRAWT, TICK43, TICK3, THREBD +C +C COMMON BLOCKS TEMPR, SET31, PWRZ1T, TCK31, PRM31, THRINT +C +C REQUIRED LIBRARY PWRZ AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C I/O PLOTS LINES. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ACCURACY + OR -.5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C +C +C + SAVE +C + COMMON /TEMPR/ RZERO +C + DIMENSION EYE(3) +C + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 ,NLX , + 2 NBY ,NRX ,NTY + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW +C +C + AVE(A,B) = (A+B)*.5 +C +C ARITHMETIC STATEMENT FUNCTION FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C +NOAO - Blockdata threbd rewritten as run time initialization. +C +C EXTERNAL THREBD + call threbd +C -NOAO +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','SET3','VERSION 1') +C +C SET UP FRAME SIZE +C + NLX = XA*1023.+1. + NRX = XB*1023.+1. + NBY = YA*1023.+1. + NTY = YB*1023.+1. +C +C CONSTANTS FOR PWRZT +C + UUMIN = ULO + UUMAX = UHI + VVMIN = VLO + VVMAX = VHI + WWMIN = WLO + WWMAX = WHI + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) +C +C FIND CORNERS IN 2-SPACE FOR 3-SPACE BOX CONTAINING OBJECT +C + ISCALE = 0 + ATU = AVE(SU(UUMIN),SU(UUMAX)) + ATV = AVE(SV(VVMIN),SV(VVMAX)) + ATW = AVE(SW(WWMIN),SW(WWMAX)) + BIGD = 0. + IF (RZERO .LE. 0.) GO TO 10 +C +C RELATIVE SIZE FEATURE IN USE. THIS SECTION OF CODE IS NEVER +C EXECUTED UNLESS RZERO IS SET POSITIVE IN THE CALLING PROGRAM +C VIA COMMON BLOCK TEMPR. RZERO IS THE DISTANCE BETWEEN THE +C OBSERVER AND THE POINT LOOKED AT (CENTER OF THE BOX BY DEFAULT) +C WHEN THE INPUT BOX IS TO FILL THE SCREEN WHEN VIEWED FROM THE +C DIRECTION WHICH MAKES THE BOX BIGGEST. RZERO IS THUS TO +C BE USED TO DETERMINE THE SHAPE OF THE OBJECT. THIS SECTION +C OF CODE IS TO BE USED WHEN IT IS DESIRED TO KEEP THE VIEWED +C OBJECT IN RELATIVE PERSPECTIVE ACROSS FRAMES--E.G. IN MAKING +C MOVIES. +C + ALPHA = -(VVMIN-ATV)/(UUMIN-ATU) + VVEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + UUEYE = VVEYE*ALPHA + VVEYE = VVEYE+ATV + UUEYE = UUEYE+ATU + WWEYE = ATW + CALL TRN32T (ATU,ATV,ATW,UUEYE,VVEYE,WWEYE,1) + CALL TRN32T (UUMIN,VVMIN,ATW,XMIN,DUMM,DUMM,2) + CALL TRN32T (UUMAX,VVMIN,WWMIN,DUMM,YMIN,DUMM,2) + CALL TRN32T (UUMAX,VVMAX,ATW,XMAX,DUMM,DUMM,2) + CALL TRN32T (UUMAX,VVMIN,WWMAX,DUMM,YMAX,DUMM,2) + BIGD = SQRT((UUMAX-UUMIN)**2+(VVMAX-VVMIN)**2+(WWMAX-WWMIN)**2)*.5 + R0 = RZERO + GO TO 20 + 10 CALL TRN32T (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + CALL TRN32T (SU(UUMIN),SV(VVMIN),SW(WWMIN),X1,Y1,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMIN),SW(WWMAX),X2,Y2,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMAX),SW(WWMIN),X3,Y3,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMAX),SW(WWMAX),X4,Y4,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMIN),SW(WWMIN),X5,Y5,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMIN),SW(WWMAX),X6,Y6,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMAX),SW(WWMIN),X7,Y7,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMAX),SW(WWMAX),X8,Y8,DUM,2) + XMIN = AMIN1(X1,X2,X3,X4,X5,X6,X7,X8) + XMAX = AMAX1(X1,X2,X3,X4,X5,X6,X7,X8) + YMIN = AMIN1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) + YMAX = AMAX1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) +C +C ADD RIGHT AMOUNT TO KEEP PICTURE SQUARE +C + 20 WIDTH = XMAX-XMIN + HIGHT = YMAX-YMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 30, 50, 40 + 30 XMIN = XMIN+DIF + XMAX = XMAX-DIF + GO TO 50 + 40 YMIN = YMIN-DIF + YMAX = YMAX+DIF + 50 ISCALE = 1 + CALL TRN32T (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + RETURN + END + SUBROUTINE TRN32T (U,V,W,XT,YT,ZT,IENT) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C TRN32T ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C TRN32 ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. WHEN ISCALE=0, XT AND YT ANR IN THE SAME +C UNITS AS U,V, AND W. WHEN ISCALE'0, XT AND YT +C ARE IN PLOTTER COORDINATES. +C ZT NOT USED. +C +C + SAVE +C + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 ,NLX , + 2 NBY ,NRX ,NTY +C +C DECIDE IF SET OR TRANSLATE CALL +C + IF (IENT .NE. 1) GO TO 50 +C +C STORE THE PARAMETERS OF THE SET CALL +C FOR USE WITH THE TRANSLATION CALL +C + AU = U + AV = V + AW = W + EU = XT + EV = YT + EW = ZT +C +C +C +C +C + DU = AU-EU + DV = AV-EV + DW = AW-EW + D = SQRT(DU*DU+DV*DV+DW*DW) + COSAL = DU/D + COSBE = DV/D + COSGA = DW/D + AL = ACOS(COSAL) + BE = ACOS(COSBE) + GA = ACOS(COSGA) + SINGA = SIN(GA) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE W AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + ASSIGN 90 TO JDONE + IF (ISCALE) 10, 30, 10 + 10 X0 = XMIN + Y0 = YMIN + X1 = NLX + Y1 = NBY + X2 = NRX-NLX + Y2 = NTY-NBY + X3 = X2/(XMAX-XMIN) + Y3 = Y2/(YMAX-YMIN) + X4 = NRX + Y4 = NTY + FACT = 1. + IF (BIGD .LE. 0.) GO TO 20 + X0 = -BIGD + Y0 = -BIGD + X3 = X2/(2.*BIGD) + Y3 = Y2/(2.*BIGD) + FACT = R0/D + 20 DELCRT = X2 + ASSIGN 80 TO JDONE + 30 IF (SINGA .LT. 0.0001) GO TO 40 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 40 SINBE = SIN(BE) + R = 1./SINBE + ASSIGN 60 TO JUMP + RETURN +C +C******************** ENTRY TRN32 ************************ +C ENTRY TRN32 (U,V,W,XT,YT,ZT) +C + 50 UU = U + VV = V + WW = W + Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA) + GO TO JUMP,( 60, 70) + 60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R + VV = (EV+Q*(VV-EV)-AV)*R + GO TO JDONE,( 80, 90) + 70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R + VV = (EW+Q*(WW-EW)-AW)*R + GO TO JDONE,( 80, 90) + 80 XT = X1+X3*(FACT*UU-X0) + YT = Y1+Y3*(FACT*VV-Y0) + RETURN + 90 XT = UU + YT = VV + RETURN + END + SUBROUTINE FRST3 (U,V,W) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','FRST3','VERSION 1') + XDUM = 5. + CALL TRN32T (U,V,W,X,Y,XDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),0) + RETURN + END + SUBROUTINE VECT3 (U,V,W) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','VECT3','VERSION 1') + CALL TRN32T (U,V,W,X,Y,ZDUM,2) + IIX = 32*IFIX(X) + IIY = 32*IFIX(Y) + CALL PLOTIT (IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT (IIX,IIY,0) + RETURN + END + SUBROUTINE LINE3 (UA,VA,WA,UB,VB,WB) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','LINE3','VERSION 1') + CALL TRN32T (UA,VA,WA,XA,YA,XDUM,2) + CALL TRN32T (UB,VB,WB,XB,YB,XDUM,2) + IIX = 32*IFIX(XB) + IIY = 32*IFIX(YB) + CALL PLOTIT (32*IFIX(XA),32*IFIX(YA),0) + CALL PLOTIT (IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT (IIX,IIY,0) + RETURN + END + SUBROUTINE POINT3 (U,V,W) + SAVE + DIMENSION VWPRT(4),WNDW(4) +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','POINT3','VERSION 1') +C +C INQUIRE CURRENT NORMALIZATION TRANS NUMBER +C + CALL GQCNTN (IERR,NTORIG) +C +C SAVE NORMALIZATION TRANS 1 AND CURRENT LOG SCALING +C + CALL GQNT (1,IERR,WNDW,VWPRT) + CALL GETUSV ('LS',IOLLS) +C +C DEFINE NOMALIZATION TRANS TO BE USED WITH POLYMARKER +C + CALL SET(0.0, 1.0, 0.0, 1.0, 1.0, 1024.0, 1.0, 1024.0, 1) +C +C SET MARKER TYPE TO 1 +C + CALL GSMK (1) + CALL TRN32T (U,V,W,X,Y,ZDUM,2) + PX = X + PY = Y + CALL GPM (1,PX,PY) +C +C RESTORE ORIGINAL TRANS 1 AND SELECT TRANS NUMBER NTORIG +C RESTORE LOG SCALING +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL GSELNT (NTORIG) + RETURN + END + SUBROUTINE CURVE3 (U,V,W,N) + SAVE + DIMENSION U(N) ,V(N) ,W(N) +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','CURVE3','VERSION 1') + CALL TRN32T (U(1),V(1),W(1),X,Y,ZDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),0) + NN = N + IF (NN .LT. 2) RETURN + DO 10 I=2,NN + UU = U(I) + VV = V(I) + WW = W(I) + CALL TRN32T (UU,VV,WW,X,Y,ZDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),1) + 10 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE PSYM3 (U,V,W,ICHAR,SIZE,IDIR,ITOP,IUP) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','PSYM3','VERSION 1') + IF (IUP .EQ. 2) CALL VECT3 (U,V,W) + CALL PWRZ (U,V,W,ICHAR,1,SIZE,IDIR,ITOP,0) + RETURN + END + SUBROUTINE PERIM3 (MAGR1,MINI1,MAGR2,MINI2,IWHICH,VAR) + SAVE + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /PRM31/ Q ,L + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV , + 1 TMAGW ,TMINW +C +C THRINT COMMON BLOCK IS USED FOR SETTING COLOR INTENSITY +C + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX + DIMENSION LASF(13) +C + TICK(T) = AMAX1(UUMAX-UUMIN,VVMAX-VVMIN,WWMAX-WWMIN)*T/1024. +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','PERIM3','VERSION 1') +C +C INQUIRE LINE COLOR INDEX AND SET ASF TO INDIVIDUAL +C + CALL GQPLCI (IERR, IPLCI) + CALL GQASF (IERR, LASF) + LSV3 = LASF(3) + LASF(3) = 1 + CALL GSASF (LASF) +C + MGR1 = MAGR1 + MN1 = MINI1-1 + MGR2 = MAGR2 + MN2 = MINI2-1 + MN1P1 = MAX0(MN1+1,1) + MN2P1 = MAX0(MN2+1,1) + L = MIN0(3,MAX0(1,IWHICH)) + Q = VAR +C +C PICK BOUNDS +C + GO TO ( 10, 30, 40),L + 10 XMIN = VVMIN + XMAX = VVMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + 20 YMIN = WWMIN + YMAX = WWMAX + DELYL = TICK(TMAGW) + DELYS = TICK(TMINW) + GO TO 50 + 30 XMIN = UUMIN + XMAX = UUMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + GO TO 20 + 40 XMIN = UUMIN + XMAX = UUMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + YMIN = VVMIN + YMAX = VVMAX + DELYL = TICK(TMAGV) + DELYS = TICK(TMINV) +C +C PERIM +C + 50 CALL LINE3W (XMIN,YMIN,XMAX,YMIN) + CALL LINE3W (XMAX,YMIN,XMAX,YMAX) + CALL LINE3W (XMAX,YMAX,XMIN,YMAX) + CALL LINE3W (XMIN,YMAX,XMIN,YMIN) + IF (MGR1 .LT. 1) GO TO 90 + DX = (XMAX-XMIN)/AMAX0(MGR1*(MN1P1),1) + DO 80 I=1,MGR1 +C +C MINORS FIRST +C + IF (MN1 .LE. 0) GO TO 70 +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + DO 60 J=1,MN1 + X = XMIN+FLOAT(MN1P1*(I-1)+J)*DX + CALL LINE3W (X,YMIN,X,YMIN+DELYS) + CALL LINE3W (X,YMAX,X,YMAX-DELYS) + 60 CONTINUE + 70 IF (I .GE. MGR1) GO TO 90 +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI (ITHRMJ) + X = XMIN+FLOAT(MN1P1*I)*DX +C +C MAJORS +C + CALL LINE3W (X,YMIN,X,YMIN+DELYL) + CALL LINE3W (X,YMAX,X,YMAX-DELYL) + 80 CONTINUE + 90 IF (MGR2 .LT. 1) GO TO 130 + DY = (YMAX-YMIN)/AMAX0(MGR2*(MN2P1),1) + DO 120 J=1,MGR2 + IF (MN2 .LE. 0) GO TO 110 + DO 100 I=1,MN2 + Y = YMIN+FLOAT(MN2P1*(J-1)+I)*DY + CALL LINE3W (XMIN,Y,XMIN+DELXS,Y) +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + CALL LINE3W (XMAX,Y,XMAX-DELXS,Y) + 100 CONTINUE + 110 IF (J .GE. MGR2) GO TO 130 +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI (ITHRMJ) + Y = YMIN+FLOAT(MN2P1*J)*DY + CALL LINE3W (XMIN,Y,XMIN+DELXL,Y) + CALL LINE3W (XMAX,Y,XMAX-DELXL,Y) + 120 CONTINUE +C +C RESTORE ASF AND LINE INTENSITY TO ORIGINAL +C + 130 LASF(3) = LSV3 + CALL GSASF (LASF) + CALL GSPLCI (IPLCI) + RETURN + END + SUBROUTINE LINE3W (XA,YA,XB,YB) + SAVE + COMMON /PRM31/ Q ,L + GO TO ( 10, 30, 40),L + 10 UA = Q + UB = Q + VA = XA + VB = XB + 20 WA = YA + WB = YB + GO TO 50 + 30 UA = XA + UB = XB + VA = Q + VB = Q + GO TO 20 + 40 UA = XA + UB = XB + VA = YA + VB = YB + WA = Q + WB = Q + 50 CALL LINE3 (UA,VA,WA,UB,VB,WB) + RETURN + END + SUBROUTINE DRAWT (IXA,IYA,IXB,IYB) + SAVE + CALL PLOTIT(32*IXA,32*IYA,0) + IIX = 32*IXB + IIY = 32*IYB + CALL PLOTIT(IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(IIX,IIY,0) + RETURN + END + SUBROUTINE TICK43 (MAGU,MINU,MAGV,MINV,MAGW,MINW) + SAVE + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV , + 1 TMAGW ,TMINW +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','TICK43','VERSION 1') + TMAGU = MAGU + TMINU = MINU + TMAGV = MAGV + TMINV = MINV + TMAGW = MAGW + TMINW = MINW + RETURN + END + SUBROUTINE TICK3 (MAG,MIN) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','TICK3','VERSION 1') + CALL TICK43 (MAG,MIN,MAG,MIN,MAG,MIN) + RETURN + END + SUBROUTINE FENCE3 (U,V,W,N,IOR,BOT) + SAVE + REAL U(N) ,V(N) ,W(N) + DIMENSION LASF(13) +C +C COMMON BLOCK THRINT IS USED FOR SETTING COLOR INTENSITY +C + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','FENCE3','VERSION 1') +C +C INQUIRE LINE COLOR INDEX AND SET ASF TO INDIVIDUAL +C + CALL GQPLCI (IERR, IPLCI) + CALL GQASF (IERR, LASF) + LSV3 = LASF(3) + LASF(3) = 1 + CALL GSASF (LASF) +C + M = N + BASE = BOT + L = MAX0(1,MIN0(3,IOR)) +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + GO TO ( 10, 40, 70),L + 10 CALL FRST3 (BASE,V(1),W(1)) + DO 20 I=2,M + VV = V(I) + WW = W(I) + CALL VECT3 (BASE,VV,WW) + 20 CONTINUE + DO 30 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,BASE,VV,WW) + 30 CONTINUE + GO TO 100 + 40 CALL FRST3 (U(1),BASE,W(1)) + DO 50 I=2,M + UU = U(I) + WW = W(I) + CALL VECT3 (UU,BASE,WW) + 50 CONTINUE + DO 60 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,UU,BASE,WW) + 60 CONTINUE + GO TO 100 + 70 CALL FRST3 (U(1),V(1),BASE) + DO 80 I=2,M + UU = U(I) + VV = V(I) + CALL VECT3 (UU,VV,BASE) + 80 CONTINUE + DO 90 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,UU,VV,BASE) + 90 CONTINUE +C +C SET LINE INTENSITY TO HIGH +C + 100 CALL GSPLCI (ITHRMJ) + CALL CURVE3 (U,V,W,M) +C +C RESTORE ASF AND LINE INTENSITY TO ORIGINAL +C + LASF(3) = LSV3 + CALL GSASF (LASF) + CALL GSPLCI (IPLCI) +C + RETURN +C +C REVISION HISTORY--- +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C FEBURARY 1979 MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C JUNE 1979 UPDATED FILE TO INCLUDE BLOCK DATA PWRZBD AND +C CORRECT A COMMENTED OUT STATEMENT IN CURVE3. +C MARCH 1980 REMOVED THE PWRZ AND PWRITZ ENTRIES. THESE +C CAPABILITIES WERE REPLACED WITH THE NEW ULIB FILE +C PWRZT. +C JULY 1984 CONVERTED TO FORTRAN 77 AND GKS +C----------------------------------------------------------------------- +C + END + SUBROUTINE PWRZ (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C WRITE (6,1001) +C WRITE (6,1002) +C STOP +C +C1001 FORMAT (1H1//////////) +C1002 FORMAT (' *****************************************'/ +C 1 ' * *'/ +C 2 ' * *'/ +C 3 ' * THE ENTRY POINT PWRZ IS NO LONGER *'/ +C 4 ' * SUPPORTED. THE CAPABILITIES OF *'/ +C 5 ' * THIS OLD ENTRY ARE NOW AVAILABLE *'/ +C 6 ' * IN THE NEW PORTABLE VERSIONS *'/ +C 7 ' * *'/ +C 8 ' * PWRZS FOR USE WITH SRFACE *'/ +C 9 ' * PWRZI FOR USE WITH ISOSRF *'/ +C + ' * PWRZT FOR USE WITH THREED *'/ +C 1 ' * *'/ +C 2 ' * FOR USAGE OF THESE ROUTINES, SEE *'/ +C 3 ' * THE DOCUMENTATION FOR THE DESIRED *'/ +C 4 ' * ROUTINE. *'/ +C 5 ' * *'/ +C 6 ' * *'/ +C 7 ' *****************************************') +C + END diff --git a/sys/gio/ncarutil/veldat.f b/sys/gio/ncarutil/veldat.f new file mode 100644 index 00000000..9baef78d --- /dev/null +++ b/sys/gio/ncarutil/veldat.f @@ -0,0 +1,67 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data veldat changed to run time initialization +c BLOCK DATA VELDAT + subroutine veldat +C +C THIS 'ROUTINE' DEFINES THE DEFAULT VALUES OF THE VELVCT PARAMETERS. +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB, + + IOFFD ,IOFFM ,ISX ,ISY, + + RMN ,RMX ,SIDE ,SIZE, + + XLT ,YBT ,ZMN ,ZMX +C + COMMON /VEC2/ BIG ,INCX ,INCY +C +c DATA EXT / 0.25 / +c DATA ICTRFG / 1 / +c DATA ILAB / 0 / +c DATA IOFFD / 0 / +c DATA IOFFM / 0 / +c DATA RMN / 160.00 / +c DATA RMX / 6400.00 / +c DATA SIDE / 0.90 / +c DATA SIZE / 256.00 / +c DATA XLT / 0.05 / +c DATA YBT / 0.05 / +c DATA ZMX / 0.00 / +c DATA INCX / 1 / +c DATA INCY / 1 / +c +c +noao: following flag added to prevent over-initialization + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + + EXT = 0.25 + ICTRFG = 1 + ILAB = 0 + IOFFD = 0 + IOFFM = 0 + RMN = 160.00 + RMX = 6400.00 + SIDE = 0.90 + SIZE = 256.00 + XLT = 0.05 + YBT = 0.05 + ZMX = 0.00 + INCX = 1 + INCY = 1 +C +c - noao + END diff --git a/sys/gio/ncarutil/velvct.f b/sys/gio/ncarutil/velvct.f new file mode 100644 index 00000000..fd8f46c7 --- /dev/null +++ b/sys/gio/ncarutil/velvct.f @@ -0,0 +1,821 @@ + SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C +C DIMENSION OF U(LU,N),V(LV,N),SPV(2) +C ARGUMENTS +C +C LATEST REVISION JULY 1984 +C +C PURPOSE VELVCT DRAWS A REPRESENTATION OF A TWO- +C DIMENSIONAL VELOCITY FIELD BY DRAWING ARROWS +C FROM EACH DATA LOCATION. THE LENGTH OF THE +C ARROW IS PROPORTIONAL TO THE STRENGTH OF THE +C FIELD AT THAT LOCATION AND THE DIRECTION OF +C THE ARROW INDICATES THE DIRECTION OF THE FLOW +C AT THAT LOCATION. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZVEC (U,V,M,N) +C +C ASSUMPTIONS - +C +C --THE WHOLE ARRAY IS PROCESSED. +C --THE SCALE FACTOR IS CHOSEN INTERNALLY. +C --THE PERIMETER IS DRAWN. +C --FRAME IS CALLED AFTER PLOTTING. +C --THERE ARE NO SPECIAL VALUES. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL VELVCT (U,LU,V,LV,M,N,FLO,HI, +C NSET,LENGTH,ISPV,SPV) +C +C ARGUMENTS +C +C ON INPUT U,V +C +C THE (ORIGINS OF THE) TWO-DIMENSIONAL ARRAYS +C CONTAINING THE VELOCITY FIELD TO BE PLOTTED. +C THE VECTOR AT THE POINT (I,J) HAS MAGNITUDE +C SQRT(U(I,J)**2+V(I,J)**2) AND DIRECTION +C ATAN2(V(I,J),U(I,J)). OTHER REPRESENTATIONS, +C SUCH AS (R,THETA), CAN BE PLOTTED BY +C CHANGING STATEMENT FUNCTIONS IN THIS ROUTINE. +C +C LU +C +C THE FIRST DIMENSION OF U IN THE CALLING +C PROGRAM. +C +C LV +C +C THE FIRST DIMENSION OF V IN THE CALLING +C PROGRAM. +C +C M +C +C THE NUMBER OF DATA VALUES TO BE PLOTTED IN +C THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING THE ENTIRE ARRAY, +C LU = LV = M. +C +C N +C +C THE NUMBER OF DATA VALUES TO BE PLOTTED IN +C THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C +C THE MINIMUM VECTOR MAGNITUDE TO BE SHOWN. +C +C HI +C +C THE MAXIMUM VECTOR MAGNITUDE TO BE SHOWN. (A +C VALUE LESS THAN OR EQUAL TO ZERO CAUSES THE +C MAXIMUM VALUE OF SQRT(U**2+V**2) TO BE USED.) +C +C NSET +C +C FLAG TO CONTROL SCALING - +C +C IF NSET IS ZERO, VELVCT ESTABLISHES THE +C WINDOW AND VIEWPORT TO PROPERLY +C SCALE PLOTTING INSTRUCTIONS TO THE STANDARD +C CONFIGURATION. PERIM IS CALLED TO DRAW A +C BORDER. +C +C IF NSET IS GREATER THAN ZERO, VELVCT ASSUMES +C THAT THE USER HAS ESTABLISHED THE WINDOW +C AND VIEWPORT IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING INSTRUCTIONS GENERATED +C BY VELVCT. PERIM IS NOT CALLED. +C +C IF NSET IS LESS THAN ZERO, VELVCT +C PLACES THE CONTOUR PLOT +C WITHIN THE LIMITS OF THE USER'S CURRENT +C WINDOW AND VIEWPORT. PERIM IS NOT CALLED. +C +C LENGTH +C +C THE LENGTH, IN PLOTTER ADDRESS UNITS (PAUS), +C OF A VECTOR HAVING MAGNITUDE HI +C (OR, IF HI=0, THE LENGTH IN PAUS +C OF THE LONGEST VECTOR). IF LENGTH=0, A +C VALUE IS CHOSEN SUCH THAT THE LONGEST VECTOR +C COULD JUST REACH TO THE TAIL OF THE NEXT +C VECTOR. IF THE HORIZONTAL AND VERTICAL +C RESOLUTIONS OF THE PLOTTER ARE DIFFERENT, +C LENGTH SHOULD BE NON-ZERO AND SPECIFIED AS A +C HORIZONTAL DISTANCE. +C +C ISPV +C +C FLAG TO CONTROL THE SPECIAL VALUE FEATURE. +C +C 0 MEANS THAT THE FEATURE IS NOT IN USE. +C +C 1 MEANS THAT IF THE VALUE OF +C U(I,J)=SPV(1) THE VECTOR WILL NOT BE +C PLOTTED. +C +C 2 MEANS THAT IF THE VALUE OF +C V(I,J)=SPV(2) THE VECTOR WILL NOT BE +C PLOTTED. +C +C 3 MEANS THAT IF EITHER U(I,J)=SPV(1) OR +C V(I,J)=SPV(2) THEN THE VECTOR WILL NOT +C BE PLOTTED. +C +C 4 MEANS THAT IF U(I,J)=SPV(1) +C AND V(I,J)=SPV(2), THE VECTOR +C WILL NOT BE PLOTTED. +C +C SPV +C +C AN ARRAY OF LENGTH 2 WHICH GIVES THE VALUE +C IN THE U ARRAY AND THE VALUE IN THE V ARRAY +C WHICH DENOTE MISSING VALUES. +C THIS ARGUMENT IS IGNORED IF ISPV=0. +C +C +C ON OUTPUT ALL ARGUMENTS REMAIN UNCHANGED. +C +C NOTE THE ENDPOINTS OF EACH ARROW DRAWN ARE (FX(X,Y), +C FY(X,Y)) AND (MXF(X,Y,U,V,SFX,SFY,MX,MY), +C MYF(X,Y,U,V,SFX,SFY,MX,MY)) WHERE X=I, Y=J, +C U=U(I,J), V=V(I,J), AND SFX AND SFY ARE SCALE +C FACTORS. HERE I IS THE X-INDEX AND J IS THE +C Y-INDEX. (MX,MY) IS THE LOCATION OF THE TAIL. +C THUS THE ACTUAL LENGTH OF THE ARROW IS +C SQRT(DX**2+DY**2) AND THE DIRECTION IS +C ATAN2(DX,DY), WHERE DX=MX-MXF(...) AND +C DY=MY-MYF(...). +C +C ENTRY POINTS VELVCT,EZVECT,DRWVEC,VELVEC,VELDAT +C +C COMMON BLOCKS VEC1,VEC2 +C +C I/O PLOTS THE VECTOR FIELD. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C REQUIRED LIBRARY GRIDAL AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C REVISED IN MAY, 1975, TO INCLUDE MXF AND MYF. +C REVISED IN MARCH, 1981, TO FIX CERTAIN ERRORS; +C TO USE FL2INT AND PLOTIT INSTEAD OF MXMY, +C FRSTPT, AND VECTOR; AND TO MAKE THE ARROWHEADS +C NARROWER. CONVERTED TO FORTRAN77 AND GKS +C IN JULY 1984. +C +C ALGORITHM EACH VECTOR IS EXAMINED, POSSIBLY TRANSFORMED, +C THEN PLOTTED. +C +C PORTABILITY FORTRAN77 +C +C --------------------------------------------------------------------- +C +C SPECIAL NOTE - +C +C USING THIS ROUTINE TO PUT VECTORS ON AN ARBITRARY BACKGROUND DRAWN BY +C SUPMAP IS A BIT TRICKY. THE ARITHMETIC STATEMENT FUNCTIONS FX AND FY +C ARE EASY TO REPLACE. THE PROBLEM ARISES IN REPLACING MXF AND MYF. +C THE FOLLOWING EXAMPLE MAY BE HELPFUL. (SUPMAP IS AN ENTRY POINT IN +C THE EZMAP PACKAGE.) +C +C SUPPOSE THAT WE HAVE TWO ARRAYS, CLON(36,9) AND CLAT(36,9), WHICH +C CONTAIN THE E-W AND N-S COMPONENTS OF A WIND FLOW FIELD ON THE SURFACE +C OF THE EARTH. CLON(I,J) IS THE MAGNITUDE OF THE EASTERLY FLOW. +C CLAT(I,J) IS THE MAGNITUDE OF THE NORTHERLY FLOW AT A LONGITUDE (I-1) +C *10 DEGREES EAST OF GREENWICH AND A LATITUDE (J-1)*10 DEGREES NORTH OF +C THE EQUATOR. SUPMAP IS TO BE USED TO DRAW A POLAR PROJECTION OF THE +C EARTH AND VELVCT IS TO BE USED TO SUPERIMPOSE VECTORS REPRESENTING THE +C FLOW FIELD ON IT. THE FOLLOWING STEPS WOULD BE NECESSARY: +C +C 1. CALL SUPMAP (1,90.,0.,-90.,90.,90.,90.,90.,-4,10,0,1,IER) +C TO DRAW THE MAP. +C +C 2. CALL VELVCT (CLON,36,CLAT,36,36,9,0.,0.,1,50,0,0.) TO PUT +C VECTORS ON IT. NOTICE THAT NSET HAS THE VALUE 1 TO TELL +C VELVCT THAT SUPMAP HAS DONE THE REQUIRED SET CALL. +C +C 3. IN ORDER TO ENSURE THAT STEP 2 WILL WORK PROPERLY, DELETE +C THE ARITHMETIC STATEMENT FUNCTIONS FX, FY, MXF, AND MYF +C FROM VELVCT AND INCLUDE THE FOLLOWING FUNCTIONS. +C +C FUNCTION FX(XX,YY) +C CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y) +C FX=X +C RETURN +C END +C +C FUNCTION FY(XX,YY) +C CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y) +C FY=Y +C RETURN +C END +C +C FUNCTION MXF(XX,YY,UU,VV,SFX,SFY,MX,MY) +C CFCT=COS(.17453292519943*(YY-1.)) +C CALL MAPTRN(10.*(YY-1.) ,10.*(XX-1.) ,X1,Y1) +C CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2) +C U=((X2-X1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2) +C MXF=MX+IFIX(SFX*U) +C RETURN +C END +C +C FUNCTION MYF(XX,YY,UU,VV,SFX,SFY,MX,MY) +C CFCT=COS(.17453292519943*(YY-1.)) +C CALL MAPTRN(10.*(YY-1.) ,10.*(XX-1.) ,X1,Y1) +C CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2) +C V=((Y2-Y1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2) +C MYF=MY+IFIX(SFY*V) +C RETURN +C END +C +C THE BASIC NOTION BEHIND THE CODING OF THE MXF AND MYF FUNCTIONS IS AS +C FOLLOWS. SINCE UU AND VV ARE THE LONGITUDINAL AND LATITUDINAL COMPONENTS, +C RESPECTIVELY, OF A VELOCITY VECTOR HAVING UNITS OF DISTANCE OVER TIME, +C 1.E-6*UU/COS(LATITUDE) AND 1.E-6*VV REPRESENT THE CHANGE IN LONGITUDE +C AND LATITUDE, RESPECTIVELY, OF A PARTICLE MOVING WITH THE FLOW FIELD +C FOR A VERY SHORT PERIOD OF TIME. THE ROUTINE MAPTRN IS USED TO FIND +C THE POSITION OF THE PARTICLE'S PROJECTION AT THE BEGINNING AND END OF +C THAT TINY TIME SLICE AND, THEREFORE, THE DIRECTION IN WHICH TO DRAW +C THE ARROW REPRESENTING THE VELOCITY VECTOR SO THAT IT WILL BE TANGENT +C TO A PROJECTED FLOW LINE OF THE FIELD AT THAT POINT. THE VALUES U +C AND V ARE COMPUTED SO AS TO GIVE THE ARROW THE LENGTH IMPLIED BY UU +C AND VV. (THE CODE ENSURES THAT SQRT(U**2+V**2) IS EQUAL TO +C SQRT(UU**2+VV**2).) THE LENGTH OF THE ARROW REPRESENTS THE MAGNITUDE +C OF THE VELOCITY VECTOR, UNAFFECTED BY PERSPECTIVE. THE SCALING SET +C UP BY VELVCT WILL THEREFORE BE APPROPRIATE FOR THE ARROWS DRAWN. +C +C THIS METHOD IS RATHER HEURISTIC AND HAS THREE INHERENT PROBLEMS. +C FIRST, THE CONSTANT 1.E-6 MAY NEED TO BE MADE LARGER OR SMALLER, +C DEPENDING ON THE MAGNITUDE OF YOUR U/V DATA. SECOND, THE NORTH AND +C SOUTH POLES MUST BE AVOIDED. AT EITHER POLE, CFCT GOES TO ZERO, +C GIVING A DIVISION BY ZERO; IN A SMALL REGION NEAR THE POLE, THE +C METHOD MAY TRY TO USE MAPTRN WITH A LATITUDE OUTSIDE THE RANGE +C (-90,+90). THIRD, THE PROJECTION MUST BE SET UP SO AS TO AVOID +C HAVING VECTOR BASEPOINTS AT THE EXACT EDGE OF THE MAP. VECTORS +C THERE WILL BE OF THE CORRECT LENGTH, BUT THEY MAY BE DRAWN IN THE +C WRONG DIRECTION (WHEN THE PROJECTED PARTICLE TRACK DETERMINING THE +C DIRECTION CROSSES THE EDGE AND REAPPEARS ELSEWHERE ON THE MAP). +C WITH A LITTLE CARE, THE DESIRED RESULTS MAY BE OBTAINED. +C --------------------------------------------------------------------- +C +C DECLARATIONS - +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + + IOFFD ,IOFFM ,ISX ,ISY , + + RMN ,RMX ,SIDE ,SIZE , + + XLT ,YBT ,ZMN ,ZMX +C + COMMON /VEC2/ BIG ,INCX ,INCY +C +C ARGUMENT DIMENSIONS. +C + DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) + CHARACTER*10 LABEL + REAL WIND(4), VIEW(4), IAR(4) +C +C --------------------------------------------------------------------- +C +C INTERNAL PARAMETERS OF VELVCT ARE AS FOLLOWS. THE DEFAULT VALUES OF +C THESE PARAMETERS ARE DECLARED IN THE BLOCK DATA ROUTINE VELDAT. +C +C NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C BIG R1MACH(2) CONSTANT USED TO INITIALIZE +C POSSIBLE SEARCH FOR HI. +C +C EXT 0.25 THE LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO M AND +C N WHEN NSET IS LESS THAN OR +C EQUAL TO ZERO, EXCEPT WHEN +C MIN(M,N)/MAX(M,N) IS LESS THAN +C EXT, IN WHICH CASE A SQUARE +C GRAPH IS PLOTTED. +C +C ICTRFG 1 FLAG TO CONTROL THE POSITION OF +C THE ARROW RELATIVE TO A BASE +C POINT AT (MX,MY). +C +C ZERO - CENTER AT (MX,MY) +C +C POSITIVE - TAIL AT (MX,MY) +C +C NEGATIVE - HEAD AT (MX,MY) +C +C ILAB 0 FLAG TO CONTROL THE DRAWING OF +C LINE LABELS. +C +C ZERO - DO NOT DRAW THE LABELS +C +C NON-ZERO - DRAW THE LABELS +C +C INCX 1 X-COORDINATE STEP SIZE FOR LESS +C DENSE ARRAYS. +C +C INCY 1 Y-COORDINATE STEP SIZE. +C +C IOFFD 0 FLAG TO CONTROL NORMALIZATION +C OF LABEL NUMBERS. +C +C ZERO - INCLUDE A DECIMAL POINT +C WHEN POSSIBLE +C +C NON-ZERO - NORMALIZE ALL LABEL +C NUMBERS BY ASH +C +C IOFFM 0 FLAG TO CONTROL PLOTTING OF +C THE MESSAGE BELOW THE PLOT. +C +C ZERO - PLOT THE MESSAGE +C +C NON-ZERO - DO NOT PLOT IT +C +C RMN 160. ARROW SIZE BELOW WHICH THE +C HEAD NO LONGER SHRINKS, ON A +C 2**15 X 2**15 GRID. +C +C RMX 6400. ARROW SIZE ABOVE WHICH THE +C HEAD NO LONGER GROWS LARGER, +C ON A 2**15 X 2**15 GRID. +C +C SIDE 0.90 LENGTH OF LONGER EDGE OF PLOT. +C (SEE ALSO EXT.) +C +C SIZE 256. WIDTH OF THE CHARACTERS IN +C VECTOR LABELS, ON A 2**15 X +C 2**15 GRID. +C +C XLT 0.05 LEFT HAND EDGE OF THE PLOT. +C (0 IS THE LEFT EDGE OF THE +C FRAME, 1 THE RIGHT EDGE.) +C +C YBT 0.05 BOTTOM EDGE OF THE PLOT (0 IS +C THE BOTTOM OF THE FRAME, 1 THE +C TOP OF THE FRAME.) +C +C --------------------------------------------------------------------- +C +C INTERNAL FUNCTIONS WHICH MAY BE MODIFIED FOR DATA TRANSFORMATION - +C +C SCALE COMPUTES A SCALE FACTOR USED IN THE +C DETERMINATION OF THE LENGTH OF THE +C VECTOR TO BE DRAWN. +C +C DIST COMPUTES THE LENGTH OF A VECTOR. +C +C FX RETURNS THE X INDEX AS THE +C X-COORDINATE OF THE VECTOR BASE. +C +C MXF RETURNS THE X-COORDINATE OF THE VECTOR +C HEAD. +C +C FY RETURNS THE Y INDEX AS THE +C Y-COORDINATE OF THE VECTOR BASE. +C +C MYF RETURNS THE Y-COORDINATE OF THE VECTOR +C HEAD. +C +C VLAB THE VALUE FOR THE VECTOR LABEL WHEN +C ILAB IS NON-ZERO. +C + SAVE + DIST(XX,YY) = SQRT(XX*XX+YY*YY) + FX(XX,YY) = XX + FY(XX,YY) = YY + MXF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MXX+IFIX(SFXX*UU) + MYF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MYY+IFIX(SFYY*VV) + SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, + 1 LENN) = LENN/HAA + SCALEY(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, + 1 LENN) = SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3, + 2 XX4,YY3,YY4,LENN) + VLAB(UU,VV,II,JJ) = DIST(UU,VV) +C +C FORCE THE BLOCK DATA ROUTINE, WHICH SETS DEFAULT VARIABLES, TO LOAD. +C +NOAO - blockdata replaced with run time initialization. +C +C EXTERNAL VELDAT + call veldat +C -NOAO +C +C --------------------------------------------------------------------- +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('NSSL','VELVCT','VELVCT','VERSION 6') +C +C INITIALIZE AND TRANSFER SOME ARGUMENTS TO LOCAL VARIABLES. +C + BIG = -R1MACH(2) + MX = LU + MY = LV + NX = M + NY = N + GL = FLO + HA = HI + ISP = ISPV + NC = 0 +C +C COMPUTE CONSTANTS BASED ON THE ADDRESSABILITY OF THE PLOTTER. +C + CALL GETUSV('XF',ISX) + CALL GETUSV('YF',ISY) + ISX = 2**(15-ISX) + ISY = 2**(15-ISY) + LEN = LENGTH*ISX +C +C SET UP THE SCALING OF THE PLOT. +C + CALL GQCNTN(IERR,IOLDNT) + CALL GQNT(IOLDNT,IERR,WIND,VIEW) + X1 = VIEW(1) + X2 = VIEW(2) + Y1 = VIEW(3) + Y2 = VIEW(4) + X3 = WIND(1) + X4 = WIND(2) + Y3 = WIND(3) + Y4 = WIND(4) + CALL GETUSV('LS',IOLLS) +C +C SAVE NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT(1,IERR,WIND,VIEW) +C + IF (NSET) 101,102,106 +C + 101 X3 = 1. + X4 = FLOAT(NX) + Y3 = 1. + Y4 = FLOAT(NY) + GO TO 105 +C + 102 X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + X3 = 1. + Y3 = 1. + X4 = FLOAT(NX) + Y4 = FLOAT(NY) + IF (AMIN1(X4,Y4)/AMAX1(X4,Y4) .LT. EXT) GO TO 105 +C + IF (NX-NY) 103,105,104 + 103 X2 = XLT+SIDE*X4/Y4 + GO TO 105 + 104 Y2 = YBT+SIDE*Y4/X4 +C + 105 CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,1) + IF (NSET .EQ. 0) CALL PERIM (1,0,1,0) +C +C CALCULATE A LENGTH IF NONE PROVIDED. +C + 106 IF (LEN .NE. 0) GO TO 107 + CALL FL2INT(FX(1.,1.),FY(1.,1.),MX,MY) + CALL FL2INT(FX(FLOAT(1+INCX),FLOAT(1+INCY)), + + FY(FLOAT(1+INCX),FLOAT(1+INCY)),LX,LY) + LEN = SQRT((FLOAT(MX-LX)**2+FLOAT(MY-LY)**2)/2.) +C +C SET UP SPECIAL VALUES. +C + 107 IF (ISP .EQ. 0) GO TO 108 + SPV1 = SPV(1) + SPV2 = SPV(2) + IF (ISP .EQ. 4) SPV2 = SPV(1) +C +C FIND THE MAXIMUM VECTOR LENGTH. +C + 108 IF (HA .GT. 0.) GO TO 118 +C + HA = BIG + IF (ISP .EQ. 0) GO TO 115 +C + DO 114 J=1,NY,INCY + DO 113 I=1,NX,INCX + IF (ISP-2) 109,111,110 + 109 IF (U(I,J) .EQ. SPV1) GO TO 113 + GO TO 112 + 110 IF (U(I,J) .EQ. SPV1) GO TO 113 + 111 IF (V(I,J) .EQ. SPV2) GO TO 113 + 112 HA = AMAX1(HA,DIST(U(I,J),V(I,J))) + 113 CONTINUE + 114 CONTINUE + GO TO 126 +C + 115 DO 117 J=1,NY,INCY + DO 116 I=1,NX,INCX + HA = AMAX1(HA,DIST(U(I,J),V(I,J))) + 116 CONTINUE + 117 CONTINUE +C +C BRANCH IF NULL VECTOR SIZE. +C + 126 IF (HA .LE. 0.) GO TO 125 +C +C COMPUTE SCALE FACTORS. +C + 118 SFX = SCALEX(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) + SFY = SCALEY(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) + IOFFDT = IOFFD + IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) + 1 IOFFDT = 1 + IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) + 1 IOFFDT = 1 + ASH = 1.0 + IF (IOFFDT .NE. 0) + 1 ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA)))-500.)-500) + IZFLG = 0 +C +C COMPUTE ZMN AND ZMX, WHICH ARE USED IN DRWVEC. +C + ZMN = LEN*(GL/HA) + ZMX = FLOAT(LEN)+.01 +C +C DRAW THE VECTORS. +C + DO 123 J=1,NY,INCY + DO 122 I=1,NX,INCX + UI = U(I,J) + VI = V(I,J) + IF (ISP-1) 121,119,120 + 119 IF (UI-SPV1) 121,122,121 + 120 IF (VI .EQ. SPV2) GO TO 122 + IF (ISP .GE. 3) GO TO 119 + 121 X = I + Y = J + CALL FL2INT(FX(X,Y),FY(X,Y),MX,MY) + LX = MAX0(1,MXF(X,Y,UI,VI,SFX,SFY,MX,MY)) + LY = MAX0(1,MYF(X,Y,UI,VI,SFX,SFY,MX,MY)) + IZFLG = 1 + IF (ILAB .NE. 0) CALL ENCD(VLAB(UI,VI,I,J),ASH,LABEL,NC, + + IOFFDT) + CALL DRWVEC (MX,MY,LX,LY,LABEL,NC) + 122 CONTINUE + 123 CONTINUE +C + IF (IZFLG .EQ. 0) GO TO 125 +C + IF (IOFFM .NE. 0) GO TO 200 +C +NOAO - FTN internal write replaced with call to encode +C WRITE(LABEL,'(E10.3)')HA + call encode (10, '(e10.3)', label, ha) +C -NOAO +C +C TURN OFF CLIPPING SO ARROW CAN BE DRAWN +C + CALL GQCLIP(IER,ICLP,IAR) + CALL GSCLIP(0) + CALL DRWVEC (28768,608,28768+LEN,608,LABEL,10) +C +C RESTORE CLIPPING +C + CALL GSCLIP(ICLP) + IX = 1+(28768+LEN/2)/ISX + IY = 1+(608-(5*ISX*MAX0(256/ISX,8))/4)/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR (XC,YC, + + 'MAXIMUM VECTOR',MAX0(256/ISX,8),0,0) + CALL GSELNT(ICN) +C +C DONE. +C + GOTO 200 +C +C ZERO-FIELD ACTION. +C + 125 IX = 1+16384/ISX + IY = 1+16384/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR (XC,YC, + + 'ZERO FIELD',MAX0(960/ISX,8),0,0) + CALL GSELNT(ICN) +C +C RESTORE TRANS 1 AND LOG SCALING AND ORIGINAL TRANS NUMBER +C + 200 CONTINUE + IF (NSET .LE. 0) THEN + CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), + - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) + ENDIF + CALL GSELNT(IOLDNT) + RETURN + END + SUBROUTINE EZVEC (U,V,M,N) +C +C THIS SUBROUTINE IS FOR THE USER WHO WANTS A QUICK-AND-DIRTY VECTOR +C PLOT WITH DEFAULT VALUES FOR MOST OF THE ARGUMENTS. +C + SAVE +C + DIMENSION U(M,N) ,V(M,N) ,SPVAL(2) +C + DATA FLO,HI,NSET,LENGTH,ISPV,SPVAL(1),SPVAL(2) / + + 0.,0., 0, 0, 0, 0., 0. / +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('CRAYLIB','VELVCT','EZVEC','VERSION 6') +C + CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPVAL) +C +NOAO - call to frame is suppressed. +C CALL FRAME +C -NOAO + RETURN + END + SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC) +C +C THIS ROUTINE IS CALLED TO DRAW A SINGLE ARROW. IT HAS ARGUMENTS AS +C FOLLOWS - +C +C (M1,M2) - COORDINATE OF ARROW BASE, ON A 2**15 X 2**15 GRID. +C (M3,M4) - COORDINATE OF ARROW HEAD, ON A 2**15 X 2**15 GRID. +C LABEL - CHARACTER LABEL TO BE PUT ABOVE ARROW. +C NC - NUMBER OF CHARACTERS IN LABEL. +C + SAVE +C +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + + IOFFD ,IOFFM ,ISX ,ISY , + + RMN ,RMX ,SIDE ,SIZE , + + XLT ,YBT ,ZMN ,ZMX + CHARACTER*10 LABEL +C +C SOME LOCAL PARAMETERS ARE THE FOLLOWING - +C +C CL - ARROW HEAD LENGTH SCALE FACTOR - EACH SIDE OF THE ARROW +C HEAD IS THIS LONG RELATIVE TO THE LENGTH OF THE ARROW +C ST,CT - SIN AND COS OF THE ARROW HEAD ANGLE +C PI - THE CONSTANT PI +C TWOPI - TWO TIMES PI +C OHOPI - ONE HALF OF PI +C FHOPI - FIVE HALVES OF PI +C + DATA CL / .25 / + DATA ST / .382683432365090 / + DATA CT / .923879532511287 / + DATA PI / 3.14159265358979 / + DATA TWOPI / 6.28318530717959 / + DATA OHOPI / 1.57079632679489 / + DATA FHOPI / 7.85398163397448 / +C + DIST(X,Y) = SQRT(X*X+Y*Y) +C +C TRANSFER ARGUMENTS TO LOCAL VARIABLES AND COMPUTE THE VECTOR LENGTH. +C + N1 = M1 + N2 = M2 + N3 = M3 + N4 = M4 + DX = N3-N1 + DY = N4-N2 + R = DIST(DX,DY) +C +C SORT OUT POSSIBLE CASES, DEPENDING ON VECTOR LENGTH. +C + IF (R .LE. ZMN) RETURN +C + IF (R .LE. ZMX) GO TO 101 +C +C PLOT A POINT FOR VECTORS WHICH ARE TOO LONG. +C + CALL PLOTIT (N1,N2,0) + CALL PLOTIT (N1,N2,1) + CALL PLOTIT (N1,N2,0) + RETURN +C +C ADJUST THE COORDINATES OF THE VECTOR ENDPOINTS AS IMPLIED BY THE +C CENTERING OPTION. +C + 101 IF (ICTRFG) 102,103,104 +C + 102 N3 = N1 + N4 = N2 + N1 = FLOAT(N1)-DX + N2 = FLOAT(N2)-DY + GO TO 104 +C + 103 N1 = FLOAT(N1)-.5*DX + N2 = FLOAT(N2)-.5*DY + N3 = FLOAT(N3)-.5*DX + N4 = FLOAT(N4)-.5*DY +C +C DETERMINE THE COORDINATES OF THE POINTS USED TO DRAW THE ARROWHEAD. +C + 104 C1 = CL +C +C SHORT ARROWS HAVE HEADS OF A FIXED MINIMUM SIZE. +C + IF (R .LT. RMN) C1 = RMN*CL/R +C +C LONG ARROWS HAVE HEADS OF A FIXED MAXIMUM SIZE. +C + IF (R .GT. RMX) C1 = RMX*CL/R +C +C COMPUTE THE COORDINATES OF THE HEAD. +C + N5 = FLOAT(N3)-C1*(CT*DX-ST*DY) + N6 = FLOAT(N4)-C1*(CT*DY+ST*DX) + N7 = FLOAT(N3)-C1*(CT*DX+ST*DY) + N8 = FLOAT(N4)-C1*(CT*DY-ST*DX) +C +C PLOT THE ARROW. +C + CALL PLOTIT (N1,N2,0) + CALL PLOTIT (N3,N4,1) + CALL PLOTIT (N5,N6,0) + CALL PLOTIT (N3,N4,1) + CALL PLOTIT (N7,N8,1) + CALL PLOTIT (0,0,0) +C +C IF REQUESTED, PUT THE VECTOR MAGNITUDE ABOVE THE ARROW. +C + IF (NC .EQ. 0) RETURN + PHI = ATAN2(DY,DX) + IF (AMOD(PHI+FHOPI,TWOPI) .GT. PI) PHI = PHI+PI + IX = 1+IFIX(.5*FLOAT(N1+N3)+1.25* + + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*COS(PHI+OHOPI))/ISX + IY = 1+IFIX(.5*FLOAT(N2+N4)+1.25* + + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*SIN(PHI+OHOPI))/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR(XC,YC, + + LABEL,MAX0(IFIX(SIZE)/ISX,8), + + IFIX(57.2957795130823*PHI),0) + CALL GSELNT(ICN) + RETURN + END + SUBROUTINE VELVEC (U,LU,V,LV,M,N,FLO,HI,NSET,ISPV,SPV) +C +C THIS ROUTINE SUPPORTS USERS OF THE OLD VERSION OF THIS PACKAGE. +C + DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) +C + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('CRAYLIB','VELVCT','VELVEC','VERSION 4') + CALL VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,0,ISPV,SPV) + RETURN + END +C +C REVISION HISTORY ---------------------------------------------------- +C +C FEBRUARY, 1979 ADDED REVISION HISTORY +C MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C +C JULY, 1979 FIXED HI VECTOR TRAP AND MESSAGE INDICATING +C MAXIMUM VECTOR PLOTTED. +C +C DECEMBER, 1979 CHANGED THE STATISTICS CALL FROM CRAYLIB TO NSSL +C +C MARCH, 1981 FIXED SOME FRINGE-CASE ERRORS, CHANGED THE CODE TO +C USE FL2INTT AND PLOTIT INSTEAD OF MXMY, FRSTPT, AND +C VECTOR, AND MADE THE ARROWHEADS NARROWER (45 DEGREES +C APART, RATHER THAN 60 DEGREES APART) +C +C FEBRUARY, 1984 PROVIDED A DIMENSION STATEMENT FOR A VARIABLE INTO +C WHICH A TEN-CHARACTER STRING WAS BEING ENCODED. ON +C THE CRAY, WHEN THE ENCODE WAS DONE, A WORD FOLLOWING +C THE VARIABLE WAS CLOBBERED, BUT THIS APPARENTLY MADE +C NO DIFFERENCE. ON AT LEAST ONE OTHER MACHINE, THE +C CODE BLEW UP. (ERROR REPORTED BY GREG WOODS) +C +C JULY, 1984 CONVERTED TO FORTRAN77 AND GKS. +C +C --------------------------------------------------------------------- diff --git a/sys/gio/nspp/README b/sys/gio/nspp/README new file mode 100644 index 00000000..38bd1580 --- /dev/null +++ b/sys/gio/nspp/README @@ -0,0 +1,9 @@ +NSPP -- The NCAR System Plot Package. + + portlib portable NSPP modules + sysint the system interface + +Usage: + The user must supply a subroutine called WRITEB to use the library. + See gio$nsppkern for an example. The subroutine Z8ZPII should be + called before using NSPP to initialize the internal variables. diff --git a/sys/gio/nspp/mkpkg b/sys/gio/nspp/mkpkg new file mode 100644 index 00000000..3ce0021c --- /dev/null +++ b/sys/gio/nspp/mkpkg @@ -0,0 +1,11 @@ +# Make the LIBNSPP.A library for the Ncar system plot package. + +$checkout libnspp.a lib$ +$update libnspp.a +$checkin libnspp.a lib$ +$exit + +libnspp.a: + @portlib + @sysint + ; diff --git a/sys/gio/nspp/portlib/README b/sys/gio/nspp/portlib/README new file mode 100644 index 00000000..261de972 --- /dev/null +++ b/sys/gio/nspp/portlib/README @@ -0,0 +1,28 @@ +This directory contains the sources for the NCAR system plot package. +The original source is in the file "plot.4.8.sav". If any modifications +have to be made, they will be recorded here. + +REVISIONS + +04Mar84 SET --> SPPSET + The name of the SET module, used to set the device window and + user coordinate system, was changed to SPPSET. The module "set.x" + in the high level code intercepts calls by the utilities to set, + so that the transformations may be stored away in a file for recovery + by another process. + +05Mar84 Elimination of Fortran i/o + All formatted writes to mprint were commented out. + +05Mar48 Resolve library conflict + getchr --> ncgchr [collision with fio.getchar] + putchr --> ncpchr [for consistency with above] + +12Mar84 Moved most of the initialization from the block data z8zpbd into + the initialization subroutine z8zpii, called by nspp_init at + GOPEN time. + +12Dec85 SPPSET -> SET + Changed this guy back, as the high level interface to the system + plot package is no longer used. The NCAR system plot package stuff + is only used by the GIO/NCAR kernel now. diff --git a/sys/gio/nspp/portlib/axes.f b/sys/gio/nspp/portlib/axes.f new file mode 100644 index 00000000..badf7004 --- /dev/null +++ b/sys/gio/nspp/portlib/axes.f @@ -0,0 +1,6 @@ + subroutine axes (x,y) + call getset (idummy,idummy,idummy,idummy,xc,xd,yc,yd,idummy) + call line (x,yc,x,yd) + call line (xc,y,xd,y) + return + end diff --git a/sys/gio/nspp/portlib/curve.f b/sys/gio/nspp/portlib/curve.f new file mode 100644 index 00000000..265b9811 --- /dev/null +++ b/sys/gio/nspp/portlib/curve.f @@ -0,0 +1,41 @@ + subroutine curve (x,y,n) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + dimension x(n) ,y(n) +c + kn = n + if (kn-1) 104,103,101 + 101 xx = x(1) + yy = y(1) + call trans + minst = 0 + call put42 + do 102 i=2,kn + xx = x(i) + yy = y(i) + call trans + minst = 1 + call put42 + 102 continue + go to 104 + 103 call point (x(1),y(1)) + 104 continue + return + end diff --git a/sys/gio/nspp/portlib/dashln.f b/sys/gio/nspp/portlib/dashln.f new file mode 100644 index 00000000..35ac6851 --- /dev/null +++ b/sys/gio/nspp/portlib/dashln.f @@ -0,0 +1,5 @@ + subroutine dashln (ipat) + jpat = ior(ishift(ipat,6),ishift(ipat,-4)) + call optn (4hdpat,jpat) + return + end diff --git a/sys/gio/nspp/portlib/fl2int.f b/sys/gio/nspp/portlib/fl2int.f new file mode 100644 index 00000000..59939aca --- /dev/null +++ b/sys/gio/nspp/portlib/fl2int.f @@ -0,0 +1,31 @@ + subroutine fl2int (x,y,imx,imy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + nx = mx + ny = my + xx = x + yy = y + call trans + imx = mx + imy = my + mx = nx + my = ny + return + end diff --git a/sys/gio/nspp/portlib/flash1.f b/sys/gio/nspp/portlib/flash1.f new file mode 100644 index 00000000..39fb31c6 --- /dev/null +++ b/sys/gio/nspp/portlib/flash1.f @@ -0,0 +1,42 @@ + subroutine flash1 (ibuf,ibufl) + dimension ibuf(ibufl) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + if (modef .eq. 1) go to 101 + mxold = -9999 + myold = -9999 + call mcflsh + mbufa = loci(ibuf) + mbufl = ibufl + modef = 1 + mnxsto = mjxmin + mnysto = mjymin + mxxsto = mjxmax + mxysto = mjymax + mjxmin = 32767 + mjymin = 32767 + mjxmax = 0 + mjymax = 0 + mbuflu = 0 + return +c + 101 call uliber (0, + 1 48h0flash1 called consecutively without flash2 call, + 2 48) + call perror + return + end diff --git a/sys/gio/nspp/portlib/flash2.f b/sys/gio/nspp/portlib/flash2.f new file mode 100644 index 00000000..0f909414 --- /dev/null +++ b/sys/gio/nspp/portlib/flash2.f @@ -0,0 +1,71 @@ + subroutine flash2 (ipoint,ibuflu) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension idummy(1) + if (modef .ne. 1) go to 101 + kpoint = ipoint + if (kpoint.lt.0 .or. kpoint.gt.10) go to 102 + call flushb + nextra = 5 + ibuflu = mbuflu+nextra + if (mf2er .gt. 0) go to 103 + if (ibuflu .gt. mbufl) go to 103 + mfwa(kpoint+1) = mbufa + mlwa(kpoint+1) = mbufa+mbuflu-1 + isub = mbufa+mbuflu-loci(idummy) + idummy(isub+1) = mbuflu + idummy(isub+2) = mjxmin + idummy(isub+3) = mjymin + idummy(isub+4) = mjxmax + idummy(isub+5) = mjymax + modef = 2 + mbufa = loci(msybuf) + mbufl = msblen + mbuflu = 0 + mbprs(1) = mpair1 + mbprs(2) = mpair2 + mipair = 2 + mflcnt = 0 + mxold = -9999 + myold = -9999 + mjxmin = mnxsto + mjymin = mnysto + mjxmax = mxxsto + mjymax = mxysto + return +c + 101 call uliber (0,29h0flash2 called without flash1,29) + call perror + return + 102 continue +c write (mprint,1001) kpoint +c + call uliber (0,38h0first argument to flash2 out of range,38) + call perror + return + 103 continue + nlen = mf2er*mbufl+ibuflu +c write (mprint,1002) nlen +c + call uliber (0,23h0flash buffer too short,23) + call perror + return +c +c1001 format (27h0flash2 called with ipoint=,i5) +c1002 format (27h0flash buffer must be about,i8,11h words long) +c + end diff --git a/sys/gio/nspp/portlib/flash3.f b/sys/gio/nspp/portlib/flash3.f new file mode 100644 index 00000000..ce7f36d5 --- /dev/null +++ b/sys/gio/nspp/portlib/flash3.f @@ -0,0 +1,70 @@ + subroutine flash3 (ipoint) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension idummy(1) + if (modef .lt. 2) go to 102 + kpoint = ipoint + if (kpoint.lt.0 .or. kpoint.gt.10) go to 103 + if (mfwa(kpoint+1) .eq. -9999) go to 102 + call mcflsh + isave1 = mbufa + isave2 = mbuflu + mbufa = mfwa(kpoint+1) + nlentg = mlwa(kpoint+1)-mbufa+1 + isub = mbufa+nlentg-loci(idummy) + nusrwc = idummy(isub+1) + if (nusrwc .ne. nlentg) go to 104 + modef = -3 + 101 mbuflu = min0(nlentg,msblen) + if (mbuflu .gt. 0) call preout + nlentg = nlentg-msblen + mbufa = mbufa+msblen + if (nlentg .gt. 0) go to 101 + mbufa = isave1 + mbuflu = isave2 + mxold = -9999 + myold = -9999 + modef = 3 + mjxmin = min0(mjxmin,idummy(isub+2)) + mjymin = min0(mjymin,idummy(isub+3)) + mjxmax = max0(mjxmax,idummy(isub+4)) + mjymax = max0(mjymax,idummy(isub+5)) + return + 102 continue +c write (mprint,1001) kpoint +c + call uliber (0, + 1 48h0flash3 called without call to flash1 and flash2, + 2 48) + call perror + return + 103 continue +c write (mprint,1001) kpoint +c + call uliber (0,37h0argument out of range in flash3 call,37) + call perror + return + 104 continue +c write (mprint,1001) kpoint +c + call uliber (0,37h0user flash buffer has been corrupted,37) + call perror + return +c +c1001 format (27h0flash3 called with ipoint=,i5) +c + end diff --git a/sys/gio/nspp/portlib/flash4.f b/sys/gio/nspp/portlib/flash4.f new file mode 100644 index 00000000..9fc13238 --- /dev/null +++ b/sys/gio/nspp/portlib/flash4.f @@ -0,0 +1,46 @@ + subroutine flash4 (ifw,lwd,ipoint) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension ifw(1) ,lwd(1) + jfwa = loci(ifw) + jlwda = loci(lwd) + kpoint = ipoint + if (jfwa .gt. jlwda) go to 101 + if (kpoint.lt.0 .or. kpoint.gt.10) go to 102 + nextra = 5 + mfwa(kpoint+1) = jfwa + mlwa(kpoint+1) = jlwda-nextra + nwds = jlwda-jfwa + modef = 4 + return + 101 continue +c write (mprint,1001) jfwa,jlwda +c + call uliber (0,38h0loci(ifw).gt.loci(lwd) in flash4 call,38) + call perror + return + 102 continue +c write (mprint,1002) kpoint +c + call uliber (0,43h0third argument out of range in flash4 call,43) + call perror + return +c +c1001 format (10h0loci(ifw)=,i10,10x,9hloci(lwd)=,i10) +c1002 format (27h0flash4 called with ipoint=,i5) +c + end diff --git a/sys/gio/nspp/portlib/flush.f b/sys/gio/nspp/portlib/flush.f new file mode 100644 index 00000000..07ee8418 --- /dev/null +++ b/sys/gio/nspp/portlib/flush.f @@ -0,0 +1,22 @@ + subroutine mcflsh + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + if (modef .eq. 1) go to 101 + call flushb + if (mbuflu .gt. 0) call preout + 101 return + end diff --git a/sys/gio/nspp/portlib/flushb.f b/sys/gio/nspp/portlib/flushb.f new file mode 100644 index 00000000..7f88c29b --- /dev/null +++ b/sys/gio/nspp/portlib/flushb.f @@ -0,0 +1,41 @@ + subroutine flushb +c dimension idummy(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + external z8zpbd + if (mipair .eq. 16) go to 102 + if (mipair .eq. 0) return + if (mipair.eq.2 .and. mflcnt.eq.0) return + mipp1 = mipair+1 + do 101 i=mipp1,16 + mbprs(i) = 40992 + 101 continue + 102 if (mbufa .eq. -9999) mbufa = loci(msybuf) + mflcnt = mflcnt+1 + call packum (mbprs,16,mbufa+mbuflu) + mbuflu = mbuflu+8 + mipair = 0 + if (modef .eq. 1) go to 103 + if (mbuflu+8 .le. mbufl) return + if (mbuflu .gt. 0) call preout + return + 103 if (mod(mbuflu,msblen) .eq. 0) go to 104 + if (mbuflu+8 .le. mbufl) return + 104 continue + if (mbuflu .gt. 0) call preout + return + end diff --git a/sys/gio/nspp/portlib/frame.f b/sys/gio/nspp/portlib/frame.f new file mode 100644 index 00000000..c8396fcd --- /dev/null +++ b/sys/gio/nspp/portlib/frame.f @@ -0,0 +1,70 @@ + subroutine frame + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + if (modef .eq. 1) go to 101 + mbpair = ior(ishift(226,8),0) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if ((mipair+5) .gt. 16) call flushb + mbpair = ior(ishift(231,8),8) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjxmin + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjymin + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjxmax + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjymax + mfrend = 1 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + call flushb + if (mbuflu .gt. 0) call preout + mjxmin = 32767 + mjymin = 32767 + mjxmax = 0 + mjymax = 0 + mxold = -9999 + myold = -9999 + mop(1) = 0 + mop(2) = 204 + mop(5) = 0 + mop(3) = 0 + mop(4) = 128 + mop(7) = 8 + mop(6) = ior(1,ishift(32767,1)) + mop(8) = 0 + mop(9) = 0 + mop(10) = 0 + mfrend = 0 + return +c + 101 call uliber (0,45h0frame call illegal between flash1 and flash2, + 1 45) + call perror + return + end diff --git a/sys/gio/nspp/portlib/frstpt.f b/sys/gio/nspp/portlib/frstpt.f new file mode 100644 index 00000000..7fea3675 --- /dev/null +++ b/sys/gio/nspp/portlib/frstpt.f @@ -0,0 +1,30 @@ + subroutine frstpt (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + mxold = mx + myold = my + xx = x + yy = y + call trans + if (iabs(mx-mxold)+iabs(my-myold) .eq. 0) return + minst = 0 + call put42 + return + end diff --git a/sys/gio/nspp/portlib/getopt.f b/sys/gio/nspp/portlib/getopt.f new file mode 100644 index 00000000..10474014 --- /dev/null +++ b/sys/gio/nspp/portlib/getopt.f @@ -0,0 +1,37 @@ + subroutine getopt (iopnam,iopval) + dimension iopnam(1) ,iopval(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c find index for input name +c + do 101 i=1,9 + iop = i + if (jlm2(iopnam) .eq. jlm2(mname(i))) go to 102 + 101 continue +c + call uliber (0,36hounknown name in optn or getopt call,36) + call perror + return + 102 if (iop .eq. 9) go to 103 + return + 103 do 104 i=1,3 + call ncgchr (mop(iop),3,i,jchar) + call ncpchr (iopval,3,i,jchar) + 104 continue + return + end diff --git a/sys/gio/nspp/portlib/getset.f b/sys/gio/nspp/portlib/getset.f new file mode 100644 index 00000000..7bc6b8ce --- /dev/null +++ b/sys/gio/nspp/portlib/getset.f @@ -0,0 +1,28 @@ + subroutine getset (nxa,nxb,nya,nyb,xc,xd,yc,yd,itype) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + nxa = ishift(mxa,-mshftx)+1 + nxb = ishift(mxb,-mshftx)+1 + xc = xxc + xd = xxd + nya = ishift(mya,-mshfty)+1 + nyb = ishift(myb,-mshfty)+1 + yc = yyc + yd = yyd + itype = mtype + return + end diff --git a/sys/gio/nspp/portlib/getsi.f b/sys/gio/nspp/portlib/getsi.f new file mode 100644 index 00000000..400da7b1 --- /dev/null +++ b/sys/gio/nspp/portlib/getsi.f @@ -0,0 +1,21 @@ + subroutine getsi (npowx,npowy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + npowx = 15-mshftx + npowy = 15-mshfty + return + end diff --git a/sys/gio/nspp/portlib/grid.f b/sys/gio/nspp/portlib/grid.f new file mode 100644 index 00000000..358045fc --- /dev/null +++ b/sys/gio/nspp/portlib/grid.f @@ -0,0 +1,4 @@ + subroutine grid (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,0,0,0,1,1) + return + end diff --git a/sys/gio/nspp/portlib/gridal.f b/sys/gio/nspp/portlib/gridal.f new file mode 100644 index 00000000..814cb42e --- /dev/null +++ b/sys/gio/nspp/portlib/gridal.f @@ -0,0 +1,218 @@ + subroutine gridal (imajx,iminx,imajy,iminy,ixlab,iylab,iflg,x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c non-compact version of gridal +c +c ray bovet ishft changed to ishfta patch + dimension nmaj(2),nmin(2),nlab(2),nflg(2),num(2) ,zza(2) , + 1 zzb(2) ,zzc(2) ,zzd(2) ,ichars(5) , + 2 ifmt(3,2) ,iz(2) ,iza(2) ,izb(2) ,imz(2) , + 3 izdec(2) ,isiz(2),imajl(2) , + 4 iminl(2) ,itype(2) ,zz(2) , + 5 ishfta(2) ,izaa(2),izbb(2),kz(4) +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c +c +c ray bovet ishft changed to ishfta patch + equivalence (xxa,zza(1)) ,(xxb,zzb(1)) ,(xxc,zzc(1)) , + 1 (xxd,zzd(1)) ,(mfmtx(1),ifmt(1,1)), + 2 (mx,iz(1)) ,(mxa,iza(1)) ,(mxb,izb(1)) , + 3 (majx,nmaj(1)) ,(minx,nmin(1)) ,(mumx,num(1)) , + 4 (mxdec,izdec(1)) ,(msizx,isiz(1)), + 5 (mmgrx,imajl(1)) ,(mmnrx,iminl(1)) , + 6 (mtypex,itype(1)) ,(xx,kz(1)) , + 7 (xx,zz(1)) ,(mshftx,ishfta(1)) +c +c set up variables for loop +c + nmaj(1) = imajx + nmaj(2) = imajy + nmin(1) = iminx + nmin(2) = iminy + nlab(1) = ixlab + nlab(2) = iylab + nflg(1) = ishift(iflg,-2)-1 + nflg(2) = iand(iflg,3)-1 + izaa(1) = iza(1) + izaa(2) = iza(2) + izbb(1) = izb(1) + izbb(2) = izb(2) + if (nflg(1).le.0 .and. nflg(2).le.0) go to 101 + xx = x + yy = y + call trans + if (nflg(2) .gt. 0) izaa(1) = mx + if (nflg(1) .gt. 0) izaa(2) = my + if (nflg(2) .gt. 0) izbb(1) = mx + if (nflg(1) .gt. 0) izbb(2) = my + 101 continue + call optn (4hdpat,65535) + do 121 i=1,2 +c +c i=1 for x axis with ticks in y direction +c i=2 for y axis with ticks in x direction +c + if (nlab(i)) 121,102,102 + 102 continue +c +c ior.ne.0 posibility for x only +c + ixor = (2-i)*90*mxor + imaj = max0(nmaj(i),1) + imin = max0(nmin(i),1) + begin = iza(i) + biginc = float(izb(i)-iza(i))/float(imaj) + smlinc = biginc/float(imin) + start = zzc(i) + dif = (zzd(i)-zzc(i))/float(imaj) + iop = 3-i +c +c iop is the opposit axis to i +c + idec = izdec(iop) + if (idec .eq. 0) idec = izaa(iop)-izbb(iop)-655 + if (ixor .eq. i-1) go to 103 +c +c labels and axis are orthogonal +c + icent = isign(1,idec-1) + go to 104 +c +c labels and axis are parallel +c + 103 icent = 0 + 104 continue + if (itype(i) .eq. 0) go to 105 + fact = 10.**imaj + if (zzc(i) .gt. zzd(i)) fact = 1./fact + val = zzc(i)/fact + delval = val + if (imin.le.10 .and. imaj.eq.1) imin = 9 + if (imin .ne. 9) imin = 1 + imaj = abs(alog10(zzd(i)/zzc(i)))+1.0001 + 105 imajp1 = imaj+1 + iminm1 = imin-1 + do 119 j=1,imajp1 + part = j-1 +c +c draw major line or tick +c + call optn (4hintn,4hhigh) + if (itype(i) .ne. 0) go to 106 + iz(i) = begin+part*biginc + go to 107 + 106 val = val*fact + zz(i) = val + kz(iop) = 1 + call trans + delval = delval*fact + if (iz(i)-10 .gt. izb(i)) go to 120 + 107 continue + iz(iop) = izaa(iop) + minst = 0 + call put42 + if (nflg(i)) 108,109,109 + 108 iz(iop) = izb(iop) + minst = 1 + call put42 + go to 111 + 109 iz(iop) = izaa(iop)+imajl(iop) + minst = 1 + call put42 + if (nflg(i)) 110,110,111 + 110 iz(iop) = izb(iop) + minst = 0 + call put42 + iz(iop) = izb(iop)-imajl(iop) + minst = 1 + call put42 + 111 continue +c +c form label if needed +c + if (nlab(i) .le. 0) go to 112 + if (itype(i) .eq. 0) val = start+part*dif + call encode (num(i),ifmt(1,i),ichars,val) +c ray bovet ishft changed to ishfta patch + imz(i) = ishift(iz(i),-ishfta(i)) + imz(iop) = max0(1,ishift(izaa(iop)-idec,-ishfta(iop))) + njust = num(i) + if (icent .eq. 0) call justfy (ichars,num(i),njust) + call pwrit (imz(1),imz(2),ichars,njust,isiz(i),ixor,icent) +c +c put in minor ticks +c + 112 if (iminm1.le.0 .or. j.eq.imajp1) go to 119 + call optn (4hintn,3hlow) + do 118 k=1,iminm1 + if (itype(i) .ne. 0) go to 113 + iz(i) = begin+part*biginc+float(k)*smlinc + go to 114 + 113 zz(i) = val+float(k)*delval + if (zzc(i) .gt. zzd(i)) zzi = val-float(k)*delval*.1 + kz(iop) = 1 + call trans + if (iz(i) .gt. izb(i)) go to 120 + if (iz(i) .lt. iza(i)) go to 118 + 114 continue + iz(iop) = izaa(iop) + minst = 0 + call put42 + if (nflg(i)) 115,116,116 + 115 iz(iop) = izb(iop) + minst = 1 + call put42 + go to 118 + 116 iz(iop) = izaa(iop)+iminl(iop) + minst = 1 + call put42 + if (nflg(i)) 117,117,118 + 117 iz(iop) = izb(iop) + minst = 0 + call put42 + iz(iop) = izb(iop)-iminl(iop) + minst = 1 + call put42 + 118 continue + 119 continue + call optn (4hintn,4hhigh) + 120 if (nflg(iop) .lt. 0) go to 121 +c +c draw axis line +c + iz(i) = iza(i) + iz(iop) = izaa(iop) + minst = 0 + call put42 + iz(i) = izb(i) + iz(iop) = izaa(iop) + minst = 1 + call put42 + if (nflg(i) .gt. 0) go to 121 + iz(i) = iza(i) + iz(iop) = izb(iop) + minst = 0 + call put42 + iz(i) = izb(i) + iz(iop) = izb(iop) + minst = 1 + call put42 + 121 continue + return + end diff --git a/sys/gio/nspp/portlib/gridl.f b/sys/gio/nspp/portlib/gridl.f new file mode 100644 index 00000000..7de4687f --- /dev/null +++ b/sys/gio/nspp/portlib/gridl.f @@ -0,0 +1,4 @@ + subroutine gridl (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,1,1,0,1,1) + return + end diff --git a/sys/gio/nspp/portlib/halfax.f b/sys/gio/nspp/portlib/halfax.f new file mode 100644 index 00000000..c996a4dd --- /dev/null +++ b/sys/gio/nspp/portlib/halfax.f @@ -0,0 +1,4 @@ + subroutine halfax (magrx,minrx,magry,minry,x,y,ixlab,iylab) + call gridal (magrx,minrx,magry,minry,ixlab,iylab,10,x,y) + return + end diff --git a/sys/gio/nspp/portlib/jlm2.f b/sys/gio/nspp/portlib/jlm2.f new file mode 100644 index 00000000..455c1310 --- /dev/null +++ b/sys/gio/nspp/portlib/jlm2.f @@ -0,0 +1,7 @@ + function jlm2 (ichar) + dimension ichar(1) + call ncgchr (ichar,2,1,ichar1) + call ncgchr (ichar,2,2,ichar2) + jlm2 = ior(ishift(ichar1,8),ichar2) + return + end diff --git a/sys/gio/nspp/portlib/justfy.f b/sys/gio/nspp/portlib/justfy.f new file mode 100644 index 00000000..f543e539 --- /dev/null +++ b/sys/gio/nspp/portlib/justfy.f @@ -0,0 +1,14 @@ + subroutine justfy (ichar,len,newlen) + dimension ichar(1) + in = 0 + call ncgchr (1h ,1,1,iblank) + do 102 i=1,len + call ncgchr (ichar,len,i,jchar) + if (in .ne. 0) go to 101 + if (jchar .eq. iblank) go to 102 + 101 in = in+1 + call ncpchr (ichar,len,in,jchar) + 102 continue + newlen = in + return + end diff --git a/sys/gio/nspp/portlib/labmod.f b/sys/gio/nspp/portlib/labmod.f new file mode 100644 index 00000000..94110f19 --- /dev/null +++ b/sys/gio/nspp/portlib/labmod.f @@ -0,0 +1,53 @@ + subroutine labmod (ifmtx,ifmty,numx,numy,isizx,isizy,ixdec,iydec, + 1 ixor) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet ishft changed to ishfta patch + dimension ifmtx(3) ,ifmty(3) ,idec(2),ishfta(2) + equivalence (mxdec,idec(1)),(mshftx,ishfta(1)) + do 101 i=1,10 + call ncgchr (ifmtx,10,i,ichar) + call ncpchr (mfmtx,10,i,ichar) + call ncgchr (ifmty,10,i,ichar) + call ncpchr (mfmty,10,i,ichar) + 101 continue + mumx = numx + mumy = numy + if (max0(mumx,mumy) .gt. 20) go to 103 + msizx = isizx + msizy = isizy + mxdec = ixdec + mydec = iydec + do 102 i=1,2 +c ray bovet ishft changed to ishfta patch + jdec = isign(ishift(iabs(idec(i)),ishfta(i)),idec(i)) + if (idec(i) .eq. 0) jdec = 655 + if (idec(i) .eq. 1) jdec = 0 + idec(i) = jdec + 102 continue + mxor = ixor + return + 103 continue +c write (mprint,1001) mumx,mumy +c + call uliber (0,36h0numx or numy .gt. 20 in labmod call,36) + call perror + return +c +c1001 format (6h0numx=,i5,6h numy=,i5) +c + end diff --git a/sys/gio/nspp/portlib/line.f b/sys/gio/nspp/portlib/line.f new file mode 100644 index 00000000..a88330db --- /dev/null +++ b/sys/gio/nspp/portlib/line.f @@ -0,0 +1,32 @@ + subroutine line (xa,ya,xb,yb) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xa,xb,ya,yb,xx,yy +c + xx = xa + yy = ya + call trans + minst = 0 + call put42 + xx = xb + yy = yb + call trans + minst = 1 + call put42 + return + end diff --git a/sys/gio/nspp/portlib/mkpkg b/sys/gio/nspp/portlib/mkpkg new file mode 100644 index 00000000..a77011d0 --- /dev/null +++ b/sys/gio/nspp/portlib/mkpkg @@ -0,0 +1,56 @@ +# Make the NCAR system plot package. + +$checkout libnspp.a lib$ +$update libnspp.a +$checkin libnspp.a lib$ +$exit + +libnspp.a: + axes.f + curve.f + dashln.f + fl2int.f + flash1.f + flash2.f + flash3.f + flash4.f + flush.f + flushb.f + frame.f + frstpt.f + getopt.f + getset.f + getsi.f + grid.f + gridal.f + gridl.f + halfax.f + jlm2.f + justfy.f + labmod.f + line.f + mxmy.f + option.f + optn.f + perim.f + periml.f + plotit.f + point.f + points.f + porgn.f + preout.f + pscale.f + psym.f + put42.f + putins.f + pwrit.f + pwrt.f + set.f + seti.f + tick4.f + ticks.f + trans.f + vector.f + z8zpbd.f + z8zpii.f + ; diff --git a/sys/gio/nspp/portlib/mxmy.f b/sys/gio/nspp/portlib/mxmy.f new file mode 100644 index 00000000..d0045227 --- /dev/null +++ b/sys/gio/nspp/portlib/mxmy.f @@ -0,0 +1,21 @@ + subroutine mxmy (imx,imy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + imx = ishift(mx,-mshftx)+1 + imy = ishift(my,-mshfty)+1 + return + end diff --git a/sys/gio/nspp/portlib/option.f b/sys/gio/nspp/portlib/option.f new file mode 100644 index 00000000..059a7e40 --- /dev/null +++ b/sys/gio/nspp/portlib/option.f @@ -0,0 +1,8 @@ + subroutine option (icas,int,ital,ior) + call optn (4hcase,icas) + if (int .eq. 0) call optn (4hintn,3hlow) + if (int .eq. 1) call optn (4hintn,4hhigh) + call optn (4hfont,ital) + call optn (4horen,ior) + return + end diff --git a/sys/gio/nspp/portlib/optn.f b/sys/gio/nspp/portlib/optn.f new file mode 100644 index 00000000..965356f1 --- /dev/null +++ b/sys/gio/nspp/portlib/optn.f @@ -0,0 +1,99 @@ + subroutine optn (iopnam,iopval) + dimension iopnam(1) ,iopval(1) + dimension ichar(3) + logical skip + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c + data ihigh,ilow/2hhi,2hlo/ +c +c find index for input name +c + do 101 i=1,9 + iop = i + if (jlm2(iopnam) .eq. jlm2(mname(i))) go to 102 + 101 continue +c + call uliber (0,36hounknown name in optn or getopt call,36) + call perror + return + 102 continue + if (iop.ne.2 .and. iop.ne.9) iopv = iopval(1) +c +c if character input for intensity, change to numeric +c + if (iop .ne. 2) go to 105 + jchar = jlm2(iopval) + if (jchar .ne. jlm2(ihigh)) go to 103 + iopv = 204 + go to 105 + 103 if (jchar .ne. jlm2(ilow)) go to 104 + iopv = 127 + go to 105 + 104 iopv = iopval(1) + 105 continue +c +c reset option if necessary +c + if (iop .ne. 9) go to 107 + skip = modef .eq. 0 + do 106 i=1,3 + call ncgchr (iopval,3,i,ichar(i)) + call ncgchr (mop(iop),3,i,jchar) + skip = skip .and. (jchar .eq. ichar(i)) + call ncpchr (mop(iop),3,i,ichar(i)) + 106 continue + if (skip) go to 109 + nchar = 4 + mbpair = 1*nchar+58112 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = ior(ishift(iop,8),ichar(1)) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = ior(ishift(ichar(2),8),ichar(3)) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + go to 109 + 107 continue + if (mop(iop).eq.iopv .and. modef.eq.0) go to 109 + mop(iop) = iopv + nchar = 2 + if (iop.eq.6 .or. iop.eq.3 .or. iop.eq.4 .or. iop.eq.7) nchar = 4 + mbpair = 1*nchar+58112 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if (nchar .eq. 4) go to 108 + mbpair = ior(ishift(iand(iop,255),8),iand(iopv,255)) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + go to 109 + 108 mbpair = ishift(iop,8) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = iand(iopv,65535) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + 109 return + end diff --git a/sys/gio/nspp/portlib/perim.f b/sys/gio/nspp/portlib/perim.f new file mode 100644 index 00000000..44c29212 --- /dev/null +++ b/sys/gio/nspp/portlib/perim.f @@ -0,0 +1,4 @@ + subroutine perim (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,0,0,5,1,1) + return + end diff --git a/sys/gio/nspp/portlib/periml.f b/sys/gio/nspp/portlib/periml.f new file mode 100644 index 00000000..a30b839d --- /dev/null +++ b/sys/gio/nspp/portlib/periml.f @@ -0,0 +1,4 @@ + subroutine periml (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,1,1,5,1,1) + return + end diff --git a/sys/gio/nspp/portlib/plotit.f b/sys/gio/nspp/portlib/plotit.f new file mode 100644 index 00000000..df048298 --- /dev/null +++ b/sys/gio/nspp/portlib/plotit.f @@ -0,0 +1,23 @@ + subroutine plotit (nx,ny,npen) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + mx = max0(0,min0(nx,32767)) + my = max0(0,min0(ny,32767)) + minst = max0(0,min0(1,npen)) + call put42 + return + end diff --git a/sys/gio/nspp/portlib/point.f b/sys/gio/nspp/portlib/point.f new file mode 100644 index 00000000..efca3bd0 --- /dev/null +++ b/sys/gio/nspp/portlib/point.f @@ -0,0 +1,43 @@ + subroutine point (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 256 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = x + yy = y + call trans + minst = 0 + call put42 + mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + return + end diff --git a/sys/gio/nspp/portlib/points.f b/sys/gio/nspp/portlib/points.f new file mode 100644 index 00000000..07b11c5b --- /dev/null +++ b/sys/gio/nspp/portlib/points.f @@ -0,0 +1,57 @@ + subroutine points (x,y,n,ichar,ipen) + dimension x(n) ,y(n) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + if (n .le. 0) return + mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if (ichar) 102,101,102 + 101 mbpair = 256 + go to 103 + 102 call ncgchr (ichar,1,1,jchar) + mbpair = 512+jchar + 103 mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = x(1) + yy = y(1) + call trans + minst = 0 + call put42 + if (n .eq. 1) go to 105 + do 104 i=2,n + xx = x(i) + yy = y(i) + call trans + minst = ipen + call put42 + 104 continue + 105 mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + return + end diff --git a/sys/gio/nspp/portlib/porgn.f b/sys/gio/nspp/portlib/porgn.f new file mode 100644 index 00000000..ed2acf93 --- /dev/null +++ b/sys/gio/nspp/portlib/porgn.f @@ -0,0 +1,27 @@ + subroutine porgn (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + xx = x + yy = y + call trans + xadd = mx-1 + yadd = my-1 + return + end diff --git a/sys/gio/nspp/portlib/preout.f b/sys/gio/nspp/portlib/preout.f new file mode 100644 index 00000000..ec2ead3b --- /dev/null +++ b/sys/gio/nspp/portlib/preout.f @@ -0,0 +1,116 @@ + subroutine preout + dimension idummy(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c+kpno +c Initialization moved to z8zpii.f. +c + common /nsplt1/ iclrfb ,isetfb ,ibpw ,ifwd +c data iclrfb/0/, isetfb/0/, ibpw/32/, ifwd/1/ +c-kpno +c + kbufa = mbufa +c +c entry while in flash1 mode will cause restart of filling user buffer +c if its size is exceded. otherwise it is assumed fixed-length output +c record size is exceded, so place for 4 bytes is reserved in user +c buffer, to allow proper record formatting during flash3 call. +c + if (modef .ne. 1) go to 101 + if (mbuflu+4 .le. mbufl) go to 113 + mbuflu = 0 + mf2er = mf2er+1 + go to 113 +c +c if necessary, build masks for setting and clearing new-frame flag +c + 101 if (iclrfb .ne. 0) go to 103 + iposn = ibpw*ifwd-21 + isetfb = ishift(1,iposn) + do 102 i=1,ibpw + ibit = 1 + if (i .eq. (ibpw-iposn)) ibit = 0 + iclrfb = ior(ishift(iclrfb,1),ibit) + 102 continue +c +c in flash3 mode, copy any shorter-than-record-length user buffer into +c system buffer, to avoid possible addressing error during fixed-length +c write. +c + 103 if (modef .ne. -3) go to 105 + if (mbuflu .eq. msblen) go to 105 + isub = kbufa-loci(idummy)+1 + do 104 i=1,mbuflu + msybuf(i) = idummy(isub) + isub = isub+1 + 104 continue + kbufa = loci(msybuf) +c +c compute metacode byte count and put in first 16 bits of buffer. +c *** note that we are directly manipulating the +c first 32 bits of the output buffer here *** +c + 105 mcrout = mcrout+1 + nbytes = -3+(ibpw*mbuflu-1)/8 + isub = kbufa-loci(idummy)+1 + idummy(isub) = ior(idummy(isub),ishift(nbytes,ibpw-16)) +c +c put in first-record-of-frame flag if appropriate. otherwise insure +c frame flag is zeroed. put buffer out via writeb. +c + isub = kbufa-loci(idummy)+ifwd + if (mfrlst .ne. 1) go to 106 + idummy(isub) = ior(idummy(isub),isetfb) + mfrlst = 0 + go to 107 + 106 idummy(isub) = iand(idummy(isub),iclrfb) + 107 if (mbuflu .eq. msblen) go to 109 + isub = kbufa+mbuflu-loci(idummy) + do 108 i=mbuflu,msblen + isub = isub+1 + idummy(isub) = 0 + 108 continue + 109 call writeb (kbufa,mbuflu,munit) +c +c if this is last buffer of frame, call writeb with zero-byte-count +c record, so that it may arrange that such a record follows the last +c frame of the metafile (note that mbufa points to msybuf when get here) +c + if (mfrend .ne. 1) go to 112 + mfrlst = 1 + isub = kbufa-loci(idummy) + do 110 i=1,mbuflu + isub = isub+1 + idummy(isub) = 0 + 110 continue + do 111 i=1,16 + mbprs(i) = 0 + 111 continue + mbprs(2) = ior(mpair2,2048) + call packum (mbprs,16,kbufa) + call writeb (kbufa,0,munit) +c +c finish up by reserving 4 bytes at start of next output buffer. +c + 112 mbuflu = 0 + 113 mbprs(1) = mpair1 + mbprs(2) = mpair2 + mipair = 2 + mflcnt = 0 + return + end diff --git a/sys/gio/nspp/portlib/pscale.f b/sys/gio/nspp/portlib/pscale.f new file mode 100644 index 00000000..3145d586 --- /dev/null +++ b/sys/gio/nspp/portlib/pscale.f @@ -0,0 +1,21 @@ + subroutine pscale (scalex,scaley) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + xfactr = scalex*2.**mshftx + yfactr = scaley*2.**mshfty + return + end diff --git a/sys/gio/nspp/portlib/psym.f b/sys/gio/nspp/portlib/psym.f new file mode 100644 index 00000000..c16cf020 --- /dev/null +++ b/sys/gio/nspp/portlib/psym.f @@ -0,0 +1,27 @@ + subroutine psym (x,y,ichr,isiz,icas,ip) + dimension ichr(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension iwide(4) + data iwide(1),iwide(2),iwide(3),iwide(4)/256,384,512,768/ + if (ip-1) 102,102,101 + 101 call vector (x,y) + 102 call optn (4hcase,icas) + call getopt (5horien,iorn) + call pwrit (x,y,ichr,1,isiz,iorn,0) + return + end diff --git a/sys/gio/nspp/portlib/put42.f b/sys/gio/nspp/portlib/put42.f new file mode 100644 index 00000000..5f8aac81 --- /dev/null +++ b/sys/gio/nspp/portlib/put42.f @@ -0,0 +1,60 @@ + subroutine put42 + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + mjxmax = max0(mx,mjxmax) + mjymax = max0(my,mjymax) + mjxmin = min0(mx,mjxmin) + mjymin = min0(my,mjymin) +c +c test if increment instruction will work +c + if (iabs(mx-mxold).gt.mxmax .or. iabs(my-myold).gt.mymax) + 1 go to 101 +c +c construct increment instructions +c + incx = (mx-mxold)/mxfac+160 + incy = (my-myold)/myfac+32+minst*128 +c +c put instruction in buffer +c + mbpair = ior(ishift(incx,8),incy) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mxold = mx + myold = my + return + 101 continue +c +c mx is first half of the instruction as it stands +c + mbpair = mx + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb +c +c my needs only pen bit +c + mbpair = my+ishift(minst,15) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mxold = mx + myold = my + return + end diff --git a/sys/gio/nspp/portlib/putins.f b/sys/gio/nspp/portlib/putins.f new file mode 100644 index 00000000..466ebd56 --- /dev/null +++ b/sys/gio/nspp/portlib/putins.f @@ -0,0 +1,59 @@ + subroutine putins (nopcd,ins,nchar) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension ins(nchar) + kopcd = nopcd + kchar = nchar +c +c put in the two header bytes +c + if (kopcd.lt.0 .or. kopcd.gt.63) go to 102 + mbpair = ior(ishift(kopcd+192,8),kchar) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if (kchar .eq. 0) return + if (kchar.lt.0 .or. kchar.ge.255) go to 103 +c +c put character string into instruction string +c + do 101 i=1,kchar,2 + call ncgchr (ins,kchar,i,jcharl) + call ncgchr (ins,kchar,i+1,jcharr) + mbpair = ior(ishift(jcharl,8),jcharr) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + 101 continue + return + 102 continue +c write (mprint,1001) kopcd +c + call uliber (0,40h0in putins call, nopcd .lt. 0 or .ge. 63,40) + call perror + return + 103 continue +c write (mprint,1002) kchar +c + call uliber (0,41h0in putins call, nchar .le. 0 or .ge. 255,41) + call perror + return +c +c1001 format (7h0nopcd=,i10) +c1002 format (7h0nchar=,i10) +c + end diff --git a/sys/gio/nspp/portlib/pwrit.f b/sys/gio/nspp/portlib/pwrit.f new file mode 100644 index 00000000..56ed0fb2 --- /dev/null +++ b/sys/gio/nspp/portlib/pwrit.f @@ -0,0 +1,95 @@ + subroutine pwrit (x,y,ichar,nchar,isize,ioren,icent) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + dimension ichar(nchar) + dimension iwide(4) + data wide,high,white /6.,7.,2./ + data iwide(1),iwide(2),iwide(3),iwide(4)/256,384,512,768/ +c +c copy parameters into local variables +c + kchar = nchar + ksize = isize + koren = ioren +c +c transform character size into metacode units. +c + if (ksize .gt. 3) ksize = ishift(ksize,mshftx) + if (ksize .le. 3) ksize = iwide(ksize+1) + call optn (4hcsiz,ksize) +c +c transform orientation. +c + if (koren .lt. 0) koren = koren+360 + if (koren .ge. 0) call optn (4horen,koren) +c +c pass on centering. +c + call optn (4hcent,max0(0,min0(2,icent+1))) +c +c make coordinates global. +c + xx = x + yy = y + call trans +c +c use real variables for convenience. +c + fmx = mx + fmy = my +c +c work with radians instead of degrees. +c 2*pi/360. approximately = .0174533 +c + angle = float(koren)*.0174533 +c +c find starting point for string when considering centering option. +c + cosa = cos(angle) + sina = sin(angle) + wide2 = ksize/2 + widen = float(ksize*kchar)-float(ksize)*white/wide + if (icent) 103,101,102 + 101 fmx = fmx-cosa*widen*.5 + fmy = fmy-sina*widen*.5 + go to 103 + 102 fmx = fmx-cosa*widen + fmy = fmy-sina*widen + 103 continue + hgt2 = (3*ksize)/4 + nxul = fmx-cosa*wide2-sina*hgt2 + nyul = fmy+cosa*hgt2-sina*wide2 + nxll = fmx-cosa*wide2+sina*hgt2 + nyll = fmy-cosa*hgt2-sina*wide2 + nxur = fmx+cosa*widen+cosa*wide2-sina*hgt2 + nyur = fmy+sina*widen+cosa*hgt2+sina*wide2 + nxlr = fmx+cosa*widen+cosa*wide2+sina*hgt2 + nylr = fmy+sina*widen-cosa*hgt2+sina*wide2 + mjxmax = min0(32767,max0(mjxmax,nxul,nxll,nxur,nxlr)) + mjxmin = max0(0,min0(mjxmin,nxul,nxll,nxur,nxlr)) + mjymax = min0(32767,max0(mjymax,nyul,nyll,nyur,nylr)) + mjymin = max0(0,min0(mjymin,nyul,nyll,nyur,nylr)) + minst = 0 + call put42 + call putins (33,ichar,kchar) + mxold = -9999 + myold = -9999 + return + end diff --git a/sys/gio/nspp/portlib/pwrt.f b/sys/gio/nspp/portlib/pwrt.f new file mode 100644 index 00000000..ebb85ca5 --- /dev/null +++ b/sys/gio/nspp/portlib/pwrt.f @@ -0,0 +1,12 @@ + subroutine pwrt (x,y,chars,nchar,jsiz,jor) + dimension chars(1) + dimension jfix(4) + data jfix(1),jfix(2),jfix(3),jfix(4)/128,192,256,384/ + isiz = max0(0,min0(3,jsiz)) + call fl2int (x,y,nx,ny) + call getsi (ixsave,iysave) + nx = max0(0,ishift(nx-(1-jor)*jfix(isiz+1),ixsave-15)) + ny = max0(0,ishift(ny-jor*jfix(isiz+1),iysave-15)) + call pwrit (nx,ny,chars,nchar,isiz,jor*90,-1) + return + end diff --git a/sys/gio/nspp/portlib/set.f b/sys/gio/nspp/portlib/set.f new file mode 100644 index 00000000..a9417d90 --- /dev/null +++ b/sys/gio/nspp/portlib/set.f @@ -0,0 +1,140 @@ + subroutine set (xa,xb,ya,yb,xc,xd,yc,yd,itype) +c +c *************** KPNO -- name changed from set to sppset ********** +c + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xa,xb,ya,yb,xxa,xxb,yya,yyb,zz + logical intt + dimension zz(4) ,mz(4) ,zc(2) ,zd(2) ,zfactr(2) , + 1 zadd(2),mtypez(2) + dimension mshftz(2) + dimension mes(2) + equivalence (xxc,zc(1)) ,(xxd,zd(1)) ,(xxa,zz(1)) , + 1 (mxa,mz(1)) ,(xfactr,zfactr(1)) , + 2 (xadd,zadd(1)) ,(mtypex,mtypez(1)) , + 3 (mshftx,mshftz(1)) ,(temp,itemp) + data mes(1),mes(2)/1hx,1hy/ + xxa = xa + xxb = xb + xxc = xc + xxd = xd + yya = ya + yyb = yb + yyc = yc + yyd = yd + mtype = itype + mtypex = (mtype-1)/2 + mtypey = mod(mtype-1,2) +c +c find mxa, mxb, etc by mapping xxa, xxb, etc into integer space if they +c are not integers +c + do 103 i=1,4 + k = i + if (k .gt. 2) k = k-2 +c ray bovet patch to avoid small integers being set to 0 +c temp = zz(i) + itemp = zz(i) +c if (temp .lt. 0.0) go to 106 +c + if (.not.(intt(temp))) go to 101 + if (itemp.lt.0) go to 106 + itemp = ishift(itemp-1,mshftz(k)) + go to 102 +c ray bovet patch to avoid small integers being set to 0 +c 101 itemp = temp*32767. + 101 if(temp.lt.0.0) go to 106 + itemp = temp*32767. +c + 102 if (itemp.lt.0 .or. itemp.gt.32767) go to 107 + mz(i) = itemp + 103 continue +c +c set up parameters for translating real input from frstpt, etc. to +c integer plotting space +c + do 105 i=1,2 + prange = mz(i+2)-mz(i) + urange = zd(i)-zc(i) +c +c test for no range +c + if (urange.eq.0. .or. prange.eq.0.) go to 108 +c +c test for log scaling +c + if (mtypez(i) .eq. 0) go to 104 +c +c test for error +c + if (zc(i) .le. 0.) go to 109 + if (zd(i) .le. 0.) go to 110 + urange = alog10(zd(i)/zc(i)) + zfactr(i) = prange/urange + zadd(i) = float(mz(i))-zfactr(i)*alog10(zc(i)) + go to 105 + 104 zfactr(i) = prange/urange + zadd(i) = float(mz(i))-zfactr(i)*zc(i) + 105 continue + return +c +c error processing +c + 106 continue + if (i.gt.1 .and. i.lt.4) i = 5-i +c write (mprint,1001) i +c + call uliber (0,53h0negative values not allowed in first 4 set argu + 1ments ,53) + call perror + return + 107 continue + if (i.gt.1 .and. i.lt.4) i = 5-i +c write (mprint,1002) i +c + call uliber (0,83h0first 4 set arguments must be real between 0 an + 1d 1 or integers between 1 and 32767,83) + call perror + return + 108 continue + i1 = i*2+3 + i2 = i*2+4 +c write (mprint,1003) i1,i2 +c + call uliber (0,31h0no range in x or y in set call,31) + call perror + return + 109 continue +c 109 write (mprint,1004) mes(i) + go to 111 + 110 continue +c 110 write (mprint,1005) mes(i) +c + 111 call uliber (0,46h0non-positive argument to set with log scaling, + 1 46) + call perror + return +c +c1001 format (9h0argument,i2,9h negative) +c1002 format (9h0argument,i2,13h out of range) +c1003 format (10h0arguments,i2,4h and,i2,14h are identical) +c1004 format (1h0,a1,8hc .le. 0) +c1005 format (1h0,a1,8hd .le. 0) +c + end diff --git a/sys/gio/nspp/portlib/seti.f b/sys/gio/nspp/portlib/seti.f new file mode 100644 index 00000000..9bc9a635 --- /dev/null +++ b/sys/gio/nspp/portlib/seti.f @@ -0,0 +1,37 @@ + subroutine seti (npowx,npowy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c patch by r bovet to ensure that values are <= 12 on vax +c this is necessary to ensure that intt can work. +c + ipowx = npowx + ipowy = npowy + if(ipowx.le.12) go to 10 + call uliber(0,'x power input to seti cannot exceed 12 + & on vax',80) + ipowx = 12 +10 continue + if(ipowy.le.12) go to 20 + call uliber(0,'y power input to seti cannot exceed 12 + & on vax',80) + ipowy = 12 +20 continue + mshftx = 15-ipowx + mshfty = 15-ipowy + return + end diff --git a/sys/gio/nspp/portlib/tick4.f b/sys/gio/nspp/portlib/tick4.f new file mode 100644 index 00000000..2f1d0ace --- /dev/null +++ b/sys/gio/nspp/portlib/tick4.f @@ -0,0 +1,30 @@ + subroutine tick4 (mgrx,mnrx,mgry,mnry) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c mmgrx(y) is the length in the x(y) direction of major tick marks +c and is therefor used on the y(x) axis (to be consistent with mx(y)dec +c of labmod). +c mgrx(y) is the length of x(y) axis major tick marks. +c similarly for mmnrx(y) and mnrx(y). +c + mmgrx = isign(ishift(iabs(mgry),mshftx),mgry) + mmgry = isign(ishift(iabs(mgrx),mshfty),mgrx) + mmnrx = isign(ishift(iabs(mnry),mshftx),mnry) + mmnry = isign(ishift(iabs(mnrx),mshfty),mnrx) + return + end diff --git a/sys/gio/nspp/portlib/ticks.f b/sys/gio/nspp/portlib/ticks.f new file mode 100644 index 00000000..96484c5d --- /dev/null +++ b/sys/gio/nspp/portlib/ticks.f @@ -0,0 +1,4 @@ + subroutine ticks (major,minor) + call tick4 (major,minor,major,minor) + return + end diff --git a/sys/gio/nspp/portlib/trans.f b/sys/gio/nspp/portlib/trans.f new file mode 100644 index 00000000..5fe0affc --- /dev/null +++ b/sys/gio/nspp/portlib/trans.f @@ -0,0 +1,52 @@ + subroutine trans + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xx,yy +c + logical intt + equivalence (zz,mz),(temp,itemp) +c ray bovet patch to avoid small integers being set to 0 +c zz = xx + mz = xx + if (intt(zz)) go to 102 + if (mtypex .eq. 0) go to 101 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + zz = xfactr*alog10(zz)+xadd + go to 103 + 101 zz = xfactr*zz+xadd + go to 103 + 102 zz = float(ishift(mz-1,mshftx)) + 103 mx = max1(0.,amin1(32767.,zz)) +c ray bovet patch to avoid small integers being set to 0 +c zz = yy + mz = yy + if (intt(zz)) go to 105 + if (mtypey .eq. 0) go to 104 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + zz = yfactr*alog10(zz)+yadd + go to 106 + 104 zz = yfactr*zz+yadd + go to 106 + 105 zz = float(ishift(mz-1,mshfty)) + 106 my = max1(0.,amin1(32767.,zz)) + return + end diff --git a/sys/gio/nspp/portlib/vector.f b/sys/gio/nspp/portlib/vector.f new file mode 100644 index 00000000..03b3bac8 --- /dev/null +++ b/sys/gio/nspp/portlib/vector.f @@ -0,0 +1,27 @@ + subroutine vector (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + xx = x + yy = y + call trans + minst = 1 + call put42 + return + end diff --git a/sys/gio/nspp/portlib/z8zpbd.f b/sys/gio/nspp/portlib/z8zpbd.f new file mode 100644 index 00000000..4392d84a --- /dev/null +++ b/sys/gio/nspp/portlib/z8zpbd.f @@ -0,0 +1,6 @@ + subroutine z8zpbd +c +c kpno: only obvious constants are initialized in this block data. +c all other initialization occurs in z8zpii. +c + end diff --git a/sys/gio/nspp/portlib/z8zpii.f b/sys/gio/nspp/portlib/z8zpii.f new file mode 100644 index 00000000..580d9968 --- /dev/null +++ b/sys/gio/nspp/portlib/z8zpii.f @@ -0,0 +1,362 @@ + subroutine z8zpii +c+kpno +c +c All data statements changed to runtime assignment statements; routine +c changed from block data to subroutine. +c +c-kpno + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c + common /nsplt1/ iclrfb ,isetfb ,ibpw ,ifwd +c +c variables use +c --------- --- +c +c mmajx,mmajy,mminx, gridal arguments stored here so they will be in a +c mminy,mxlab,mylab, known order for insertion in the instruction +c mflg stream only when ultracompact metacode is +c being produced. +c +c mtype scaling type of the most recent set call +c +c mx,my plotter address of the pen location +c +c mxa,mya,mxb,myb plotter address corresponding to the first four +c arguments of the most recent set call. +c +c mtypex,mtypey a decoding of mtype-- 0 = linear, 1 = log +c +c xxa,yya,xxb,yyb, exact copies of the first eight parameters +c xxc,yyc,xxd,yyd of the most recent set call +c +c xfactr,yfactr,xadd, numbers computed from the most recent set call +c yadd arguments so that real valued coordinates can +c be translated to integers by +c mx = xfactr*xx + xadd +c or +c mx = xfactr*alog10(xx) + xadd +c and similarly for y. +c +c xx,yy most recent coordinate input to the plot package +c +c mfmtx,mfmty,mumx, most recent labmod inputs except that mxdec = 0 +c mumy,msizx,msizy, and mydec = 0 are decoded and mxdec = 1 and +c mxdec,mydec,mxor mydec = 1 become 0. +c +c mop(i),mname(i) option names are given in mname and their +c current values in mop +c +c mxold,myold,mxmax, all used for increment instructions only. mxold +c mymax,mxfac,myfac and myold are the plotter coordinates of the +c previous point, mxmax and mymax are the greatest +c distance an increment can move, and mxfac and +c myfac are the number of plotter units per +c increment unit (generally 1, but can be more if +c compaction is important and high resolution is +c not). +c +c modef = 0 flash routines have not been used +c = 1 most recent flash call was to flash1 +c (we are between flash1 and flash2 calls +c and the instructions should be put in the +c users buffer) +c = 2 flash1 call has been closed with a +c flash2 call +c =-3 flash3 has been entered, but not exited, +c i.e., flash3 is dumping a user buffer. +c = 3 most recent flash activity is a completed +c flash3 call. +c = 4 most recent flash call was to flash4 +c +c mf2er = 0 no flash buffer overflow +c = n counts the number of times the buffer +c was reused so the required size can be +c estimated +c +c mshftx,mshfty the power of two of the ratio between the +c resolution of the metacode address and the +c resolution the user is working in. in the +c default case, the user assumes the plotter +c is 1024 by 1024 (1024 = 2 **10). metacode +c addresses have 15 bits, so their capacity is +c 32,768. thus, the default for mshftx and mshfty +c is 5, and user integer coordinates are left +c shifted 5 to make plotter addresses. +c +c mmgrx,mmgry,mmnrx, tick mark lengths (positive values point in) +c mmnry +c +c mcrout number of metacode records that have been put +c out via preout. +c +c mflcnt used to count the number of flushb calls since +c last mbprs initialization. it is used to avoid +c empty records which could otherwise be put out. +c +c mfrend frame sets to 1 to indicate last output call of a +c frame, and resets to zero before returning. +c +c mfrlst preout manipulates, based on mfrend, so that it +c knows when a record is the first of a new frame. +c +c mjxmin,mjymin, used to keep track of the range of the plotting +c mjxmax,mjymax address on the frame being created +c +c mnxsto,mnysto used to hold mjxmin,... after flash1 call, and +c mxxsto,mxysto restore them after flash2. mjxmin,... are ac- +c cumulated anew during flash saving, and stored +c in user flash buffer after flash2 call. +c +c mpair1,mpair2 two 16-bit pairs used to initialize each output +c record, so that preout may format first 32 bits. +c they are actually put into mbprs at proper times +c +c mprint unit number for printing error messages too +c extensive to be handled by uliber +c +c msybuf buffer to hold up to a few hundred metacode +c instructions +c +c msblen word length of msybuf. +c +c mncpw the number of characters per word on the host +c computer +c +c minst holds instruction op-code for the instruction +c being formed +c +c mbufa contains the address of the buffer for the +c metacode instructions, either loci(msybuf) or +c loci(user buffer) from a flash1 call +c +c mbuflu the number of words of the buffer pointed to by +c mbufa that have been filled with metacode or +c dd80 instructions +c +c mfwa,mlwa contains the first word address and the last +c word address for the flash buffers +c +c mipair,mbprs mbprs is used to store byte pairs of metacode +c until they can be packed in an integral number +c of words and placed in the buffer pointed to by +c mbufa. mipair tells how much of mbprs has been +c used. +c +c mbufl the length of the buffer pointed to by mbufa. +c +c munit unit number for writing metacode +c +c small smallest positive number on the host computer. +c this is used when nonpositive numbers are plotted +c with log scaling. +c +c + dimension mfssx(2), mfssy(2), mnsss(9) +c + data mfssx(1)/4h(e10/ + data mfssx(2)/4h.3) / + data mfssy(1)/4h(e10/ + data mfssy(2)/4h.3) / +c + data mnsss(1)/4hcase/ + data mnsss(2)/4hintn/ + data mnsss(3)/4horen/ + data mnsss(4)/4hcsiz/ + data mnsss(5)/4hfont/ + data mnsss(6)/4hdpat/ + data mnsss(7)/4hssiz/ + data mnsss(8)/4hcent/ + data mnsss(9)/4hcolr/ +c + do 10 i = 1, 2 + mfmtx(i) = mfssx(i) +10 continue + do 11 i = 1, 2 + mfmty(i) = mfssy(i) +11 continue + do 12 i = 1, 9 + mname(i) = mnsss(i) +12 continue +c +c data iclrfb/0/, isetfb/0/, ibpw/32/, ifwd/1/ + iclrfb = 0 + isetfb = 0 + ibpw = 32 + ifwd = 1 +c +c data mtype,mtypex,mtypey/1,0,0/ + mtype = 1 + mtypex = 0 + mtypey = 0 +c +c data mx,my/0,0/ + mx = 0 + my = 0 +c +c data xxa,yya,xxb,yyb/0.,0.,1.,1./ + xxa = 0.0 + yya = 0.0 + xxb = 1.0 + yyb = 1.0 +c +c data xxc,yyc,xxd,yyd/0.,0.,1.,1./ + xxc = 0.0 + yyc = 0.0 + xxd = 1.0 + yyd = 1.0 +c +c data mxa,mya,mxb,myb/1,1,32767,32767/ + mxa = 1 + mya = 32767 + mxb = 1 + mxb = 32767 +c +c data xfactr,yfactr/32767.,32767./ + xfactr = 32767. + yfactr = 32767. +c +c data xadd,yadd/1.,1./ + xadd = 1.0 + yadd = 1.0 +c +c data mumx,mumy/10,10/ + mumx = 10 + mumy = 10 +c +c data msizx,msizy/0,0/ + msizx = 0 + msizy = 0 +c +c data mxdec,mydec/655,655/ + mxdec = 655 + mydec = 655 +c +c data mxor/0/ + mxor = 0 +c +c data mop(1)/0/ +c data mop(2)/204/ +c data mop(3)/0/ +c data mop(4)/128/ +c data mop(5)/0/ +c data mop(6)/65535/ +c data mop(7)/8/ +c data mop(8)/0/ +c data mop(9)/0/ + mop(1) = 0 + mop(2) = 204 + mop(3) = 0 + mop(4) = 128 + mop(5) = 0 + mop(6) = 65535 + mop(7) = 8 + mop(8) = 0 + mop(9) = 0 +c +c data mxold,myold/-9999,-9999/ + mxold = -9999 + myold = -9999 +c +c data mxmax,mymax/31,31/ + mxmax = 31 + mymax = 31 +c +c data mxfac,myfac/1,1/ + mxfac = 1 + myfac = 1 +c +c data mmgrx,mmgry/385,385/ + mmgrx = 385 + mmgry = 385 +c +c data mmnrx,mmnry/255,255/ + mmnrx = 255 + mmnry = 255 +c +c data modef/0/ + modef = 0 +c +c data mncpw/4/ + mncpw = 4 +c +c data mbuflu/0/ + mbuflu = 0 +c +c data msblen/360/ + msblen = 360 +c +c data mbufl/360/ + mbufl = 360 +c +c data mf2er/0/ + mf2er = 0 +c +c data mshftx,mshfty/5,5/ + mshftx = 5 + mshfty = 5 +c +c data mbufa/-9999/ + mbufa = -9999 +c +c data mflcnt/0/ + mflcnt = 0 +c +c data mfrend/0/ + mfrend = 0 +c +c data mfrlst/1/ + mfrlst = 1 +c +c data mpair1/0/ + mpair1 = 0 +c +c data mpair2/8192/ + mpair2 = 8192 +c +c data mcrout/0/ + mcrout = 0 +c +c data mbprs(1)/0/ + mbprs(1) = 0 +c +c data mbprs(2)/8192/ + mbprs(2) = 8192 +c +c data mipair/2/ + mipair = 2 +c +c data mjxmax,mjymax,mjxmin,mjymin/0,0,32767,32767/ + mjxmax = 0 + mjymax = 0 + mjxmin = 32767 + mjxmin = 32767 +c +c set to unit number for printer +c +c data mprint/6/ + mprint = 6 +c +c set to unit number for plotter +c +c data munit/8/ + munit = 8 +c set to smallest positive number on the computer +c +c data small/1.e-25/ + small = 1.e-25 + end diff --git a/sys/gio/nspp/sysint/README b/sys/gio/nspp/sysint/README new file mode 100644 index 00000000..64537d9d --- /dev/null +++ b/sys/gio/nspp/sysint/README @@ -0,0 +1 @@ +SYSINT -- System interface for the Ncar System Plot Package (NSPP) diff --git a/sys/gio/nspp/sysint/encd.f b/sys/gio/nspp/sysint/encd.f new file mode 100644 index 00000000..1dba902b --- /dev/null +++ b/sys/gio/nspp/sysint/encd.f @@ -0,0 +1,78 @@ + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) +C +C +C +C +C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS +C TO BE CREATED. +C ASH SEE IOFFD. +C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE +C MAGNITUDE OF VALU IS TO BE CREATED. +C .1 .LE. ABS(VALU) .LE. 99999.49999... +C OR VALUE .EQ. 0.0. THE LABEL CREATED +C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING +C ON THE MAGNITUDE OF VALU. SEE IOUT. +C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT +C THE MAGNITUDE OF VALU IS TO BE CREATED. +C ASH IS USED AS THE NORMALIZATION FACTOR. +C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR +C VALU .EQ. 0.0. THE LABEL CREATED SHOULD +C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE +C MAGNITUDE OF ASH*VALU. SEE IOUT. +C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO +C LEADING BLANKS. SEE NC. +C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE +C 1 TO 5. +C + SAVE + CHARACTER*11 IFMT, IOUT +C +C IFMT MUST HOLD 11 CHARACTERS +C + VAL = VALU + IF (IOFFD .NE. 0) GO TO 103 + IF (VAL) 101,104,101 + 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000 + V = VAL + NS = MAX0(4,MIN0(6,LOG+2)) + ND = MIN0(3,MAX0(0,2-LOG)) +c IF (VAL.LT.0) NS = NS + 1 +c +noao: replacing ftn i/o for iraf implementation +c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')' + 102 continue +c if (len (char (ns + ichar ('0'))) .eq. 2) then +c ifmt(1:7) = '(f . )' +c ifmt(3:4) = char (ns + ichar ('0')) +c ifmt(6:6) = char (nd + ichar ('0')) +c else +c ifmt(1:6) = '(f . )' +c ifmt(3:3) = char (ns + ichar ('0')) +c ifmt(5:5) = char (nd + ichar ('0')) +c endif +c WRITE (IOUT,IFMT) V + call encode (ns, ifmt, iout, v) + NC = NS +c +noao +c The following statement was making 5 digit labels (+4800) come out +c truncated (+480) and it has been commented out. +c IF (LOG.GE.3) NC = NC - 1 +c -noao + RETURN + 103 NS = 4 + IF (VAL.LT.0.) NS=5 + IF (VAL.EQ.0.) NS=2 + ND = 0 + V = VAL*ASH + LOG = 100 + GO TO 102 + 104 iout(1:3) = '0.0' + nc = 3 +c 104 NS = 3 +c ND = 1 +c LOG = -100 +c V = 0. +c GO TO 102 +C +C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')') +C + END diff --git a/sys/gio/nspp/sysint/encode.f b/sys/gio/nspp/sysint/encode.f new file mode 100644 index 00000000..e6417bee --- /dev/null +++ b/sys/gio/nspp/sysint/encode.f @@ -0,0 +1,15 @@ + subroutine encode (nchars, ftnfmt, ftnout, rval) + + character*11 ftnfmt, ftnout + integer*2 sppfmt(12), sppout(12) + integer SZFMT + parameter (SZFMT=11) + +c unpack the fortran character string, call fencd to actually encode the +c output string, then pack the output string into a fortran string for return +c + call f77upk (ftnfmt, sppfmt, SZFMT) + call fencd (nchars, sppfmt, sppout, rval) + call f77pak (sppout, ftnout, SZFMT) + + end diff --git a/sys/gio/nspp/sysint/erprt77.f b/sys/gio/nspp/sysint/erprt77.f new file mode 100644 index 00000000..a4f60e1d --- /dev/null +++ b/sys/gio/nspp/sysint/erprt77.f @@ -0,0 +1,441 @@ +C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES +C FOLLOWS THIS PACKAGE DESCRIPTION. +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR +C HANDLING PACKAGE. +C +C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN +C THE SAME MANNER AS THEIR SIMILARLY NAMED +C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT +C FOR ROUTINE SETER, THE CALLING SEQUENCES +C OF THESE ROUTINES ARE THE SAME AS FOR +C THEIR PORT COUNTERPARTS. +C ERPRT77 ENTRY PORT ENTRY +C ------------- ---------- +C ENTSR ENTSRC +C RETSR RETSRC +C NERRO NERROR +C ERROF ERROFF +C SETER SETERR +C EPRIN EPRINT +C FDUM FDUMP +C +C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES. +C +C PRECISION NOT APPLICABLE +C +C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON +C FILES NCAR'S CRAY MACHINES. +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER, +C COLORADO BY FRED CLARE OF THE SCIENTIFIC +C COMPUTING DIVISION BY ADAPTING THE NON- +C PROPRIETARY, ERROR HANDLING ROUTINES +C FROM THE PORT LIBRARY OF BELL LABS. +C +C PORTABILITY FULLY PORTABLE +C +C REFERENCES SEE THE MANUAL +C PORT MATHEMATICAL SUBROUTINE LIBRARY +C ESPECIALLY "ERROR HANDLING" IN SECTION 2 +C OF THE INTRODUCTION, AND THE VARIOUS +C SUBROUTINE DESCRIPTIONS. +C ****************************************************************** +C +C SUBBROUTINE ENTSR(IROLD,IRNEW) +C +C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND +C SETS A NEW ONE. IT ALSO CHECKS THE ERROR +C STATE, AND IF THERE IS AN ACTIVE ERROR +C STATE A MESSAGE IS PRINTED. +C +C USAGE CALL ENTSR(IROLD,IRNEW) +C +C ARGUMENTS +C +C ON INPUT IRNEW +C VALUE SPECIFIED BY USER FOR ERROR +C RECOVERY +C = 0 LEAVES RECOVERY UNCHANGED +C = 1 GIVES RECOVERY +C = 2 TURNS RECOVERY OFF +C +C ON OUTPUT IROLD +C RECEIVES THE CURRENT VALUE OF THE ERROR +C RECOVERY MODE +C +C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE +C MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IRNEW. +C 2 - CALLED WHILE IN AN ERROR STATE. +C ****************************************************************** +C +C SUBROUTINE RETSR(IROLD) +C +C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN +C BY THE INPUT ARGUMENT. A TEST IS THEN MADE +C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH +C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN +C ERROR MESSAGE AND TERMINATES THE RUN. +C +C BY CONVENTION, RETSR IS USED UPON EXIT +C FROM A SUBROUTINE TO RESTORE THE PREVIOUS +C RECOVERY MODE STATUS STORED BY ROUTINE +C ENTSR IN IROLD. +C +C USAGE CALL RETSR(IROLD) +C +C ARGUMENTS +C +C ON INPUT IROLD +C = 1 SETS FOR RECOVERY +C = 2 SETS FOR NONRECOVERY +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE, +C THE MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IROLD. +C ****************************************************************** +C +C INTEGER FUNCTION NERRO(NERR) +C +C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY) +C OR ZERO IF THE PROGRAM IS NOT IN THE +C ERROR STATE. +C +C USAGE N = NERRO(NERR) +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NERR +C CURRENT VALUE OF THE ERROR NUMBER +C ****************************************************************** +C SUBROUTINE ERROF +C +C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE +C ERROR NUMBER TO ZERO +C +C USAGE CALL ERROF +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE SETER(MESSG,NERR,IOPT) +C +C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING +C ON THE OPTIONS STATED BELOW, PRINTS A +C MESSAGE AND PROVIDES A DUMP. +C +C +C USAGE CALL SETER(MESSG,NERR,IOPT) +C +C ARGUMENTS +C +C ON INPUT MESSG +C HOLLERITH STRING CONTAINING THE MESSAGE +C ASSOCIATED WITH THE ERROR +C +C NERR +C THE NUMBER TO ASSIGN TO THE ERROR +C +C IOPT +C = 1 FOR A RECOVERABLE ERROR +C = 2 FOR A FATAL ERROR +C +C IF IOPT = 1 AND THE USER IS IN ERROR +C RECOVERY MODE, SETERR SIMPLY REMEMBERS +C THE ERROR MESSAGE, SETS THE ERROR NUMBER +C TO NERR, AND RETURNS. +C +C IF IOPT = 1 AND THE USER IS NOT IN ERROR +C RECOVERY MODE, SETERR PRINTS THE ERROR +C MESSAGE AND TERMINATES THE RUN. +C +C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR +C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN. +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT +C TO ANY VALUE OTHER THAN 1 OR 2. +C ****************************************************************** +C +C SUBROUTINE EPRIN +C +C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE +C PROGRAM IS IN THE ERROR STATE; OTHERWISE +C NOTHING IS PRINTED. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE FDUM +C +C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES +C AS A PLACEHOLDER FOR A SYMBOLIC DUMP +C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO +C PROVIDE SUCH A ROUTINE. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** + SUBROUTINE ENTSR(IROLD,IRNEW) +C + LOGICAL TEMP + IF (IRNEW.LT.0 .OR. IRNEW.GT.2) + 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2) +C + TEMP = IRNEW.NE.0 + IROLD = I8SAV(2,IRNEW,TEMP) +C +C IF HAVE AN ERROR STATE, STOP EXECUTION. +C + IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER + 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2) +C + RETURN +C + END + SUBROUTINE RETSR(IROLD) +C + IF (IROLD.LT.1 .OR. IROLD.GT.2) + 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2) +C + ITEMP=I8SAV(2,IROLD,.TRUE.) +C +C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. +C + IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + END + INTEGER FUNCTION NERRO(NERR) +C + NERRO=I8SAV(1,0,.FALSE.) + NERR=NERRO + RETURN +C + END + SUBROUTINE ERROF +C + I=I8SAV(1,0,.TRUE.) + RETURN +C + END + SUBROUTINE SETER(MESSG,NERR,IOPT) +C + CHARACTER*(*) MESSG + COMMON /UERRF/IERF +C +C THE UNIT FOR ERROR MESSAGES IS I1MACH(4) +C +c +noao: blockdata uerrbd changed to runtime initialization subroutine +C FORCE LOAD OF BLOCKDATA +C +c EXTERNAL UERRBD + call uerrbd +c -noao + IF (IERF .EQ. 0) THEN + IERF = I1MACH(4) + ENDIF +C + NMESSG = LEN(MESSG) + IF (NMESSG.GE.1) GO TO 10 +C +C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9000) +c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.') + call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80) +c -noao + GO TO 60 +C + 10 CONTINUE + IF (NERR.NE.0) GO TO 20 +C +C CANNOT TURN THE ERROR STATE OFF USING SETER. +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9001) +c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/ +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/) + call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80) + call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80) +c -noao + CALL E9RIN(MESSG,NERR,.TRUE.) + ITEMP=I8SAV(1,1,.TRUE.) + GO TO 50 +C +C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. +C + 20 CONTINUE + IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30 +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9002) +c9002 FORMAT(' ERROR 3 IN SETER -', +c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'// +c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///) + call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80) + call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80) +c -noao + CALL EPRIN + CALL E9RIN(MESSG,NERR,.TRUE.) + GO TO 50 +C +C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. +C + 30 CALL E9RIN(MESSG,NERR,.TRUE.) +C + IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 +C +C MUST HAVE IOPT = 1 OR 2. +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9003) +c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'// +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) + call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80) + call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80) +c -noao + GO TO 50 +C +C TEST FOR RECOVERY. +C + 40 CONTINUE + IF (IOPT.EQ.2) GO TO 50 +C + IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + 50 CALL EPRIN + 60 CALL FDUM +c STOP +C + END + SUBROUTINE EPRIN +C + CHARACTER*1 MESSG +C + CALL E9RIN(MESSG,1,.FALSE.) + RETURN +C + END + SUBROUTINE E9RIN(MESSG,NERR,SAVE) +C +C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, +C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . +C + CHARACTER*(*) MESSG + CHARACTER*113 MESSGP + LOGICAL SAVE + COMMON /UERRF/IERF +C +C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE +C +C +C START WITH NO PREVIOUS MESSAGE. +C +c+noao +c Moved save to before data statements. + SAVE MESSGP,NERRP +c-noao + DATA MESSGP/'1'/ + DATA NERRP/0/ +C + IF (.NOT.SAVE) GO TO 20 +C +C SAVE THE MESSAGE. +C + NERRP=NERR + MESSGP = MESSG +C + GO TO 30 +C + 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30 +C +C PRINT THE MESSAGE. +C +c +noao: FTN write rewritten as call to uliber +c WRITE(IERF,9000) NERRP,MESSGP +c9000 FORMAT(' ERROR ',I4,' IN ',A113) + call uliber (nerrp, messgp, 113) +C + 30 RETURN +C + END + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) +C +C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C +C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C + LOGICAL SET +C +C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. +C +c+noao +c Moved save to before data statement. + SAVE LERROR,LRECOV + DATA LERROR/0/ , LRECOV/2/ +c-noao + IF (ISW .EQ. 1) THEN + I8SAV = LERROR + IF (SET) LERROR = IVALUE + ELSE IF (ISW .EQ. 2) THEN + I8SAV = LRECOV + IF (SET) LRECOV = IVALUE + ENDIF + RETURN + END + SUBROUTINE FDUM +C +C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED +C + RETURN + END +c +noao: Blockdata uerrbd rewritten as a runtime initialization subroutine +c BLOCKDATA UERRBD + subroutine uerrbd +c + COMMON /UERRF/IERF +C DEFAULT ERROR UNIT +c DATA IERF/0/ + IERF= 0 + END +c -noao diff --git a/sys/gio/nspp/sysint/fencode.x b/sys/gio/nspp/sysint/fencode.x new file mode 100644 index 00000000..fe3e37ed --- /dev/null +++ b/sys/gio/nspp/sysint/fencode.x @@ -0,0 +1,79 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_FORMAT 11 + +# FENCD -- Format a real variable and return as a spp character string. +# A packed format string is passed as an input argument to define how the +# number is to be encoded. The format of the format string is: +# format string = "(cW.D)" +# where c is one of [EFGI], and where W and D are the field width and +# number of decimal places or precision, respectively. + +procedure fencd (nchars, f_format, spp_outstr, rval) + +int nchars # desired number of output chars +char f_format[SZ_FORMAT+1] # SPP string containing format +char spp_outstr[SZ_FORMAT+1] # SPP string containing encoded number +real rval # value to be encoded + +char fmtchar, outstr[MAX_DIGITS], spp_format[SZ_FORMAT+1] +int ip, op, stridx() +real x + +begin + # Encode format string for SPRINTF, format "%w.d". Start copying + # Fortran format at char 3, which should follow the EFGI char. + + spp_format[1] = '%' + op = 2 + + if (f_format[1] != '(') + call fatal (1, "Missing lparen in Ncar ENCODE format") + for (ip=3; f_format[ip] != ')' && f_format[ip] != EOS; ip=ip+1) { + spp_format[op] = f_format[ip] + op = op + 1 + } + + # Now add the SPP format character. EFG are the same for sprintf as + # as for Fortran. The integer format is 'd' for decimal in SPP. + + fmtchar = f_format[2] + if (IS_UPPER(fmtchar)) + fmtchar = TO_LOWER (fmtchar) + + switch (fmtchar) { + case 'e', 'f', 'g': + spp_format[op] = fmtchar + case 'i': + spp_format[op] = 'd' + default: + call fatal (1, "Unknown Ncar ENCODE format code") + } + op = op + 1 + spp_format[op] = EOS + x = rval + if (rval > 0) + x = -x + + # Now encode the user supplied variable and return it as a spp + # string. + + iferr { + call sprintf (outstr, MAX_DIGITS, spp_format) + call pargr (x) + } then + call erract (EA_FATAL) + + # Let's try adding a "+" prefix to positive numbers to set if that + # makes nicer plots. + + op = stridx ('-', outstr) + if (rval > 0 && op > 0) + outstr[op] = '+' + + call strcpy (outstr, spp_outstr, SZ_LINE) +end diff --git a/sys/gio/nspp/sysint/fulib.x b/sys/gio/nspp/sysint/fulib.x new file mode 100644 index 00000000..1951f26c --- /dev/null +++ b/sys/gio/nspp/sysint/fulib.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FULIB -- Print an error message processed by fortran routine uliber. + +procedure fulib (errcode, upkmsg, msglen) + +int errcode +char upkmsg[ARB] # unpacked string +int msglen # number of chars in string + +pointer sp, sppmsg + +begin + call smark (sp) + call salloc (sppmsg, SZ_LINE, TY_CHAR) + + # Construct error message string + call sprintf (Memc[sppmsg], SZ_LINE, "ERROR %d IN %s\n") + call pargi (errcode) + call pargstr (upkmsg) + + # Call error with the constructed message + iferr (call error (errcode, Memc[sppmsg])) + call erract (EA_WARN) + + call sfree (sp) +end diff --git a/sys/gio/nspp/sysint/intt.x b/sys/gio/nspp/sysint/intt.x new file mode 100644 index 00000000..315248fd --- /dev/null +++ b/sys/gio/nspp/sysint/intt.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# INTT -- Test whether the argument is an integer (return true) or a real +# (return false). This works, hopefully, because legal NCAR metacode integers +# are always less than 2 ** 15, while real numbers will always appear to be +# large positive or negative integers. + +bool procedure intt (value) + +int value + +begin + return (value > 0 && value < INTT_TESTVAL) +end diff --git a/sys/gio/nspp/sysint/ishift.x b/sys/gio/nspp/sysint/ishift.x new file mode 100644 index 00000000..580996c0 --- /dev/null +++ b/sys/gio/nspp/sysint/ishift.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ISHIFT -- integer shift. To be used for calls to ISHIFT in NCAR routines. + +int procedure ishift (in_word, n) + +int in_word, n +int new_word, bit, index, i +int bitupk() + +begin + if (n > NBITS_INT) + call error (0, "n > NBITS_INT in ishift") + if (n < 0) + # Right end-off shift + new_word = bitupk (in_word, abs(n) + 1, NBITS_INT - abs(n)) + else { + # Left circular shift (rotate) + do i = 1, NBITS_INT { + index = n + i + if (index > NBITS_INT) + index = mod ((n + i), NBITS_INT) + bit = bitupk (in_word, i, 1) + call bitpak (bit, new_word, index, 1) + } + } + + return (new_word) +end + + +# IAND -- AND two integers. + +int procedure iand (a, b) + +int a, b +int and() + +begin + return (and (a, b)) +end + + +# IOR -- OR two integers. + +int procedure ior (a, b) + +int a, b +int or() + +begin + return (or (a, b)) +end diff --git a/sys/gio/nspp/sysint/loc.x b/sys/gio/nspp/sysint/loc.x new file mode 100644 index 00000000..59e509b5 --- /dev/null +++ b/sys/gio/nspp/sysint/loc.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# LOCI -- Return the zero-indexed offset of the argument in the user address +# space, in integer units. In other words, if A is an integer array, +# { loci(a[2]) - loci(a[1]) } is exactly one. +# +# NOTE -- The original NSPP (portlib) code called this function LOC, however, +# the Sun-4 Fortran compiler has an intrinsic function of the same name which +# behaves slightly differently, hence the name was changed to LOCI. + +int procedure loci (x) + +int x +int xaddr + +begin + # ZLOCVA returns the address of the variable in units of XCHAR. + + call zlocva (x, xaddr) + return (xaddr / SZ_INT) +end diff --git a/sys/gio/nspp/sysint/mcswap.x b/sys/gio/nspp/sysint/mcswap.x new file mode 100644 index 00000000..eb9cee7d --- /dev/null +++ b/sys/gio/nspp/sysint/mcswap.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MCSWAP -- Swap the instructions in a metacode array. + +procedure mcswap (a, npix) + +int a[npix] +int npix +int i, temp + +begin + do i = 1, npix, 2 { + temp = a[i] + a[i] = a[i+1] + a[i+1] = temp + } +end diff --git a/sys/gio/nspp/sysint/mkpkg b/sys/gio/nspp/sysint/mkpkg new file mode 100644 index 00000000..b00eb46e --- /dev/null +++ b/sys/gio/nspp/sysint/mkpkg @@ -0,0 +1,24 @@ +# Make the system interface modules for libnspp.a. + +$checkout libnspp.a lib$ +$update libnspp.a +$checkin libnspp.a lib$ +$exit + +libnspp.a: + encd.f + encode.f + erprt77.f + fencode.x + fulib.x + intt.x + ishift.x + loc.x + mcswap.x + ncgchr.x + ncpchr.x + packum.x nspp.com + perror.x + q8qst4.f + uliber.f + ; diff --git a/sys/gio/nspp/sysint/ncgchr.x b/sys/gio/nspp/sysint/ncgchr.x new file mode 100644 index 00000000..5cf40b22 --- /dev/null +++ b/sys/gio/nspp/sysint/ncgchr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NCGCHR -- Get a single character (byte) from a packed array. Return +# a blank if the index is out of bounds. + +procedure ncgchr (ichars, len_ichars, index, char_value) + +int ichars[ARB] # packed character array +int len_ichars # length of the array +int index # index of char to be extracted +int char_value # return value + +char ch + +begin + if (index < 1 || index > len_ichars) + char_value = ' ' + else { + call chrupk (ichars, index, ch, 1, 1) + char_value = ch + } +end diff --git a/sys/gio/nspp/sysint/ncpchr.x b/sys/gio/nspp/sysint/ncpchr.x new file mode 100644 index 00000000..4312068d --- /dev/null +++ b/sys/gio/nspp/sysint/ncpchr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NCPCHR -- Put a single character (byte) into a packed array. Do nothing if +# the index is out of bounds. + +procedure ncpchr (ichars, len_ichars, index, char_value) + +int ichars[ARB] # packed character array +int len_ichars # length of the array +int index # index of char to be set +int char_value # value to be stored + +char ch[1] + +begin + if (index >= 1 && index <= len_ichars) { + ch[1] = char_value + call chrpak (ch, 1, ichars, index, 1) + } +end diff --git a/sys/gio/nspp/sysint/nspp.com b/sys/gio/nspp/sysint/nspp.com new file mode 100644 index 00000000..e3cac846 --- /dev/null +++ b/sys/gio/nspp/sysint/nspp.com @@ -0,0 +1,40 @@ +# NSPP.COM -- The nspp system plot package common block. + +int mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab +int mflg ,mtype ,mxa ,mya ,mxb ,myb +int mx ,my ,mtypex ,mtypey +real xxa ,yya , xxb ,yyb ,xxc ,yyc +real xxd ,yyd , xfactr ,yfactr ,xadd ,yadd +real xx ,yy + +# XX declared integer some places in nspp code !!! +# on a VAX this works, but what if float not same size as int ??? + +int mfmtx[3] ,mfmty[3] ,mumx ,mumy +int msizx ,msizy ,mxdec ,mydec ,mxor ,mop[19] +int mname[19] ,mxold ,myold ,mxmax ,mymax +int mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty +int mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst +int mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin +int mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto +int mxysto ,mprint ,msybuf[360] ,mncpw ,minst +int mbufa ,mbuflu ,mfwa[12] ,mlwa[12] +int mipair ,mbprs[16] ,mbufl ,munit ,mbswap + +real small + +common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab, + mflg ,mtype ,mxa ,mya ,mxb ,myb, + mx ,my ,mtypex ,mtypey ,xxa ,yya, + xxb ,yyb ,xxc ,yyc ,xxd ,yyd, + xfactr ,yfactr ,xadd ,yadd ,xx ,yy, + mfmtx ,mfmty ,mumx ,mumy, + msizx ,msizy ,mxdec ,mydec ,mxor ,mop, + mname ,mxold ,myold ,mxmax ,mymax, + mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty, + mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst, + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin, + mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto, + mxysto ,mprint ,msybuf ,mncpw ,minst, + mbufa ,mbuflu ,mfwa ,mlwa, + mipair ,mbprs ,mbufl ,munit ,mbswap ,small diff --git a/sys/gio/nspp/sysint/packum.x b/sys/gio/nspp/sysint/packum.x new file mode 100644 index 00000000..7991658c --- /dev/null +++ b/sys/gio/nspp/sysint/packum.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PACKUM -- Pack an integer array containing 16 bit quantities into a buffer. +# Each 16 bit input datum occupies one integer; the input integers may be +# any size. This implementation will work on most byte oriented machines, +# but will generate a fatal error on machines with 24, 60, etc. bit words. + +procedure packum (a, npix, bp) + +int a[ARB] # input array, one 16-bit datum per word +int npix # number of mc words +int bp # LOC pointer to output buffer + +int offset, dummy[1] +int loci() +include "nspp.com" + +begin + offset = bp - loci (dummy) + 1 + + # It is necessary to swap the order of the metacode words on some + # machines. Npix is always an even number. The swapping must be + # done here because the NSPP and MCTR code assumes that the bytes + # are ordered in a certain manner (most significant first). Thus, + # when the buffer is flushed FLUSHB will set the magic bits, and + # if we wait and swap upon output rather than here, it will set the + # bits in the wrong word. + + if (mbswap == YES) # flag set from graphcap in nsppkern + call mcswap (a, npix) + + switch (NBITS_MCWORD) { + case NBITS_SHORT: + call achtis (a, dummy[offset], npix) + case NBITS_INT: + call amovi (a, dummy[offset], npix) + default: + call fatal (1, "gio.ncar.packum: cannot pack metacode") + } +end diff --git a/sys/gio/nspp/sysint/perror.x b/sys/gio/nspp/sysint/perror.x new file mode 100644 index 00000000..6c1cb85b --- /dev/null +++ b/sys/gio/nspp/sysint/perror.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PERROR -- Fatal error in NSPP. + +procedure perror() + +begin + call fatal (0, "Fatal error in Ncar system plot package") +end diff --git a/sys/gio/nspp/sysint/q8qst4.f b/sys/gio/nspp/sysint/q8qst4.f new file mode 100644 index 00000000..0b8ca796 --- /dev/null +++ b/sys/gio/nspp/sysint/q8qst4.f @@ -0,0 +1,24 @@ + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) +C +C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH +C INFORMATION ABOUT THE CIRCUMSTANCES OF A +C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING +C TAPE FOR LATER PROCESSING. +C +C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE +C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH +C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT +C MONITORS USE OF NCAR ROUTINES WITH LOCAL +C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL +C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE +C DELETED FROM ALL NSSL ROUTINES. +C + CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION +C + RETURN + END diff --git a/sys/gio/nspp/sysint/uliber.f b/sys/gio/nspp/sysint/uliber.f new file mode 100644 index 00000000..7dba302e --- /dev/null +++ b/sys/gio/nspp/sysint/uliber.f @@ -0,0 +1,14 @@ + subroutine uliber (errcode, pkerrmsg, msglen) + + character*80 pkerrmsg + integer errcode, msglen + integer*2 sppmsg(81) + integer SZLINE + parameter (SZLINE=80) + +c unpack the fortran character string, call fulib to output the string. +c + call f77upk (pkerrmsg, sppmsg, SZLINE) + call fulib (errcode, sppmsg, msglen) + + end diff --git a/sys/gio/nsppkern/README b/sys/gio/nsppkern/README new file mode 100644 index 00000000..0990eac0 --- /dev/null +++ b/sys/gio/nsppkern/README @@ -0,0 +1,399 @@ +This directory contains the source for the NSPP/GIO kernel, the interface +between GIO and the old Ncar system plot package and associated metacode +translators. + +Special graphcap entries used by this kernel: + + MF maximum frame count per metafile + FS frame advance req'd at start of metafile + FE frame advance req'd at end of metafile + +Rev 1.0 installed in March 1985. +---------------------------------------------------------------------------- + +Differences between Rev 1.0 and Rev 1.1 of the NSPP/GIO kernel. +Collated at installation of Rev 1.1 on 24 April 1985. +---------------------------------------------------------------------------- + +gktclose.x ++ diff gktclose.x ../nsppkern.old/gktclose.x +12,13d11 +< call frame +< call gkt_flush ++ echo gktclosews.x +gktinit.x ++ diff gktinit.x ../nsppkern.old/gktinit.x +49a50,59 +> # get the window offsets +> +> g_xoff = ttygeti (tty, "XO") +> if (g_xoff < 0) +> g_xoff = 0 +> g_yoff = ttygeti (tty, "YO") +> if (g_yoff < 0) +> g_yoff = 0 +> +> +112d121 +< GKT_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) +gktopenws.x ++ diff gktopenws.x ../nsppkern.old/gktopenws.x +98,104c98,99 +< if (mode == NEW_FILE) { +< # Frame call only if NEW_FILE and not first time open with +< # this device. This prevents frame before first data. +< if (!need_open) +< call frame +< call gkt_reset +< } +--- +> if (mode == NEW_FILE) +> call frame() ++ echo gktpcell.x +gktpcell.x ++ diff gktpcell.x ../nsppkern.old/gktpcell.x +8a9 +> +12c13 +< procedure gkt_putcellarray (m, nc, nr, ax1,ay1, ax2,ay2) +--- +> procedure gkt_putcellarray (m, nc, nr, x1,y1, x2,y2) +17,18c18,19 +< int ax1, ay1 # lower left corner of output window +< int ax2, ay2 # upper right corner of output window +--- +> int x1, y1 # lower left corner of output window +> int x2, y2 # upper right corner of output window +20d20 +< int x1,y1,x2,y2 # device coordinates +22c22 +< int nx, ny, y +--- +> int nx, ny +28c28 +< bool ca, use_orig, new_row, pr +--- +> bool ca, use_orig, new_row +31,32d30 +< real delta_y +< int xrep, yrep +43c41 +< # Determine if can do real cell array. If not, use character +--- +> # determine if can do real cell array. If not, use character +49d46 +< pr = false +53d49 +< pr = (GKT_PIXREP(g_kt) != 0) +65,66c61 +< # Input arguments (ax, ay) refer to corners of put cell array; +< # we need corners of the corresponding device array. +--- +> # find out how many real pixels we have to fill +68,73c63,66 +< x1 = ax1 +< x2 = ax2 +< y1 = ay1 +< y2 = ay2 +< call adjust(x1,x2,xres) +< call adjust(y1,y2,yres) +--- +> px1 = real(x1)/GKI_MAXNDC +> py1 = real(y1)/GKI_MAXNDC +> px2 = real(x2)/GKI_MAXNDC +> py2 = real(y2)/GKI_MAXNDC +75,79c68,69 +< # Find out how many real pixels we have to fill +< px1 = real(x1)/(GKI_MAXNDC+1) +< py1 = real(y1)/(GKI_MAXNDC+1) +< px2 = real(x2)/(GKI_MAXNDC+1) +< py2 = real(y2)/(GKI_MAXNDC+1) +--- +> nx = int( (px2 - px1) * (xres-1.0) + 1.5 ) +> ny = int( (py2 - py1) * (yres-1.0) + 1.5 ) +81,90c71 +< nx = int( px2 * xres ) - int( px1 * xres ) + 1 +< ny = int( py2 * yres ) - int( py1 * yres ) + 1 +< +< if ( ny > 1) +< delta_y = (real(y2) - real(y1))/ny +< else { +< delta_y = 0. +< } +< +< # If too many data points in input, set skip. If skip is close +--- +> # if too many data points in input, set skip. If skip is close +92,93c73,74 +< # Set block replication factors - will be > 1.0 if too few input points. +< # Cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have +--- +> # set block replication factors - will be > 1.0 if too few input points. +> # cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have +110c91,101 +< # Allocate storage for a row of pixels. This is quite inefficient +--- +> +> # try for the simplest case: 1:1 match with input data +> +> if ( ca && (nx == nc) && (ny == nr) ) { +> call pixels( real(x1)/GKI_MAXNDC, real(y1)/GKI_MAXNDC, +> nx, ny, m) +> call sfree(sp) +> return +> } +> +> # allocate storage for a row of pixels. This is quite inefficient +113d103 +< # need nx+1 in case nx odd ... pixels() wants to pad output. +115,116c105 +< call salloc ( cell, nx+1, TY_SHORT) +< Mems[cell + nx] = 0 +--- +> call salloc ( cell, nx, TY_SHORT) +118c107 +< # Initialize counters +--- +> # initialize counters +125c114 +< # See if we can use original data ... no massaging +--- +> # see if we can use original data ... no massaging +128c117 +< # Note that if blockx > 1.0, skip_x must be 1.0, and vv +--- +> # note that if blockx > 1.0, skip_x must be 1.0, and vv +138,152c127 +< # If device can pixel replicate, use that feature where we can +< if( pr) { +< if( (skip_x == 1.0) && ( int(blockx) == blockx) ) { +< xrep = int(blockx) +< use_orig = true +< nx = nc +< } else +< xrep = 1 +< if( (skip_y == 1.0) && ( int(blocky) == blocky) ) { +< yrep = int(blocky) +< ny = 1 +< } else +< yrep = 1 +< } +< call pixel0(1,0,xrep,0,1,yrep) +--- +> # do it +154c129 +< # Do it +--- +> for (i = 1; i <= ny; i = i + 1) { +156c131 +< for ( i = 1; i <= ny ; i = i + 1) { +--- +> # Build the row data. +158,159d132 +< # Build the row data +< +161c134 +< if ( skip_x == 1.0) { +--- +> if ( skip_x == 1.0) +163c136 +< } else { +--- +> else { +181d153 +< y = y1 + ((i - 1)*delta_y + 0.5) +183,184c155,159 +< call pixels( px1, real(y)/GKI_MAXNDC, +< nx, 1, m[element]) +--- +> if ( i == 1 ) +> call pixelr( real(x1)/GKI_MAXNDC, real(y1)/GKI_MAXNDC, +> nx, ny, m[element]) +> else +> call pixeli( 0., 0., nx, 1, m[element]) +186c161,165 +< call pixels( px1, real(y)/GKI_MAXNDC, nx, 1, Mems[cell]) +--- +> if ( i == 1 ) +> call pixelr( real(x1)/GKI_MAXNDC, real(y1)/GKI_MAXNDC, +> nx, ny, Mems[cell]) +> else +> call pixeli( 0., 0., nx, 1, Mems[cell]) +188,189c167 +< } +< else +--- +> } else +192c170 +< # Advance a row +--- +> # Advance a row. +206c184 +< # All done, restore text parameters and release storage +--- +> # all done, restore text parameters and release storage +209c187 +< call restoretx (txsave,tx) +--- +> call restoretx(txsave,tx) +212a191 +> +218d196 +< pointer savep, txp +219a198 +> pointer savep, txp +254a234 +> +258d237 +< pointer savep, txp +259a239 +> pointer savep, txp +263c243 +< # Restore values +--- +> # restore values +283a264 +> +287c268,269 +< procedure fakepc (indata, outdata, nx, scale) +--- +> procedure fakepc( indata, outdata, nx, scale) +> +298c280 +< data cdata /' ', '.', ':', '|', 'i', 'l', 'J', 'm', '#', 'S', 'B', EOS/ +--- +> data cdata /' ', '.', ':', '|', 'i', 'l', 'J', 'm', '#', 'S', 'B', EOS/ +330,374d311 +< end +< +< # ADJUST -- round/truncate putcell array corners to device coordinates +< # move up lower bound if it is above center point of device cell, +< # move down upper bound if below. Don't allow bounds to go beyond +< # resolution or below zero. Do not allow bounds to cross. Part of the +< # assumptions behind all this is that putcells will be continguous and +< # rows/columns must not be plotted twice. +< +< procedure adjust ( lower, upper, res) +< +< int lower, upper +< real res +< +< real factor +< real low, up +< +< begin +< factor = res/(GKI_MAXNDC+1) +< low = real(lower) * factor +< up = real(upper) * factor +< +< # if boundaries result in same row, return +< if ( int(low) == int(up) ) +< return +< +< # if low is in upper half of device pixel, round up +< if ( (low - int(low)) >= 0.5 ) { +< low = int(low) + 1 +< # don't go to or beyond upper bound +< if ( low < up ) { +< # ... 0.2 just for "rounding protection"; +< lower = (low + 0.2)/factor +< # if now reference same cell, return +< if ( int(low) == int(up) ) +< return +< } +< } +< +< # if "up" in bottom half of pixel, drop down one. Note that +< # due to two "==" tests above, upper will not drop below lower. +< # 0.2 means drop partway down into pixel below; calling code will +< # truncate. +< if ( (up - int(up)) < 0.5 ) +< upper = real(int(up) - 0.2)/factor ++ echo gktpl.x +gktpl.x ++ diff gktpl.x ../nsppkern.old/gktpl.x +51,52c51,52 +< x = p[1] +< y = p[2] +--- +> x = p[1] + g_xoff +> y = p[2] + g_yoff +58,59c58,59 +< x = p[i] +< y = p[i+1] +--- +> x = p[i] + g_xoff +> y = p[i+1] + g_yoff +gktpm.x ++ diff gktpm.x ../nsppkern.old/gktpm.x +48,49c48,49 +< x = p[1] +< y = p[2] +--- +> x = p[1] + g_xoff +> y = p[2] + g_yoff +63,64c63,64 +< x = p[i] +< y = p[i+1] +--- +> x = p[i] + g_xoff +> y = p[i+1] + g_yoff ++ echo gktpmset.x +gkttx.x ++ diff gkttx.x ../nsppkern.old/gkttx.x +109,110c109,110 +< call pwrity (real(x)/GKI_MAXNDC, +< real(y)/GKI_MAXNDC, Memc[pstring], seglen, +--- +> call pwrity (real(x+g_xoff)/GKI_MAXNDC, +> real(y+g_yoff)/GKI_MAXNDC, Memc[pstring], seglen, +_____________________________________________________________________________ + +25Apr85 gktpl.x + Call to optn to set line width changed to set option "inten" instead + of "spot size", which was not changing the line width. + +26Apr85 gktpm.x + Same change as one to gktpl.x + + Character size as used in gkttx.x is a floating point number, but + NCAR pwry.f uses an integer value -- the conversion was causing + centering errors as gkttx.x would calculate a "path length" for + the text based on one size, and pwry.f would use a different size + to generate the text. Changed pwry.f to use a floating point + size as an input variable, changed gkttx.x to send same. + + gktpcell.x + Moved pixel0 call inside the "if (pr) {" statment, where it should + have been. + + graphcap + Added "pr" capablility flag to dicomed entry. Changed character + height to reflect the 9 to 8 ratio that pwry uses. + + +--------------------------------------------------------------------------- +Rev 1.2 10 May 1985 Dct. + +Fairly extensive modifications made to minimize the number of frame calls +and metafiles generated. Redundant CLEAR calls or clear calls immediately +after open workstation are ignored. Multiple frames are permitted in a +metafile (formerly the metafile was disposed after each frame). Graphcap +parameters were added to control automatic frame advances at the beginning +and end of metafiles. + +--------------------------------------------------------------------------- +Rev 1.3 1 June 1985 Dct. + +[1] Fixed a bug in polymarker; was drawing polylines. + +[2] Replaced the old character generation code by all new code, using the stroke +table from the NCAR/GKS code. Replaced "pwry.f" by the much simpler +"gktdrawch.x". Largely copied the stdgraph "stgtx.x", including the clipping +logic therein. + +17-Aug-85 Dct. + Added support for the new DD graphcap parameter, used to pass device + dependent information to the device driver. This information was + formerly encoded in a table at compile time, with the table defined + in . diff --git a/sys/gio/nsppkern/font.com b/sys/gio/nsppkern/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/nsppkern/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/nsppkern/font.h b/sys/gio/nsppkern/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/sys/gio/nsppkern/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/nsppkern/gkt.com b/sys/gio/nsppkern/gkt.com new file mode 100644 index 00000000..828b39bb --- /dev/null +++ b/sys/gio/nsppkern/gkt.com @@ -0,0 +1,17 @@ +# GKTRANS common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_kt # kernel transform graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in, g_out # input, output files +int g_xres, g_yres # desired device resolution +char g_device[SZ_GDEVICE] # force output to named device + +common /gktcom/ g_kt, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_out, g_xres, g_yres, g_device diff --git a/sys/gio/nsppkern/gkt.h b/sys/gio/nsppkern/gkt.h new file mode 100644 index 00000000..09ab7b80 --- /dev/null +++ b/sys/gio/nsppkern/gkt.h @@ -0,0 +1,75 @@ +# GKTRANS definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_MFRECORD (1440/SZB_CHAR) # metafile record size +define SZ_GDEVICE 31 # maxsize forced device name +define DEF_MAXFRAMES 16 # maximum frames/metafile + +# The GKTRANS state/device descriptor. + +define LEN_GKT 81 + +define GKT_SBUF Memi[$1] # string buffer +define GKT_SZSBUF Memi[$1+1] # size of string buffer +define GKT_NEXTCH Memi[$1+2] # next char pos in string buf +define GKT_NCHARSIZES Memi[$1+3] # number of character sizes +define GKT_POLYLINE Memi[$1+4] # device supports polyline +define GKT_POLYMARKER Memi[$1+5] # device supports polymarker +define GKT_FILLAREA Memi[$1+6] # device supports fillarea +define GKT_CELLARRAY Memi[$1+7] # device supports cell array +define GKT_ZRES Memi[$1+8] # device resolution in Z +define GKT_FILLSTYLE Memi[$1+9] # number of fill styles +define GKT_ROAM Memi[$1+10] # device supports roam +define GKT_ZOOM Memi[$1+11] # device supports zoom +define GKT_SELERASE Memi[$1+12] # device has selective erase +define GKT_PIXREP Memi[$1+13] # device supports pixel replic. +define GKT_STARTFRAME Memi[$1+14] # frame advance at metafile BOF +define GKT_ENDFRAME Memi[$1+15] # frame advance at metafile EOF + # extra space +define GKT_CURSOR Memi[$1+20] # last cursor accessed +define GKT_COLOR Memi[$1+21] # last color set +define GKT_TXSIZE Memi[$1+22] # last text size set +define GKT_TXFONT Memi[$1+23] # last text font set +define GKT_TYPE Memi[$1+24] # last line type set +define GKT_WIDTH Memi[$1+25] # last line width set +define GKT_DEVNAME Memi[$1+26] # name of open device + # extra space +define GKT_CHARHEIGHT Memi[$1+30+$2-1] # character height +define GKT_CHARWIDTH Memi[$1+40+$2-1] # character width +define GKT_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define GKT_PLAP ($1+60) # polyline attributes +define GKT_PMAP ($1+64) # polymarker attributes +define GKT_FAAP ($1+68) # fill area attributes +define GKT_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/nsppkern/gktcancel.x b/sys/gio/nsppkern/gktcancel.x new file mode 100644 index 00000000..17679f89 --- /dev/null +++ b/sys/gio/nsppkern/gktcancel.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_CANCEL -- Cancel any buffered output. + +procedure gkt_cancel (dummy) + +int dummy # not used at present +include "gkt.com" + +begin + if (g_kt == NULL) + return + + # First we cancel any output in the FIO stream, then + # flush the nspp buffers. This might, of course, + # put something in the FIO stream, so we cancel again. + # note the Fortran escape for "flush"...spp has a reserved + # word of the same name. + + call fseti (g_out, F_CANCEL, OK) +% call mcflsh + call fseti (g_out, F_CANCEL, OK) + call gkt_reset() +end diff --git a/sys/gio/nsppkern/gktclear.x b/sys/gio/nsppkern/gktclear.x new file mode 100644 index 00000000..4132d371 --- /dev/null +++ b/sys/gio/nsppkern/gktclear.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure gkt_clear (dummy) + +int dummy # not used at present + +int gkt_mfopen() +errchk gkt_mfopen +include "gkt.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_kt == NULL || g_ndraw == 0) + return + + # Start a new frame. This is done either by calling NSPP to do a frame + # advance or by starting a new metafile. Close the output file and + # start a new metafile if the maximum frame count has been reached. + # This disposes of the metafile to the system, causing the actual + # plots to be drawn. Open a new metafile ready to receive next frame. + + g_nframes = g_nframes + 1 + if (g_nframes >= g_maxframes) { + + # Does this device require a frame advance at end of metafile? + if (GKT_ENDFRAME(g_kt) == YES) + call frame() + + # The call to the NSPP flush procedure must be escaped to avoid + # interpretation as the FIO flush procedure. + +% call mcflsh + + g_nframes = 0 + call close (g_out) + + g_out = gkt_mfopen (g_tty, NEW_FILE) + + # Does this device require a frame advance at beginning of metafile? + if (GKT_STARTFRAME(g_kt) == YES) + call frame() + + } else { + # Merely output NSPP frame instruction to start a new frame in + # the same metafile. + + call frame() + } + + # Init kernel data structures. + call gkt_reset() + g_ndraw = 0 +end diff --git a/sys/gio/nsppkern/gktclose.x b/sys/gio/nsppkern/gktclose.x new file mode 100644 index 00000000..9ab73c34 --- /dev/null +++ b/sys/gio/nsppkern/gktclose.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_CLOSE -- Close the nspp translation kernel. Close the spool file so +# the output is finally plotted. Free up storage. + +procedure gkt_close() + +include "gkt.com" + +begin + # If there is anything in the metafile, flush it and add a frame + # advance if required for the device. + + if (g_ndraw > 0 || g_nframes > 0) { + # Does this device require a frame advance at end of metafile? + if (GKT_ENDFRAME(g_kt) == YES) + call frame() + + # The call to the NSPP flush procedure must be escaped to avoid + # interpretation as the FIO flush procedure. + +% call mcflsh + } + + # Close output metafile, disposing of it to the host system. + call close (g_out) + + # Free kernel data structures. + call mfree (GKT_SBUF(g_kt), TY_CHAR) + call mfree (g_kt, TY_STRUCT) + + g_kt = NULL +end diff --git a/sys/gio/nsppkern/gktclws.x b/sys/gio/nsppkern/gktclws.x new file mode 100644 index 00000000..27889c7c --- /dev/null +++ b/sys/gio/nsppkern/gktclws.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_CLOSEWS -- Close the named workstation. Flush the output. +# The spool file is closed only on the next plot or at gktclose time. +# If the spool file is closed here, APPEND mode would not work. + +procedure gkt_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +include "gkt.com" + +begin + call gkt_flush (0) +end diff --git a/sys/gio/nsppkern/gktcolor.x b/sys/gio/nsppkern/gktcolor.x new file mode 100644 index 00000000..7d24368a --- /dev/null +++ b/sys/gio/nsppkern/gktcolor.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# nspp particulars +# colors +define BLACK 1 +define WHITE 2 +define RED 3 +define GREEN 4 +define BLUE 5 + +# GKT_COLOR set the color option in the nspp world + +procedure gkt_color(index) + +int index # index for color switch statement +include "gkt.com" + +begin + switch (index) { + case WHITE: + call optn (*"co", *"white") + case RED: + call optn (*"co", *"red") + case GREEN: + call optn (*"co", *"green") + case BLUE: + call optn (*"co", *"blue") + default: + call optn (*"co", *"black") + } +end diff --git a/sys/gio/nsppkern/gktdrawch.x b/sys/gio/nsppkern/gktdrawch.x new file mode 100644 index 00000000..dd7dbeb1 --- /dev/null +++ b/sys/gio/nsppkern/gktdrawch.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# GKT_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure gkt_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +real px, py, sx, sy, coso, sino, theta +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call gkt_font (font) + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + sx = x + px * coso + py * sino + sy = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call frstpt (sx / GKI_MAXNDC, sy / GKI_MAXNDC) + else + call vector (sx / GKI_MAXNDC, sy / GKI_MAXNDC) + } +end diff --git a/sys/gio/nsppkern/gktescape.x b/sys/gio/nsppkern/gktescape.x new file mode 100644 index 00000000..ad8ff494 --- /dev/null +++ b/sys/gio/nsppkern/gktescape.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GKt_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The nspp kernel does not have any escape functions at present. + +procedure gkt_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +begin +end diff --git a/sys/gio/nsppkern/gktfa.x b/sys/gio/nsppkern/gktfa.x new file mode 100644 index 00000000..4df21260 --- /dev/null +++ b/sys/gio/nsppkern/gktfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_FILLAREA -- Fill a closed area. + +procedure gkt_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "gkt.com" + +begin + # Not implemented yet. + call gkt_polyline (p, npts) +end diff --git a/sys/gio/nsppkern/gktfaset.x b/sys/gio/nsppkern/gktfaset.x new file mode 100644 index 00000000..f5851cb9 --- /dev/null +++ b/sys/gio/nsppkern/gktfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_FASET -- Set the fillarea attributes. + +procedure gkt_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "gkt.com" + +begin + fa = GKT_FAAP(g_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/nsppkern/gktflush.x b/sys/gio/nsppkern/gktflush.x new file mode 100644 index 00000000..decb5300 --- /dev/null +++ b/sys/gio/nsppkern/gktflush.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_FLUSH -- Flush output. + +procedure gkt_flush (dummy) + +int dummy # not used at present +include "gkt.com" + +begin + # Since the NSPP devices are not interactive, calls to FLUSH + # are ignored. +end diff --git a/sys/gio/nsppkern/gktfont.x b/sys/gio/nsppkern/gktfont.x new file mode 100644 index 00000000..cbcb9f90 --- /dev/null +++ b/sys/gio/nsppkern/gktfont.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# GKT_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set GKT_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure gkt_font (font) + +int font # code for font to be set +int pk1, pk2, width +include "gkt.com" + +begin + pk1 = GKI_PACKREAL(1.0) + pk2 = GKI_PACKREAL(2.0) + + width = GKT_WIDTH(g_kt) + + if (font == GT_BOLD) { + if (width != pk2) { + call optn (*"inten", *"high") + width = pk2 + } + } else { + if (GKI_UNPACKREAL(width) > 1.5) { + call optn (*"inten", *"low") + width = pk1 + } + } + + GKT_WIDTH(g_kt) = width +end diff --git a/sys/gio/nsppkern/gktgcell.x b/sys/gio/nsppkern/gktgcell.x new file mode 100644 index 00000000..197bf018 --- /dev/null +++ b/sys/gio/nsppkern/gktgcell.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GKT_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkt_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. +end diff --git a/sys/gio/nsppkern/gktinit.x b/sys/gio/nsppkern/gktinit.x new file mode 100644 index 00000000..78ae0840 --- /dev/null +++ b/sys/gio/nsppkern/gktinit.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +# GKT_INIT -- Initialize the gkt data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine GKT_RESET initializes the attribute +# packets when the frame is flushed. + +procedure gkt_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "gkt.com" +include "nspp.com" +int pow2() + +begin + # Allocate the gkt descriptor and the string buffer. + if (g_kt == NULL) { + call calloc (g_kt, LEN_GKT, TY_STRUCT) + call malloc (GKT_SBUF(g_kt), SZ_SBUF, TY_CHAR) + } + + # Get the maximum frame count and the flags controlling frame advance + # at start and end of metafile (NSPP parameters). + + g_maxframes = ttygeti (tty, "MF") + if (g_maxframes == 0) + g_maxframes = DEF_MAXFRAMES + GKT_STARTFRAME(g_kt) = btoi (ttygetb (tty, "FS")) + GKT_ENDFRAME(g_kt) = btoi (ttygetb (tty, "FE")) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + GKT_SZSBUF(g_kt) = SZ_SBUF + GKT_NEXTCH(g_kt) = GKT_SBUF(g_kt) + 1 + Memc[GKT_SBUF(g_kt)] = EOS + + # Get the device resolution from the graphcap entry. + + g_xres = ttygeti (tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_yres = ttygeti (tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + + # Set up coordinate transformations. + + call seti (pow2(g_xres), pow2(g_yres)) + call set (0., 1., 0., 1., 0., 1., 0., 1., 1) + call z8zpii() + + # Set byteswap flag for output metacode. + mbswap = btoi (ttygetb (tty, "BS")) + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + # ... not relevant for nspp, but leave here anyway for now + + GKT_NCHARSIZES(g_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = GKT_NEXTCH(g_kt) + + if (GKT_NCHARSIZES(g_kt) <= 0) { + GKT_NCHARSIZES(g_kt) = 1 + GKT_CHARSIZE(g_kt,1) = 1.0 + GKT_CHARHEIGHT(g_kt,1) = char_height + GKT_CHARWIDTH(g_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= GKT_NCHARSIZES(g_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + GKT_CHARSIZE(g_kt,i) = char_size + GKT_CHARHEIGHT(g_kt,i) = char_height * char_size + GKT_CHARWIDTH(g_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the gkt + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + GKT_POLYLINE(g_kt) = btoi (ttygetb (tty, "pl")) + GKT_POLYMARKER(g_kt) = btoi (ttygetb (tty, "pm")) + GKT_FILLAREA(g_kt) = btoi (ttygetb (tty, "fa")) + GKT_FILLSTYLE(g_kt) = ttygeti (tty, "fs") + GKT_ROAM(g_kt) = btoi (ttygetb (tty, "ro")) + GKT_ZOOM(g_kt) = btoi (ttygetb (tty, "zo")) + GKT_ZRES(g_kt) = ttygeti (tty, "zr") + GKT_CELLARRAY(g_kt) = btoi (ttygetb (tty, "ca")) + GKT_SELERASE(g_kt) = btoi (ttygetb (tty, "se")) + GKT_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + GKT_CURSOR(g_kt) = 1 + + # Save the device string in the descriptor. + nextch = GKT_NEXTCH(g_kt) + GKT_DEVNAME(g_kt) = nextch + maxch = GKT_SBUF(g_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + GKT_NEXTCH(g_kt) = nextch +end + + +# GKT_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure gkt_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "gkt.com" + +begin + nextch = GKT_NEXTCH(g_kt) + maxch = GKT_SBUF(g_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = GKT_SBUF(g_kt) + + GKT_NEXTCH(g_kt) = nextch + return (strp) +end + + +# POW2 -- Return the integer base two exponent of the first power of two +# greater than the argument. The technique is to use successive one bit +# shift rights to determine the index of the leftmost one-bit. + +int procedure pow2 (num) + +int num +int bitshift, n, pow + +begin + bitshift = 0 + for (n=max(1,num); n > 0; n=n/2) + bitshift = bitshift + 1 + pow = bitshift - 1 + + if (num > 2 ** pow) + return (pow + 1) + else + return (pow) +end diff --git a/sys/gio/nsppkern/gktline.x b/sys/gio/nsppkern/gktline.x new file mode 100644 index 00000000..08318c91 --- /dev/null +++ b/sys/gio/nsppkern/gktline.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_LINETYPE -- Set the line type option in the nspp world. + +procedure gkt_linetype (index) + +int index # index for line type switch statement + +int linetype +include "gkt.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 0FF00X + case GL_DOTTED: + linetype = 08888X + case GL_DOTDASH: + linetype = 0F040X + default: + linetype = 0FFFFX # GL_SOLID and default + } + + call optn (*"dp", linetype) +end diff --git a/sys/gio/nsppkern/gktmfopen.x b/sys/gio/nsppkern/gktmfopen.x new file mode 100644 index 00000000..97ab92f9 --- /dev/null +++ b/sys/gio/nsppkern/gktmfopen.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +define SZ_DDSTR 256 + + +# GKT_MFOPEN -- Open the NSPP metacode output file. The device is connected +# to FIO as a binary file. Metacode output to the device will be spooled +# and then disposed of to the device when the file descriptor we return is +# later closed. + +int procedure gkt_mfopen (tty, mode) + +pointer tty # pointer to graphcap entry for device +int mode # access mode + +int fd +pointer sp, ddstr +int fopnbf(), ttygets() +extern zopnpl(), zardpl(), zawrpl(), zawtpl(), zsttpl(), zclspl() +errchk fopnbf + +begin + call smark (sp) + call salloc (ddstr, SZ_DDSTR, TY_CHAR) + + # The DD string is used to pass device dependent information to the + # NSPP graphics device driver. + + if (ttygets (tty, "DD", Memc[ddstr], SZ_DDSTR) <= 0) + call error (1, "nsppkern: missing DD parameter in graphcap") + + fd = fopnbf (Memc[ddstr], mode, + zopnpl, zardpl, zawrpl, zawtpl, zsttpl, zclspl) + + # Set the FIO buffer size to the size of a metafile record. + call fseti (fd, F_BUFSIZE, SZ_MFRECORD) + + call sfree (sp) + return (fd) +end diff --git a/sys/gio/nsppkern/gktopen.x b/sys/gio/nsppkern/gktopen.x new file mode 100644 index 00000000..41e3b19a --- /dev/null +++ b/sys/gio/nsppkern/gktopen.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_OPEN -- Install the nspp kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure gkt_open (devname, dd) + +char devname[ARB] # nonnull for forced output to a device +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern gkt_openws(), gkt_closews(), gkt_clear(), gkt_cancel() +extern gkt_flush(), gkt_polyline(), gkt_polymarker(), gkt_text() +extern gkt_fillarea(), gkt_putcellarray(), gkt_plset() +extern gkt_pmset(), gkt_txset(), gkt_faset() +extern gkt_escape() +include "gkt.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_kt = NULL + g_nframes = 0 + g_ndraw = 0 + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (gkt_openws) + dd[GKI_CLOSEWS] = locpr (gkt_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (gkt_clear) + dd[GKI_CANCEL] = locpr (gkt_cancel) + dd[GKI_FLUSH] = locpr (gkt_flush) + dd[GKI_POLYLINE] = locpr (gkt_polyline) + dd[GKI_POLYMARKER] = locpr (gkt_polymarker) + dd[GKI_TEXT] = locpr (gkt_text) + dd[GKI_FILLAREA] = locpr (gkt_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (gkt_putcellarray) + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (gkt_plset) + dd[GKI_PMSET] = locpr (gkt_pmset) + dd[GKI_TXSET] = locpr (gkt_txset) + dd[GKI_FASET] = locpr (gkt_faset) + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (gkt_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call gkt_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/nsppkern/gktopenws.x b/sys/gio/nsppkern/gktopenws.x new file mode 100644 index 00000000..2ef91e3d --- /dev/null +++ b/sys/gio/nsppkern/gktopenws.x @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +# GKT_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure gkt_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +int gkt_mfopen() +bool need_open, same_dev + +include "gkt.com" +include "nspp.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_kt != NULL) { + same_dev = (streq (Memc[GKT_DEVNAME(g_kt)], Memc[buf])) + if (!same_dev) { + # Does this device require a frame advance at end of metafile? + if (GKT_ENDFRAME(g_kt) == YES) + call frame() + call close (g_out) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if (!same_dev) { + if (g_kt != NULL) + call ttycdes (g_tty) + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + + # Initialize data structures if we had to open a new device. + call gkt_init (g_tty, Memc[buf]) + call gkt_reset() + } + + # Open the output file. The device is connected to FIO as a + # binary file. Metacode output to the device will be spooled + # and then disposed of to the device at CLOSEWS time. + + iferr (g_out = gkt_mfopen (g_tty, mode)) { + call ttycdes (g_tty) + call erract (EA_ERROR) + } else { + # Does this device require a frame advance at start of metafile? + if (GKT_STARTFRAME(g_kt) == YES) + call frame() + g_nframes = 0 + g_ndraw = 0 + } + + # Initialize output file descriptor in nspp common. + munit = g_out + } + + # Clear the screen if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will clear + # the screen if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call gkt_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/nsppkern/gktpcell.x b/sys/gio/nsppkern/gktpcell.x new file mode 100644 index 00000000..e7e0ca4a --- /dev/null +++ b/sys/gio/nsppkern/gktpcell.x @@ -0,0 +1,383 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# Number of grey scale symbols +define NSYMBOL 11 +define TSIZE (1.0/2.0) + +# GKT_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkt_putcellarray (m, nc, nr, ax1,ay1, ax2,ay2) + +short m[ARB] # cell array +int nc, nr # number of pixels in X and Y + # (number of columns[x], rows[y] +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +int x1,y1,x2,y2 # device coordinates +real px1, py1, px2, py2 +int nx, ny, y +real skip_x, skip_y, sx, sy +real blockx, blocky, bcy +int i, j, startrow, element +real xres, yres +pointer sp, cell, tx, txsave +bool ca, use_orig, new_row, pr +real z_scale +real charheight, charwidth +real delta_y +int xrep, yrep + +include "gkt.com" + +begin + call smark(sp) + + # Keep track of the number of drawing instructions since the last frame + # clear. + + g_ndraw = g_ndraw + 1 + + skip_x = 1.0 + skip_y = 1.0 + blockx = 1.0 + blocky = 1.0 + + # Determine if can do real cell array. If not, use character + # sized boxes as pixels. In that case, we need to save all + # the character attributes since we will want to force default + # character size, orientation, etc. + + ca = (GKT_CELLARRAY(g_kt) != 0) + pr = false + if ( ca ) { + xres = real(g_xres) + yres = real(g_yres) + pr = (GKT_PIXREP(g_kt) != 0) + } else { + charwidth = real(GKT_CHARWIDTH(g_kt,1))*TSIZE + charheight = real(GKT_CHARHEIGHT(g_kt,1))*TSIZE + xres = real(GKI_MAXNDC)/ charwidth + yres = real(GKI_MAXNDC)/ charheight + z_scale = 1.0 / sqrt ( real(max(NSYMBOL, GKT_ZRES(g_kt))) ) + tx = GKT_TXAP(g_kt) + call salloc(txsave, LEN_TX, TY_INT) + call savetx(txsave,tx) + } + + # Input arguments (ax, ay) refer to corners of put cell array; + # we need corners of the corresponding device array. + + x1 = ax1 + x2 = ax2 + y1 = ay1 + y2 = ay2 + call adjust(x1,x2,xres) + call adjust(y1,y2,yres) + + # Find out how many real pixels we have to fill + px1 = real(x1)/(GKI_MAXNDC+1) + py1 = real(y1)/(GKI_MAXNDC+1) + px2 = real(x2)/(GKI_MAXNDC+1) + py2 = real(y2)/(GKI_MAXNDC+1) + + nx = int( px2 * xres ) - int( px1 * xres ) + 1 + ny = int( py2 * yres ) - int( py1 * yres ) + 1 + + if ( ny > 1) + delta_y = (real(y2) - real(y1))/ny + else { + delta_y = 0. + } + + # If too many data points in input, set skip. If skip is close + # enough to one, set it to one. + # Set block replication factors - will be > 1.0 if too few input points. + # Cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have + # enough points and so *some* have to be replicated. + + if ( nc > nx ) { + skip_x = real(nc)/nx + if ( (skip_x - 1.0)*(nx-1) < 1.0 ) + skip_x = 1.0 + } else + blockx = real(nx)/nc + + if ( nr > ny ) { + skip_y = real(nr)/ny + if ( (skip_y - 1.0)*(ny-1) < 1.0 ) + skip_y = 1.0 + } else + blocky = real(ny)/nr + + # Allocate storage for a row of pixels. This is quite inefficient + # if the x dimension of the cell array is small, but the metacode + # won't be too much bigger (?). + # need nx+1 in case nx odd ... pixels() wants to pad output. + + call salloc ( cell, nx+1, TY_SHORT) + Mems[cell + nx] = 0 + + # Initialize counters + + sy = skip_y + bcy = blocky + startrow = 1 + element = startrow + + # See if we can use original data ... no massaging + # also set the initial value of the new_row flag, which tells + # if we have to rebuild the row data + # Note that if blockx > 1.0, skip_x must be 1.0, and vv + + if ( (skip_x == 1.0) && (blockx == 1.0) ) { + use_orig = true + new_row = false + } else { + use_orig = false + new_row = true + } + + # If device can pixel replicate, use that feature where we can + if( pr) { + if( (skip_x == 1.0) && ( int(blockx) == blockx) ) { + xrep = int(blockx) + use_orig = true + nx = nc + } else + xrep = 1 + if( (skip_y == 1.0) && ( int(blocky) == blocky) ) { + yrep = int(blocky) + ny = 1 + } else + yrep = 1 + call pixel0(1,0,xrep,0,1,yrep) + } + + # Do it + + for ( i = 1; i <= ny ; i = i + 1) { + + # Build the row data + + if ( !use_orig && new_row ) { + if ( skip_x == 1.0) { + call blockit(m[element], Mems[cell], nx, blockx) + } else { + sx = skip_x + for ( j = 1; j <= nx; j = j + 1) { + Mems[cell+j-1] = m[element] + element = startrow + int(sx+0.5) + sx = sx + skip_x + } + } + if ( !ca ) + if ( use_orig) + call fakepc(m[element], Mems[cell], nx, z_scale) + else + call fakepc(Mems[cell], Mems[cell], nx, z_scale) + } + + # Send the row data. + + if ( ca ) { + y = y1 + ((i - 1)*delta_y + 0.5) + if ( use_orig ) { + call pixels( px1, real(y)/GKI_MAXNDC, + nx, 1, m[element]) + } else { + call pixels( px1, real(y)/GKI_MAXNDC, nx, 1, Mems[cell]) + } + } + else + call gkt_text( x1, y1+(i-1)*int(charheight), Mems[cell], nx) + + # Advance a row + + element = startrow + if ( bcy <= real(i) ) { + startrow = 1 + nc * int(sy+0.5) + element = startrow + sy = sy + skip_y + bcy = bcy + blocky + new_row = true + } else { + new_row = false + } + } + + # All done, restore text parameters and release storage + + if ( !ca ) + call restoretx (txsave,tx) + call sfree(sp) +end + +# SAVETX --- save the current text parameters as pointed to by "txp" +# in the area pointed to by "savep", and then set the necessary +# defaults. + +procedure savetx (savep, txp) +pointer savep, txp + +include "gkt.com" + +begin + # save old values + + TX_UP(savep) = TX_UP(txp) + TX_SIZE(savep) = TX_SIZE(txp) + TX_PATH(savep) = TX_PATH(txp) + TX_HJUSTIFY(savep) = TX_HJUSTIFY(txp) + TX_VJUSTIFY(savep) = TX_VJUSTIFY(txp) + TX_FONT(savep) = TX_FONT(txp) + TX_COLOR(savep) = TX_COLOR(txp) + TX_SPACING(savep) = TX_SPACING(txp) + + # set new (default) ones + + TX_UP(txp) = 90 + TX_SIZE(txp) = GKI_PACKREAL(TSIZE) + TX_PATH(txp) = GT_RIGHT + TX_HJUSTIFY(txp)= GT_LEFT + TX_VJUSTIFY(txp)= GT_BOTTOM + TX_FONT(txp) = GT_ROMAN + TX_COLOR(txp) = 1 + TX_SPACING(txp) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + GKT_TYPE(g_kt) = -1 + GKT_WIDTH(g_kt) = -1 + GKT_COLOR(g_kt) = -1 + GKT_TXSIZE(g_kt) = -1 + GKT_TXFONT(g_kt) = -1 +end + +# RESTORETX --- restore the text parameters from the save area + +procedure restoretx (savep, txp) +pointer savep, txp + +include "gkt.com" + +begin + # Restore values + + TX_UP(txp) = TX_UP(savep) + TX_SIZE(txp) = TX_SIZE(savep) + TX_PATH(txp) = TX_PATH(savep) + TX_HJUSTIFY(txp) = TX_HJUSTIFY(savep) + TX_VJUSTIFY(txp) = TX_VJUSTIFY(savep) + TX_FONT(txp) = TX_FONT(savep) + TX_COLOR(txp) = TX_COLOR(savep) + TX_SPACING(txp) = TX_SPACING(savep) + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + GKT_TYPE(g_kt) = -1 + GKT_WIDTH(g_kt) = -1 + GKT_COLOR(g_kt) = -1 + GKT_TXSIZE(g_kt) = -1 + GKT_TXFONT(g_kt) = -1 +end + +# FAKEPC --- fake putcell output by using appropriately chosen text +# characters to make grey scale. + +procedure fakepc (indata, outdata, nx, scale) +int nx # number of points in row +short indata[ARB] # input row data +short outdata[ARB] # output row data +real scale # intensity scaling factor + +include "gkt.com" + +int i +real temp +char cdata[NSYMBOL] # characters to represent intensity +data cdata /' ', '.', ':', '|', 'i', 'l', 'J', 'm', '#', 'S', 'B', EOS/ + +begin + # + for ( i = 1 ; i <= nx ; i = i + 1 ) { + temp = sqrt( max(0., real(indata[i])) ) + outdata[i] = cdata[ min( NSYMBOL, int(NSYMBOL*scale*temp)+1 ) ] + } +end + +# BLOCKIT -- block replication of data + +procedure blockit( from, to, count, factor) + +short from[ARB] # input data +short to[ARB] # output data +int count # number of output pixels +real factor # blocking factor + +int i, j +real bc + +begin + bc = factor + j = 1 + for ( i = 1; i <= count ; i = i + 1 ) { + to[i] = from[j] + if ( bc <= real(i) ) { + j = j + 1 + bc = bc + factor + } + } +end + +# ADJUST -- round/truncate putcell array corners to device coordinates +# move up lower bound if it is above center point of device cell, +# move down upper bound if below. Don't allow bounds to go beyond +# resolution or below zero. Do not allow bounds to cross. Part of the +# assumptions behind all this is that putcells will be continguous and +# rows/columns must not be plotted twice. + +procedure adjust ( lower, upper, res) + +int lower, upper +real res + +real factor +real low, up + +begin + factor = res/(GKI_MAXNDC+1) + low = real(lower) * factor + up = real(upper) * factor + + # if boundaries result in same row, return + if ( int(low) == int(up) ) + return + + # if low is in upper half of device pixel, round up + if ( (low - int(low)) >= 0.5 ) { + low = int(low) + 1 + # don't go to or beyond upper bound + if ( low < up ) { + # ... 0.2 just for "rounding protection"; + lower = (low + 0.2)/factor + # if now reference same cell, return + if ( int(low) == int(up) ) + return + } + } + + # if "up" in bottom half of pixel, drop down one. Note that + # due to two "==" tests above, upper will not drop below lower. + # 0.2 means drop partway down into pixel below; calling code will + # truncate. + if ( (up - int(up)) < 0.5 ) + upper = real(int(up) - 0.2)/factor +end diff --git a/sys/gio/nsppkern/gktpl.x b/sys/gio/nsppkern/gktpl.x new file mode 100644 index 00000000..7e7243cf --- /dev/null +++ b/sys/gio/nsppkern/gktpl.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure gkt_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int i, len_p +int x,y +include "gkt.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = GKT_PLAP(g_kt) + + if (GKT_TYPE(g_kt) != PL_LTYPE(pl)) { + call gkt_linetype (PL_LTYPE(pl)) + GKT_TYPE(g_kt) = PL_LTYPE(pl) + } + if (GKT_WIDTH(g_kt) != PL_WIDTH(pl)) { + if (GKI_UNPACKREAL(PL_WIDTH(pl)) < 1.5) + call optn (*"inten", *"low") + else + call optn (*"inten", *"high") + GKT_WIDTH(g_kt) = PL_WIDTH(pl) + } + if (GKT_COLOR(g_kt) != PL_COLOR(pl)) { + call gkt_color (PL_COLOR(pl)) + GKT_COLOR(g_kt) = PL_COLOR(pl) + } + + # Transform the first point from GKI coords to nspp coords and + # move to the transformed point. + + x = p[1] + y = p[2] + call frstpt(real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + + # Draw the polyline. + + for (i=3; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call vector (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + } +end diff --git a/sys/gio/nsppkern/gktplset.x b/sys/gio/nsppkern/gktplset.x new file mode 100644 index 00000000..9342fccc --- /dev/null +++ b/sys/gio/nsppkern/gktplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure gkt_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "gkt.com" + +begin + pl = GKT_PLAP(g_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/nsppkern/gktpm.x b/sys/gio/nsppkern/gktpm.x new file mode 100644 index 00000000..fe6a9a0a --- /dev/null +++ b/sys/gio/nsppkern/gktpm.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# Nspp particulars. +define BASELW 8 # base width of line + + +# GKT_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure gkt_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int x, y, oldx, oldy +include "gkt.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = GKT_PMAP(g_kt) + + if (GKT_TYPE(g_kt) != PM_LTYPE(pm)) { + call gkt_linetype (PM_LTYPE(pm)) + GKT_TYPE(g_kt) = PM_LTYPE(pm) + } + if (GKT_WIDTH(g_kt) != PM_WIDTH(pm)) { + if (GKI_UNPACKREAL(PM_WIDTH(pm)) < 1.5) + call optn (*"inten", *"low") + else + call optn (*"inten", *"high") + GKT_WIDTH(g_kt) = PM_WIDTH(pm) + } + if (GKT_COLOR(g_kt) != PM_COLOR(pm)) { + call gkt_color (PM_COLOR(pm)) + GKT_COLOR(g_kt) = PM_COLOR(pm) + } + + # Get to start of marker. + call frstpt (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + oldx = 0; oldy = 0 + + # Draw the polymarker. + for (i=1; i <= len_p; i=i+2) { + x = p[i]; y = p[i+1] + if (x != oldx && y != oldy) + call point (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + oldx = x; oldy = y + } +end diff --git a/sys/gio/nsppkern/gktpmset.x b/sys/gio/nsppkern/gktpmset.x new file mode 100644 index 00000000..8a3ebe24 --- /dev/null +++ b/sys/gio/nsppkern/gktpmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_PMSET -- Set the polymarker attributes. + +procedure gkt_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "gkt.com" + +begin + pm = GKT_PMAP(g_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/nsppkern/gktreset.x b/sys/gio/nsppkern/gktreset.x new file mode 100644 index 00000000..6e34cec4 --- /dev/null +++ b/sys/gio/nsppkern/gktreset.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# GKT_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure gkt_reset() + +pointer pl, pm, fa, tx +include "gkt.com" + +begin + # Set pointers to attribute substructures. + pl = GKT_PLAP(g_kt) + pm = GKT_PMAP(g_kt) + fa = GKT_FAAP(g_kt) + tx = GKT_TXAP(g_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + GKT_TYPE(g_kt) = -1 + GKT_WIDTH(g_kt) = -1 + GKT_COLOR(g_kt) = -1 + GKT_TXSIZE(g_kt) = -1 + GKT_TXFONT(g_kt) = -1 + + # Reset the nspp common. + + call z8zpii() + + # If cellarray allowed, reset pixel size to standard one. + + if (GKT_CELLARRAY(g_kt) != 0) + call pixel0 (1,0,1,0,1,1) +end diff --git a/sys/gio/nsppkern/gkttx.x b/sys/gio/nsppkern/gkttx.x new file mode 100644 index 00000000..7aaf3c31 --- /dev/null +++ b/sys/gio/nsppkern/gkttx.x @@ -0,0 +1,428 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# GKT_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure gkt_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen +pointer sp, seg, ip, op, tx, first +int stx_segment() +include "gkt.com" + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = GKT_TXAP(g_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by gkt_txset, and is just a scaling factor. + + GKT_TXSIZE(g_kt) = TX_SIZE(tx) + if (TX_COLOR(tx) != GKT_COLOR(g_kt)) { + call gkt_color (TX_COLOR(tx)) + GKT_COLOR(g_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line, and invalidate last setting. + call gkt_linetype (GL_SOLID) + GKT_TYPE(g_kt) = -1 + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, gki_dx,gki_dy, polytext, + orien) + + # For nspp, have 32767 sizes, so just scale the the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = GKT_CHARHEIGHT(g_kt,1) * tsz + cw = GKT_CHARWIDTH(g_kt,1) * tsz + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call gkt_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "gkt.com" + +begin + tx = GKT_TXAP(g_kt) + + # Get character sizes in GKI(NSPP) coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = GKT_CHARHEIGHT(g_kt,1) * sz + cw = GKT_CHARWIDTH(g_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/nsppkern/gkttxset.x b/sys/gio/nsppkern/gkttxset.x new file mode 100644 index 00000000..28ed1d32 --- /dev/null +++ b/sys/gio/nsppkern/gkttxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# GKT_TXSET -- Set the text drawing attributes. + +procedure gkt_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "gkt.com" + +begin + tx = GKT_TXAP(g_kt) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/nsppkern/mkpkg b/sys/gio/nsppkern/mkpkg new file mode 100644 index 00000000..e9f92d6e --- /dev/null +++ b/sys/gio/nsppkern/mkpkg @@ -0,0 +1,56 @@ +# Make the NSPPKERN GIO graphics kernel. Requires LIBNSPP. Requires +# a host system metacode translation task for each device. + +$checkout libgkt.a lib$ +$update libgkt.a +$checkin libgkt.a lib$ +$call relink +$exit + +update: # update lib$x_nsppkern.e + $call relink + $call install + ; + +relink: # make x_nsppkern.e in local directory + $omake writeb.x gkt.h gkt.com + $omake x_nsppkern.x + $link x_nsppkern.o writeb.o -lgkt -lnspp + ; + +install: # install in system library + $move x_nsppkern.e bin$ + ; + +libgkt.a: + gktcancel.x gkt.com gkt.h + gktclear.x gkt.com gkt.h + gktclose.x gkt.com gkt.h + gktclws.x gkt.h gkt.com + gktcolor.x gkt.com gkt.h + gktdrawch.x font.com font.h gkt.h + gktescape.x + gktfa.x gkt.com gkt.h + gktfaset.x gkt.com gkt.h + gktflush.x gkt.com gkt.h + gktfont.x gkt.com gkt.h + gktgcell.x + gktinit.x gkt.com gkt.h nspp.com + gktline.x gkt.com gkt.h + gktmfopen.x gkt.h + gktopen.x gkt.com gkt.h + gktopenws.x gkt.com gkt.h nspp.com + gktpcell.x gkt.com gkt.h + gktpl.x gkt.com gkt.h + gktplset.x gkt.com gkt.h + gktpm.x gkt.com gkt.h + gktpmset.x gkt.com gkt.h + gktreset.x gkt.com gkt.h + gkttx.x gkt.com gkt.h + gkttxset.x gkt.com gkt.h + pixel0.f + pixels.f + t_nsppkern.x + tran16.f + writeb.x gkt.h gkt.com + ; diff --git a/sys/gio/nsppkern/nspp.com b/sys/gio/nsppkern/nspp.com new file mode 100644 index 00000000..e3cac846 --- /dev/null +++ b/sys/gio/nsppkern/nspp.com @@ -0,0 +1,40 @@ +# NSPP.COM -- The nspp system plot package common block. + +int mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab +int mflg ,mtype ,mxa ,mya ,mxb ,myb +int mx ,my ,mtypex ,mtypey +real xxa ,yya , xxb ,yyb ,xxc ,yyc +real xxd ,yyd , xfactr ,yfactr ,xadd ,yadd +real xx ,yy + +# XX declared integer some places in nspp code !!! +# on a VAX this works, but what if float not same size as int ??? + +int mfmtx[3] ,mfmty[3] ,mumx ,mumy +int msizx ,msizy ,mxdec ,mydec ,mxor ,mop[19] +int mname[19] ,mxold ,myold ,mxmax ,mymax +int mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty +int mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst +int mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin +int mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto +int mxysto ,mprint ,msybuf[360] ,mncpw ,minst +int mbufa ,mbuflu ,mfwa[12] ,mlwa[12] +int mipair ,mbprs[16] ,mbufl ,munit ,mbswap + +real small + +common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab, + mflg ,mtype ,mxa ,mya ,mxb ,myb, + mx ,my ,mtypex ,mtypey ,xxa ,yya, + xxb ,yyb ,xxc ,yyc ,xxd ,yyd, + xfactr ,yfactr ,xadd ,yadd ,xx ,yy, + mfmtx ,mfmty ,mumx ,mumy, + msizx ,msizy ,mxdec ,mydec ,mxor ,mop, + mname ,mxold ,myold ,mxmax ,mymax, + mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty, + mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst, + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin, + mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto, + mxysto ,mprint ,msybuf ,mncpw ,minst, + mbufa ,mbuflu ,mfwa ,mlwa, + mipair ,mbprs ,mbufl ,munit ,mbswap ,small diff --git a/sys/gio/nsppkern/pixel0.f b/sys/gio/nsppkern/pixel0.f new file mode 100644 index 00000000..df42b150 --- /dev/null +++ b/sys/gio/nsppkern/pixel0.f @@ -0,0 +1,58 @@ + subroutine pixel0(dx1,dy1,n1,dx2,dy2,n2) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + data ipixop / 10/ + mbpair = ior(ishift(ior(192, ipixop), 8), 12) + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = dx1 + yy = dy1 + call dtran16 + mx1 = mx + mbpair = mx + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + my1=my + mbpair=my + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=n1 + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = dx2 + yy = dy2 + call dtran16 + mbpair=mx + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=my + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=n2 + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if(n1*n2*(mx1*my-mx*my1) .ne. 0) return + call uliber(0,35h vectors not independent in pixel0.,35) + call perror + end diff --git a/sys/gio/nsppkern/pixels.f b/sys/gio/nsppkern/pixels.f new file mode 100644 index 00000000..a7b5e039 --- /dev/null +++ b/sys/gio/nsppkern/pixels.f @@ -0,0 +1,74 @@ + subroutine pixels(x0,y0,ni,nj,inten) + integer*2 inten(1) +c assume inten is a linear array rather than 2-d. This is a change +c from the original code. +c assume nj == 1 + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + data ipixop / 10/ + mbpair = ior(ishift(ior(192, ipixop + 1), 8), 8) + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = x0 + yy = y0 + call tran16 + mbpair = mx + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=my + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=ni + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=nj + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + nni = max0(1,(ni+iand(ni,1))) + nnj = max0(1,nj) + kmax=nni*nnj + k=0 + do 200 j=1,nnj + do 100 i=1,nni + if(mod(k,254).ne.0) goto 90 + mbpair = ior(ishift(ior(192, ipixop+2),8), min0(254,kmax-k)) + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + 90 ik = iand ( i, 1) +c +c 14Nov85 mod so that arguments to ishift are of same type + itmp = inten(i) + mbpair = ior (ishift(iand(itmp,255),8*ik),mbpair) +c mbpair = ior (ishift(iand(inten(i),255),8*ik),mbpair) +c + if ( ik .ne. 0 ) go to 95 + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + 95 k = k + 1 + 100 continue + 200 continue + return + end diff --git a/sys/gio/nsppkern/t_nsppkern.x b/sys/gio/nsppkern/t_nsppkern.x new file mode 100644 index 00000000..69a5ec27 --- /dev/null +++ b/sys/gio/nsppkern/t_nsppkern.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# NSPPKERN -- Graphics kernel for the NCAR System Plot Package graphics +# interface. + +procedure t_nsppkern() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +bool clgetb() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Open the graphics kernel. + call gkt_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call gkt_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/nsppkern/tran16.f b/sys/gio/nsppkern/tran16.f new file mode 100644 index 00000000..e0503d57 --- /dev/null +++ b/sys/gio/nsppkern/tran16.f @@ -0,0 +1,64 @@ + subroutine tran16 + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xx,yy +c + logical intt + equivalence (zz,mz),(temp,itemp) +c ray bovet patch to avoid small integers being set to 0 +c zz = xx + mz = xx + if (intt(zz)) go to 102 + if (mtypex .eq. 0) go to 101 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + mz = 2.0*(xfactr*alog10(zz)+xadd) + go to 103 + 101 mz = 2.0*(xfactr*zz+xadd) + go to 103 + 102 mz = ishift(mz,mshftx+1) + 103 mx = max0(0,min0(65535,mz-1)) +c ray bovet patch to avoid small integers being set to 0 +c zz = yy + mz = yy + if (intt(zz)) go to 105 + if (mtypey .eq. 0) go to 104 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + mz = 2.0*(yfactr*alog10(zz)+yadd) + go to 106 + 104 mz = 2.0*(yfactr*zz+yadd) + go to 106 + 105 mz =ishift(mz,mshfty+1) + 106 my = max0(0,min0(65535,mz-1)) + return +C + entry DTRAN16 +C + zz = xx + if(intt(zz) .or. (zz .eq. 0.0)) goto 203 + mz = 2.0 * xfactr * zz + 203 mx = max0(-127,min0(127,mz)) + zz = yy + if(intt(zz) .or. (zz .eq. 0.0)) goto 206 + mz = 2.0 * yfactr * zz + 206 my = max0(-127,min0(127,mz)) + return + end diff --git a/sys/gio/nsppkern/writeb.x b/sys/gio/nsppkern/writeb.x new file mode 100644 index 00000000..dfcd82bb --- /dev/null +++ b/sys/gio/nsppkern/writeb.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +.help writeb +.nf ___________________________________________________________________________ +WRITEB -- Write an NCAR metacode record. Always write a full record +regardless of the buffer length; any data beyond buflen is undefined. +If the buffer length is passed as zero, the metafile standard wants us to +write a full (zeroed) record and backspace over it, to signify end of +metafile if the physical metafile is subsequently closed. Instead of +writing the EOF record here, we leave that to the FIO close routine +for the graphics device. +.endhelp ______________________________________________________________________ + +procedure writeb (metacode_buffer, buflen, mbunit) + +int metacode_buffer # LOC pointer to metacode buffer +int buflen # number of words of metacode data +int mbunit # FIO file descriptor !! from nspp common !! + +int dummy[1], offset +int loci() +include "gkt.com" + +begin + if (buflen <= 0) + return + + # Standard NCAR pointer technique for accessing integer arrays. This + # assumes alignment of integer variables. Convert to use IRAF + # pointers if this causes problems. + + offset = metacode_buffer - loci (dummy) + 1 + + iferr (call write (mbunit, dummy[offset], SZ_MFRECORD)) + call erract (EA_FATAL) +end diff --git a/sys/gio/nsppkern/x_nsppkern.x b/sys/gio/nsppkern/x_nsppkern.x new file mode 100644 index 00000000..4b54cba2 --- /dev/null +++ b/sys/gio/nsppkern/x_nsppkern.x @@ -0,0 +1,3 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task nsppkern = t_nsppkern diff --git a/sys/gio/nsppkern/zzdebug.x b/sys/gio/nsppkern/zzdebug.x new file mode 100644 index 00000000..b2ae6144 --- /dev/null +++ b/sys/gio/nsppkern/zzdebug.x @@ -0,0 +1,472 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "font.h" + +define XS 0.216 +define XE 0.719 +define YS 0.214 +define YE 0.929 + +task grid = t_grid, + grey = t_grey, + text = t_text, + seefont = t_seefont, + txup = t_txup, + font = t_font, + efont = t_efont + + +# GRID -- Test program for graphics plotting. A labelled grid is output. + +procedure t_grid () + +pointer gp +bool redir +char command[SZ_LINE], image[SZ_FNAME], word[SZ_LINE] +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int cmd, input_fd, stat, fd + +pointer gopen() +bool streq() +int fstati(), open(), getline(), sscan() + +begin + # If the input has been redirected, input is read from the named + # command file. If not, each image name in the input template is + # plotted. + + if (fstati (STDIN, F_REDIR) == YES) { +call eprintf ("Input has been redirected\n") + redir = true + cmd = open (STDIN, READ_ONLY, TEXT_FILE) + } + + # Loop over commands until EOF + repeat { + if (redir) { + if (getline (STDIN, command, SZ_LINE) == EOF) + break + stat = sscan (command) + call gargwrd (word, SZ_LINE) + if (!streq (word, "plot")) { + # Pixel window has been stored as WCS 2 + call gseti (gp, G_WCS, 2) + call gscan (command) + next + } else + call gargwrd (image) + } + + call clgstr ("output", output, SZ_FNAME) + if (!streq (output, "")) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$crt", NEW_FILE, BINARY_FILE) + + call clgstr ("device", device, SZ_FNAME) + gp = gopen (device, NEW_FILE, fd) + + call gseti (gp, G_XDRAWGRID, 1) + call gseti (gp, G_YDRAWGRID, 1) + call gseti (gp, G_NMAJOR, 21) + call glabax (gp, "TEST", "NDC_X", "NDC_Y") + call gline (gp, XS, YS, XE, YS) + call gline (gp, XE, YS, XE, YE) + call gline (gp, XE, YE, XS, YE) + call gline (gp, XS, YE, XS, YS) + call gmark (gp, 0.5, 0.5, GM_CROSS, 3.0, 3.0) + call gtext (gp, XS, YS-0.1, "DICOMED crtpict film area") + call gclose (gp) + call close (fd) + } + + call clpcls (input_fd) +end + + +# GREY -- test code to generate grey scale on plotters + +procedure t_grey() + +pointer gp +real size +int i, fd, count +short celldata[1024] +char output[SZ_FNAME], device[SZ_FNAME] + +pointer gopen() +real clgetr() +int open(), clgeti() +string fmt "hj=c;vj=c" + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + size = clgetr ("size") + + call gsetr (gp, G_TXSIZE, size) + call gtext (gp, .5, .9, "! !\"#$%&'()*+,-./", fmt) + call gtext (gp, .5, .8, "1234567890", fmt) + call gtext (gp, .5, .7, "ABCDEFGHIJKLMNOPQR", fmt) + call gtext (gp, .5, .6, "STUVWXYZ[\\]^_`", fmt) + call gtext (gp, .5, .5, "abcdefghijklmnopqr", fmt) + call gtext (gp, .5, .4, "stuvwxyz{}|~", fmt) + + call gtext (gp, .5, .1, "Grey Scale Test", fmt) + + count = clgeti ( "count") + if (count > 1024) + count = 1024 + for (i=1; i <= count; i=i+1) + celldata[i] = i - 1 + + call gpcell (gp, celldata, count, 1, 0.05, 0.2, .95, 0.3) + + call gclose (gp) + call close (fd) +end + + +# TEXT -- Test character drawing. + +procedure t_text() + +char device[SZ_FNAME] +char output[SZ_FNAME] +int fd, open() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + call gsetr (gp, G_TXSIZE, 1.0) + + call gtext (gp, .1, .1, + "abcdefghijklmnopqrstuvwxyz", "hj=l,vj=b") + call gtext (gp, .1, .2, + "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "hj=l,vj=b") + call gtext (gp, .1, .3, + "0123456789", "hj=l,vj=b") + call gtext (gp, .1, .4, + " ,./<>?;:'\"\\|[]{}!@#$%^&*()-_=+`~", "hj=l,vj=b") + + call gsetr (gp, G_TXSIZE, 2.0) + + call gtext (gp, .1, .5, + "abcdefghijklmnopqrstuvwxyz", "hj=l,vj=b") + call gtext (gp, .1, .6, + "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "hj=l,vj=b") + call gtext (gp, .1, .7, + "0123456789", "hj=l,vj=b") + call gtext (gp, .1, .8, + " ,./<>?;:'\"\\|[]{}!@#$%^&*()-_=+`~", "hj=l,vj=b") + + call gclose (gp) + call close (fd) +end + + +# SEEFONT definitions. +define L .40 +define R .60 +define U .75 +define D .25 +define W (R-L) +define H (U-D) + + +# SEEFONT -- Draw a character from the font table. + +procedure t_seefont() + +char ch +pointer gp +real x, y +int wcs, key +char strval[SZ_FNAME] + +pointer gopen() +int clgcur() + +begin + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + + call gline (gp, L, D, R, D) + call gline (gp, R, D, R, U) + call gline (gp, R, U, L, U) + call gline (gp, L, U, L, D) + + ch = 'A' + call gdrwch (gp, L, D, ch, W, H) + + while (clgcur ("gcur", x, y, wcs, key, strval, SZ_FNAME) != EOF) { + call gclear (gp) + + call gline (gp, L, D, R, D) + call gline (gp, R, D, R, U) + call gline (gp, R, U, L, U) + call gline (gp, L, U, L, D) + + ch = key + call gdrwch (gp, L, D, ch, W, H) + } + + call gclose (gp) +end + + +# GDRWCH -- Draw a character of the given size and orientation at the given +# position. + +procedure gdrwch (gp, x, y, ch, xsize, ysize) + +pointer gp # graphics descriptor +real x, y # lower left NDC coords of character +char ch # character to be drawn +real xsize, ysize # size of character in NDC units + +real px, py +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" +common /font/ chridx, chrtab + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + px = x + ((px + FONT_LEFT) / FONT_WIDTH) * xsize + py = y + ((py + FONT_BOTTOM) / FONT_HEIGHT) * ysize + + if (pen == 0) + call gamove (gp, px, py) + else + call gadraw (gp, px, py) + } +end + + +# TXUP -- Draw text strings with various character up vectors and paths. + +procedure t_txup() + +char device[SZ_FNAME] +char output[SZ_FNAME] +char text[SZ_LINE] +int fd, open(), clgeti() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + call clgstr ("text", text, SZ_LINE) + + call gseti (gp, G_TXHJUSTIFY, clgeti("hjustify")) + call gseti (gp, G_TXVJUSTIFY, clgeti("vjustify")) + + call gmark (gp, .1, .2, GM_CROSS, 3., 3.) + call gtext (gp, .1, .2, text, "up=0,path=right") + # -- + call gmark (gp, .2, .2, GM_CROSS, 3., 3.) + call gtext (gp, .2, .2, text, "up=45,path=right") + # -- + call gmark (gp, .3, .2, GM_CROSS, 3., 3.) + call gtext (gp, .3, .2, text, "up=90,path=right") + # -- + call gmark (gp, .4, .2, GM_CROSS, 3., 3.) + call gtext (gp, .4, .2, text, "up=135,path=right") + # -- + call gmark (gp, .5, .2, GM_CROSS, 3., 3.) + call gtext (gp, .5, .2, text, "up=180,path=right") + + call gmark (gp, .1, .4, GM_CROSS, 3., 3.) + call gtext (gp, .1, .4, text, "up=90,path=left") + # -- + call gmark (gp, .2, .4, GM_CROSS, 3., 3.) + call gtext (gp, .2, .4, text, "up=90,path=right") + # -- + call gmark (gp, .3, .4, GM_CROSS, 3., 3.) + call gtext (gp, .3, .4, text, "up=90,path=up") + # -- + call gmark (gp, .4, .4, GM_CROSS, 3., 3.) + call gtext (gp, .4, .4, text, "up=90,path=down") + + call gclose (gp) + call close (fd) +end + + +# FONT -- Test the font change escapes. + +procedure t_font() + +char device[SZ_FNAME] +char output[SZ_FNAME] +char text[SZ_LINE], format[SZ_FNAME] +int fd, i, open() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + do i = 2, 8, 2 { + call clgstr ("text", text, SZ_LINE) + call clgstr ("format", format, SZ_FNAME) + call gtext (gp, .2, i / 10.0, text, format) + } + + call gclose (gp) + call close (fd) +end + + +# EFONT -- Font editor. + +procedure t_efont() + +char cmd[SZ_LINE] +real scale +int pen, x, y, nw, w1, w2, ch, fcn +int ip, i, tab1, tab2, stroke, junk + +int bitupk(), ctoi(), ctor(), getline() +short chridx[96], chrtab[800] +common /font/ chridx, chrtab +define decode_ 91 + +begin + repeat { + # Get command. + call clgstr ("cmd", cmd, SZ_FNAME) + if (cmd[1] == 'q') + break + + # Decode function and integer arguments (range of words). + # Format "fcn [scale] ch w1 w2". + + fcn = cmd[1] + ip = 2 + + scale = 0 + if (fcn == 'x' || fcn == 'y') + if (ctor (cmd, ip, scale) <= 0) + scale = 1.0 + + while (IS_WHITE(cmd[ip])) + ip = ip + 1 + + ch = cmd[ip] + ip = ip + 1 + + if (ctoi (cmd, ip, w1) < 0) + w1 = 1 + if (ctoi (cmd, ip, w2) < 0) + w2 = w1 + + if (ch < CHARACTER_START || ch > CHARACTER_END) + next + else + i = ch - CHARACTER_START + 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + nw = tab2 - tab1 + 1 + w1 = max(1, min(nw, w1)) + w2 = max(1, min(nw, w2)) + +call eprintf ("fcn=%c [%g], ch=%c, tab1=%d, tab2=%d, nw=%d, w1=%d, w2=%d\n") +call pargi(fcn); call pargr (scale); +call pargi(ch); call pargi(tab1); call pargi(tab2) +call pargi(nw); call pargi(w1); call pargi(w2) + + # Functions: + # + # w write codes + # r read and encode + # x scale in X + # y scale in Y + + do i = w1-1+tab1, w2-1+tab1 { + stroke = chrtab[i] + x = bitupk (stroke, COORD_X_START, COORD_X_LEN) + y = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + switch (fcn) { + case 'w': +decode_ call eprintf ("%2d %6d (%6o) %d %3d %3d\n") + call pargi (i - tab1 + 1) + call pargi (stroke) + call pargi (stroke) + call pargi (pen) + call pargi (x) + call pargi (y) + next + + case 'r': + junk = getline (STDIN, cmd) + ip = 1 + junk = ctoi (cmd, ip, pen) + junk = ctoi (cmd, ip, x) + junk = ctoi (cmd, ip, y) + call bitpak (x, stroke, COORD_X_START, COORD_X_LEN) + call bitpak (y, stroke, COORD_Y_START, COORD_Y_LEN) + call bitpak (pen, stroke, COORD_PEN_START, COORD_PEN_LEN) + chrtab[i] = stroke + goto decode_ + + case 'x': + x = x * scale + call bitpak (x, stroke, COORD_X_START, COORD_X_LEN) + call bitpak (y, stroke, COORD_Y_START, COORD_Y_LEN) + call bitpak (pen, stroke, COORD_PEN_START, COORD_PEN_LEN) + chrtab[i] = stroke + goto decode_ + + case 'y': + y = (y - FONT_BASE) * scale + FONT_BASE + call bitpak (x, stroke, COORD_X_START, COORD_X_LEN) + call bitpak (y, stroke, COORD_Y_START, COORD_Y_LEN) + call bitpak (pen, stroke, COORD_PEN_START, COORD_PEN_LEN) + chrtab[i] = stroke + goto decode_ + + default: + call eprintf ("unknown function code\n") + } + } + } +end diff --git a/sys/gio/sgikern/README b/sys/gio/sgikern/README new file mode 100644 index 00000000..e944a4be --- /dev/null +++ b/sys/gio/sgikern/README @@ -0,0 +1,12 @@ +SGIKERN - + +This directory contains the source for the simple GIO kernel, used to write +a metacode file using only the simplest possible drawing instructions. This +makes it relatively easy to implement functional (but probably suboptimal) +translators for new devices. + +Special graphcap entries used by this kernel: + + MF maximum frame count per metafile + FS frame advance req'd at start of metafile + FE frame advance req'd at end of metafile diff --git a/sys/gio/sgikern/font.com b/sys/gio/sgikern/font.com new file mode 100644 index 00000000..c26af8d6 --- /dev/null +++ b/sys/gio/sgikern/font.com @@ -0,0 +1,746 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short chridx[97] # character index in chrtab +short chrwid[97] # character width table +short chrtab[3363] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (chridx(i), i=001,005) / 1, 3, 32, 49, 58/ +data (chridx(i), i=006,010) / 110, 140, 207, 228, 253/ +data (chridx(i), i=011,015) / 278, 309, 322, 343, 350/ +data (chridx(i), i=016,020) / 365, 372, 418, 438, 494/ +data (chridx(i), i=021,025) / 563, 583, 632, 696, 733/ +data (chridx(i), i=026,030) / 803, 867, 896, 931, 935/ +data (chridx(i), i=031,035) / 948, 952, 999, 1052, 1077/ +data (chridx(i), i=036,040) / 1139, 1174, 1223, 1281, 1330/ +data (chridx(i), i=041,045) / 1381, 1436, 1463, 1500, 1547/ +data (chridx(i), i=046,050) / 1583, 1626, 1653, 1703, 1748/ +data (chridx(i), i=051,055) / 1818, 1881, 1923, 1962, 1997/ +data (chridx(i), i=056,060) / 2021, 2060, 2097, 2131, 2160/ +data (chridx(i), i=061,065) / 2169, 2172, 2181, 2190, 2193/ +data (chridx(i), i=066,070) / 2214, 2263, 2303, 2335, 2378/ +data (chridx(i), i=071,075) / 2415, 2447, 2527, 2575, 2606/ +data (chridx(i), i=076,080) / 2640, 2682, 2704, 2778, 2826/ +data (chridx(i), i=081,085) / 2868, 2916, 2961, 2994, 3033/ +data (chridx(i), i=086,090) / 3052, 3086, 3108, 3140, 3173/ +data (chridx(i), i=091,095) / 3204, 3233, 3271, 3274, 3312/ +data (chridx(i), i=096,096) / 3335/ + + +# Width data. + +data (chrwid(i), i=001,005) / 21, 16, 23, 26, 25/ +data (chrwid(i), i=006,010) / 29, 31, 16, 19, 19/ +data (chrwid(i), i=011,015) / 21, 30, 16, 30, 16/ +data (chrwid(i), i=016,020) / 28, 25, 25, 25, 25/ +data (chrwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (chrwid(i), i=026,030) / 25, 16, 16, 29, 30/ +data (chrwid(i), i=031,035) / 29, 24, 32, 25, 27/ +data (chrwid(i), i=036,040) / 26, 27, 26, 25, 28/ +data (chrwid(i), i=041,045) / 29, 17, 21, 27, 23/ +data (chrwid(i), i=046,050) / 31, 29, 27, 27, 27/ +data (chrwid(i), i=051,055) / 27, 25, 25, 29, 25/ +data (chrwid(i), i=056,060) / 29, 25, 27, 25, 19/ +data (chrwid(i), i=061,065) / 19, 19, 21, 21, 16/ +data (chrwid(i), i=066,070) / 25, 26, 24, 26, 24/ +data (chrwid(i), i=071,075) / 19, 24, 28, 17, 18/ +data (chrwid(i), i=076,080) / 27, 17, 32, 28, 25/ +data (chrwid(i), i=081,085) / 26, 25, 22, 22, 20/ +data (chrwid(i), i=086,090) / 28, 23, 29, 25, 24/ +data (chrwid(i), i=091,095) / 23, 19, 13, 19, 29/ +data (chrwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (chrtab(i), i=0001,0005) / 35, 0, 220, 4251, 4249/ +data (chrtab(i), i=0006,0010) / 4305, 220, 4302, 4366, 220/ +data (chrtab(i), i=0011,0015) / 4380, 4366, 284, 4443, 4441/ +data (chrtab(i), i=0016,0020) / 4369, 202, 4233, 4232, 4295/ +data (chrtab(i), i=0021,0025) / 4359, 4424, 4425, 4362, 4298/ +data (chrtab(i), i=0026,0030) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0031,0035) / 0, 220, 4251, 4245, 219/ +data (chrtab(i), i=0036,0040) / 4245, 220, 4379, 4245, 796/ +data (chrtab(i), i=0041,0045) / 4827, 4821, 795, 4821, 796/ +data (chrtab(i), i=0046,0050) / 4955, 4821, 0, 604, 4224/ +data (chrtab(i), i=0051,0055) / 988, 4608, 145, 5137, 75/ +data (chrtab(i), i=0056,0060) / 5067, 0, 416, 4483, 672/ +data (chrtab(i), i=0061,0065) / 4739, 919, 5016, 4952, 4950/ +data (chrtab(i), i=0066,0070) / 5078, 5080, 5018, 4955, 4764/ +data (chrtab(i), i=0071,0075) / 4508, 4315, 4185, 4182, 4244/ +data (chrtab(i), i=0076,0080) / 4434, 4816, 4943, 5005, 5002/ +data (chrtab(i), i=0081,0085) / 4936, 150, 4308, 4435, 4817/ +data (chrtab(i), i=0086,0090) / 4944, 5006, 219, 4249, 4247/ +data (chrtab(i), i=0091,0095) / 4309, 4436, 4818, 5008, 5070/ +data (chrtab(i), i=0096,0100) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0101,0105) / 4296, 4233, 4171, 4173, 4301/ +data (chrtab(i), i=0106,0110) / 4299, 4235, 4236, 0, 1244/ +data (chrtab(i), i=0111,0115) / 4167, 412, 4634, 4632, 4566/ +data (chrtab(i), i=0116,0120) / 4437, 4309, 4183, 4185, 4251/ +data (chrtab(i), i=0121,0125) / 4380, 4508, 4635, 4826, 5018/ +data (chrtab(i), i=0126,0130) / 5211, 5340, 974, 4941, 4875/ +data (chrtab(i), i=0131,0135) / 4873, 4999, 5127, 5256, 5322/ +data (chrtab(i), i=0136,0140) / 5324, 5198, 5070, 0, 1299/ +data (chrtab(i), i=0141,0145) / 5396, 5332, 5330, 5458, 5460/ +data (chrtab(i), i=0146,0150) / 5397, 5333, 5268, 5202, 5069/ +data (chrtab(i), i=0151,0155) / 4938, 4808, 4679, 4423, 4296/ +data (chrtab(i), i=0156,0160) / 4234, 4237, 4303, 4691, 4821/ +data (chrtab(i), i=0161,0165) / 4887, 4889, 4827, 4700, 4571/ +data (chrtab(i), i=0166,0170) / 4505, 4502, 4563, 4688, 4939/ +data (chrtab(i), i=0171,0175) / 5128, 5255, 5383, 5449, 5450/ +data (chrtab(i), i=0176,0180) / 264, 4298, 4301, 4367, 4432/ +data (chrtab(i), i=0181,0185) / 725, 4889, 791, 4827, 475/ +data (chrtab(i), i=0186,0190) / 4503, 468, 4689, 4940, 5129/ +data (chrtab(i), i=0191,0195) / 5256, 455, 4424, 4362, 4365/ +data (chrtab(i), i=0196,0200) / 4431, 4691, 409, 4565, 4753/ +data (chrtab(i), i=0201,0205) / 5004, 5193, 5320, 5384, 5449/ +data (chrtab(i), i=0206,0210) / 0, 346, 4377, 4313, 4250/ +data (chrtab(i), i=0211,0215) / 4251, 4316, 4380, 4443, 4440/ +data (chrtab(i), i=0216,0220) / 4374, 4245, 219, 4314, 4378/ +data (chrtab(i), i=0221,0225) / 4379, 4315, 281, 4440, 346/ +data (chrtab(i), i=0226,0230) / 4374, 0, 544, 4510, 4379/ +data (chrtab(i), i=0231,0235) / 4247, 4178, 4174, 4233, 4357/ +data (chrtab(i), i=0236,0240) / 4482, 4608, 282, 4311, 4243/ +data (chrtab(i), i=0241,0245) / 4237, 4297, 4358, 414, 4444/ +data (chrtab(i), i=0246,0250) / 4377, 4307, 4301, 4359, 4420/ +data (chrtab(i), i=0251,0255) / 4482, 0, 160, 4382, 4507/ +data (chrtab(i), i=0256,0260) / 4631, 4690, 4686, 4617, 4485/ +data (chrtab(i), i=0261,0265) / 4354, 4224, 410, 4567, 4627/ +data (chrtab(i), i=0266,0270) / 4621, 4553, 4486, 286, 4444/ +data (chrtab(i), i=0271,0275) / 4505, 4563, 4557, 4487, 4420/ +data (chrtab(i), i=0276,0280) / 4354, 0, 412, 4443, 4561/ +data (chrtab(i), i=0281,0285) / 4496, 412, 4496, 412, 4571/ +data (chrtab(i), i=0286,0290) / 4433, 4496, 89, 4249, 4755/ +data (chrtab(i), i=0291,0295) / 4819, 89, 4819, 89, 4184/ +data (chrtab(i), i=0296,0300) / 4820, 4819, 729, 4761, 4243/ +data (chrtab(i), i=0301,0305) / 4179, 729, 4179, 729, 4824/ +data (chrtab(i), i=0306,0310) / 4180, 4179, 0, 665, 4744/ +data (chrtab(i), i=0311,0315) / 4808, 665, 4825, 4808, 145/ +data (chrtab(i), i=0316,0320) / 5329, 5328, 145, 4240, 5328/ +data (chrtab(i), i=0321,0325) / 0, 328, 4359, 4295, 4232/ +data (chrtab(i), i=0326,0330) / 4233, 4298, 4362, 4425, 4422/ +data (chrtab(i), i=0331,0335) / 4356, 4227, 201, 4296, 4360/ +data (chrtab(i), i=0336,0340) / 4361, 4297, 263, 4422, 328/ +data (chrtab(i), i=0341,0345) / 4356, 0, 145, 5329, 5328/ +data (chrtab(i), i=0346,0350) / 145, 4240, 5328, 0, 202/ +data (chrtab(i), i=0351,0355) / 4233, 4232, 4295, 4359, 4424/ +data (chrtab(i), i=0356,0360) / 4425, 4362, 4298, 201, 4296/ +data (chrtab(i), i=0361,0365) / 4360, 4361, 4297, 0, 1184/ +data (chrtab(i), i=0366,0370) / 4096, 4160, 1184, 5344, 4160/ +data (chrtab(i), i=0371,0375) / 0, 476, 4379, 4248, 4179/ +data (chrtab(i), i=0376,0380) / 4176, 4235, 4360, 4551, 4679/ +data (chrtab(i), i=0381,0385) / 4872, 5003, 5072, 5075, 5016/ +data (chrtab(i), i=0386,0390) / 4891, 4700, 4572, 282, 4312/ +data (chrtab(i), i=0391,0395) / 4244, 4239, 4299, 4361, 777/ +data (chrtab(i), i=0396,0400) / 4939, 5007, 5012, 4952, 4890/ +data (chrtab(i), i=0401,0405) / 476, 4443, 4377, 4308, 4303/ +data (chrtab(i), i=0406,0410) / 4362, 4424, 4551, 583, 4808/ +data (chrtab(i), i=0411,0415) / 4874, 4943, 4948, 4889, 4827/ +data (chrtab(i), i=0416,0420) / 4700, 0, 474, 4551, 538/ +data (chrtab(i), i=0421,0425) / 4616, 604, 4679, 604, 4505/ +data (chrtab(i), i=0426,0430) / 4376, 199, 4935, 456, 4423/ +data (chrtab(i), i=0431,0435) / 457, 4487, 585, 4743, 584/ +data (chrtab(i), i=0436,0440) / 4807, 0, 152, 4247, 4311/ +data (chrtab(i), i=0441,0445) / 4312, 4248, 153, 4313, 4376/ +data (chrtab(i), i=0446,0450) / 4375, 4310, 4246, 4183, 4184/ +data (chrtab(i), i=0451,0455) / 4250, 4315, 4508, 4764, 4955/ +data (chrtab(i), i=0456,0460) / 5018, 5080, 5078, 5012, 4818/ +data (chrtab(i), i=0461,0465) / 4496, 4367, 4237, 4170, 4167/ +data (chrtab(i), i=0466,0470) / 858, 5016, 5014, 4948, 668/ +data (chrtab(i), i=0471,0475) / 4891, 4952, 4950, 4884, 4754/ +data (chrtab(i), i=0476,0480) / 4496, 73, 4234, 4362, 4681/ +data (chrtab(i), i=0481,0485) / 4937, 5066, 266, 4680, 4936/ +data (chrtab(i), i=0486,0490) / 5001, 266, 4679, 4935, 5000/ +data (chrtab(i), i=0491,0495) / 5066, 5068, 0, 152, 4247/ +data (chrtab(i), i=0496,0500) / 4311, 4312, 4248, 153, 4313/ +data (chrtab(i), i=0501,0505) / 4376, 4375, 4310, 4246, 4183/ +data (chrtab(i), i=0506,0510) / 4184, 4250, 4315, 4508, 4764/ +data (chrtab(i), i=0511,0515) / 4955, 5017, 5014, 4948, 4755/ +data (chrtab(i), i=0516,0520) / 795, 4953, 4950, 4884, 604/ +data (chrtab(i), i=0521,0525) / 4827, 4889, 4886, 4820, 4691/ +data (chrtab(i), i=0526,0530) / 467, 4755, 4882, 5008, 5070/ +data (chrtab(i), i=0531,0535) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0536,0540) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0541,0545) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0546,0550) / 848, 5006, 5003, 4937, 595/ +data (chrtab(i), i=0551,0555) / 4818, 4881, 4942, 4939, 4872/ +data (chrtab(i), i=0556,0560) / 4743, 140, 4235, 4299, 4300/ +data (chrtab(i), i=0561,0565) / 4236, 0, 601, 4679, 666/ +data (chrtab(i), i=0566,0570) / 4744, 732, 4807, 732, 4109/ +data (chrtab(i), i=0571,0575) / 5133, 391, 4999, 584, 4551/ +data (chrtab(i), i=0576,0580) / 585, 4615, 713, 4871, 712/ +data (chrtab(i), i=0581,0585) / 4935, 0, 220, 4178, 4308/ +data (chrtab(i), i=0586,0590) / 4501, 4693, 4884, 5010, 5071/ +data (chrtab(i), i=0591,0595) / 5069, 5002, 4872, 4679, 4487/ +data (chrtab(i), i=0596,0600) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0601,0605) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0606,0610) / 850, 5008, 5004, 4938, 597/ +data (chrtab(i), i=0611,0615) / 4820, 4883, 4944, 4940, 4873/ +data (chrtab(i), i=0616,0620) / 4808, 4679, 140, 4235, 4299/ +data (chrtab(i), i=0621,0625) / 4300, 4236, 220, 4956, 219/ +data (chrtab(i), i=0626,0630) / 4827, 218, 4570, 4827, 4956/ +data (chrtab(i), i=0631,0635) / 0, 793, 4888, 4952, 4953/ +data (chrtab(i), i=0636,0640) / 4889, 858, 4890, 4825, 4824/ +data (chrtab(i), i=0641,0645) / 4887, 4951, 5016, 5017, 4955/ +data (chrtab(i), i=0646,0650) / 4828, 4636, 4443, 4313, 4247/ +data (chrtab(i), i=0651,0655) / 4179, 4173, 4234, 4360, 4551/ +data (chrtab(i), i=0656,0660) / 4679, 4872, 5002, 5069, 5070/ +data (chrtab(i), i=0661,0665) / 5009, 4883, 4692, 4564, 4435/ +data (chrtab(i), i=0666,0670) / 4370, 4304, 281, 4311, 4243/ +data (chrtab(i), i=0671,0675) / 4237, 4298, 4361, 842, 5004/ +data (chrtab(i), i=0676,0680) / 5007, 4945, 540, 4507, 4442/ +data (chrtab(i), i=0681,0685) / 4376, 4308, 4301, 4362, 4424/ +data (chrtab(i), i=0686,0690) / 4551, 583, 4808, 4873, 4940/ +data (chrtab(i), i=0691,0695) / 4943, 4882, 4819, 4692, 0/ +data (chrtab(i), i=0696,0700) / 92, 4182, 988, 5081, 5014/ +data (chrtab(i), i=0701,0705) / 4753, 4687, 4619, 4615, 592/ +data (chrtab(i), i=0706,0710) / 4622, 4555, 4551, 918, 4689/ +data (chrtab(i), i=0711,0715) / 4558, 4491, 4487, 4615, 88/ +data (chrtab(i), i=0716,0720) / 4250, 4380, 4508, 4825, 4953/ +data (chrtab(i), i=0721,0725) / 5018, 5084, 218, 4379, 4507/ +data (chrtab(i), i=0726,0730) / 4634, 88, 4249, 4378, 4506/ +data (chrtab(i), i=0731,0735) / 4825, 0, 412, 4315, 4249/ +data (chrtab(i), i=0736,0740) / 4246, 4308, 4499, 4755, 4948/ +data (chrtab(i), i=0741,0745) / 5014, 5017, 4955, 4764, 4508/ +data (chrtab(i), i=0746,0750) / 283, 4313, 4310, 4372, 788/ +data (chrtab(i), i=0751,0755) / 4950, 4953, 4891, 412, 4443/ +data (chrtab(i), i=0756,0760) / 4377, 4374, 4436, 4499, 659/ +data (chrtab(i), i=0761,0765) / 4820, 4886, 4889, 4827, 4764/ +data (chrtab(i), i=0766,0770) / 403, 4306, 4241, 4175, 4171/ +data (chrtab(i), i=0771,0775) / 4233, 4296, 4487, 4743, 4936/ +data (chrtab(i), i=0776,0780) / 5001, 5067, 5071, 5009, 4946/ +data (chrtab(i), i=0781,0785) / 4755, 209, 4239, 4235, 4297/ +data (chrtab(i), i=0786,0790) / 841, 5003, 5007, 4945, 403/ +data (chrtab(i), i=0791,0795) / 4370, 4303, 4299, 4360, 4487/ +data (chrtab(i), i=0796,0800) / 647, 4872, 4939, 4943, 4882/ +data (chrtab(i), i=0801,0805) / 4755, 0, 203, 4298, 4362/ +data (chrtab(i), i=0806,0810) / 4363, 4299, 851, 4881, 4816/ +data (chrtab(i), i=0811,0815) / 4687, 4559, 4368, 4242, 4181/ +data (chrtab(i), i=0816,0820) / 4182, 4249, 4379, 4572, 4700/ +data (chrtab(i), i=0821,0825) / 4891, 5017, 5078, 5072, 5004/ +data (chrtab(i), i=0826,0830) / 4938, 4808, 4615, 4423, 4296/ +data (chrtab(i), i=0831,0835) / 4234, 4235, 4300, 4364, 4427/ +data (chrtab(i), i=0836,0840) / 4426, 4361, 4297, 210, 4244/ +data (chrtab(i), i=0841,0845) / 4247, 4313, 794, 4953, 5014/ +data (chrtab(i), i=0846,0850) / 5008, 4940, 4874, 463, 4432/ +data (chrtab(i), i=0851,0855) / 4369, 4308, 4311, 4378, 4443/ +data (chrtab(i), i=0856,0860) / 4572, 604, 4827, 4889, 4950/ +data (chrtab(i), i=0861,0865) / 4943, 4875, 4809, 4744, 4615/ +data (chrtab(i), i=0866,0870) / 0, 213, 4244, 4243, 4306/ +data (chrtab(i), i=0871,0875) / 4370, 4435, 4436, 4373, 4309/ +data (chrtab(i), i=0876,0880) / 212, 4307, 4371, 4372, 4308/ +data (chrtab(i), i=0881,0885) / 202, 4233, 4232, 4295, 4359/ +data (chrtab(i), i=0886,0890) / 4424, 4425, 4362, 4298, 201/ +data (chrtab(i), i=0891,0895) / 4296, 4360, 4361, 4297, 0/ +data (chrtab(i), i=0896,0900) / 213, 4244, 4243, 4306, 4370/ +data (chrtab(i), i=0901,0905) / 4435, 4436, 4373, 4309, 212/ +data (chrtab(i), i=0906,0910) / 4307, 4371, 4372, 4308, 328/ +data (chrtab(i), i=0911,0915) / 4359, 4295, 4232, 4233, 4298/ +data (chrtab(i), i=0916,0920) / 4362, 4425, 4422, 4356, 4227/ +data (chrtab(i), i=0921,0925) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0926,0930) / 263, 4422, 328, 4356, 0/ +data (chrtab(i), i=0931,0935) / 1177, 4240, 5255, 0, 149/ +data (chrtab(i), i=0936,0940) / 5333, 5332, 149, 4244, 5332/ +data (chrtab(i), i=0941,0945) / 141, 5325, 5324, 141, 4236/ +data (chrtab(i), i=0946,0950) / 5324, 0, 153, 5264, 4231/ +data (chrtab(i), i=0951,0955) / 0, 151, 4248, 4312, 4310/ +data (chrtab(i), i=0956,0960) / 4182, 4184, 4250, 4315, 4444/ +data (chrtab(i), i=0961,0965) / 4700, 4891, 4954, 5016, 5014/ +data (chrtab(i), i=0966,0970) / 4948, 4883, 4625, 794, 4953/ +data (chrtab(i), i=0971,0975) / 4949, 4884, 604, 4827, 4889/ +data (chrtab(i), i=0976,0980) / 4885, 4819, 4754, 465, 4558/ +data (chrtab(i), i=0981,0985) / 4622, 4625, 4561, 458, 4489/ +data (chrtab(i), i=0986,0990) / 4488, 4551, 4615, 4680, 4681/ +data (chrtab(i), i=0991,0995) / 4618, 4554, 457, 4552, 4616/ +data (chrtab(i), i=0996,1000) / 4617, 4553, 0, 1044, 5078/ +data (chrtab(i), i=1001,1005) / 4951, 4759, 4630, 4565, 4498/ +data (chrtab(i), i=1006,1010) / 4495, 4557, 4684, 4876, 5005/ +data (chrtab(i), i=1011,1015) / 5071, 663, 4629, 4562, 4559/ +data (chrtab(i), i=1016,1020) / 4621, 4684, 1047, 5071, 5069/ +data (chrtab(i), i=1021,1025) / 5196, 5324, 5454, 5521, 5523/ +data (chrtab(i), i=1026,1030) / 5462, 5400, 5274, 5147, 4956/ +data (chrtab(i), i=1031,1035) / 4764, 4571, 4442, 4312, 4246/ +data (chrtab(i), i=1036,1040) / 4179, 4176, 4237, 4299, 4425/ +data (chrtab(i), i=1041,1045) / 4552, 4743, 4935, 5128, 5257/ +data (chrtab(i), i=1046,1050) / 5322, 1111, 5135, 5133, 5196/ +data (chrtab(i), i=1051,1055) / 0, 540, 4168, 473, 4935/ +data (chrtab(i), i=1056,1060) / 537, 4999, 540, 5063, 205/ +data (chrtab(i), i=1061,1065) / 4877, 7, 4423, 647, 5191/ +data (chrtab(i), i=1066,1070) / 72, 4103, 72, 4295, 840/ +data (chrtab(i), i=1071,1075) / 4807, 841, 4871, 905, 5127/ +data (chrtab(i), i=1076,1080) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1081,1085) / 348, 4423, 28, 4892, 5083/ +data (chrtab(i), i=1086,1090) / 5146, 5208, 5206, 5140, 5075/ +data (chrtab(i), i=1091,1095) / 4882, 986, 5144, 5142, 5076/ +data (chrtab(i), i=1096,1100) / 796, 5019, 5081, 5077, 5011/ +data (chrtab(i), i=1101,1105) / 4882, 338, 4882, 5073, 5136/ +data (chrtab(i), i=1106,1110) / 5198, 5195, 5129, 5064, 4871/ +data (chrtab(i), i=1111,1115) / 4103, 976, 5134, 5131, 5065/ +data (chrtab(i), i=1116,1120) / 786, 5009, 5071, 5066, 5000/ +data (chrtab(i), i=1121,1125) / 4871, 92, 4315, 156, 4314/ +data (chrtab(i), i=1126,1130) / 412, 4442, 476, 4443, 200/ +data (chrtab(i), i=1131,1135) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=1136,1140) / 328, 4551, 0, 985, 5148/ +data (chrtab(i), i=1141,1145) / 5142, 5081, 4955, 4828, 4636/ +data (chrtab(i), i=1146,1150) / 4443, 4313, 4247, 4180, 4175/ +data (chrtab(i), i=1151,1155) / 4236, 4298, 4424, 4615, 4807/ +data (chrtab(i), i=1156,1160) / 4936, 5066, 5132, 281, 4311/ +data (chrtab(i), i=1161,1165) / 4244, 4239, 4300, 4362, 540/ +data (chrtab(i), i=1166,1170) / 4507, 4376, 4308, 4303, 4363/ +data (chrtab(i), i=1171,1175) / 4488, 4615, 0, 220, 4295/ +data (chrtab(i), i=1176,1180) / 283, 4360, 348, 4423, 28/ +data (chrtab(i), i=1181,1185) / 4764, 4955, 5081, 5143, 5204/ +data (chrtab(i), i=1186,1190) / 5199, 5132, 5066, 4936, 4743/ +data (chrtab(i), i=1191,1195) / 4103, 921, 5079, 5140, 5135/ +data (chrtab(i), i=1196,1200) / 5068, 5002, 668, 4891, 5016/ +data (chrtab(i), i=1201,1205) / 5076, 5071, 5003, 4872, 4743/ +data (chrtab(i), i=1206,1210) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1211,1215) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1216,1220) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1221,1225) / 4551, 0, 220, 4295, 283/ +data (chrtab(i), i=1226,1230) / 4360, 348, 4423, 28, 5148/ +data (chrtab(i), i=1231,1235) / 5142, 338, 4818, 726, 4814/ +data (chrtab(i), i=1236,1240) / 7, 5127, 5133, 92, 4315/ +data (chrtab(i), i=1241,1245) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1246,1250) / 4443, 732, 5147, 860, 5146/ +data (chrtab(i), i=1251,1255) / 924, 5145, 988, 5142, 726/ +data (chrtab(i), i=1256,1260) / 4754, 4814, 724, 4690, 4816/ +data (chrtab(i), i=1261,1265) / 723, 4562, 4817, 200, 4167/ +data (chrtab(i), i=1266,1270) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1271,1275) / 4551, 711, 5128, 839, 5129/ +data (chrtab(i), i=1276,1280) / 903, 5130, 967, 5133, 0/ +data (chrtab(i), i=1281,1285) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1286,1290) / 4423, 28, 5148, 5142, 338/ +data (chrtab(i), i=1291,1295) / 4818, 726, 4814, 7, 4615/ +data (chrtab(i), i=1296,1300) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1301,1305) / 4442, 476, 4443, 732, 5147/ +data (chrtab(i), i=1306,1310) / 860, 5146, 924, 5145, 988/ +data (chrtab(i), i=1311,1315) / 5142, 726, 4754, 4814, 724/ +data (chrtab(i), i=1316,1320) / 4690, 4816, 723, 4562, 4817/ +data (chrtab(i), i=1321,1325) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1326,1330) / 4487, 328, 4551, 0, 985/ +data (chrtab(i), i=1331,1335) / 5148, 5142, 5081, 4955, 4828/ +data (chrtab(i), i=1336,1340) / 4636, 4443, 4313, 4247, 4180/ +data (chrtab(i), i=1341,1345) / 4175, 4236, 4298, 4424, 4615/ +data (chrtab(i), i=1346,1350) / 4807, 4936, 5064, 5127, 5135/ +data (chrtab(i), i=1351,1355) / 281, 4311, 4244, 4239, 4300/ +data (chrtab(i), i=1356,1360) / 4362, 540, 4507, 4376, 4308/ +data (chrtab(i), i=1361,1365) / 4303, 4363, 4488, 4615, 974/ +data (chrtab(i), i=1366,1370) / 5065, 911, 5001, 4936, 719/ +data (chrtab(i), i=1371,1375) / 5327, 783, 5006, 847, 5005/ +data (chrtab(i), i=1376,1380) / 1103, 5133, 1167, 5134, 0/ +data (chrtab(i), i=1381,1385) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1386,1390) / 4423, 988, 5063, 1051, 5128/ +data (chrtab(i), i=1391,1395) / 1116, 5191, 28, 4636, 796/ +data (chrtab(i), i=1396,1400) / 5404, 338, 5074, 7, 4615/ +data (chrtab(i), i=1401,1405) / 775, 5383, 92, 4315, 156/ +data (chrtab(i), i=1406,1410) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1411,1415) / 860, 5083, 924, 5082, 1180/ +data (chrtab(i), i=1416,1420) / 5210, 1244, 5211, 200, 4167/ +data (chrtab(i), i=1421,1425) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1426,1430) / 4551, 968, 4935, 969, 4999/ +data (chrtab(i), i=1431,1435) / 1097, 5255, 1096, 5319, 0/ +data (chrtab(i), i=1436,1440) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1441,1445) / 4423, 28, 4636, 7, 4615/ +data (chrtab(i), i=1446,1450) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1451,1455) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1456,1460) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1461,1465) / 4551, 0, 476, 4555, 4488/ +data (chrtab(i), i=1466,1470) / 4423, 539, 4619, 4552, 604/ +data (chrtab(i), i=1471,1475) / 4683, 4616, 4423, 4295, 4168/ +data (chrtab(i), i=1476,1480) / 4106, 4108, 4173, 4237, 4300/ +data (chrtab(i), i=1481,1485) / 4299, 4234, 4170, 76, 4171/ +data (chrtab(i), i=1486,1490) / 4235, 4236, 4172, 284, 4892/ +data (chrtab(i), i=1491,1495) / 348, 4571, 412, 4570, 668/ +data (chrtab(i), i=1496,1500) / 4698, 732, 4699, 0, 220/ +data (chrtab(i), i=1501,1505) / 4295, 283, 4360, 348, 4423/ +data (chrtab(i), i=1506,1510) / 1051, 4432, 530, 5063, 594/ +data (chrtab(i), i=1511,1515) / 5127, 596, 5191, 28, 4636/ +data (chrtab(i), i=1516,1520) / 860, 5340, 7, 4615, 775/ +data (chrtab(i), i=1521,1525) / 5319, 92, 4315, 156, 4314/ +data (chrtab(i), i=1526,1530) / 412, 4442, 476, 4443, 988/ +data (chrtab(i), i=1531,1535) / 5147, 1180, 5147, 200, 4167/ +data (chrtab(i), i=1536,1540) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1541,1545) / 4551, 969, 4935, 969, 5255/ +data (chrtab(i), i=1546,1550) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1551,1555) / 348, 4423, 28, 4636, 7/ +data (chrtab(i), i=1556,1560) / 5063, 5069, 92, 4315, 156/ +data (chrtab(i), i=1561,1565) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1566,1570) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1571,1575) / 4487, 328, 4551, 647, 5064/ +data (chrtab(i), i=1576,1580) / 775, 5065, 839, 5066, 903/ +data (chrtab(i), i=1581,1585) / 5069, 0, 220, 4296, 220/ +data (chrtab(i), i=1586,1590) / 4743, 284, 4746, 348, 4810/ +data (chrtab(i), i=1591,1595) / 1116, 4743, 1116, 5191, 1179/ +data (chrtab(i), i=1596,1600) / 5256, 1244, 5319, 28, 4444/ +data (chrtab(i), i=1601,1605) / 1116, 5532, 7, 4487, 903/ +data (chrtab(i), i=1606,1610) / 5511, 92, 4315, 1308, 5338/ +data (chrtab(i), i=1611,1615) / 1372, 5339, 200, 4167, 200/ +data (chrtab(i), i=1616,1620) / 4423, 1096, 5063, 1097, 5127/ +data (chrtab(i), i=1621,1625) / 1225, 5383, 1224, 5447, 0/ +data (chrtab(i), i=1626,1630) / 220, 4296, 220, 5191, 284/ +data (chrtab(i), i=1631,1635) / 5130, 348, 5194, 1115, 5191/ +data (chrtab(i), i=1636,1640) / 28, 4444, 924, 5404, 7/ +data (chrtab(i), i=1641,1645) / 4487, 92, 4315, 988, 5211/ +data (chrtab(i), i=1646,1650) / 1244, 5211, 200, 4167, 200/ +data (chrtab(i), i=1651,1655) / 4423, 0, 540, 4443, 4313/ +data (chrtab(i), i=1656,1660) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1661,1665) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1666,1670) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1671,1675) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1676,1680) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1681,1685) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1686,1690) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1691,1695) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1696,1700) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1701,1705) / 4764, 0, 220, 4295, 283/ +data (chrtab(i), i=1706,1710) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1711,1715) / 5083, 5146, 5208, 5205, 5139/ +data (chrtab(i), i=1716,1720) / 5074, 4881, 4433, 986, 5144/ +data (chrtab(i), i=1721,1725) / 5141, 5075, 796, 5019, 5081/ +data (chrtab(i), i=1726,1730) / 5076, 5010, 4881, 7, 4615/ +data (chrtab(i), i=1731,1735) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1736,1740) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1741,1745) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1746,1750) / 4551, 0, 540, 4443, 4313/ +data (chrtab(i), i=1751,1755) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1756,1760) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1761,1765) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1766,1770) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1771,1775) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1776,1780) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1781,1785) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1786,1790) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1791,1795) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1796,1800) / 4764, 330, 4492, 4621, 4685/ +data (chrtab(i), i=1801,1805) / 4812, 4874, 4932, 4994, 5122/ +data (chrtab(i), i=1806,1810) / 5188, 5190, 838, 4996, 5059/ +data (chrtab(i), i=1811,1815) / 5123, 778, 4997, 5060, 5124/ +data (chrtab(i), i=1816,1820) / 5189, 0, 220, 4295, 283/ +data (chrtab(i), i=1821,1825) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1826,1830) / 5083, 5146, 5208, 5206, 5140/ +data (chrtab(i), i=1831,1835) / 5075, 4882, 4434, 986, 5144/ +data (chrtab(i), i=1836,1840) / 5142, 5076, 796, 5019, 5081/ +data (chrtab(i), i=1841,1845) / 5077, 5011, 4882, 594, 4817/ +data (chrtab(i), i=1846,1850) / 4879, 5001, 5063, 5191, 5257/ +data (chrtab(i), i=1851,1855) / 5259, 907, 5065, 5128, 5192/ +data (chrtab(i), i=1856,1860) / 721, 4880, 5066, 5129, 5193/ +data (chrtab(i), i=1861,1865) / 5258, 7, 4615, 92, 4315/ +data (chrtab(i), i=1866,1870) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1871,1875) / 4443, 200, 4167, 201, 4231/ +data (chrtab(i), i=1876,1880) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=1881,1885) / 921, 5084, 5078, 5017, 4891/ +data (chrtab(i), i=1886,1890) / 4700, 4508, 4315, 4185, 4182/ +data (chrtab(i), i=1891,1895) / 4244, 4434, 4816, 4943, 5005/ +data (chrtab(i), i=1896,1900) / 5002, 4936, 150, 4308, 4435/ +data (chrtab(i), i=1901,1905) / 4817, 4944, 5006, 219, 4249/ +data (chrtab(i), i=1906,1910) / 4247, 4309, 4436, 4818, 5008/ +data (chrtab(i), i=1911,1915) / 5070, 5067, 5001, 4936, 4743/ +data (chrtab(i), i=1916,1920) / 4551, 4360, 4234, 4173, 4167/ +data (chrtab(i), i=1921,1925) / 4234, 0, 28, 4118, 476/ +data (chrtab(i), i=1926,1930) / 4551, 539, 4616, 604, 4679/ +data (chrtab(i), i=1931,1935) / 1052, 5142, 28, 5148, 263/ +data (chrtab(i), i=1936,1940) / 4871, 92, 4118, 156, 4121/ +data (chrtab(i), i=1941,1945) / 220, 4122, 348, 4123, 732/ +data (chrtab(i), i=1946,1950) / 5147, 860, 5146, 924, 5145/ +data (chrtab(i), i=1951,1955) / 988, 5142, 456, 4423, 457/ +data (chrtab(i), i=1956,1960) / 4487, 585, 4743, 584, 4807/ +data (chrtab(i), i=1961,1965) / 0, 220, 4301, 4362, 4488/ +data (chrtab(i), i=1966,1970) / 4679, 4807, 5000, 5130, 5197/ +data (chrtab(i), i=1971,1975) / 5211, 283, 4364, 4426, 348/ +data (chrtab(i), i=1976,1980) / 4428, 4489, 4552, 4679, 28/ +data (chrtab(i), i=1981,1985) / 4636, 924, 5404, 92, 4315/ +data (chrtab(i), i=1986,1990) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1991,1995) / 4443, 988, 5211, 1244, 5211/ +data (chrtab(i), i=1996,2000) / 0, 92, 4615, 156, 4618/ +data (chrtab(i), i=2001,2005) / 4615, 220, 4682, 987, 4615/ +data (chrtab(i), i=2006,2010) / 28, 4508, 732, 5212, 28/ +data (chrtab(i), i=2011,2015) / 4250, 284, 4314, 348, 4315/ +data (chrtab(i), i=2016,2020) / 860, 5083, 1052, 5083, 0/ +data (chrtab(i), i=2021,2025) / 156, 4487, 220, 4492, 4487/ +data (chrtab(i), i=2026,2030) / 284, 4556, 668, 4556, 4487/ +data (chrtab(i), i=2031,2035) / 668, 4999, 732, 5004, 4999/ +data (chrtab(i), i=2036,2040) / 796, 5068, 1179, 5068, 4999/ +data (chrtab(i), i=2041,2045) / 28, 4572, 668, 4892, 988/ +data (chrtab(i), i=2046,2050) / 5468, 28, 4315, 92, 4314/ +data (chrtab(i), i=2051,2055) / 348, 4378, 412, 4379, 1052/ +data (chrtab(i), i=2056,2060) / 5275, 1308, 5275, 0, 92/ +data (chrtab(i), i=2061,2065) / 4935, 156, 4999, 220, 5063/ +data (chrtab(i), i=2066,2070) / 923, 4232, 28, 4508, 732/ +data (chrtab(i), i=2071,2075) / 5212, 7, 4423, 647, 5191/ +data (chrtab(i), i=2076,2080) / 28, 4314, 284, 4314, 348/ +data (chrtab(i), i=2081,2085) / 4315, 796, 5019, 1052, 5019/ +data (chrtab(i), i=2086,2090) / 136, 4103, 136, 4359, 840/ +data (chrtab(i), i=2091,2095) / 4807, 841, 4871, 841, 5127/ +data (chrtab(i), i=2096,2100) / 0, 92, 4625, 4615, 156/ +data (chrtab(i), i=2101,2105) / 4689, 4680, 220, 4753, 4743/ +data (chrtab(i), i=2106,2110) / 1051, 4753, 28, 4508, 860/ +data (chrtab(i), i=2111,2115) / 5340, 327, 4935, 28, 4251/ +data (chrtab(i), i=2116,2120) / 348, 4315, 924, 5147, 1180/ +data (chrtab(i), i=2121,2125) / 5147, 520, 4487, 521, 4551/ +data (chrtab(i), i=2126,2130) / 649, 4807, 648, 4871, 0/ +data (chrtab(i), i=2131,2135) / 988, 4188, 4182, 860, 4167/ +data (chrtab(i), i=2136,2140) / 924, 4231, 988, 4295, 71/ +data (chrtab(i), i=2141,2145) / 5063, 5069, 156, 4182, 220/ +data (chrtab(i), i=2146,2150) / 4185, 284, 4186, 412, 4187/ +data (chrtab(i), i=2151,2155) / 647, 5064, 775, 5065, 839/ +data (chrtab(i), i=2156,2160) / 5066, 903, 5069, 0, 160/ +data (chrtab(i), i=2161,2165) / 4224, 224, 4288, 160, 4704/ +data (chrtab(i), i=2166,2170) / 128, 4672, 0, 28, 4868/ +data (chrtab(i), i=2171,2175) / 0, 480, 4544, 544, 4608/ +data (chrtab(i), i=2176,2180) / 96, 4640, 64, 4608, 0/ +data (chrtab(i), i=2181,2185) / 278, 4505, 4630, 83, 4504/ +data (chrtab(i), i=2186,2190) / 4819, 408, 4487, 0, 5/ +data (chrtab(i), i=2191,2195) / 4997, 0, 348, 4315, 4249/ +data (chrtab(i), i=2196,2200) / 4246, 4309, 4373, 4438, 4439/ +data (chrtab(i), i=2201,2205) / 4376, 4312, 4247, 215, 4310/ +data (chrtab(i), i=2206,2210) / 4374, 4375, 4311, 219, 4247/ +data (chrtab(i), i=2211,2215) / 153, 4312, 0, 210, 4307/ +data (chrtab(i), i=2216,2220) / 4371, 4369, 4241, 4243, 4308/ +data (chrtab(i), i=2221,2225) / 4437, 4693, 4820, 4883, 4945/ +data (chrtab(i), i=2226,2230) / 4938, 5000, 5063, 723, 4881/ +data (chrtab(i), i=2231,2235) / 4874, 4936, 597, 4756, 4818/ +data (chrtab(i), i=2236,2240) / 4810, 4872, 5063, 5127, 720/ +data (chrtab(i), i=2241,2245) / 4751, 4430, 4237, 4171, 4170/ +data (chrtab(i), i=2246,2250) / 4232, 4423, 4615, 4744, 4810/ +data (chrtab(i), i=2251,2255) / 205, 4235, 4234, 4296, 655/ +data (chrtab(i), i=2256,2260) / 4494, 4365, 4299, 4298, 4360/ +data (chrtab(i), i=2261,2265) / 4423, 0, 220, 4295, 4360/ +data (chrtab(i), i=2266,2270) / 4488, 283, 4361, 28, 4444/ +data (chrtab(i), i=2271,2275) / 4424, 338, 4500, 4629, 4757/ +data (chrtab(i), i=2276,2280) / 4948, 5074, 5135, 5133, 5066/ +data (chrtab(i), i=2281,2285) / 4936, 4743, 4615, 4488, 4426/ +data (chrtab(i), i=2286,2290) / 914, 5072, 5068, 5002, 661/ +data (chrtab(i), i=2291,2295) / 4884, 4947, 5008, 5004, 4937/ +data (chrtab(i), i=2296,2300) / 4872, 4743, 92, 4315, 156/ +data (chrtab(i), i=2301,2305) / 4314, 0, 849, 4946, 4882/ +data (chrtab(i), i=2306,2310) / 4880, 5008, 5010, 4884, 4757/ +data (chrtab(i), i=2311,2315) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2316,2320) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2321,2325) / 5002, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2326,2330) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2331,2335) / 4361, 4424, 4551, 0, 796/ +data (chrtab(i), i=2336,2340) / 4871, 5191, 859, 4936, 604/ +data (chrtab(i), i=2341,2345) / 5020, 4999, 786, 4820, 4693/ +data (chrtab(i), i=2346,2350) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2351,2355) / 4234, 4360, 4551, 4679, 4808/ +data (chrtab(i), i=2356,2360) / 4874, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2361,2365) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2366,2370) / 4361, 4424, 4551, 668, 4891/ +data (chrtab(i), i=2371,2375) / 732, 4890, 905, 5063, 904/ +data (chrtab(i), i=2376,2380) / 5127, 0, 207, 5007, 5009/ +data (chrtab(i), i=2381,2385) / 4947, 4884, 4693, 4565, 4372/ +data (chrtab(i), i=2386,2390) / 4242, 4175, 4173, 4234, 4360/ +data (chrtab(i), i=2391,2395) / 4551, 4679, 4872, 5002, 848/ +data (chrtab(i), i=2396,2400) / 4945, 4883, 210, 4240, 4236/ +data (chrtab(i), i=2401,2405) / 4298, 783, 4882, 4820, 4693/ +data (chrtab(i), i=2406,2410) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2411,2415) / 4361, 4424, 4551, 0, 666/ +data (chrtab(i), i=2416,2420) / 4763, 4699, 4697, 4825, 4827/ +data (chrtab(i), i=2421,2425) / 4764, 4572, 4443, 4378, 4311/ +data (chrtab(i), i=2426,2430) / 4295, 346, 4375, 4360, 476/ +data (chrtab(i), i=2431,2435) / 4507, 4441, 4423, 21, 4693/ +data (chrtab(i), i=2436,2440) / 7, 4615, 200, 4167, 201/ +data (chrtab(i), i=2441,2445) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2446,2450) / 0, 852, 5011, 5076, 5013/ +data (chrtab(i), i=2451,2455) / 4949, 4820, 4755, 405, 4372/ +data (chrtab(i), i=2456,2460) / 4307, 4241, 4239, 4301, 4364/ +data (chrtab(i), i=2461,2465) / 4491, 4619, 4748, 4813, 4879/ +data (chrtab(i), i=2466,2470) / 4881, 4819, 4756, 4629, 4501/ +data (chrtab(i), i=2471,2475) / 275, 4305, 4303, 4365, 653/ +data (chrtab(i), i=2476,2480) / 4815, 4817, 4755, 405, 4436/ +data (chrtab(i), i=2481,2485) / 4370, 4366, 4428, 4491, 523/ +data (chrtab(i), i=2486,2490) / 4684, 4750, 4754, 4692, 4629/ +data (chrtab(i), i=2491,2495) / 205, 4236, 4170, 4169, 4231/ +data (chrtab(i), i=2496,2500) / 4294, 4485, 4741, 4932, 4995/ +data (chrtab(i), i=2501,2505) / 199, 4486, 4742, 4933, 73/ +data (chrtab(i), i=2506,2510) / 4232, 4423, 4743, 4934, 4996/ +data (chrtab(i), i=2511,2515) / 4995, 4929, 4736, 4352, 4161/ +data (chrtab(i), i=2516,2520) / 4099, 4100, 4166, 4359, 256/ +data (chrtab(i), i=2521,2525) / 4225, 4163, 4164, 4230, 4359/ +data (chrtab(i), i=2526,2530) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2531,2535) / 28, 4444, 4423, 337, 4499/ +data (chrtab(i), i=2536,2540) / 4564, 4693, 4885, 5012, 5075/ +data (chrtab(i), i=2541,2545) / 5136, 5127, 915, 5072, 5064/ +data (chrtab(i), i=2546,2550) / 789, 4948, 5009, 4999, 7/ +data (chrtab(i), i=2551,2555) / 4615, 711, 5319, 92, 4315/ +data (chrtab(i), i=2556,2560) / 156, 4314, 200, 4167, 201/ +data (chrtab(i), i=2561,2565) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2566,2570) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2571,2575) / 5191, 1032, 5255, 0, 220/ +data (chrtab(i), i=2576,2580) / 4314, 4442, 4444, 4316, 284/ +data (chrtab(i), i=2581,2585) / 4378, 219, 4443, 213, 4295/ +data (chrtab(i), i=2586,2590) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2591,2595) / 7, 4615, 85, 4308, 149/ +data (chrtab(i), i=2596,2600) / 4307, 200, 4167, 201, 4231/ +data (chrtab(i), i=2601,2605) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=2606,2610) / 348, 4442, 4570, 4572, 4444/ +data (chrtab(i), i=2611,2615) / 412, 4506, 347, 4571, 341/ +data (chrtab(i), i=2616,2620) / 4420, 4353, 4288, 404, 4485/ +data (chrtab(i), i=2621,2625) / 4418, 149, 4565, 4549, 4482/ +data (chrtab(i), i=2626,2630) / 4417, 4288, 4096, 4097, 4099/ +data (chrtab(i), i=2631,2635) / 4163, 4161, 4097, 4098, 213/ +data (chrtab(i), i=2636,2640) / 4436, 277, 4435, 0, 220/ +data (chrtab(i), i=2641,2645) / 4295, 283, 4360, 28, 4444/ +data (chrtab(i), i=2646,2650) / 4423, 916, 4427, 591, 5127/ +data (chrtab(i), i=2651,2655) / 590, 5063, 526, 4999, 725/ +data (chrtab(i), i=2656,2660) / 5269, 7, 4615, 711, 5255/ +data (chrtab(i), i=2661,2665) / 92, 4315, 156, 4314, 789/ +data (chrtab(i), i=2666,2670) / 5012, 1109, 5012, 200, 4167/ +data (chrtab(i), i=2671,2675) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2676,2680) / 4551, 905, 4871, 841, 5191/ +data (chrtab(i), i=2681,2685) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2686,2690) / 28, 4444, 4423, 7, 4615/ +data (chrtab(i), i=2691,2695) / 92, 4315, 156, 4314, 200/ +data (chrtab(i), i=2696,2700) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2701,2705) / 328, 4551, 0, 213, 4295/ +data (chrtab(i), i=2706,2710) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2711,2715) / 337, 4499, 4564, 4693, 4885/ +data (chrtab(i), i=2716,2720) / 5012, 5075, 5136, 5127, 915/ +data (chrtab(i), i=2721,2725) / 5072, 5064, 789, 4948, 5009/ +data (chrtab(i), i=2726,2730) / 4999, 1041, 5203, 5268, 5397/ +data (chrtab(i), i=2731,2735) / 5589, 5716, 5779, 5840, 5831/ +data (chrtab(i), i=2736,2740) / 1619, 5776, 5768, 1493, 5652/ +data (chrtab(i), i=2741,2745) / 5713, 5703, 7, 4615, 711/ +data (chrtab(i), i=2746,2750) / 5319, 1415, 6023, 85, 4308/ +data (chrtab(i), i=2751,2755) / 149, 4307, 200, 4167, 201/ +data (chrtab(i), i=2756,2760) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2761,2765) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2766,2770) / 5191, 1032, 5255, 1608, 5575/ +data (chrtab(i), i=2771,2775) / 1609, 5639, 1737, 5895, 1736/ +data (chrtab(i), i=2776,2780) / 5959, 0, 213, 4295, 276/ +data (chrtab(i), i=2781,2785) / 4360, 21, 4437, 4423, 337/ +data (chrtab(i), i=2786,2790) / 4499, 4564, 4693, 4885, 5012/ +data (chrtab(i), i=2791,2795) / 5075, 5136, 5127, 915, 5072/ +data (chrtab(i), i=2796,2800) / 5064, 789, 4948, 5009, 4999/ +data (chrtab(i), i=2801,2805) / 7, 4615, 711, 5319, 85/ +data (chrtab(i), i=2806,2810) / 4308, 149, 4307, 200, 4167/ +data (chrtab(i), i=2811,2815) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2816,2820) / 4551, 904, 4871, 905, 4935/ +data (chrtab(i), i=2821,2825) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=2826,2830) / 469, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2831,2835) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2836,2840) / 5002, 5069, 5071, 5010, 4884/ +data (chrtab(i), i=2841,2845) / 4693, 4565, 210, 4240, 4236/ +data (chrtab(i), i=2846,2850) / 4298, 842, 5004, 5008, 4946/ +data (chrtab(i), i=2851,2855) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2856,2860) / 4361, 4424, 4551, 583, 4808/ +data (chrtab(i), i=2861,2865) / 4873, 4940, 4944, 4883, 4820/ +data (chrtab(i), i=2866,2870) / 4693, 0, 213, 4288, 276/ +data (chrtab(i), i=2871,2875) / 4353, 21, 4437, 4416, 338/ +data (chrtab(i), i=2876,2880) / 4500, 4629, 4757, 4948, 5074/ +data (chrtab(i), i=2881,2885) / 5135, 5133, 5066, 4936, 4743/ +data (chrtab(i), i=2886,2890) / 4615, 4488, 4426, 914, 5072/ +data (chrtab(i), i=2891,2895) / 5068, 5002, 661, 4884, 4947/ +data (chrtab(i), i=2896,2900) / 5008, 5004, 4937, 4872, 4743/ +data (chrtab(i), i=2901,2905) / 0, 4608, 85, 4308, 149/ +data (chrtab(i), i=2906,2910) / 4307, 193, 4160, 194, 4224/ +data (chrtab(i), i=2911,2915) / 322, 4480, 321, 4544, 0/ +data (chrtab(i), i=2916,2920) / 788, 4864, 851, 4929, 724/ +data (chrtab(i), i=2921,2925) / 4948, 5013, 4992, 786, 4820/ +data (chrtab(i), i=2926,2930) / 4693, 4565, 4372, 4242, 4175/ +data (chrtab(i), i=2931,2935) / 4173, 4234, 4360, 4551, 4679/ +data (chrtab(i), i=2936,2940) / 4808, 4874, 210, 4240, 4236/ +data (chrtab(i), i=2941,2945) / 4298, 469, 4436, 4371, 4304/ +data (chrtab(i), i=2946,2950) / 4300, 4361, 4424, 4551, 576/ +data (chrtab(i), i=2951,2955) / 5184, 769, 4736, 770, 4800/ +data (chrtab(i), i=2956,2960) / 898, 5056, 897, 5120, 0/ +data (chrtab(i), i=2961,2965) / 213, 4295, 276, 4360, 21/ +data (chrtab(i), i=2966,2970) / 4437, 4423, 787, 4884, 4820/ +data (chrtab(i), i=2971,2975) / 4818, 4946, 4948, 4885, 4757/ +data (chrtab(i), i=2976,2980) / 4628, 4498, 4431, 7, 4615/ +data (chrtab(i), i=2981,2985) / 85, 4308, 149, 4307, 200/ +data (chrtab(i), i=2986,2990) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2991,2995) / 328, 4551, 0, 723, 4885/ +data (chrtab(i), i=2996,3000) / 4881, 4819, 4756, 4629, 4373/ +data (chrtab(i), i=3001,3005) / 4244, 4179, 4177, 4239, 4366/ +data (chrtab(i), i=3006,3010) / 4685, 4812, 4873, 148, 4177/ +data (chrtab(i), i=3011,3015) / 144, 4367, 4686, 4813, 780/ +data (chrtab(i), i=3016,3020) / 4808, 83, 4241, 4368, 4687/ +data (chrtab(i), i=3021,3025) / 4814, 4876, 4873, 4808, 4679/ +data (chrtab(i), i=3026,3030) / 4423, 4296, 4233, 4171, 4167/ +data (chrtab(i), i=3031,3035) / 4233, 0, 218, 4300, 4361/ +data (chrtab(i), i=3036,3040) / 4424, 4551, 4679, 4808, 4874/ +data (chrtab(i), i=3041,3045) / 282, 4363, 4425, 218, 4444/ +data (chrtab(i), i=3046,3050) / 4427, 4488, 4551, 21, 4693/ +data (chrtab(i), i=3051,3055) / 0, 213, 4300, 4361, 4424/ +data (chrtab(i), i=3056,3060) / 4551, 4743, 4872, 4937, 5003/ +data (chrtab(i), i=3061,3065) / 276, 4363, 4425, 21, 4437/ +data (chrtab(i), i=3066,3070) / 4427, 4488, 4551, 917, 4999/ +data (chrtab(i), i=3071,3075) / 5319, 980, 5064, 725, 5141/ +data (chrtab(i), i=3076,3080) / 5127, 85, 4308, 149, 4307/ +data (chrtab(i), i=3081,3085) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=3086,3090) / 85, 4551, 149, 4553, 213/ +data (chrtab(i), i=3091,3095) / 4617, 852, 4617, 4551, 21/ +data (chrtab(i), i=3096,3100) / 4501, 597, 5077, 21, 4307/ +data (chrtab(i), i=3101,3105) / 341, 4308, 725, 4948, 917/ +data (chrtab(i), i=3106,3110) / 4948, 0, 149, 4487, 213/ +data (chrtab(i), i=3111,3115) / 4490, 277, 4554, 661, 4554/ +data (chrtab(i), i=3116,3120) / 4487, 661, 4999, 725, 5002/ +data (chrtab(i), i=3121,3125) / 661, 4885, 5066, 1172, 5066/ +data (chrtab(i), i=3126,3130) / 4999, 21, 4565, 981, 5461/ +data (chrtab(i), i=3131,3135) / 21, 4308, 405, 4372, 1045/ +data (chrtab(i), i=3136,3140) / 5268, 1301, 5268, 0, 149/ +data (chrtab(i), i=3141,3145) / 4871, 213, 4935, 277, 4999/ +data (chrtab(i), i=3146,3150) / 852, 4296, 21, 4565, 661/ +data (chrtab(i), i=3151,3155) / 5141, 7, 4487, 583, 5127/ +data (chrtab(i), i=3156,3160) / 85, 4308, 405, 4372, 725/ +data (chrtab(i), i=3161,3165) / 4948, 981, 4948, 200, 4167/ +data (chrtab(i), i=3166,3170) / 200, 4423, 776, 4743, 840/ +data (chrtab(i), i=3171,3175) / 5063, 0, 149, 4615, 213/ +data (chrtab(i), i=3176,3180) / 4617, 277, 4681, 916, 4681/ +data (chrtab(i), i=3181,3185) / 4483, 4353, 4224, 4096, 4097/ +data (chrtab(i), i=3186,3190) / 4099, 4163, 4161, 4097, 4098/ +data (chrtab(i), i=3191,3195) / 21, 4565, 661, 5141, 85/ +data (chrtab(i), i=3196,3200) / 4371, 405, 4372, 789, 5012/ +data (chrtab(i), i=3201,3205) / 981, 5012, 0, 725, 4167/ +data (chrtab(i), i=3206,3210) / 789, 4231, 853, 4295, 853/ +data (chrtab(i), i=3211,3215) / 4181, 4177, 71, 4935, 4939/ +data (chrtab(i), i=3216,3220) / 149, 4177, 213, 4178, 277/ +data (chrtab(i), i=3221,3225) / 4179, 405, 4180, 519, 4936/ +data (chrtab(i), i=3226,3230) / 647, 4937, 711, 4938, 775/ +data (chrtab(i), i=3231,3235) / 4939, 0, 480, 4447, 4382/ +data (chrtab(i), i=3236,3240) / 4316, 4314, 4376, 4439, 4501/ +data (chrtab(i), i=3241,3245) / 4499, 4369, 351, 4381, 4379/ +data (chrtab(i), i=3246,3250) / 4441, 4504, 4566, 4564, 4498/ +data (chrtab(i), i=3251,3255) / 4240, 4494, 4556, 4554, 4488/ +data (chrtab(i), i=3256,3260) / 4423, 4357, 4355, 4417, 271/ +data (chrtab(i), i=3261,3265) / 4493, 4491, 4425, 4360, 4294/ +data (chrtab(i), i=3266,3270) / 4292, 4354, 4417, 4544, 0/ +data (chrtab(i), i=3271,3275) / 160, 4224, 0, 224, 4447/ +data (chrtab(i), i=3276,3280) / 4510, 4572, 4570, 4504, 4439/ +data (chrtab(i), i=3281,3285) / 4373, 4371, 4497, 351, 4509/ +data (chrtab(i), i=3286,3290) / 4507, 4441, 4376, 4310, 4308/ +data (chrtab(i), i=3291,3295) / 4370, 4624, 4366, 4300, 4298/ +data (chrtab(i), i=3296,3300) / 4360, 4423, 4485, 4483, 4417/ +data (chrtab(i), i=3301,3305) / 399, 4365, 4363, 4425, 4488/ +data (chrtab(i), i=3306,3310) / 4550, 4548, 4482, 4417, 4288/ +data (chrtab(i), i=3311,3315) / 0, 77, 4175, 4242, 4371/ +data (chrtab(i), i=3316,3320) / 4499, 4626, 4879, 5006, 5134/ +data (chrtab(i), i=3321,3325) / 5263, 5329, 79, 4241, 4370/ +data (chrtab(i), i=3326,3330) / 4498, 4625, 4878, 5005, 5133/ +data (chrtab(i), i=3331,3335) / 5262, 5329, 5331, 0, 284/ +data (chrtab(i), i=3336,3340) / 4251, 4185, 4183, 4245, 4372/ +data (chrtab(i), i=3341,3345) / 4500, 4629, 4695, 4697, 4635/ +data (chrtab(i), i=3346,3350) / 4508, 4380, 284, 4185, 4245/ +data (chrtab(i), i=3351,3355) / 4500, 4695, 4635, 4380, 412/ +data (chrtab(i), i=3356,3360) / 4251, 4183, 4372, 4629, 4697/ +data (chrtab(i), i=3361,3362) / 4508, 0/ diff --git a/sys/gio/sgikern/font.h b/sys/gio/sgikern/font.h new file mode 100644 index 00000000..eb2e72f4 --- /dev/null +++ b/sys/gio/sgikern/font.h @@ -0,0 +1,29 @@ +# FONT.H -- Font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/sgikern/greek.com b/sys/gio/sgikern/greek.com new file mode 100644 index 00000000..cb9fffdc --- /dev/null +++ b/sys/gio/sgikern/greek.com @@ -0,0 +1,501 @@ +# GCHTAB -- Table of strokes for the printable GREEK characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short gchidx[97] # character index in gchtab +short gchwid[97] # character width table +short gchtab[2140] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (gchidx(i), i=001,005) / 1, 3, 16, 29, 38/ +data (gchidx(i), i=006,010) / 77, 107, 154, 162, 181/ +data (gchidx(i), i=011,015) / 200, 205, 212, 233, 240/ +data (gchidx(i), i=016,020) / 246, 259, 297, 306, 348/ +data (gchidx(i), i=021,025) / 392, 402, 437, 483, 510/ +data (gchidx(i), i=026,030) / 568, 614, 645, 658, 666/ +data (gchidx(i), i=031,035) / 673, 681, 688, 741, 767/ +data (gchidx(i), i=036,040) / 793, 795, 806, 821, 863/ +data (gchidx(i), i=041,045) / 874, 883, 888, 899, 901/ +data (gchidx(i), i=046,050) / 912, 921, 930, 972, 987/ +data (gchidx(i), i=051,055) / 1037, 1067, 1083, 1088, 1117/ +data (gchidx(i), i=056,060) / 1143, 1182, 1207, 1242, 1244/ +data (gchidx(i), i=061,065) / 1253, 1256, 1265, 1267, 1276/ +data (gchidx(i), i=066,070) / 1284, 1321, 1373, 1394, 1436/ +data (gchidx(i), i=071,075) / 1465, 1500, 1525, 1554, 1568/ +data (gchidx(i), i=076,080) / 1610, 1635, 1655, 1679, 1699/ +data (gchidx(i), i=081,085) / 1729, 1746, 1788, 1817, 1849/ +data (gchidx(i), i=086,090) / 1862, 1891, 1893, 1934, 1975/ +data (gchidx(i), i=091,095) / 2006, 2036, 2074, 2079, 2117/ +data (gchidx(i), i=096,096) / 2126/ + + +# Width data. + +data (gchwid(i), i=001,005) / 21, 15, 15, 26, 25/ +data (gchwid(i), i=006,010) / 29, 30, 15, 19, 19/ +data (gchwid(i), i=011,015) / 27, 29, 30, 29, 15/ +data (gchwid(i), i=016,020) / 31, 25, 25, 25, 25/ +data (gchwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (gchwid(i), i=026,030) / 25, 29, 15, 29, 31/ +data (gchwid(i), i=031,035) / 29, 31, 32, 25, 30/ +data (gchwid(i), i=036,040) / 21, 25, 29, 26, 23/ +data (gchwid(i), i=041,045) / 26, 19, 25, 21, 25/ +data (gchwid(i), i=046,050) / 21, 21, 27, 29, 27/ +data (gchwid(i), i=051,055) / 29, 26, 19, 24, 25/ +data (gchwid(i), i=056,060) / 27, 27, 28, 21, 19/ +data (gchwid(i), i=061,065) / 19, 19, 21, 31, 27/ +data (gchwid(i), i=066,070) / 28, 26, 23, 24, 23/ +data (gchwid(i), i=071,075) / 27, 25, 27, 17, 24/ +data (gchwid(i), i=076,080) / 25, 25, 28, 25, 23/ +data (gchwid(i), i=081,085) / 27, 28, 24, 26, 25/ +data (gchwid(i), i=086,090) / 25, 21, 28, 22, 28/ +data (gchwid(i), i=091,095) / 23, 19, 19, 19, 31/ +data (gchwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (gchtab(i), i=0001,0005) / 35, 0, 220, 4250, 4302/ +data (gchtab(i), i=0006,0010) / 4378, 4316, 218, 4308, 201/ +data (gchtab(i), i=0011,0015) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0016,0020) / 213, 4244, 4307, 4372, 4309/ +data (gchtab(i), i=0021,0025) / 199, 4232, 4297, 4360, 4358/ +data (gchtab(i), i=0026,0030) / 4292, 4227, 0, 604, 4224/ +data (gchtab(i), i=0031,0035) / 988, 4608, 145, 5137, 75/ +data (gchtab(i), i=0036,0040) / 5067, 0, 416, 4483, 672/ +data (gchtab(i), i=0041,0045) / 4739, 921, 4952, 5015, 5080/ +data (gchtab(i), i=0046,0050) / 5081, 4955, 4764, 4508, 4315/ +data (gchtab(i), i=0051,0055) / 4185, 4183, 4245, 4308, 4435/ +data (gchtab(i), i=0056,0060) / 4817, 4944, 5070, 87, 4309/ +data (gchtab(i), i=0061,0065) / 4436, 4818, 4945, 5008, 5070/ +data (gchtab(i), i=0066,0070) / 5066, 4936, 4743, 4487, 4296/ +data (gchtab(i), i=0071,0075) / 4170, 4171, 4236, 4299, 4234/ +data (gchtab(i), i=0076,0080) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=0081,0085) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=0086,0090) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=0091,0095) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=0096,0100) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=0101,0105) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=0106,0110) / 0, 1236, 5267, 5330, 5395/ +data (gchtab(i), i=0111,0115) / 5396, 5333, 5269, 5204, 5138/ +data (gchtab(i), i=0116,0120) / 5005, 4874, 4744, 4615, 4423/ +data (gchtab(i), i=0121,0125) / 4232, 4170, 4173, 4239, 4627/ +data (gchtab(i), i=0126,0130) / 4757, 4823, 4825, 4763, 4636/ +data (gchtab(i), i=0131,0135) / 4507, 4441, 4439, 4500, 4625/ +data (gchtab(i), i=0136,0140) / 4938, 5064, 5255, 5319, 5384/ +data (gchtab(i), i=0141,0145) / 5385, 327, 4296, 4234, 4237/ +data (gchtab(i), i=0146,0150) / 4303, 4433, 343, 4501, 5002/ +data (gchtab(i), i=0151,0155) / 5128, 5255, 0, 218, 4251/ +data (gchtab(i), i=0156,0160) / 4316, 4379, 4377, 4311, 4246/ +data (gchtab(i), i=0161,0165) / 0, 608, 4574, 4443, 4311/ +data (gchtab(i), i=0166,0170) / 4242, 4238, 4297, 4421, 4546/ +data (gchtab(i), i=0171,0175) / 4672, 478, 4442, 4375, 4306/ +data (gchtab(i), i=0176,0180) / 4302, 4361, 4422, 4546, 0/ +data (gchtab(i), i=0181,0185) / 96, 4318, 4443, 4567, 4626/ +data (gchtab(i), i=0186,0190) / 4622, 4553, 4421, 4290, 4160/ +data (gchtab(i), i=0191,0195) / 222, 4442, 4503, 4562, 4558/ +data (gchtab(i), i=0196,0200) / 4489, 4422, 4290, 0, 151/ +data (gchtab(i), i=0201,0205) / 5129, 1047, 4233, 0, 664/ +data (gchtab(i), i=0206,0210) / 4743, 144, 5264, 135, 5255/ +data (gchtab(i), i=0211,0215) / 0, 1227, 5195, 5068, 4942/ +data (gchtab(i), i=0216,0220) / 4754, 4691, 4564, 4436, 4307/ +data (gchtab(i), i=0221,0225) / 4241, 4239, 4301, 4428, 4556/ +data (gchtab(i), i=0226,0230) / 4685, 4750, 4946, 5076, 5205/ +data (gchtab(i), i=0231,0235) / 5333, 0, 664, 4743, 152/ +data (gchtab(i), i=0236,0240) / 5272, 144, 5264, 0, 201/ +data (gchtab(i), i=0241,0245) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0246,0250) / 729, 4760, 4823, 4888, 4825/ +data (gchtab(i), i=0251,0255) / 144, 5392, 713, 4744, 4807/ +data (gchtab(i), i=0256,0260) / 4872, 4809, 0, 476, 4379/ +data (gchtab(i), i=0261,0265) / 4248, 4179, 4176, 4235, 4360/ +data (gchtab(i), i=0266,0270) / 4551, 4679, 4872, 5003, 5072/ +data (gchtab(i), i=0271,0275) / 5075, 5016, 4891, 4700, 4572/ +data (gchtab(i), i=0276,0280) / 476, 4443, 4378, 4312, 4243/ +data (gchtab(i), i=0281,0285) / 4240, 4299, 4361, 4424, 4551/ +data (gchtab(i), i=0286,0290) / 583, 4808, 4873, 4939, 5008/ +data (gchtab(i), i=0291,0295) / 5011, 4952, 4890, 4827, 4700/ +data (gchtab(i), i=0296,0300) / 0, 280, 4505, 4700, 4679/ +data (gchtab(i), i=0301,0305) / 539, 4615, 263, 4935, 0/ +data (gchtab(i), i=0306,0310) / 152, 4311, 4246, 4183, 4184/ +data (gchtab(i), i=0311,0315) / 4250, 4315, 4508, 4764, 4955/ +data (gchtab(i), i=0316,0320) / 5018, 5080, 5078, 5012, 4818/ +data (gchtab(i), i=0321,0325) / 4496, 4367, 4237, 4170, 4167/ +data (gchtab(i), i=0326,0330) / 668, 4891, 4954, 5016, 5014/ +data (gchtab(i), i=0331,0335) / 4948, 4754, 4496, 73, 4234/ +data (gchtab(i), i=0336,0340) / 4362, 4680, 4872, 5001, 5066/ +data (gchtab(i), i=0341,0345) / 266, 4679, 4935, 5000, 5066/ +data (gchtab(i), i=0346,0350) / 5068, 0, 152, 4311, 4246/ +data (gchtab(i), i=0351,0355) / 4183, 4184, 4250, 4315, 4508/ +data (gchtab(i), i=0356,0360) / 4764, 4955, 5017, 5014, 4948/ +data (gchtab(i), i=0361,0365) / 4755, 4563, 668, 4891, 4953/ +data (gchtab(i), i=0366,0370) / 4950, 4884, 4755, 659, 4882/ +data (gchtab(i), i=0371,0375) / 5008, 5070, 5067, 5001, 4936/ +data (gchtab(i), i=0376,0380) / 4743, 4487, 4296, 4233, 4171/ +data (gchtab(i), i=0381,0385) / 4172, 4237, 4300, 4235, 849/ +data (gchtab(i), i=0386,0390) / 5006, 5003, 4937, 4872, 4743/ +data (gchtab(i), i=0391,0395) / 0, 666, 4743, 732, 4807/ +data (gchtab(i), i=0396,0400) / 732, 4109, 5133, 455, 4999/ +data (gchtab(i), i=0401,0405) / 0, 220, 4178, 82, 4308/ +data (gchtab(i), i=0406,0410) / 4501, 4693, 4884, 5010, 5071/ +data (gchtab(i), i=0411,0415) / 5069, 5002, 4872, 4679, 4487/ +data (gchtab(i), i=0416,0420) / 4296, 4233, 4171, 4172, 4237/ +data (gchtab(i), i=0421,0425) / 4300, 4235, 597, 4820, 4946/ +data (gchtab(i), i=0426,0430) / 5007, 5005, 4938, 4808, 4679/ +data (gchtab(i), i=0431,0435) / 220, 4956, 219, 4635, 4956/ +data (gchtab(i), i=0436,0440) / 0, 857, 4888, 4951, 5016/ +data (gchtab(i), i=0441,0445) / 5017, 4955, 4828, 4636, 4443/ +data (gchtab(i), i=0446,0450) / 4313, 4247, 4179, 4173, 4234/ +data (gchtab(i), i=0451,0455) / 4360, 4551, 4679, 4872, 5002/ +data (gchtab(i), i=0456,0460) / 5069, 5070, 5009, 4883, 4692/ +data (gchtab(i), i=0461,0465) / 4628, 4435, 4305, 4238, 540/ +data (gchtab(i), i=0466,0470) / 4507, 4377, 4311, 4243, 4237/ +data (gchtab(i), i=0471,0475) / 4298, 4424, 4551, 583, 4808/ +data (gchtab(i), i=0476,0480) / 4938, 5005, 5006, 4945, 4819/ +data (gchtab(i), i=0481,0485) / 4692, 0, 92, 4182, 88/ +data (gchtab(i), i=0486,0490) / 4250, 4380, 4508, 4825, 4953/ +data (gchtab(i), i=0491,0495) / 5018, 5084, 154, 4379, 4507/ +data (gchtab(i), i=0496,0500) / 4825, 988, 5081, 5014, 4753/ +data (gchtab(i), i=0501,0505) / 4687, 4620, 4615, 918, 4689/ +data (gchtab(i), i=0506,0510) / 4623, 4556, 4551, 0, 412/ +data (gchtab(i), i=0511,0515) / 4315, 4249, 4246, 4308, 4499/ +data (gchtab(i), i=0516,0520) / 4755, 4948, 5014, 5017, 4955/ +data (gchtab(i), i=0521,0525) / 4764, 4508, 412, 4379, 4313/ +data (gchtab(i), i=0526,0530) / 4310, 4372, 4499, 659, 4884/ +data (gchtab(i), i=0531,0535) / 4950, 4953, 4891, 4764, 403/ +data (gchtab(i), i=0536,0540) / 4306, 4241, 4175, 4171, 4233/ +data (gchtab(i), i=0541,0545) / 4296, 4487, 4743, 4936, 5001/ +data (gchtab(i), i=0546,0550) / 5067, 5071, 5009, 4946, 4755/ +data (gchtab(i), i=0551,0555) / 403, 4370, 4305, 4239, 4235/ +data (gchtab(i), i=0556,0560) / 4297, 4360, 4487, 647, 4872/ +data (gchtab(i), i=0561,0565) / 4937, 5003, 5007, 4945, 4882/ +data (gchtab(i), i=0566,0570) / 4755, 0, 917, 4946, 4816/ +data (gchtab(i), i=0571,0575) / 4623, 4559, 4368, 4242, 4181/ +data (gchtab(i), i=0576,0580) / 4182, 4249, 4379, 4572, 4700/ +data (gchtab(i), i=0581,0585) / 4891, 5017, 5078, 5072, 5004/ +data (gchtab(i), i=0586,0590) / 4938, 4808, 4615, 4423, 4296/ +data (gchtab(i), i=0591,0595) / 4234, 4235, 4300, 4363, 4298/ +data (gchtab(i), i=0596,0600) / 463, 4432, 4306, 4245, 4246/ +data (gchtab(i), i=0601,0605) / 4313, 4443, 4572, 604, 4827/ +data (gchtab(i), i=0606,0610) / 4953, 5014, 5008, 4940, 4874/ +data (gchtab(i), i=0611,0615) / 4744, 4615, 0, 1247, 5278/ +data (gchtab(i), i=0616,0620) / 5341, 5406, 5407, 5344, 5216/ +data (gchtab(i), i=0621,0625) / 5087, 4957, 4891, 4824, 4756/ +data (gchtab(i), i=0626,0630) / 4616, 4548, 4482, 926, 4956/ +data (gchtab(i), i=0631,0635) / 4888, 4748, 4680, 4613, 4547/ +data (gchtab(i), i=0636,0640) / 4417, 4288, 4160, 4097, 4098/ +data (gchtab(i), i=0641,0645) / 4163, 4226, 4161, 0, 213/ +data (gchtab(i), i=0646,0650) / 4244, 4307, 4372, 4309, 199/ +data (gchtab(i), i=0651,0655) / 4232, 4297, 4360, 4358, 4292/ +data (gchtab(i), i=0656,0660) / 4227, 0, 1180, 4245, 5262/ +data (gchtab(i), i=0661,0665) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0666,0670) / 149, 5397, 144, 5392, 139/ +data (gchtab(i), i=0671,0675) / 5387, 0, 156, 5269, 4238/ +data (gchtab(i), i=0676,0680) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0681,0685) / 1177, 4359, 147, 5395, 141/ +data (gchtab(i), i=0686,0690) / 5389, 0, 1044, 5078, 4951/ +data (gchtab(i), i=0691,0695) / 4759, 4630, 4565, 4498, 4495/ +data (gchtab(i), i=0696,0700) / 4557, 4684, 4876, 5005, 5071/ +data (gchtab(i), i=0701,0705) / 663, 4629, 4562, 4559, 4621/ +data (gchtab(i), i=0706,0710) / 4684, 1047, 5071, 5069, 5196/ +data (gchtab(i), i=0711,0715) / 5324, 5454, 5521, 5523, 5462/ +data (gchtab(i), i=0716,0720) / 5400, 5274, 5147, 4956, 4764/ +data (gchtab(i), i=0721,0725) / 4571, 4442, 4312, 4246, 4179/ +data (gchtab(i), i=0726,0730) / 4176, 4237, 4299, 4425, 4552/ +data (gchtab(i), i=0731,0735) / 4743, 4935, 5128, 5257, 5322/ +data (gchtab(i), i=0736,0740) / 1111, 5135, 5133, 5196, 0/ +data (gchtab(i), i=0741,0745) / 473, 4167, 601, 5063, 537/ +data (gchtab(i), i=0746,0750) / 4999, 205, 4877, 7, 4423/ +data (gchtab(i), i=0751,0755) / 711, 5191, 480, 4447, 4381/ +data (gchtab(i), i=0756,0760) / 4379, 4441, 4568, 4696, 4825/ +data (gchtab(i), i=0761,0765) / 4891, 4893, 4831, 4704, 4576/ +data (gchtab(i), i=0766,0770) / 0, 1295, 5325, 5196, 5068/ +data (gchtab(i), i=0771,0775) / 4941, 4878, 4690, 4627, 4500/ +data (gchtab(i), i=0776,0780) / 4372, 4243, 4177, 4175, 4237/ +data (gchtab(i), i=0781,0785) / 4364, 4492, 4621, 4686, 4882/ +data (gchtab(i), i=0786,0790) / 4947, 5076, 5204, 5331, 5393/ +data (gchtab(i), i=0791,0795) / 5391, 0, 35, 0, 540/ +data (gchtab(i), i=0796,0800) / 4103, 540, 5127, 537, 5063/ +data (gchtab(i), i=0801,0805) / 72, 5064, 7, 5127, 0/ +data (gchtab(i), i=0806,0810) / 1176, 4824, 4567, 4438, 4308/ +data (gchtab(i), i=0811,0815) / 4241, 4239, 4300, 4426, 4553/ +data (gchtab(i), i=0816,0820) / 4808, 5256, 144, 5008, 0/ +data (gchtab(i), i=0821,0825) / 540, 4615, 604, 4679, 407/ +data (gchtab(i), i=0826,0830) / 4310, 4245, 4179, 4176, 4238/ +data (gchtab(i), i=0831,0835) / 4301, 4492, 4812, 5005, 5070/ +data (gchtab(i), i=0836,0840) / 5136, 5139, 5077, 5014, 4823/ +data (gchtab(i), i=0841,0845) / 4503, 407, 4374, 4309, 4243/ +data (gchtab(i), i=0846,0850) / 4240, 4302, 4365, 4492, 716/ +data (gchtab(i), i=0851,0855) / 4941, 5006, 5072, 5075, 5013/ +data (gchtab(i), i=0856,0860) / 4950, 4823, 348, 4892, 327/ +data (gchtab(i), i=0861,0865) / 4871, 0, 220, 4295, 284/ +data (gchtab(i), i=0866,0870) / 4359, 28, 5084, 5078, 5020/ +data (gchtab(i), i=0871,0875) / 7, 4551, 0, 608, 4224/ +data (gchtab(i), i=0876,0880) / 992, 4608, 147, 5139, 77/ +data (gchtab(i), i=0881,0885) / 5069, 0, 160, 4224, 544/ +data (gchtab(i), i=0886,0890) / 4608, 0, 28, 4615, 92/ +data (gchtab(i), i=0891,0895) / 4617, 1052, 4615, 28, 5148/ +data (gchtab(i), i=0896,0900) / 91, 5083, 0, 35, 0/ +data (gchtab(i), i=0901,0905) / 540, 4167, 540, 5063, 537/ +data (gchtab(i), i=0906,0910) / 4999, 7, 4423, 711, 5191/ +data (gchtab(i), i=0911,0915) / 0, 278, 4505, 4630, 83/ +data (gchtab(i), i=0916,0920) / 4504, 4819, 408, 4487, 0/ +data (gchtab(i), i=0921,0925) / 266, 4487, 4618, 77, 4488/ +data (gchtab(i), i=0926,0930) / 4813, 409, 4488, 0, 540/ +data (gchtab(i), i=0931,0935) / 4443, 4313, 4247, 4179, 4176/ +data (gchtab(i), i=0936,0940) / 4236, 4298, 4424, 4615, 4743/ +data (gchtab(i), i=0941,0945) / 4936, 5066, 5132, 5200, 5203/ +data (gchtab(i), i=0946,0950) / 5143, 5081, 4955, 4764, 4636/ +data (gchtab(i), i=0951,0955) / 540, 4507, 4377, 4311, 4243/ +data (gchtab(i), i=0956,0960) / 4240, 4300, 4362, 4488, 4615/ +data (gchtab(i), i=0961,0965) / 647, 4872, 5002, 5068, 5136/ +data (gchtab(i), i=0966,0970) / 5139, 5079, 5017, 4891, 4764/ +data (gchtab(i), i=0971,0975) / 0, 220, 4295, 284, 4359/ +data (gchtab(i), i=0976,0980) / 1052, 5127, 1116, 5191, 28/ +data (gchtab(i), i=0981,0985) / 5404, 7, 4551, 839, 5383/ +data (gchtab(i), i=0986,0990) / 0, 540, 4443, 4313, 4247/ +data (gchtab(i), i=0991,0995) / 4179, 4176, 4236, 4298, 4424/ +data (gchtab(i), i=0996,1000) / 4615, 4743, 4936, 5066, 5132/ +data (gchtab(i), i=1001,1005) / 5200, 5203, 5143, 5081, 4955/ +data (gchtab(i), i=1006,1010) / 4764, 4636, 540, 4507, 4377/ +data (gchtab(i), i=1011,1015) / 4311, 4243, 4240, 4300, 4362/ +data (gchtab(i), i=1016,1020) / 4488, 4615, 647, 4872, 5002/ +data (gchtab(i), i=1021,1025) / 5068, 5136, 5139, 5079, 5017/ +data (gchtab(i), i=1026,1030) / 4891, 4764, 405, 4494, 789/ +data (gchtab(i), i=1031,1035) / 4878, 402, 4882, 401, 4881/ +data (gchtab(i), i=1036,1040) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=1041,1045) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=1046,1050) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=1051,1055) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=1056,1060) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=1061,1065) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=1066,1070) / 0, 92, 4626, 4103, 28/ +data (gchtab(i), i=1071,1075) / 4562, 28, 5084, 5142, 5020/ +data (gchtab(i), i=1076,1080) / 72, 5000, 7, 5063, 5133/ +data (gchtab(i), i=1081,1085) / 4999, 0, 160, 4224, 544/ +data (gchtab(i), i=1086,1090) / 4608, 0, 23, 4121, 4187/ +data (gchtab(i), i=1091,1095) / 4252, 4380, 4443, 4505, 4565/ +data (gchtab(i), i=1096,1100) / 4551, 25, 4251, 4379, 4505/ +data (gchtab(i), i=1101,1105) / 983, 5081, 5019, 4956, 4828/ +data (gchtab(i), i=1106,1110) / 4763, 4697, 4629, 4615, 985/ +data (gchtab(i), i=1111,1115) / 4955, 4827, 4697, 263, 4807/ +data (gchtab(i), i=1116,1120) / 0, 473, 4167, 601, 5063/ +data (gchtab(i), i=1121,1125) / 537, 4999, 205, 4877, 7/ +data (gchtab(i), i=1126,1130) / 4423, 711, 5191, 480, 4447/ +data (gchtab(i), i=1131,1135) / 4381, 4379, 4441, 4568, 4696/ +data (gchtab(i), i=1136,1140) / 4825, 4891, 4893, 4831, 4704/ +data (gchtab(i), i=1141,1145) / 4576, 0, 74, 4231, 4487/ +data (gchtab(i), i=1146,1150) / 4363, 4239, 4178, 4182, 4249/ +data (gchtab(i), i=1151,1155) / 4379, 4572, 4828, 5019, 5145/ +data (gchtab(i), i=1156,1160) / 5206, 5202, 5135, 5003, 4871/ +data (gchtab(i), i=1161,1165) / 5127, 5194, 267, 4302, 4242/ +data (gchtab(i), i=1166,1170) / 4246, 4313, 4443, 4572, 732/ +data (gchtab(i), i=1171,1175) / 4955, 5081, 5142, 5138, 5070/ +data (gchtab(i), i=1176,1180) / 5003, 136, 4424, 840, 5128/ +data (gchtab(i), i=1181,1185) / 0, 157, 4184, 1117, 5144/ +data (gchtab(i), i=1186,1190) / 404, 4431, 852, 4879, 139/ +data (gchtab(i), i=1191,1195) / 4166, 1099, 5126, 155, 5147/ +data (gchtab(i), i=1196,1200) / 154, 5146, 402, 4882, 401/ +data (gchtab(i), i=1201,1205) / 4881, 137, 5129, 136, 5128/ +data (gchtab(i), i=1206,1210) / 0, 604, 4679, 668, 4743/ +data (gchtab(i), i=1211,1215) / 21, 4182, 4309, 4369, 4431/ +data (gchtab(i), i=1216,1220) / 4494, 4621, 86, 4245, 4305/ +data (gchtab(i), i=1221,1225) / 4367, 4430, 4621, 4813, 5006/ +data (gchtab(i), i=1226,1230) / 5071, 5137, 5205, 5270, 717/ +data (gchtab(i), i=1231,1235) / 4942, 5007, 5073, 5141, 5270/ +data (gchtab(i), i=1236,1240) / 5333, 412, 4956, 391, 4935/ +data (gchtab(i), i=1241,1245) / 0, 35, 0, 160, 4224/ +data (gchtab(i), i=1246,1250) / 224, 4288, 160, 4704, 128/ +data (gchtab(i), i=1251,1255) / 4672, 0, 28, 4868, 0/ +data (gchtab(i), i=1256,1260) / 480, 4544, 544, 4608, 96/ +data (gchtab(i), i=1261,1265) / 4640, 64, 4608, 0, 35/ +data (gchtab(i), i=1266,1270) / 0, 1106, 5392, 5198, 917/ +data (gchtab(i), i=1271,1275) / 5328, 5003, 144, 5328, 0/ +data (gchtab(i), i=1276,1280) / 85, 4437, 4809, 277, 4807/ +data (gchtab(i), i=1281,1285) / 1312, 4807, 0, 533, 4436/ +data (gchtab(i), i=1286,1290) / 4306, 4240, 4173, 4170, 4232/ +data (gchtab(i), i=1291,1295) / 4423, 4551, 4680, 4875, 5006/ +data (gchtab(i), i=1296,1300) / 5138, 5205, 533, 4500, 4370/ +data (gchtab(i), i=1301,1305) / 4304, 4237, 4234, 4296, 4423/ +data (gchtab(i), i=1306,1310) / 533, 4757, 4884, 4946, 5066/ +data (gchtab(i), i=1311,1315) / 5128, 5191, 661, 4820, 4882/ +data (gchtab(i), i=1316,1320) / 5002, 5064, 5191, 5255, 0/ +data (gchtab(i), i=1321,1325) / 732, 4635, 4505, 4373, 4306/ +data (gchtab(i), i=1326,1330) / 4238, 4168, 4096, 732, 4699/ +data (gchtab(i), i=1331,1335) / 4569, 4437, 4370, 4302, 4232/ +data (gchtab(i), i=1336,1340) / 4160, 732, 4956, 5083, 5146/ +data (gchtab(i), i=1341,1345) / 5143, 5077, 5012, 4819, 4563/ +data (gchtab(i), i=1346,1350) / 860, 5082, 5079, 5013, 4948/ +data (gchtab(i), i=1351,1355) / 4819, 467, 4818, 4944, 5006/ +data (gchtab(i), i=1356,1360) / 5003, 4937, 4872, 4679, 4551/ +data (gchtab(i), i=1361,1365) / 4424, 4361, 4300, 467, 4754/ +data (gchtab(i), i=1366,1370) / 4880, 4942, 4939, 4873, 4808/ +data (gchtab(i), i=1371,1375) / 4679, 0, 21, 4245, 4372/ +data (gchtab(i), i=1376,1380) / 4434, 4739, 4801, 4864, 149/ +data (gchtab(i), i=1381,1385) / 4308, 4370, 4675, 4737, 4864/ +data (gchtab(i), i=1386,1390) / 4992, 981, 5011, 4880, 4229/ +data (gchtab(i), i=1391,1395) / 4098, 4096, 0, 724, 4693/ +data (gchtab(i), i=1396,1400) / 4565, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1401,1405) / 4233, 4296, 4423, 4551, 4744/ +data (gchtab(i), i=1406,1410) / 4875, 4942, 4945, 4883, 4632/ +data (gchtab(i), i=1411,1415) / 4570, 4572, 4637, 4765, 4892/ +data (gchtab(i), i=1416,1420) / 5018, 469, 4436, 4305, 4238/ +data (gchtab(i), i=1421,1425) / 4234, 4296, 455, 4680, 4811/ +data (gchtab(i), i=1426,1430) / 4878, 4882, 4820, 4695, 4633/ +data (gchtab(i), i=1431,1435) / 4635, 4700, 4828, 5018, 0/ +data (gchtab(i), i=1436,1440) / 850, 4820, 4693, 4437, 4308/ +data (gchtab(i), i=1441,1445) / 4306, 4432, 4623, 341, 4372/ +data (gchtab(i), i=1446,1450) / 4370, 4496, 4623, 527, 4302/ +data (gchtab(i), i=1451,1455) / 4172, 4170, 4232, 4423, 4615/ +data (gchtab(i), i=1456,1460) / 4744, 4874, 527, 4366, 4236/ +data (gchtab(i), i=1461,1465) / 4234, 4296, 4423, 0, 404/ +data (gchtab(i), i=1466,1470) / 4371, 4241, 4174, 4171, 4233/ +data (gchtab(i), i=1471,1475) / 4296, 4423, 4615, 4808, 5002/ +data (gchtab(i), i=1476,1480) / 5133, 5200, 5203, 5077, 4949/ +data (gchtab(i), i=1481,1485) / 4819, 4687, 4554, 4352, 75/ +data (gchtab(i), i=1486,1490) / 4297, 4424, 4616, 4809, 5003/ +data (gchtab(i), i=1491,1495) / 5133, 1107, 5076, 4948, 4818/ +data (gchtab(i), i=1496,1500) / 4687, 4553, 4416, 0, 18/ +data (gchtab(i), i=1501,1505) / 4180, 4309, 4437, 4564, 4627/ +data (gchtab(i), i=1506,1510) / 4688, 4684, 4616, 4416, 19/ +data (gchtab(i), i=1511,1515) / 4244, 4500, 4627, 1045, 5074/ +data (gchtab(i), i=1516,1520) / 5008, 4681, 4484, 4352, 981/ +data (gchtab(i), i=1521,1525) / 5010, 4944, 4681, 0, 17/ +data (gchtab(i), i=1526,1530) / 4115, 4245, 4437, 4500, 4498/ +data (gchtab(i), i=1531,1535) / 4430, 4295, 277, 4436, 4434/ +data (gchtab(i), i=1536,1540) / 4366, 4231, 334, 4562, 4692/ +data (gchtab(i), i=1541,1545) / 4821, 4949, 5076, 5139, 5136/ +data (gchtab(i), i=1546,1550) / 5067, 4864, 853, 5075, 5072/ +data (gchtab(i), i=1551,1555) / 5003, 4800, 0, 277, 4238/ +data (gchtab(i), i=1556,1560) / 4170, 4168, 4231, 4423, 4553/ +data (gchtab(i), i=1561,1565) / 4619, 341, 4302, 4234, 4232/ +data (gchtab(i), i=1566,1570) / 4295, 0, 848, 4883, 4820/ +data (gchtab(i), i=1571,1575) / 4693, 4565, 4372, 4241, 4174/ +data (gchtab(i), i=1576,1580) / 4171, 4233, 4296, 4423, 4551/ +data (gchtab(i), i=1581,1585) / 4744, 4874, 4941, 5010, 5015/ +data (gchtab(i), i=1586,1590) / 4954, 4891, 4764, 4572, 4443/ +data (gchtab(i), i=1591,1595) / 4378, 4377, 4441, 4442, 469/ +data (gchtab(i), i=1596,1600) / 4436, 4305, 4238, 4234, 4296/ +data (gchtab(i), i=1601,1605) / 455, 4680, 4810, 4877, 4946/ +data (gchtab(i), i=1606,1610) / 4951, 4890, 4764, 0, 277/ +data (gchtab(i), i=1611,1615) / 4103, 341, 4167, 917, 5076/ +data (gchtab(i), i=1616,1620) / 5140, 5077, 4949, 4820, 4560/ +data (gchtab(i), i=1621,1625) / 4431, 4303, 335, 4558, 4680/ +data (gchtab(i), i=1626,1630) / 4743, 335, 4494, 4616, 4679/ +data (gchtab(i), i=1631,1635) / 4807, 4936, 5067, 0, 92/ +data (gchtab(i), i=1636,1640) / 4316, 4443, 4506, 4568, 4938/ +data (gchtab(i), i=1641,1645) / 5000, 5063, 220, 4442, 4504/ +data (gchtab(i), i=1646,1650) / 4874, 4936, 5063, 5127, 533/ +data (gchtab(i), i=1651,1655) / 4103, 533, 4167, 0, 341/ +data (gchtab(i), i=1656,1660) / 4096, 405, 4096, 338, 4364/ +data (gchtab(i), i=1661,1665) / 4361, 4487, 4615, 4744, 4874/ +data (gchtab(i), i=1666,1670) / 5005, 1045, 4938, 4936, 4999/ +data (gchtab(i), i=1671,1675) / 5191, 5321, 5387, 1109, 5002/ +data (gchtab(i), i=1676,1680) / 5000, 5063, 0, 277, 4231/ +data (gchtab(i), i=1681,1685) / 341, 4367, 4298, 4231, 981/ +data (gchtab(i), i=1686,1690) / 5009, 4877, 1045, 5074, 5008/ +data (gchtab(i), i=1691,1695) / 4877, 4747, 4553, 4424, 4231/ +data (gchtab(i), i=1696,1700) / 85, 4437, 0, 469, 4372/ +data (gchtab(i), i=1701,1705) / 4241, 4174, 4171, 4233, 4296/ +data (gchtab(i), i=1706,1710) / 4423, 4551, 4744, 4875, 4942/ +data (gchtab(i), i=1711,1715) / 4945, 4883, 4820, 4693, 4565/ +data (gchtab(i), i=1716,1720) / 469, 4436, 4305, 4238, 4234/ +data (gchtab(i), i=1721,1725) / 4296, 455, 4680, 4811, 4878/ +data (gchtab(i), i=1726,1730) / 4882, 4820, 0, 468, 4295/ +data (gchtab(i), i=1731,1735) / 468, 4359, 852, 4935, 852/ +data (gchtab(i), i=1736,1740) / 4999, 18, 4244, 4437, 5269/ +data (gchtab(i), i=1741,1745) / 18, 4243, 4436, 5268, 0/ +data (gchtab(i), i=1746,1750) / 17, 4115, 4245, 4437, 4500/ +data (gchtab(i), i=1751,1755) / 4498, 4429, 4426, 4488, 4551/ +data (gchtab(i), i=1756,1760) / 277, 4436, 4434, 4365, 4362/ +data (gchtab(i), i=1761,1765) / 4424, 4551, 4679, 4808, 4938/ +data (gchtab(i), i=1766,1770) / 5069, 5136, 5205, 5209, 5147/ +data (gchtab(i), i=1771,1775) / 5020, 4892, 4762, 4760, 4821/ +data (gchtab(i), i=1776,1780) / 4946, 5072, 5262, 712, 4939/ +data (gchtab(i), i=1781,1785) / 5005, 5072, 5141, 5145, 5083/ +data (gchtab(i), i=1786,1790) / 5020, 0, 140, 4297, 4360/ +data (gchtab(i), i=1791,1795) / 4487, 4615, 4808, 4939, 5006/ +data (gchtab(i), i=1796,1800) / 5009, 4947, 4884, 4757, 4629/ +data (gchtab(i), i=1801,1805) / 4436, 4305, 4238, 4096, 519/ +data (gchtab(i), i=1806,1810) / 4744, 4875, 4942, 4946, 4884/ +data (gchtab(i), i=1811,1815) / 533, 4500, 4369, 4302, 4096/ +data (gchtab(i), i=1816,1820) / 0, 1109, 4565, 4372, 4241/ +data (gchtab(i), i=1821,1825) / 4174, 4171, 4233, 4296, 4423/ +data (gchtab(i), i=1826,1830) / 4551, 4744, 4875, 4942, 4945/ +data (gchtab(i), i=1831,1835) / 4883, 4820, 4693, 469, 4436/ +data (gchtab(i), i=1836,1840) / 4305, 4238, 4234, 4296, 455/ +data (gchtab(i), i=1841,1845) / 4680, 4811, 4878, 4882, 4820/ +data (gchtab(i), i=1846,1850) / 724, 5204, 0, 596, 4487/ +data (gchtab(i), i=1851,1855) / 596, 4551, 18, 4244, 4437/ +data (gchtab(i), i=1856,1860) / 5141, 18, 4243, 4436, 5140/ +data (gchtab(i), i=1861,1865) / 0, 17, 4115, 4245, 4437/ +data (gchtab(i), i=1866,1870) / 4500, 4498, 4364, 4361, 4487/ +data (gchtab(i), i=1871,1875) / 277, 4436, 4434, 4300, 4297/ +data (gchtab(i), i=1876,1880) / 4360, 4487, 4551, 4744, 4874/ +data (gchtab(i), i=1881,1885) / 5005, 5072, 5075, 5013, 4948/ +data (gchtab(i), i=1886,1890) / 5011, 5072, 909, 5075, 0/ +data (gchtab(i), i=1891,1895) / 35, 0, 145, 4371, 4564/ +data (gchtab(i), i=1896,1900) / 4501, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1901,1905) / 4232, 4295, 4423, 4552, 4683/ +data (gchtab(i), i=1906,1910) / 4750, 75, 4233, 4296, 4424/ +data (gchtab(i), i=1911,1915) / 4553, 4683, 590, 4683, 4744/ +data (gchtab(i), i=1916,1920) / 4807, 4935, 5064, 5195, 5262/ +data (gchtab(i), i=1921,1925) / 5265, 5204, 5141, 5076, 5203/ +data (gchtab(i), i=1926,1930) / 5265, 587, 4745, 4808, 4936/ +data (gchtab(i), i=1931,1935) / 5065, 5195, 0, 604, 4571/ +data (gchtab(i), i=1936,1940) / 4506, 4505, 4568, 4759, 4951/ +data (gchtab(i), i=1941,1945) / 663, 4502, 4373, 4307, 4305/ +data (gchtab(i), i=1946,1950) / 4431, 4622, 4814, 663, 4566/ +data (gchtab(i), i=1951,1955) / 4437, 4371, 4369, 4495, 4622/ +data (gchtab(i), i=1956,1960) / 526, 4365, 4236, 4170, 4168/ +data (gchtab(i), i=1961,1965) / 4294, 4612, 4675, 4673, 4544/ +data (gchtab(i), i=1966,1970) / 4416, 526, 4429, 4300, 4234/ +data (gchtab(i), i=1971,1975) / 4232, 4358, 4612, 0, 860/ +data (gchtab(i), i=1976,1980) / 4544, 924, 4480, 17, 4115/ +data (gchtab(i), i=1981,1985) / 4245, 4437, 4500, 4498, 4429/ +data (gchtab(i), i=1986,1990) / 4426, 4552, 4744, 4873, 5068/ +data (gchtab(i), i=1991,1995) / 5199, 277, 4436, 4434, 4365/ +data (gchtab(i), i=1996,2000) / 4362, 4424, 4551, 4743, 4872/ +data (gchtab(i), i=2001,2005) / 5002, 5133, 5199, 5333, 0/ +data (gchtab(i), i=2006,2010) / 604, 4571, 4506, 4505, 4568/ +data (gchtab(i), i=2011,2015) / 4759, 5079, 5080, 4887, 4629/ +data (gchtab(i), i=2016,2020) / 4435, 4240, 4173, 4171, 4233/ +data (gchtab(i), i=2021,2025) / 4423, 4613, 4675, 4673, 4608/ +data (gchtab(i), i=2026,2030) / 4480, 4417, 662, 4499, 4304/ +data (gchtab(i), i=2031,2035) / 4237, 4235, 4297, 4423, 0/ +data (gchtab(i), i=2036,2040) / 480, 4447, 4382, 4316, 4314/ +data (gchtab(i), i=2041,2045) / 4376, 4439, 4501, 4499, 4369/ +data (gchtab(i), i=2046,2050) / 351, 4381, 4379, 4441, 4504/ +data (gchtab(i), i=2051,2055) / 4566, 4564, 4498, 4240, 4494/ +data (gchtab(i), i=2056,2060) / 4556, 4554, 4488, 4423, 4357/ +data (gchtab(i), i=2061,2065) / 4355, 4417, 271, 4493, 4491/ +data (gchtab(i), i=2066,2070) / 4425, 4360, 4294, 4292, 4354/ +data (gchtab(i), i=2071,2075) / 4417, 4544, 0, 160, 4224/ +data (gchtab(i), i=2076,2080) / 544, 4608, 0, 224, 4447/ +data (gchtab(i), i=2081,2085) / 4510, 4572, 4570, 4504, 4439/ +data (gchtab(i), i=2086,2090) / 4373, 4371, 4497, 351, 4509/ +data (gchtab(i), i=2091,2095) / 4507, 4441, 4376, 4310, 4308/ +data (gchtab(i), i=2096,2100) / 4370, 4624, 4366, 4300, 4298/ +data (gchtab(i), i=2101,2105) / 4360, 4423, 4485, 4483, 4417/ +data (gchtab(i), i=2106,2110) / 399, 4365, 4363, 4425, 4488/ +data (gchtab(i), i=2111,2115) / 4550, 4548, 4482, 4417, 4288/ +data (gchtab(i), i=2116,2120) / 0, 338, 4240, 4430, 533/ +data (gchtab(i), i=2121,2125) / 4304, 4619, 208, 5392, 0/ +data (gchtab(i), i=2126,2130) / 284, 4251, 4185, 4183, 4245/ +data (gchtab(i), i=2131,2135) / 4372, 4500, 4629, 4695, 4697/ +data (gchtab(i), i=2136,2139) / 4635, 4508, 4380, 0/ diff --git a/sys/gio/sgikern/ltype.dat b/sys/gio/sgikern/ltype.dat new file mode 100644 index 00000000..a5509e21 --- /dev/null +++ b/sys/gio/sgikern/ltype.dat @@ -0,0 +1,28 @@ +# LTYPE.DAT -- Initialize the builtin line types for the SGI kernel. Data +# is given in GKI units (1.0 = 32768 units). A segment of 32 GKI units is +# resolved on a device with 1024 resolved pixels. + +data p_seg /1, 1, 1/ +data p_segleft /320, 32, 512/ + +data p_nseg[1] /2/ # PL_DASHED +data p_penup[1,1] /false/ +data p_penup[1,2] /true/ +data p_seglen[1,1] /320/ +data p_seglen[1,2] /128/ + +data p_nseg[2] /2/ # PL_DOTTED +data p_penup[2,1] /false/ +data p_penup[2,2] /true/ +data p_seglen[2,1] /32/ +data p_seglen[2,2] /128/ + +data p_nseg[3] /4/ # PL_DOTDASH +data p_penup[3,1] /false/ +data p_penup[3,2] /true/ +data p_penup[3,3] /false/ +data p_penup[3,4] /true/ +data p_seglen[3,1] /512/ +data p_seglen[3,2] /128/ +data p_seglen[3,3] /32/ +data p_seglen[3,4] /128/ diff --git a/sys/gio/sgikern/mkpkg b/sys/gio/sgikern/mkpkg new file mode 100644 index 00000000..3dd9e943 --- /dev/null +++ b/sys/gio/sgikern/mkpkg @@ -0,0 +1,53 @@ +# Make the GIO/SGIKERN simple graphics kernel. + +$checkout libsgi.a lib$ +$update libsgi.a +$checkin libsgi.a lib$ +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $omake x_sgikern.x + $link x_sgikern.o -lsgi + ; + +install: # install in system library + $move x_sgikern.e bin$ + ; + +libsgi.a: + sgicancel.x sgi.com sgi.h + sgiclear.x sgi.com sgi.h + sgiclose.x sgi.com sgi.h + sgiclws.x sgi.h sgi.com + sgicolor.x sgi.com sgi.h + sgidrawch.x font.com font.h greek.com sgi.com sgi.h \ + + sgiescape.x + sgifa.x sgi.com sgi.h + sgifaset.x sgi.com sgi.h + sgiflush.x sgi.com sgi.h + sgifont.x sgi.com sgi.h + sgigcell.x + sgiinit.x sgi.com sgi.h + sgiline.x sgi.com sgi.h + sgiopen.x sgi.com sgi.h + sgiopenws.x sgi.com sgi.h + sgipcell.x sgi.com sgi.h + sgipl.x ltype.dat sgi.com sgi.h + sgiplset.x sgi.com sgi.h + sgipm.x sgi.com sgi.h + sgipmset.x sgi.com sgi.h + sgireset.x sgi.com sgi.h + sgitx.x font.com font.h greek.com sgi.com sgi.h \ + + sgitxset.x sgi.com sgi.h + sgk.x sgk.com sgk.h + t_sgideco.x sgk.h + t_sgikern.x + ; diff --git a/sys/gio/sgikern/sgi.com b/sys/gio/sgikern/sgi.com new file mode 100644 index 00000000..e050183b --- /dev/null +++ b/sys/gio/sgikern/sgi.com @@ -0,0 +1,17 @@ +# SGI common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_kt # kernel transform graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in, g_out # input, output files +int g_xres, g_yres # desired device resolution +char g_device[SZ_GDEVICE] # force output to named device + +common /sgicom/ g_kt, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_out, g_xres, g_yres, g_device diff --git a/sys/gio/sgikern/sgi.h b/sys/gio/sgikern/sgi.h new file mode 100644 index 00000000..a9f1da20 --- /dev/null +++ b/sys/gio/sgikern/sgi.h @@ -0,0 +1,76 @@ +# SGI global definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_GDEVICE 31 # maxsize forced device name +define DEF_MAXFRAMES 16 # maximum frames/metafile + +# The SGI state/device descriptor. + +define LEN_SGI 81 + +define SGI_SBUF Memi[$1] # string buffer +define SGI_SZSBUF Memi[$1+1] # size of string buffer +define SGI_NEXTCH Memi[$1+2] # next char pos in string buf +define SGI_NCHARSIZES Memi[$1+3] # number of character sizes +define SGI_POLYLINE Memi[$1+4] # device supports polyline +define SGI_POLYMARKER Memi[$1+5] # device supports polymarker +define SGI_FILLAREA Memi[$1+6] # device supports fillarea +define SGI_CELLARRAY Memi[$1+7] # device supports cell array +define SGI_XRES Memi[$1+8] # device resolution in X +define SGI_YRES Memi[$1+9] # device resolution in Y +define SGI_ZRES Memi[$1+10] # device resolution in Z +define SGI_FILLSTYLE Memi[$1+11] # number of fill styles +define SGI_ROAM Memi[$1+12] # device supports roam +define SGI_ZOOM Memi[$1+13] # device supports zoom +define SGI_SELERASE Memi[$1+14] # device has selective erase +define SGI_PIXREP Memi[$1+15] # device supports pixel replic. +define SGI_STARTFRAME Memi[$1+16] # frame advance at metafile BOF +define SGI_ENDFRAME Memi[$1+17] # frame advance at metafile EOF + # extra space +define SGI_CURSOR Memi[$1+20] # last cursor accessed +define SGI_COLOR Memi[$1+21] # last color set +define SGI_TXSIZE Memi[$1+22] # last text size set +define SGI_TXFONT Memi[$1+23] # last text font set +define SGI_TYPE Memi[$1+24] # last line type set +define SGI_WIDTH Memi[$1+25] # last line width set +define SGI_DEVNAME Memi[$1+26] # name of open device + # extra space +define SGI_CHARHEIGHT Memi[$1+30+$2-1] # character height +define SGI_CHARWIDTH Memi[$1+40+$2-1] # character width +define SGI_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define SGI_PLAP ($1+60) # polyline attributes +define SGI_PMAP ($1+64) # polymarker attributes +define SGI_FAAP ($1+68) # fill area attributes +define SGI_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/sgikern/sgicancel.x b/sys/gio/sgikern/sgicancel.x new file mode 100644 index 00000000..d9249d4b --- /dev/null +++ b/sys/gio/sgikern/sgicancel.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_CANCEL -- Cancel any buffered output. + +procedure sgi_cancel (dummy) + +int dummy # not used at present +include "sgi.com" + +begin + if (g_kt == NULL) + return + call sgi_reset() +end diff --git a/sys/gio/sgikern/sgiclear.x b/sys/gio/sgikern/sgiclear.x new file mode 100644 index 00000000..f2a63d29 --- /dev/null +++ b/sys/gio/sgikern/sgiclear.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure sgi_clear (dummy) + +int dummy # not used at present + +int sgk_open() +errchk sgk_open +include "sgi.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_kt == NULL || g_ndraw == 0) + return + + # Start a new frame. This is done either by issuing the frame advance + # instruction or by starting a new metafile. Close the output file and + # start a new metafile if the maximum frame count has been reached. + # This disposes of the metafile to the system, causing the actual + # plots to be drawn. Open a new metafile ready to receive next frame. + + g_nframes = g_nframes + 1 + if (g_nframes >= g_maxframes) { + + # Does this device require a frame advance at end of metafile? + if (SGI_ENDFRAME(g_kt) == YES) + call sgk_frame (g_out) + + g_nframes = 0 + call sgk_close (g_out) + g_out = sgk_open (Memc[SGI_DEVNAME(g_kt)], g_tty) + + # Does this device require a frame advance at beginning of metafile? + if (SGI_STARTFRAME(g_kt) == YES) + call sgk_frame (g_out) + + } else { + # Merely output frame instruction to start a new frame in the same + # metafile. + + call sgk_frame (g_out) + } + + # Init kernel data structures. + call sgi_reset() + g_ndraw = 0 +end diff --git a/sys/gio/sgikern/sgiclose.x b/sys/gio/sgikern/sgiclose.x new file mode 100644 index 00000000..380cd01f --- /dev/null +++ b/sys/gio/sgikern/sgiclose.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_CLOSE -- Close the SGI translation kernel. Close the spool file so +# the output is finally plotted. Free up storage. + +procedure sgi_close() + +include "sgi.com" + +begin + # If there is anything in the metafile, flush it and add a frame + # advance if required for the device. + + if (g_ndraw > 0 || g_nframes > 0) { + # Does this device require a frame advance at end of metafile? + if (SGI_ENDFRAME(g_kt) == YES) + call sgk_frame (g_out) + } + + # Close output metafile, disposing of it to the host system. + call sgk_close (g_out) + + # Free kernel data structures. + call mfree (SGI_SBUF(g_kt), TY_CHAR) + call mfree (g_kt, TY_STRUCT) + + g_kt = NULL +end diff --git a/sys/gio/sgikern/sgiclws.x b/sys/gio/sgikern/sgiclws.x new file mode 100644 index 00000000..e7d29dd7 --- /dev/null +++ b/sys/gio/sgikern/sgiclws.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_CLOSEWS -- Close the named workstation. Flush the output. +# The spool file is closed only on the next plot or at gktclose time. +# If the spool file is closed here, APPEND mode would not work. + +procedure sgi_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +include "sgi.com" + +begin + call sgk_flush (g_out) +end diff --git a/sys/gio/sgikern/sgicolor.x b/sys/gio/sgikern/sgicolor.x new file mode 100644 index 00000000..cdd13708 --- /dev/null +++ b/sys/gio/sgikern/sgicolor.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_COLOR -- Set line drawing color. + +procedure sgi_color (index) + +int index # index for color switch statement +include "sgi.com" + +begin + # switch (index) { + # case WHITE: + # case RED: + # case GREEN: + # case BLUE: + # default: + # } +end diff --git a/sys/gio/sgikern/sgidrawch.x b/sys/gio/sgikern/sgidrawch.x new file mode 100644 index 00000000..ab7500ea --- /dev/null +++ b/sys/gio/sgikern/sgidrawch.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# SGI_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +int procedure sgi_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +int mx, my +real px, py, coso, sino, theta +int stroke, tab1, tab2, i, pen, width +int bitupk() +include "font.com" +include "greek.com" +include "sgi.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call sgi_font (font) + + if (font == GT_GREEK) { + width = gchwid[i] + tab1 = gchidx[i] + tab2 = gchidx[i+1] - 1 + } else { + width = chrwid[i] + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + } + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + if (font == GT_GREEK) + stroke = gchtab[i] + else + stroke = chrtab[i] + + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / width * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + mx = x + px * coso + py * sino + my = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call sgk_move (g_out, mx, my) + else + call sgk_draw (g_out, mx, my) + } + + return (int(real(width) / real(FONT_WIDTH) * xsize)) +end diff --git a/sys/gio/sgikern/sgiescape.x b/sys/gio/sgikern/sgiescape.x new file mode 100644 index 00000000..ff2480cd --- /dev/null +++ b/sys/gio/sgikern/sgiescape.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SGI_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The SGK kernel does not have any escape functions at present. + +procedure sgi_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +begin +end diff --git a/sys/gio/sgikern/sgifa.x b/sys/gio/sgikern/sgifa.x new file mode 100644 index 00000000..37793f22 --- /dev/null +++ b/sys/gio/sgikern/sgifa.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_FILLAREA -- Fill a closed area. + +procedure sgi_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "sgi.com" + +begin + # This kernel doesn't have any real fill area capability yet; if + # fill area is enabled in the graphcap entry, just draw the outline + # of the area. + + if (SGI_FILLAREA(g_kt) == YES) + call sgi_polyline (p, npts) +end diff --git a/sys/gio/sgikern/sgifaset.x b/sys/gio/sgikern/sgifaset.x new file mode 100644 index 00000000..c3810252 --- /dev/null +++ b/sys/gio/sgikern/sgifaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_FASET -- Set the fillarea attributes. + +procedure sgi_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "sgi.com" + +begin + fa = SGI_FAAP(g_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/sgikern/sgiflush.x b/sys/gio/sgikern/sgiflush.x new file mode 100644 index 00000000..e3e1b805 --- /dev/null +++ b/sys/gio/sgikern/sgiflush.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_FLUSH -- Flush output. + +procedure sgi_flush (dummy) + +int dummy # not used at present +include "sgi.com" + +begin + call sgk_flush (g_out) +end diff --git a/sys/gio/sgikern/sgifont.x b/sys/gio/sgikern/sgifont.x new file mode 100644 index 00000000..808c7f56 --- /dev/null +++ b/sys/gio/sgikern/sgifont.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +# SGI_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set SGI_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure sgi_font (font) + +int font # code for font to be set + +int normal, bold +int pk1, pk2, width +include "sgi.com" + +begin + width = SGI_WIDTH(g_kt) + normal = 0 + bold = 1 + + pk1 = GKI_PACKREAL(real(normal)) + pk2 = GKI_PACKREAL(real(bold)) + + if (font == GT_BOLD) { + if (width != pk2) { + call sgk_linewidth (g_out, bold) + width = pk2 + } + } else { + if (width != pk1) { + call sgk_linewidth (g_out, normal) + width = pk1 + } + } + + SGI_WIDTH(g_kt) = width +end diff --git a/sys/gio/sgikern/sgigcell.x b/sys/gio/sgikern/sgigcell.x new file mode 100644 index 00000000..4c2bfe06 --- /dev/null +++ b/sys/gio/sgikern/sgigcell.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SGI_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure sgi_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. +end diff --git a/sys/gio/sgikern/sgiinit.x b/sys/gio/sgikern/sgiinit.x new file mode 100644 index 00000000..54caf25d --- /dev/null +++ b/sys/gio/sgikern/sgiinit.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" + +# SGI_INIT -- Initialize the gkt data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine SGI_RESET initializes the attribute +# packets when the frame is flushed. + +procedure sgi_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "sgi.com" + +begin + # Allocate the gkt descriptor and the string buffer. + if (g_kt == NULL) { + call calloc (g_kt, LEN_SGI, TY_STRUCT) + call malloc (SGI_SBUF(g_kt), SZ_SBUF, TY_CHAR) + } + + # Get the maximum frame count and the flags controlling frame advance + # at start and end of metafile. + + g_maxframes = ttygeti (tty, "MF") + if (g_maxframes == 0) + g_maxframes = DEF_MAXFRAMES + SGI_STARTFRAME(g_kt) = btoi (ttygetb (tty, "FS")) + SGI_ENDFRAME(g_kt) = btoi (ttygetb (tty, "FE")) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + SGI_SZSBUF(g_kt) = SZ_SBUF + SGI_NEXTCH(g_kt) = SGI_SBUF(g_kt) + 1 + Memc[SGI_SBUF(g_kt)] = EOS + + # Get the device resolution from the graphcap entry. + + g_xres = ttygeti (tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_yres = ttygeti (tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + SGI_NCHARSIZES(g_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = SGI_NEXTCH(g_kt) + + if (SGI_NCHARSIZES(g_kt) <= 0) { + SGI_NCHARSIZES(g_kt) = 1 + SGI_CHARSIZE(g_kt,1) = 1.0 + SGI_CHARHEIGHT(g_kt,1) = char_height + SGI_CHARWIDTH(g_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= SGI_NCHARSIZES(g_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + SGI_CHARSIZE(g_kt,i) = char_size + SGI_CHARHEIGHT(g_kt,i) = char_height * char_size + SGI_CHARWIDTH(g_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the gkt + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + SGI_POLYLINE(g_kt) = btoi (ttygetb (tty, "pl")) + SGI_POLYMARKER(g_kt) = btoi (ttygetb (tty, "pm")) + SGI_FILLAREA(g_kt) = btoi (ttygetb (tty, "fa")) + SGI_FILLSTYLE(g_kt) = ttygeti (tty, "fs") + SGI_ROAM(g_kt) = btoi (ttygetb (tty, "ro")) + SGI_ZOOM(g_kt) = btoi (ttygetb (tty, "zo")) + SGI_XRES(g_kt) = ttygeti (tty, "xr") + SGI_YRES(g_kt) = ttygeti (tty, "yr") + SGI_ZRES(g_kt) = ttygeti (tty, "zr") + SGI_CELLARRAY(g_kt) = btoi (ttygetb (tty, "ca")) + SGI_SELERASE(g_kt) = btoi (ttygetb (tty, "se")) + SGI_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + SGI_CURSOR(g_kt) = 1 + + # Save the device string in the descriptor. + nextch = SGI_NEXTCH(g_kt) + SGI_DEVNAME(g_kt) = nextch + maxch = SGI_SBUF(g_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + SGI_NEXTCH(g_kt) = nextch +end + + +# SGI_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure sgi_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "sgi.com" + +begin + nextch = SGI_NEXTCH(g_kt) + maxch = SGI_SBUF(g_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = SGI_SBUF(g_kt) + + SGI_NEXTCH(g_kt) = nextch + return (strp) +end diff --git a/sys/gio/sgikern/sgiline.x b/sys/gio/sgikern/sgiline.x new file mode 100644 index 00000000..086ac158 --- /dev/null +++ b/sys/gio/sgikern/sgiline.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_LINETYPE -- Set the line type option. + +procedure sgi_linetype (index) + +int index # index for line type switch statement + +int linetype +include "sgi.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 2 + case GL_DOTTED: + linetype = 3 + case GL_DOTDASH: + linetype = 4 + default: + linetype = 1 # solid + } + + # This will be done in software in a future version of the SGI kernel. + # call sgk_linetype (g_out, linetype) +end diff --git a/sys/gio/sgikern/sgiopen.x b/sys/gio/sgikern/sgiopen.x new file mode 100644 index 00000000..5164ecd7 --- /dev/null +++ b/sys/gio/sgikern/sgiopen.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_OPEN -- Install the SGI kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure sgi_open (devname, dd) + +char devname[ARB] # nonnull for forced output to a device +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern sgi_openws(), sgi_closews(), sgi_clear(), sgi_cancel() +extern sgi_flush(), sgi_polyline(), sgi_polymarker(), sgi_text() +extern sgi_fillarea(), sgi_putcellarray(), sgi_plset() +extern sgi_pmset(), sgi_txset(), sgi_faset() +extern sgi_escape() +include "sgi.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_kt = NULL + g_nframes = 0 + g_ndraw = 0 + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (sgi_openws) + dd[GKI_CLOSEWS] = locpr (sgi_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (sgi_clear) + dd[GKI_CANCEL] = locpr (sgi_cancel) + dd[GKI_FLUSH] = locpr (sgi_flush) + dd[GKI_POLYLINE] = locpr (sgi_polyline) + dd[GKI_POLYMARKER] = locpr (sgi_polymarker) + dd[GKI_TEXT] = locpr (sgi_text) + dd[GKI_FILLAREA] = locpr (sgi_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (sgi_putcellarray) + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (sgi_plset) + dd[GKI_PMSET] = locpr (sgi_pmset) + dd[GKI_TXSET] = locpr (sgi_txset) + dd[GKI_FASET] = locpr (sgi_faset) + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (sgi_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call sgi_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/sgikern/sgiopenws.x b/sys/gio/sgikern/sgiopenws.x new file mode 100644 index 00000000..a2a5a7eb --- /dev/null +++ b/sys/gio/sgikern/sgiopenws.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" + +# SGI_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure sgi_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +int sgk_open() +bool need_open, same_dev +include "sgi.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_kt != NULL) { + same_dev = (streq (Memc[SGI_DEVNAME(g_kt)], Memc[buf])) + if (!same_dev) { + # Does this device require a frame advance at end of metafile? + if (SGI_ENDFRAME(g_kt) == YES) + call sgk_frame (g_out) + call sgk_close (g_out) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if (!same_dev) { + if (g_kt != NULL) + call ttycdes (g_tty) + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + + # Initialize data structures if we had to open a new device. + call sgi_init (g_tty, Memc[buf]) + call sgi_reset() + } + + # Open the output file. Metacode output to the device will be + # spooled and then disposed of to the device at CLOSEWS time. + + iferr (g_out = sgk_open (Memc[SGI_DEVNAME(g_kt)], g_tty)) { + call ttycdes (g_tty) + call erract (EA_ERROR) + } else { + # Does this device require a frame advance at start of metafile? + if (SGI_STARTFRAME(g_kt) == YES) + call sgk_frame (g_out) + g_nframes = 0 + g_ndraw = 0 + } + } + + # Clear the screen if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will clear + # the screen if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call sgi_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/sgikern/sgipcell.x b/sys/gio/sgikern/sgipcell.x new file mode 100644 index 00000000..b39e6377 --- /dev/null +++ b/sys/gio/sgikern/sgipcell.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +define DEF_YRES 2048 # default height of device pixel in GKI units +define ZSTEP 4 # bit to be tested (step function width) + + +# SGI_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). The algorithm used here maps 8 bits in into 1 bit +# out, using a step function lookup table. The result is a band-contoured +# image, where the spacing and width of the contour bands decreases as the +# rate of change of intensity in the input cell array increases. + +procedure sgi_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +bool ttygetb() +include "sgi.com" + +begin + if (ttygetb (g_tty, "BI")) + call sgi_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + else + call sgi_mcell (m, nx, ny, ax1,ay1, ax2,ay2) +end + + +# SGI_BCELL -- Put cell array, optimized for a bitmap device. In this case, +# to get the maximum resolution at maximum efficiency it is desirable for the +# main loop to be over device pixels, mapping the device pixel into the +# nearest line of the input cell array. + +procedure sgi_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int my, i1, i2, v, i, j, k +include "sgi.com" +int and() + +begin + # Count drawing instruction, set polyline width to 1 for max y-res. + g_ndraw = g_ndraw + 1 + call sgk_linewidth (g_out, 1) + SGI_WIDTH(g_kt) = 0 + + # Determine the width of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + + # Determine the height of a device pixel in GKI units. + if (SGI_YRES(g_kt) <= 0) + dy = GKI_MAXNDC / DEF_YRES + else + dy = max (1.0, real(GKI_MAXNDC) / real(SGI_YRES(g_kt))) + + # Process the cell array. The outer loop runs over device pixels in Y; + # each iteration writes one line of the output raster. The inner loop + # runs down a line of the cell array. + + k = 0 + for (my = ay1 + dy/2; my < ay2; my = k * dy + ay1) { + j = max(1, min(ny, int (real(my-ay1) / real(ay2-ay1) * (ny-1)) + 1)) + my = min (my, int (ay2 - dy/2)) + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i1 + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call sgk_move (g_out, int ((i1-1) * dx + ax1), my) + call sgk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + + k = k + 1 + } +end + + +# SGI_MCELL -- Put cell array, optimized for a metafile device. In this case, +# it is prohibitively expensive to draw into each resolvable line of the +# output device. It is better to set the linewidth to the width of a cell +# array pixel, output the minimum number of drawing instructions, and let the +# metafile device widen the lines. + +procedure sgi_mcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int yres, my, i1, i2, v, i, j +include "sgi.com" +int and() + +begin + # Count drawing instruction, clobber saved polyline width. + g_ndraw = g_ndraw + 1 + SGI_WIDTH(g_kt) = 0 + + # Determine the width and height of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + dy = real (ay2 - ay1) / ny + + # Set the SGK line width to the height of a pixel in the cell array. + yres = SGI_YRES(g_kt) + if (yres <= 0) + yres = DEF_YRES + call sgk_linewidth (g_out, + max (1, nint (dy / (real(GKI_MAXNDC) / real(yres))))) + + # Process the cell array. The outer loop runs over lines of the input + # cell array; each iteration writes only one line of the output raster, + # but the width of the line is adjusted to the height of a pixel in + # the cell array (the resolution of the cell array should not exceed + # that of the device). + + for (j=1; j <= ny; j=j+1) { + my = int ((j - 0.5) * dy) + ay1 + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call sgk_move (g_out, int ((i1-1) * dx + ax1), my) + call sgk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + } +end diff --git a/sys/gio/sgikern/sgipl.x b/sys/gio/sgikern/sgipl.x new file mode 100644 index 00000000..e3eea44f --- /dev/null +++ b/sys/gio/sgikern/sgipl.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +define MAX_LTYPES 3 # max software line type patterns (excl. solid) +define MAX_LSEGMENTS 4 # max line segments per pattern +define LT_OFFSET 1 # offset to be subtracted from ltype code + + +# SGI_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure sgi_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int x, y +int len_p, i +include "sgi.com" + +begin + if (npts < 2) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = SGI_PLAP(g_kt) + + if (SGI_WIDTH(g_kt) != PL_WIDTH(pl)) { + call sgk_linewidth (g_out, nint (GKI_UNPACKREAL(PL_WIDTH(pl)))) + SGI_WIDTH(g_kt) = PL_WIDTH(pl) + } + if (SGI_COLOR(g_kt) != PL_COLOR(pl)) { + call sgi_color (PL_COLOR(pl)) + SGI_COLOR(g_kt) = PL_COLOR(pl) + } + + if (PL_LTYPE(pl) == GL_CLEAR) { + # Ignore clear (erase) polylines. + ; + + } else if (PL_LTYPE(pl) != GL_SOLID) { + # Draw a dashed or dotted polyline of the indicated type. + call sgi_dashline (g_out, p, npts, PL_LTYPE(pl)) + + } else { + # Draw a solid polyline (usual case, optimized). + + # Move to the first point. + x = p[1] + y = p[2] + call sgk_move (g_out, x, y) + + # Draw the polyline. + for (i=3; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call sgk_draw (g_out, x, y) + } + } +end + + +# SGI_DASHLINE -- Draw a dashed or dotted polyline using the indicated line +# style. + +procedure sgi_dashline (g_out, p, npts, ltype) + +int g_out # output file +short p[ARB] # the polyline points +int npts # number of points, i.e., (x,y) pairs +int ltype # desired line type + +bool penup +int len_p, i +real vlen, vpos, seglen, dx, dy +int oldx, oldy, newx, newy, penx, peny +int sgi_getseg() + +begin + len_p = npts * 2 + + oldx = p[1]; oldy = p[2] + call sgk_move (g_out, oldx, oldy) + + # Process each line segment in the polyline. + do i = 3, len_p, 2 { + newx = p[i] + newy = p[i+1] + + # Compute VLEN, the length of the polyline line segment to be + # drawn, VPOS, the relative position along the line segment, + # and DX and DY, the scale factors to be applied to VPOS to get + # the x and y coordinates of a point along the line segment. + + dx = newx - oldx + dy = newy - oldy + vlen = sqrt (dx*dx + dy*dy) + if (vlen < 1.0) # GKI units + next + + dx = dx / vlen + dy = dy / vlen + vpos = 0.0 + + # For each line segment, get segments of the line type pattern + # until all of the current line segment has been drawn. The pattern + # wraps around indefinitely, following the polyline around the + # vertices with concern only for the total length traversed. + + while (vlen - vpos >= 1.0) { + seglen = sgi_getseg (int (vlen - vpos), penup, ltype) + if (seglen < 1.0) + break + + vpos = vpos + seglen + penx = oldx + vpos * dx + peny = oldy + vpos * dy + + if (penup) + call sgk_move (g_out, penx, peny) + else + call sgk_draw (g_out, penx, peny) + } + + oldx = newx + oldy = newy + } +end + + +# SGI_GETSEG -- Get a segment of a line style pattern. The segment extends +# from the current position in the pattern to either the next penup/pendown +# breakpoint in the pattern, or to the point MAXLEN units further along in +# the pattern. When the end of the pattern is reached wrap around and +# duplicate the pattern indefinitely. + +int procedure sgi_getseg (maxlen, penup, ltype) + +int maxlen # max length segment to be returned +bool penup # [out] pen up or pen down type segment? +int ltype # line type code + +int seglen, seg, lt +int p_seg[MAX_LTYPES] +int p_nseg[MAX_LTYPES] +int p_segleft[MAX_LTYPES] +bool p_penup[MAX_LTYPES,MAX_LSEGMENTS] +int p_seglen[MAX_LTYPES,MAX_LSEGMENTS] +include "ltype.dat" + +begin + lt = max (1, min (MAX_LTYPES, ltype - LT_OFFSET)) + seg = p_seg[lt] + penup = p_penup[lt,seg] + + repeat { + if (maxlen < p_segleft[lt]) { + seglen = maxlen + p_segleft[lt] = p_segleft[lt] - seglen + } else { + seglen = p_segleft[lt] + seg = seg + 1 + if (seg > p_nseg[lt]) + seg = 1 + p_seg[lt] = seg + p_segleft[lt] = p_seglen[lt,seg] + } + } until (seglen > 0) + + return (seglen) +end diff --git a/sys/gio/sgikern/sgiplset.x b/sys/gio/sgikern/sgiplset.x new file mode 100644 index 00000000..30038437 --- /dev/null +++ b/sys/gio/sgikern/sgiplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure sgi_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "sgi.com" + +begin + pl = SGI_PLAP(g_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/sgikern/sgipm.x b/sys/gio/sgikern/sgipm.x new file mode 100644 index 00000000..e53f3f03 --- /dev/null +++ b/sys/gio/sgikern/sgipm.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure sgi_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int x, y, oldx, oldy +include "sgi.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = SGI_PMAP(g_kt) + + if (SGI_TYPE(g_kt) != PM_LTYPE(pm)) { + call sgi_linetype (PM_LTYPE(pm)) + SGI_TYPE(g_kt) = PM_LTYPE(pm) + } + if (SGI_WIDTH(g_kt) != PM_WIDTH(pm)) { + call sgk_linewidth (g_out, nint (GKI_UNPACKREAL(PM_WIDTH(pm)))) + SGI_WIDTH(g_kt) = PM_WIDTH(pm) + } + if (SGI_COLOR(g_kt) != PM_COLOR(pm)) { + call sgi_color (PM_COLOR(pm)) + SGI_COLOR(g_kt) = PM_COLOR(pm) + } + + # Draw the polymarker. + oldx = 0; oldy = 0 + for (i=1; i <= len_p; i=i+2) { + x = p[i]; y = p[i+1] + if (x != oldx || y != oldy) { + call sgk_move (g_out, x, y) + call sgk_draw (g_out, x, y) + } + oldx = x; oldy = y + } +end diff --git a/sys/gio/sgikern/sgipmset.x b/sys/gio/sgikern/sgipmset.x new file mode 100644 index 00000000..0d72392f --- /dev/null +++ b/sys/gio/sgikern/sgipmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_PMSET -- Set the polymarker attributes. + +procedure sgi_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "sgi.com" + +begin + pm = SGI_PMAP(g_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/sgikern/sgireset.x b/sys/gio/sgikern/sgireset.x new file mode 100644 index 00000000..a97034eb --- /dev/null +++ b/sys/gio/sgikern/sgireset.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +# SGI_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure sgi_reset() + +pointer pl, pm, fa, tx +include "sgi.com" + +begin + # Set pointers to attribute substructures. + pl = SGI_PLAP(g_kt) + pm = SGI_PMAP(g_kt) + fa = SGI_FAAP(g_kt) + tx = SGI_TXAP(g_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + SGI_TYPE(g_kt) = -1 + SGI_WIDTH(g_kt) = -1 + SGI_COLOR(g_kt) = -1 + SGI_TXSIZE(g_kt) = -1 + SGI_TXFONT(g_kt) = -1 +end diff --git a/sys/gio/sgikern/sgitx.x b/sys/gio/sgikern/sgitx.x new file mode 100644 index 00000000..d0db5c58 --- /dev/null +++ b/sys/gio/sgikern/sgitx.x @@ -0,0 +1,459 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" +include "font.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# SGI_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure sgi_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz, offset, cosv, sinv +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen, totwidth +pointer sp, seg, ip, op, tx, first +int stx_segment(), sgi_drawchar() +include "sgi.com" + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = SGI_TXAP(g_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by sgi_txset, and is just a scaling factor. + + SGI_TXSIZE(g_kt) = TX_SIZE(tx) + if (TX_COLOR(tx) != SGI_COLOR(g_kt)) { + call sgi_color (TX_COLOR(tx)) + SGI_COLOR(g_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line. + if (SGI_TYPE(g_kt) != GL_SOLID) { + call sgi_linetype (GL_SOLID) + SGI_TYPE(g_kt) = GL_SOLID + } + + # No discreet character sizes, so just scale the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = SGI_CHARHEIGHT(g_kt,1) * tsz + cw = SGI_CHARWIDTH(g_kt,1) * tsz + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx), cw, totwidth) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, totwidth, x0,y0, gki_dx,gki_dy, + polytext, orien) + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + cosv = cos (-DEGTORAD(orien)) + sinv = sin (-DEGTORAD(orien)) + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + offset = sgi_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + (offset * cosv) + y = y - (offset * sinv) + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font, cw, totwidth) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code +int cw # default character width +int totwidth # seg width in GKI units + +int i +int ip, op +int totlen, font + +include "font.com" +include "greek.com" + +begin + out[1] = start_font + font = start_font + totlen = 0 + totwidth = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + if (text[ip] < CHARACTER_START || text[ip] > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = text[ip] - CHARACTER_START + 1 + + if (font == GT_GREEK) { + totwidth = totwidth + + int(real(gchwid[i]) / real(FONT_WIDTH) * cw) + } else { + totwidth = totwidth + + int(real(chrwid[i]) / real(FONT_WIDTH) * cw) + } + + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, totwidth, x0, y0, dx, dy, polytext, + orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int totwidth # width of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "sgi.com" + +begin + tx = SGI_TXAP(g_kt) + + # Get character sizes in GKI coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = SGI_CHARHEIGHT(g_kt,1) * sz + cw = SGI_CHARWIDTH(g_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + #xvlen = dx * (totlen - 1) + if (dx > 0) + xvlen = totwidth - dx + else + xvlen = 0 + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/sgikern/sgitxset.x b/sys/gio/sgikern/sgitxset.x new file mode 100644 index 00000000..c064d556 --- /dev/null +++ b/sys/gio/sgikern/sgitxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +# SGI_TXSET -- Set the text drawing attributes. + +procedure sgi_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "sgi.com" + +begin + tx = SGI_TXAP(g_kt) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/sgikern/sgk.com b/sys/gio/sgikern/sgk.com new file mode 100644 index 00000000..a919e147 --- /dev/null +++ b/sys/gio/sgikern/sgk.com @@ -0,0 +1,49 @@ +# SGK.COM -- The common for the SGK kernel. A common is used here for maximum +# efficiency (minimum indirection) when rasterizing vectors and encoding +# metacode. The maximum bitmap size is set at compile time in sgk.h. + +# Booleans put here to avoid possible alignment problems. + +bool mf_bitmap # metafile type, metacode or bitmap +bool mf_rotate # rotate (swap x and y) +bool mf_yflip # flip y axis end for end +bool mf_update # update bitmap +bool mf_delete # delete metacode file after dispose +bool mf_debug # print kernel debugging messages +bool mf_swap2 # swap every 2 bytes on output +bool mf_swap4 # swap every 4 bytes on output +bool mf_oneperfile # store each frame in a new file + +common /sgkboo/ mf_bitmap, mf_rotate, mf_yflip, mf_update, mf_delete, mf_debug, + mf_swap2, mf_swap4, mf_oneperfile + +# Everything else goes here. + +int mf_fd # file descriptor of output file +int mf_frame # frame counter +char mf_fname[SZ_PATHNAME] # metafile filename +char mf_dispose[SZ_OSCMD] # host dispose command + +int mf_op # [MCODE] index into obuf +short mf_obuf[LEN_OBUF] # metacode buffer + +int mf_cx, mf_cy # [BITMAPS] current pen position +int mf_nbpb # packing factor, bits per byte +int mf_pxsize, mf_pysize # physical x, y size of bitmap, bits +int mf_wxsize, mf_wysize # x, y size of bitmap window, bits +int mf_xorigin, mf_yorigin # origin of bitmap window +real mf_xscale, mf_yscale # to convert from NDC to device coords +int mf_xmin, mf_xmax # x clipping limits +int mf_ymin, mf_ymax # y clipping limits +int mf_lenframe # frame size, words +int mf_linewidth # relative line width +int mf_lworigin # device width of line size 1.0 +real mf_lwslope # device pixels per line size increment +int mf_fbuf[LEN_FBUF] # frame buffer (BIG) +int mf_bitmask[BPW] # bit mask table + +common /sgkcom/ mf_fd, mf_frame, mf_op, mf_cx, mf_cy, mf_nbpb, mf_pxsize, + mf_pysize, mf_wxsize, mf_wysize, mf_xorigin, mf_yorigin, mf_xscale, + mf_yscale, mf_xmin, mf_xmax, mf_ymin, mf_ymax, mf_lenframe, + mf_linewidth, mf_lworigin, mf_lwslope, mf_fbuf, mf_bitmask, mf_obuf, + mf_fname, mf_dispose diff --git a/sys/gio/sgikern/sgk.h b/sys/gio/sgikern/sgk.h new file mode 100644 index 00000000..09c62d95 --- /dev/null +++ b/sys/gio/sgikern/sgk.h @@ -0,0 +1,7 @@ +# SGK.H -- SGK metacode definitions. + +define SGK_LENMCI 3 # SGK instruction length +define SGK_FRAME 1 # new frame instruction +define SGK_MOVE 2 # move pen +define SGK_DRAW 3 # draw pen +define SGK_SETLW 4 # set line width diff --git a/sys/gio/sgikern/sgk.x b/sys/gio/sgikern/sgk.x new file mode 100644 index 00000000..3ed77f76 --- /dev/null +++ b/sys/gio/sgikern/sgk.x @@ -0,0 +1,853 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgk.h" + +.help sgk +.nf --------------------------------------------------------------------------- +SGK -- Simple graphics device interface. The purpose of this interface is +to provide a simple means for interfacing new plotter devices to IRAF/GIO. +The interface works by writing a binary metacode file and then disposing of +it by issuing a command to the host system. + + g_out = sgk_open (device, tty) # device open + sgk_close (g_out) # device close + sgk_flush (g_out) # flush output + + sgk_frame (g_out) # start a new frame + sgk_move (g_out, x, y) # move to (x,y) + sgk_draw (g_out, x, y) # draw a vector to (x,y) + sgk_linewidth (g_out, width) # set line width (>=1) + +The procedures comprising the top end of the SGK interface are summarized +above and the code is included in this file. These procedures could be +rewritten by the user to talk directly to a graphics device if desired, +although the metacode file interface is likely to be simpler in most cases. + +The SGK kernel can produce either metacode or bitmap output. Metacode output +is normally preferred for intelligent plotters and for pen plotters. Bitmap +output is normally preferred for raster plotters. The type of output file +to be generated is selected by the graphcap entry for an SGI/SGK device. + +The METACODE FORMAT written by the SGK interface is a sequence of 16 bit integer +words containing binary opcodes and data. The metacode is extremely simple, +consisting of only two drawing instructions (pen up move and pen down draw), +a frame instruction, and an optional set line width instruction. All text is +rendered into vectors by the SGI kernel hence there are no text drawing +instructions. The SGK metacode instruction formats are summarized below. + + opcode / data words + + 1 0 0 # frame instruction + 2 X Y # move to (x,y) + 3 X Y # draw to (x,y) + 4 W 0 # set line width (>= 1, 1=normal, 2=bold) + +All opcodes and data words are 16 bit positive integers encoded in the machine +independent MII format, i.e., most significant byte first. Only 15 bits of +each 16 bit word are actually used. Coordinates are specified in the range 0 +to 32767. All instructions are zero padded to 3 words to simplify metacode +translation programs. + +The BITMAP FORMAT written by the SGK is even simpler than the metacode format. +Output consists of a binary raster file containing one or more bitmaps with no +embedded header information. All bitmaps in a raster file are of the same +size. The size is specified in the graphcap entry for the device and may be +passed to the host dispose task on the foreign task command line if desired. +Page offsets may also be passed on the command line, e.g., to position the +plot on the plotter page. + +The following graphcap fields apply to both metacode and bitmap devices. + + DD host command to dispose of metacode file ($F) + DB have the kernel print debug messages during execution + RM boolean; if present, SGK will delete metacode file + MF multiframe count (max frames per job) + NF store each frame in a new file (rather than all in one file) + RO rotate plot (swap x and y) + YF y-flip plot (flip y axis) (done after rotate) + +The following additional fields are defined for bitmap devices. + + BI boolean; presence indicates a bitmapped or raster device + LO width in device pixels of a line of size 1.0 + LS difference in device pixels between line sizes + PX physical x size (linelen) of bitmap as stored in memory, bits + PY physical y size of bitmap, i.e., number of lines in bitmap + XO,YO origin of plotting window in device pixels + XW,YW width of plotting window in device pixels + NB number of bits to be set in each 8 bit byte output + BF bit-flip each byte in bitmap (easier here than later) + BS byte swap the bitmap when output (swap every two bytes) + WS word swap the bitmap when output (swap every four bytes) + +The multiframe count (MF) limits the number of frames per job, where a job +refers to the dispose command submitted to the host to process the frames. +If the new file flag (NF) is absent, all frames will be stored in the same +physical file (this holds for both metacode and bitmap frames). If the new +file flag (NF) is set, each frame will be stored in a separate file, with +the N files having the names $F.1, $F.2, ... $F.N, where $F is the unique +(root) filename generated from the template given in the DD string. The $F +is replaced by the root filename, rather than by a list of all the filenames, +to keep the OS command to a reasonable length and to permit the use of host +file templates to perform operate upon the full set of files (and to avoid +having to choose between spaces and commas to delimit the filenames). +For example, if MF=8 and NF=yes, then "$F.[1-8]" will match the file set +on a UNIX host. The template "$F.*" is less precise but would also work. + +The output raster will consist of PY lines each of length PX bits. If PX is +chosen to be a multiple of 8, there will be PX/8 bytes per line of the output +raster. Note that the values of PX and PY are arbitrary and should be chosen +to simplify the code of the translator and maximize efficiency. In particular, +PX and PY do not in general define the maximum physical resolution of the +device, although if NB=8 the value of PX will typically approximate the +physical resolution in X. If there are multiple bitmap frames per file, +each frame will occupy an integral number of SPP char units of storage in the +output file, with the values of any extra bits at the end of the bitmap being +undefined (a char is 16 bits on most IRAF host machines). + +The plot will be rasterized in a logical window XW one-bit pixels wide and YW +pixels high. The first YO lines of the output raster will be zero, with the +plotting window beginning at line YO+1. The first XO bits of each output line +will be zeroed, with the plotting window beginning at bit XO+1. The bytes in +each output line may be bit-flipped if desired, and all of the bits in each +output byte need not be used for pixel data. If the bit packing factor NB is +set to 8 the plotting window will map into XW bits of storage of each output +line. If fewer than 8 bits are used in each output byte more than XW physical +bits of storage will be used, e.g., if NB=4, XW*2 bits of storage are required +for a line of the plotting window. The unused bits are set to zero. The +translator can later "or" a mask into the zeroed bits, flip the data bits, +or perform any other bytewise operation using simple lookup table mapping +techniques. +.endhelp ---------------------------------------------------------------------- + +# NOTE -- The mf_physbit lookup table, used to map logical screen bits into +# physical bits in the bitmap (for NB != 8) is equivalenced to the mf_obuf +# array which is not otherwise used for bitmap devices. The length of the +# mf_obuf array must therefore be >= PX. + +define mf_physbit mf_obuf # union these two arrays [[[NOTE]]] +define BPW NBITS_INT # nbits in an integer +define LEN_FBUF (2550*3300/BPW) # max size bitmap / frame buffer +define LEN_OBUF 3300 # nwords in output buffer +define SZ_DDSTR 256 # max size graphcap.DD +define SZ_OSCMD 256 # OS dispose command from graphcap.DD + + +# SGK_OPEN -- Open the metacode file. Parse the DD string from the graphcap +# entry for the device to get the file template and OS dispose command. +# Generate a unique file name and open the metacode file as a NEW_FILE. +# Save the dispose command for later. + +int procedure sgk_open (device, tty) + +char device[ARB] # device name [NOT USED] +pointer tty # pointer to graphcap descriptor + +char cap[2] +int len_nodeprefix, byte, off, op, i, j +pointer sp, raw_ddstr, ddstr, devname, spool, fname, tempfn, val, ip + +bool ttygetb() +real ttygetr() +int open(), ttygets(), ttygeti(), gstrcpy(), shifti() +errchk open, ttygets, ttygeti, ttygetb +include "sgk.com" + +begin + call smark (sp) + call salloc (raw_ddstr, SZ_DDSTR, TY_CHAR) + call salloc (ddstr, SZ_DDSTR, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (spool, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tempfn, SZ_PATHNAME, TY_CHAR) + call salloc (val, SZ_FNAME, TY_CHAR) + + # The DB flag may be set in the graphcap entry for an SGI device to + # print debug messages during execution. + + mf_debug = ttygetb (tty, "DB") + + # The DD string is used to pass device dependent information to the + # graphics device driver. + + if (ttygets (tty, "DD", Memc[raw_ddstr], SZ_DDSTR) <= 0) + call error (1, "sgikern: missing DD parameter in graphcap") + + # Expand any $(XX) graphcap parameter references in the DD string. + op = ddstr + for (ip=raw_ddstr; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && Memc[ip+1] == '(' && Memc[ip-1] != '\\') { + # Graphcap parameter substitution. + call strcpy (Memc[ip+2], cap, 2) + if (ttygets (tty, cap, Memc[val], SZ_FNAME) <= 0) { + call eprintf ("Warning: graphcap field `%s' not found\n") + call pargstr (cap) + } else { + for (off=val; Memc[off] == '#'; off=off+1) + ; + for (; Memc[off] != EOS; off=off+1) { + Memc[op] = Memc[off] + op = op + 1 + } + } + ip = ip + 4 + + } else { + # Ordinary character. + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Parse the DD string into the node/device name, temp file name, + # and host dispose command. + + # Get node and device name (e.g., "node!device,..."). + len_nodeprefix = 0 + ip = ddstr + for (op=devname; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ',') { + if (Memc[ip-1] == '\\') { + Memc[op-1] = ',' + ip = ip - 1 + } else { + ip = ip + 1 + break + } + } else { + if (Memc[ip] == FNNODE_CHAR) + len_nodeprefix = op - devname + 1 + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Get spoolfile root name. + op = spool + gstrcpy (Memc[devname], Memc[spool], len_nodeprefix) + for (; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ',') { + if (Memc[ip-1] == '\\') { + Memc[op-1] = ',' + ip = ip - 1 + } else { + ip = ip + 1 + break + } + } else { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Get OS pathname of spoofile. + call mktemp (Memc[spool], Memc[tempfn], SZ_PATHNAME) + call fmapfn (Memc[tempfn], mf_fname, SZ_PATHNAME) + call strupk (mf_fname, mf_fname, SZ_PATHNAME) + + # Get pathname of spoolfile on the remote node. The call to + # ki_fmapfn() is currently necessary to translate the filename for + # the remote node, but may be replaced by the usual fmapfn() in a + # future version of the kernel interface. + + call ki_fmapfn (Memc[tempfn], Memc[fname], SZ_PATHNAME) + call strupk (Memc[fname], Memc[fname], SZ_PATHNAME) + + if (mf_debug) { + call eprintf ("sgk: open device %s, outfile = %s\n") + call pargstr (Memc[devname]) + call pargstr (mf_fname) + } + + # Copy OS command for disposing of metacode file into common, replacing + # all $F sequences in the command by the OS pathname of the spool file. + + op = gstrcpy (Memc[devname], mf_dispose, len_nodeprefix) + 1 + + for (; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && Memc[ip-1] == '\\') { + # Escape a $. + mf_dispose[op-1] = '$' + + } else if (Memc[ip] == '$' && Memc[ip+1] == 'F') { + # Filename substitution. + for (i=fname; Memc[i] != EOS; i=i+1) { + mf_dispose[op] = Memc[i] + op = op + 1 + } + ip = ip + 1 + + } else { + # Ordinary character. + mf_dispose[op] = Memc[ip] + op = op + 1 + } + + mf_dispose[op] = EOS + + # Remove (delete) metacode file after issuing OS dispose command? + mf_delete = ttygetb (tty, "RM") + + # Store each frame in a new file? + mf_oneperfile = ttygetb (tty, "NF") + + mf_update = false + mf_frame = 1 + + # Open a new metacode file. + if (mf_oneperfile) + call sgk_mkfname (mf_fname, mf_frame, Memc[fname], SZ_FNAME) + else + call strcpy (mf_fname, Memc[fname], SZ_FNAME) + + if (mf_debug) { + call eprintf ("sgk: open frame %2d, outfile = %s\n") + call pargi (mf_frame) + call pargstr (Memc[fname]) + } + mf_fd = open (Memc[fname], NEW_FILE, BINARY_FILE) + + # Rotate plot (swap x,y)? Y-flip plot? + mf_rotate = ttygetb (tty, "RO") + mf_yflip = ttygetb (tty, "YF") + + # Raster (bitmap) or metacode device? + mf_bitmap = ttygetb (tty, "BI") + + if (mf_bitmap) { + # Bitmap output; initialize bitmap parameters. + + mf_pxsize = ttygeti (tty, "PX") + mf_pysize = ttygeti (tty, "PY") + mf_xorigin = ttygeti (tty, "XO") + mf_yorigin = ttygeti (tty, "YO") + mf_wxsize = ttygeti (tty, "XW") + mf_wysize = ttygeti (tty, "YW") + mf_nbpb = ttygeti (tty, "NB") + mf_swap2 = ttygetb (tty, "BS") + mf_swap4 = ttygetb (tty, "WS") + + mf_lworigin = max (1, ttygeti (tty, "LO")) + mf_lwslope = ttygetr (tty, "LS") + mf_lenframe = (mf_pxsize * mf_pysize + BPW-1) / BPW + + if (mf_wxsize == 0) + mf_wxsize = mf_pxsize - mf_xorigin + if (mf_wysize == 0) + mf_wysize = mf_pysize - mf_yorigin + if (mf_nbpb == 0) + mf_nbpb = NBITS_BYTE + + mf_linewidth = mf_lworigin + mf_cx = 0 + mf_cy = 0 + + mf_xmin = mf_xorigin + mf_ymin = mf_yorigin + mf_xmax = mf_xmin + mf_wxsize - 1 + mf_ymax = mf_ymin + mf_wysize - 1 + + mf_xscale = real(mf_wxsize) / real(GKI_MAXNDC) + mf_yscale = real(mf_wysize) / real(GKI_MAXNDC) + + if (mf_lenframe > LEN_FBUF) + call error (1, "sgikern: bitmap too large") + + # Initialize the bit mask table. If it is necessary to bit-flip + # bytes in the bitmap, we can do that here by flipping each byte + # of the word mask. Bit flipping can be done during rasterization + # at no additional cost, but is an expensive operation if done + # later with a filter. + + if (ttygetb (tty, "BF")) { + do j = 1, (BPW/NBITS_BYTE) + do i = 1, NBITS_BYTE { + off = (j - 1) * NBITS_BYTE + mf_bitmask[off+i] = shifti (1, off + NBITS_BYTE - i) + } + } else { + do i = 1, BPW + mf_bitmask[i] = shifti (1, i - 1) + } + + # Initialize the bit offset lookup table. This gives the physical + # x-offset into the lookup table of each addressable x-coordinate + # on the device. If NB is NBITS_BYTE the mapping is one-to-one. + # Note that the table contains zero-indexed bit offsets. + + do i = 1, mf_pxsize { + byte = (i - 1) / mf_nbpb + mf_physbit[i] = min (mf_pxsize, + byte * NBITS_BYTE + (i - (byte * mf_nbpb))) - 1 + } + + if (mf_debug) { + call eprintf ("bitmap [%d,%d] origin=[%d,%d] wsize=[%d,%d]\n") + call pargi (mf_pxsize); call pargi (mf_pysize) + call pargi (mf_xorigin); call pargi (mf_yorigin) + call pargi (mf_wxsize); call pargi (mf_wysize) + } + + } else { + # Metacode output; initialize the metacode output buffer. + mf_op = 1 + if (mf_debug) + call eprintf ("metafile device\n") + } + + call sfree (sp) + return (mf_fd) +end + + +# SGK_CLOSE -- Close the metacode spool file and dispose of it to a host system +# metacode translation task. Delete the spool file when the OS command +# completes, unless it has already been deleted by the task run. + +procedure sgk_close (fd) + +int fd # output stream [NOT USED] + +int i +pointer sp, fname +int oscmd() +errchk sgk_flush, close, oscmd +include "sgk.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + if (mf_debug) + call eprintf ("close device\n") + + if (mf_bitmap) + call sgk_frame (mf_fd) + else + call sgk_flush (mf_fd) + + if (mf_debug) { + call eprintf ("dispose: %s\n") + call pargstr (mf_dispose) + } + + if (mf_fd != NULL) { + call close (mf_fd) + mf_fd = NULL + } + + # Send the dispose command to the host system. + if (mf_dispose[1] != EOS) + if (oscmd (mf_dispose, "", "", "") != OK) + call eprintf ("Warning: SGK graphics output dispose error\n") + + # Delete the metacode or raster file if so indicated in the graphcap + # entry for the device. + + if (mf_delete) { + if (mf_debug) { + call eprintf ("delete metafile %s\n") + call pargstr (mf_fname) + } + if (mf_oneperfile) { + do i = 1, mf_frame { + call sgk_mkfname (mf_fname, i, Memc[fname], SZ_FNAME) + iferr (call delete (Memc[fname])) + ; + } + } else iferr (call delete (mf_fname)) + ; + } + + call sfree (sp) +end + + +# SGK_FLUSH -- Flush any buffered metacode output. + +procedure sgk_flush (fd) + +int fd # output stream [NOT USED] +include "sgk.com" + +begin + if (!mf_bitmap && mf_op > 1) { + if (mf_debug) + call eprintf ("flush graphics output\n") + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + if (mf_fd != NULL) + call flush (mf_fd) +end + + +# SGK_FRAME -- Output a frame advance instruction. + +procedure sgk_frame (fd) + +int fd # output stream [NOT USED] +include "sgk.com" + +begin + # Ignore frame commands if frame is empty. + if (!mf_update) + return + + if (mf_debug) + call eprintf ("start a new frame\n") + + if (mf_bitmap) { + # Write the bitmap to the output raster-file. + + if (mf_swap2) + call bswap2 (mf_fbuf, 1, mf_fbuf, 1, + mf_lenframe * SZ_INT * SZB_CHAR) + if (mf_swap4) + call bswap4 (mf_fbuf, 1, mf_fbuf, 1, + mf_lenframe * SZ_INT * SZB_CHAR) + + call write (mf_fd, mf_fbuf, mf_lenframe * SZ_INT) + + } else { + # Write the SGI frame instruction to the output mcode-file. + + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_FRAME + mf_obuf[mf_op+1] = 0 + mf_obuf[mf_op+2] = 0 + mf_op = mf_op + SGK_LENMCI + } + + mf_frame = mf_frame + 1 + mf_update = false +end + + +# SGK_MOVE -- Output a pen move instruction. + +procedure sgk_move (fd, x, y) + +int fd # output stream [NOT USED] +int x, y # point to move to + +include "sgk.com" + +begin + if (mf_bitmap) { + if (mf_rotate) { + mf_cx = y + mf_cy = x + } else { + mf_cx = x + mf_cy = y + } + + if (mf_yflip) + mf_cy = GKI_MAXNDC - mf_cy + + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + mf_cx = max (mf_xmin, min (mf_xmax, + int (mf_cx * mf_xscale) + mf_xorigin)) + mf_cy = max (mf_ymin, min (mf_ymax, + int (mf_cy * mf_yscale) + mf_yorigin)) + + } else { + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_MOVE + if (mf_rotate) { + mf_obuf[mf_op+1] = y + mf_obuf[mf_op+2] = x + } else { + mf_obuf[mf_op+1] = x + mf_obuf[mf_op+2] = y + } + if (mf_yflip) + mf_obuf[mf_op+2] = GKI_MAXNDC - mf_obuf[mf_op+2] + mf_op = mf_op + SGK_LENMCI + } +end + + +# SGK_DRAW -- Output a pen draw instruction. + +procedure sgk_draw (fd, a_x, a_y) + +int fd # output stream [NOT USED] +int a_x, a_y # point to draw to + +char fname[SZ_FNAME] +int xshift, yshift, dx, dy +int new_x, new_y, x1, y1, x2, y2, n, i +int open() +errchk open, close +include "sgk.com" + +begin + if (mf_rotate) { + new_x = a_y + new_y = a_x + } else { + new_x = a_x + new_y = a_y + } + + if (mf_yflip) + new_y = GKI_MAXNDC - new_y + + if (!mf_update) { + # We are called when the first drawing instruction is output for a + # new frame. We clear the bitmap or close and open a new frame + # file here, rather than at sgk_frame() time, as we do not want + # to initialize the frame buffer or open a new frame file unless + # we are actually going to write into the frame. + + # Zero out all the bits in a bitmap. + if (mf_bitmap) + call aclri (mf_fbuf, mf_lenframe) + + # Open a new frame file if the one frame per file flag is set. + if (mf_oneperfile && mf_frame > 1) { + if (mf_fd != NULL) + call close (mf_fd) + call sgk_mkfname (mf_fname, mf_frame, fname, SZ_FNAME) + if (mf_debug) { + call eprintf ("sgk: open frame %2d, outfile = %s\n") + call pargi (mf_frame) + call pargstr (fname) + } + mf_fd = open (fname, NEW_FILE, BINARY_FILE) + } + + mf_update = true + } + + if (mf_bitmap) { + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + new_x = max (mf_xmin, min (mf_xmax, + int (new_x * mf_xscale) + mf_xorigin)) + new_y = max (mf_ymin, min (mf_ymax, + int (new_y * mf_yscale) + mf_yorigin)) + + if (mf_linewidth <= 1) + call sgk_vector (mf_cx, mf_cy, new_x, new_y) + else { + # Redraw the vector several times with small normal shifts to + # produce a wider line. + + xshift = 0 + yshift = 0 + + if (abs (new_x - mf_cx) > abs (new_y - mf_cy)) { + dx = 0 + dy = 1 + } else { + dx = 1 + dy = 0 + } + + do i = 1, mf_linewidth { + x1 = mf_cx + xshift + y1 = mf_cy + yshift + x2 = new_x + xshift + y2 = new_y + yshift + + call sgk_vector (x1, y1, x2, y2) + + n = (i + 1) / 2 + if (and (i, 1) == 0) { + xshift = dx * n + yshift = dy * n + } else { + xshift = -dx * n + yshift = -dy * n + } + } + } + + # Update the current pen position, and set the update flag so that + # the bitmap will be written to the output file. + + mf_cx = new_x + mf_cy = new_y + + } else { + # Output a metacode draw instruction. + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_DRAW + mf_obuf[mf_op+1] = new_x + mf_obuf[mf_op+2] = new_y + mf_op = mf_op + SGK_LENMCI + } +end + + +# SGK_VECTOR -- Write a vector (line) of unit width into the bitmap. The line +# endpoints are expressed in physical device coordinates. + +procedure sgk_vector (a_x1, a_y1, a_x2, a_y2) + +int a_x1, a_y1 # start point of line +int a_x2, a_y2 # end point of line + +real dydx, dxdy +long fbit, wbit, word +int wpln, mask, dx, dy, x, y, x1, y1, x2, y2, or() +include "sgk.com" + +begin + x1 = a_x1; y1 = a_y1 + x2 = a_x2; y2 = a_y2 + + dx = x2 - x1 + dy = y2 - y1 + + if (abs(dx) > abs(dy)) { + if (x1 > x2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dy == 0 && mf_nbpb == NBITS_BYTE) { + # Somewhat optimized code for the case of a horiz. vector. + + fbit = y1 * mf_pxsize + x1 + word = fbit / BPW + wbit = and (fbit, BPW-1) + + do x = x1, x2 { + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + wbit = wbit + 1 + if (wbit >= BPW) { + wbit = 0 + word = word + 1 + } + } + + } else { + # The general case for a mostly-X vector. + + dydx = real(dy) / real(dx) + do x = x1, x2 { + y = int ((x - x1) * dydx) + y1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else if (dy != 0) { + if (y1 > y2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dx == 0) { + # Optimized code for the case of a vertical vector. + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + 1 + wbit = and (fbit, BPW-1) + wpln = (mf_pxsize + BPW-1) / BPW + mask = mf_bitmask[wbit+1] + + do y = y1, y2 { + mf_fbuf[word] = or (mf_fbuf[word], mask) + word = word + wpln + } + + } else { + # The general case of a mostly-Y vector. + + dxdy = real(dx) / real(dy) + do y = y1, y2 { + x = int ((y - y1) * dxdy) + x1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else { + # Plot a single point (dx=dy=0). + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } +end + + +# SGK_LINEWIDTH -- Output a line width set instruction. + +procedure sgk_linewidth (fd, width) + +int fd # output stream [NOT USED] +int width # new line width + +int gap +include "sgk.com" + +begin + if (mf_bitmap) { + # Set the line width in device pixels. + mf_linewidth = max (1, mf_lworigin + int ((width-1) * mf_lwslope)) + + # Set the clipping limits. Allow for shifting to widen lines. + gap = mf_linewidth - 1 + mf_xmin = mf_xorigin + gap + mf_ymin = mf_yorigin + gap + mf_xmax = mf_xorigin + (mf_wxsize - 1) - gap + mf_ymax = mf_yorigin + (mf_wysize - 1) - gap + + } else { + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_SETLW + mf_obuf[mf_op+1] = width + mf_obuf[mf_op+2] = 0 + mf_op = mf_op + SGK_LENMCI + } +end + + +# SGK_MKFNAME -- Make the name of file N of a multiframe set. + +procedure sgk_mkfname (root, num, outstr, maxch) + +char root[ARB] # root filename +int num # file number +char outstr[maxch] # receives new filename +int maxch + +begin + call sprintf (outstr, maxch, "%s.%d") + call pargstr (root) + call pargi (num) +end diff --git a/sys/gio/sgikern/t_sgideco.x b/sys/gio/sgikern/t_sgideco.x new file mode 100644 index 00000000..57dae876 --- /dev/null +++ b/sys/gio/sgikern/t_sgideco.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgk.h" + +define LEN_MCBUF 3000 + + +# SGIDECODE -- Decode an SGI metacode file, printing the decoded metacode +# instructions on the standard output. + +procedure t_sgidecode() + +pointer sp, fname, mcbuf, ip, itop +int fd, list, verbose, gkiunits, nwords + +bool clgetb() +int clpopni(), clgfil(), clplen(), open(), btoi(), miireads() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (mcbuf, LEN_MCBUF, TY_SHORT) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + if (clgetb ("generic")) { + verbose = NO + gkiunits = NO + } else { + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Print header if new file. + if (clplen (list) > 1) { + call printf ("\n# METAFILE `%s':\n") + call pargstr (Memc[fname]) + } + + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode. + + itop = mcbuf + ip = mcbuf + + repeat { + if (ip >= itop) { + # Refill buffer. + nwords = miireads (fd, Mems[mcbuf], LEN_MCBUF) + if (nwords == EOF) + break + itop = mcbuf + nwords + ip = mcbuf + } + + switch (Mems[ip]) { + case SGK_FRAME: + call printf ("new_frame\n") + case SGK_MOVE: + if (gkiunits == YES) { + call printf ("move (%d, %d)\n") + call pargs (Mems[ip+1]) + call pargs (Mems[ip+2]) + } else { + call printf ("move (%0.5f, %0.5f)\n") + call pargr (real(Mems[ip+1]) / real(GKI_MAXNDC)) + call pargr (real(Mems[ip+2]) / real(GKI_MAXNDC)) + } + case SGK_DRAW: + if (gkiunits == YES) { + call printf ("draw (%d, %d)\n") + call pargs (Mems[ip+1]) + call pargs (Mems[ip+2]) + } else { + call printf ("draw (%0.5f, %0.5f)\n") + call pargr (real(Mems[ip+1]) / real(GKI_MAXNDC)) + call pargr (real(Mems[ip+2]) / real(GKI_MAXNDC)) + } + case SGK_SETLW: + call printf ("set_linewidth (%d)\n") + call pargs (Mems[ip+1]) + default: + call printf ("unknown instruction\n") + } + + ip = ip + SGK_LENMCI + } + + call close (fd) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/sgikern/t_sgikern.x b/sys/gio/sgikern/t_sgikern.x new file mode 100644 index 00000000..359a87ad --- /dev/null +++ b/sys/gio/sgikern/t_sgikern.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# SGIKERN -- Generic graphics kernel for the standard plotter output. The whole +# package is copied as much as possible from the stdgraph package. + +procedure t_sgikern() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +bool clgetb() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Open the graphics kernel. + call sgi_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call sgi_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/sgikern/x_sgikern.x b/sys/gio/sgikern/x_sgikern.x new file mode 100644 index 00000000..797820c2 --- /dev/null +++ b/sys/gio/sgikern/x_sgikern.x @@ -0,0 +1,5 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task stdplot = t_sgikern, + sgikern = t_sgikern, + sgidecode = t_sgidecode diff --git a/sys/gio/stdgraph/README b/sys/gio/stdgraph/README new file mode 100644 index 00000000..6007b9b1 --- /dev/null +++ b/sys/gio/stdgraph/README @@ -0,0 +1,77 @@ +gio$stdgraph + + This directory contains the source and executables for the STDGRAPH and +GKIDECODE graphics kernels. The two kernels are implemented both as libraries +and as executable tasks. + + gkidecode This kernel is used standalone to examine GKI + metafiles. The real work is done by the GKIPRINT + library module in the GIO package. + + stdgraph A graphics kernel for graphics terminals. Implemented + both as the library "libstdg.a" and as the kernel task + STDGRAPH. The library is required for this kernel to + permit inclusion of the stdgraph kernel in the CL + process. + +Both kernels are available as CL callable tasks in the executable file +x_kernel.e. + + +GKIPRINT -- Graphics kernel for decoding metacode. This graphics kernel +formats metacode instructions into readable form and prints them on the output +file. The gkiprint kernel is useful for examining metafiles and for +debugging kernels which drive specific devices. The driver consists of the +following procedures: + + gkp_openws (devname, n, mode) + gkp_closews (devname, n) + gkp_mftitle (title, n) ** + gkp_clear (dummy) + gkp_cancel (dummy) + gkp_flush (dummy) + gkp_polyline (p, npts) + gkp_polymarker (p, npts) + gkp_text (x, y, text, n) + gkp_fillarea (p, npts) + gkp_getcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_setcursor (x, y, cursor) + gkp_plset (gki) + gkp_pmset (gki) + gkp_txset (gki) + gkp_faset (gki) + gkp_getcursor (cursor) + gkp_escape (fn, instruction, nwords) ** + gkp_setwcs (wcs, nwords) ** + gkp_getwcs (wcs, nwords) ** + gkp_unknown (gki) ** + +A GKI driven device driver may implement any subset of these procedures. +The starred procedures should be omitted by most drivers. In particular, +the SETWCS and GETWCS instructions are internal instructions which should +be ignored by ordinary device drivers. The procedure names may be anything, +but the arguments lists must be as shown. All coordinates are in GKI units, +0 to 32767. Character strings are passed in ASCII, one character per metacode +word. Whenever a GKI character string appears as an array argument in the +argument list of a procedure, the count N of the number of characters in the +string follows as the next argument. GKI character strings are not EOS +delimited. Polyline, polymarker, and fillarea data is passed as an array +of (x,y) points P, in GKI coordinates, defining the polyline or polygon to +be plotted. + +One additional procedure, GKP_INSTALL, is called by the main program of the +graphics kernel task to install the debugging driver, i.e., to fill the DD +array with the entry point addresses of the driver procedures. For a normal +driver this function is performed by a user supplied procedure named +GKOPEN (graphics kernel open). The user supplied kernel procedures will +be called to execute each instruction as the instructions are decoded by the +main routine. The user supplied procedure GKCLOSE will be called when +interpretation ends and the task is about to exit. + + gkopen (dd) + gkclose () + +Do not confuse GKOPEN and GKCLOSE, which open and close the graphics kernel, +with GKI_OPENWS and GKI_CLOSEWS, the metacode instructions used to direct +an opened kernel to open and close workstations. diff --git a/sys/gio/stdgraph/font.com b/sys/gio/stdgraph/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/stdgraph/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/stdgraph/font.h b/sys/gio/stdgraph/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/sys/gio/stdgraph/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/stdgraph/mkpkg b/sys/gio/stdgraph/mkpkg new file mode 100644 index 00000000..8530f2c9 --- /dev/null +++ b/sys/gio/stdgraph/mkpkg @@ -0,0 +1,80 @@ +# Make the STDGRAPH GIO graphics kernel. + +$checkout libstg.a lib$ +$update libstg.a +$checkin libstg.a lib$ +$exit + +update: # update lib$x_stdgraph.e + $call relink + $call install + ; + +relink: # make x_stdgraph.e in local directory + $omake x_stdgraph.x + $link x_stdgraph.o -lstg + ; + +install: # install in system library + $move x_stdgraph.e bin$ + ; + +libstg.a: + # $set xflags = "$(xflags) -qfx" + + stgcancel.x stdgraph.com stdgraph.h + stgclear.x stdgraph.com stdgraph.h + stgclose.x stdgraph.com stdgraph.h + stgclws.x stdgraph.h stdgraph.com + stgctrl.x stdgraph.com stdgraph.h + stgdeact.x stdgraph.com stdgraph.h + stgdraw.x stdgraph.com stdgraph.h + stgdrawch.x font.com font.h stdgraph.com stdgraph.h \ + + stgencode.x stdgraph.com stdgraph.h + stgescape.x + stgfa.x stdgraph.com stdgraph.h + stgfaset.x stdgraph.com stdgraph.h + stgfilter.x stdgraph.com stdgraph.h + stgflush.x stdgraph.com stdgraph.h + stggcell.x + stggcur.x stdgraph.com stdgraph.h + stggdisab.x stdgraph.com stdgraph.h + stggim.x stdgraph.com stdgraph.h \ + + stggenab.x stdgraph.com stdgraph.h + stggrstr.x stdgraph.com stdgraph.h + stginit.x stdgraph.com stdgraph.h \ + + stglkcur.x stdgraph.com stdgraph.h + stgmove.x stdgraph.com stdgraph.h + stgonerr.x stdgraph.com stdgraph.h + stgonint.x stdgraph.h + stgopen.x stdgraph.com stdgraph.h + stgopenws.x stdgraph.com stdgraph.h \ + + stgoutput.x stdgraph.com stdgraph.h + stgoutstr.x stdgraph.com stdgraph.h + stgpcell.x stdgraph.com stdgraph.h + stgpl.x stdgraph.com stdgraph.h + stgplset.x stdgraph.com stdgraph.h + stgpm.x stdgraph.com stdgraph.h + stgpmset.x stdgraph.com stdgraph.h + stgrcur.x stdgraph.com stdgraph.h \ + + stgreact.x stdgraph.com stdgraph.h + stgres.x stdgraph.com stdgraph.h + stgreset.x stdgraph.com stdgraph.h + stgrtty.x stdgraph.com stdgraph.h + stgscur.x stdgraph.com stdgraph.h + stgtx.x stdgraph.com stdgraph.h \ + + stgtxqual.x stdgraph.com stdgraph.h + stgtxset.x stdgraph.com stdgraph.h + stgtxsize.x stdgraph.com stdgraph.h + stgunkown.x + stgwtty.x stdgraph.com stdgraph.h + t_gkideco.x + t_showcap.x stdgraph.h + t_stdgraph.x + ; diff --git a/sys/gio/stdgraph/stdgraph.com b/sys/gio/stdgraph/stdgraph.com new file mode 100644 index 00000000..3d3c43c5 --- /dev/null +++ b/sys/gio/stdgraph/stdgraph.com @@ -0,0 +1,46 @@ +# STDGRAPH common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. For maximum efficiency the polyline generation and +# coordinate transformation datums are kept in the common. + +pointer g_sg # stdgraph graphics descriptor +pointer g_tty # graphcap descriptor +pointer g_term # termcap descriptor for terminal +pointer g_pbtty # script graphcap, playback mode +int g_nopen # open count for the kernel +int g_active # workstation is open for graphics i/o +int g_enable # graphics is enabled +int g_message # message mode (output text) +pointer g_msgbuf # message buffer (input text) +int g_msgbuflen # allocated size of message buffer +int g_msglen # amount of data in message +int g_keycol # used to show keys in playback mode +int g_keyline # used to show keys in playback mode +pointer g_xy # pointer to coord encoding string +int g_stream # graphics stream (metacode) +int g_in, g_out # input, output streams to device +int g_ucaseout # stty ucaseout status flag +int g_xres, g_yres # desired device resolution +int g_dxres, g_dyres # scale down to resolution coords +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +int g_lastx, g_lasty # used to clip unresolved points +int g_hardchar # controls use of hardware character gen +int g_cursor # user override of logical cursor +int g_reg[NREGISTERS] # encoder registers +char g_mem[SZ_MEMORY] # encoder memory +char g_device[SZ_GDEVICE] # device name for forced device output +char g_pbdevice[SZ_GDEVICE] # device name of playback script +char g_hixy[TEK_XRES] # lookup tables for tek encoding +char g_lox[TEK_XRES] # " " +char g_loy[TEK_YRES] # " " + +common /stgcom/ g_sg, g_tty, g_term, g_pbtty, g_nopen, g_active, g_enable, + g_message, g_msgbuf, g_msgbuflen, g_msglen, + g_keycol, g_keyline, g_xy, g_stream, g_in, g_out, + g_ucaseout, g_xres, g_yres, g_dxres, g_dyres, g_dx, g_dy, g_x1, + g_y1, g_x2, g_y2, g_lastx, g_lasty, g_hardchar, g_cursor, g_reg, + g_mem, g_device, g_pbdevice, g_hixy, g_lox, g_loy diff --git a/sys/gio/stdgraph/stdgraph.h b/sys/gio/stdgraph/stdgraph.h new file mode 100644 index 00000000..de216065 --- /dev/null +++ b/sys/gio/stdgraph/stdgraph.h @@ -0,0 +1,98 @@ +# STDGRAPH definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 2048 # initial string buffer size +define SZ_MEMORY 1024 # encoder memory size +define SZ_GDEVICE 256 # force output to named device +define SZ_UIFNAME 199 # user interface file name +define SZ_MSGBUF 4096 # default size message buffer +define FLUSH_MEMORY 117 # time to flush encoded polyline +define LEN_STACK 20 # encoder stack size +define NREGISTERS 12 # number of encoder registers +define E_IOP 11 # encoder i/o pointer register +define E_TOP 12 # encoder top memory register +define LONG_POLYLINE 50 # big enough to post X_INT +define PADCHAR 0 # used to gen. delays + +# The user can have private copies of UI specifications in GUIDIR. +define GUIDIR "guidir" + +# The STDGRAPH state/device descriptor. + +define LEN_SG 91 + +define SG_SBUF Memi[$1] # string buffer +define SG_SZSBUF Memi[$1+1] # size of string buffer +define SG_NEXTCH Memi[$1+2] # next char pos in string buf +define SG_NCHARSIZES Memi[$1+3] # number of character sizes +define SG_POLYLINE Memi[$1+4] # polyline output permitted +define SG_POLYMARKER Memi[$1+5] # device supports polymarker +define SG_FILLAREA Memi[$1+6] # device supports fillarea +define SG_ENCODEXY Memi[$1+7] # format for encoding coords +define SG_STARTDRAW Memi[$1+8] # pointer to DS string +define SG_ENDDRAW Memi[$1+9] # pointer to DE string +define SG_STARTMOVE Memi[$1+10] # pointer to VS string +define SG_ENDMOVE Memi[$1+11] # pointer to VE string +define SG_STARTMARK Memi[$1+12] # pointer to MS string +define SG_ENDMARK Memi[$1+13] # pointer to ME string +define SG_STARTFILL Memi[$1+14] # pointer to FS string +define SG_ENDFILL Memi[$1+15] # pointer to FE string +define SG_STARTTEXT Memi[$1+16] # start text draw +define SG_ENDTEXT Memi[$1+17] # end text draw +define SG_CURSOR Memi[$1+18] # last cursor accessed +define SG_UPDCURSOR Memi[$1+19] # update cursor pos before read +define SG_CURSOR_X Memi[$1+20] # current cursor X position +define SG_CURSOR_Y Memi[$1+21] # current cursor Y position +define SG_COLOR Memi[$1+22] # last color set +define SG_TXSIZE Memi[$1+23] # last text size set +define SG_TXFONT Memi[$1+24] # last text font set +define SG_PLTYPE Memi[$1+25] # last line type set +define SG_FASTYLE Memi[$1+26] # last fill area style set +define SG_PLWIDTH Memi[$1+27] # last line width set +define SG_DEVNAME Memi[$1+28] # name of open device +define SG_UIFNAME Memi[$1+29] # user interface file name +define SG_UIFDATE Memi[$1+30] # UI file date + # empty +define SG_CHARHEIGHT Memi[$1+40+$2-1] # character height +define SG_CHARWIDTH Memi[$1+50+$2-1] # character width +define SG_CHARSIZE Memr[P2R($1+60+$2-1)] # text sizes permitted +define SG_PLAP ($1+70) # polyline attributes +define SG_PMAP ($1+74) # polymarker attributes +define SG_FAAP ($1+78) # fill area attributes +define SG_TXAP ($1+81) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] + +# TEK 4012 definitions for optimized tek coordinate encoding. + +define TEK_XRES 1024 +define TEK_YRES 780 diff --git a/sys/gio/stdgraph/stgcancel.x b/sys/gio/stdgraph/stgcancel.x new file mode 100644 index 00000000..d47e24df --- /dev/null +++ b/sys/gio/stdgraph/stgcancel.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_CANCEL -- Cancel any buffered output. + +procedure stg_cancel (dummy) + +int dummy # not used at present +include "stdgraph.com" + +begin + call fseti (g_out, F_CANCEL, YES) + call stg_reset() +end diff --git a/sys/gio/stdgraph/stgclear.x b/sys/gio/stdgraph/stgclear.x new file mode 100644 index 00000000..9573c972 --- /dev/null +++ b/sys/gio/stdgraph/stgclear.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_CLEAR -- Clear the workstation screen. All attribute packets are +# initialized to their default values when the screen is cleared. + +procedure stg_clear (dummy) + +int dummy # not used at present +include "stdgraph.com" + +begin + call stg_ctrl ("CL") + call stg_reset() +end diff --git a/sys/gio/stdgraph/stgclose.x b/sys/gio/stdgraph/stgclose.x new file mode 100644 index 00000000..3d7eb70b --- /dev/null +++ b/sys/gio/stdgraph/stgclose.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_CLOSE -- Close the STDGRAPH kernel. Free all storage associated with the +# stdgraph descriptor. Note that the stdgraph kernel may be multiply opened +# (connected to two or more graphics steams, e.g., both STDGRAPH and STDIMAGE), +# hence we do not physically close down until the last stream is closed. + +procedure stg_close() + +include "stdgraph.com" + +begin + g_nopen = g_nopen - 1 + + if (g_nopen <= 0) { + call stg_deactivatews (0) + call flush (g_out) + call mfree (SG_SBUF(g_sg), TY_CHAR) + call mfree (g_sg, TY_STRUCT) + + if (g_tty != NULL) { + call ttycdes (g_tty) + g_tty = NULL + } + + if (g_term != NULL) { + call ttycdes (g_term) + g_term = NULL + } + + if (g_pbtty != NULL) { + call ttycdes (g_pbtty) + g_pbtty = NULL + } + + if (g_msgbuf != NULL) { + call mfree (g_msgbuf, TY_CHAR) + g_msgbuf = NULL + g_msgbuflen = 0 + g_msglen = 0 + } + + g_nopen = 0 + } +end diff --git a/sys/gio/stdgraph/stgclws.x b/sys/gio/stdgraph/stgclws.x new file mode 100644 index 00000000..137784cd --- /dev/null +++ b/sys/gio/stdgraph/stgclws.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_CLOSEWS -- Close the named workstation. Output the termination string, +# if any, and flush the output. Buffer deallocation is handled by STGCLOSE. + +procedure stg_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name + +include "stdgraph.com" + +begin + call stg_ctrl ("CW") + call flush (g_out) + + g_active = NO + g_enable = NO + + # Reenable stty ucaseout mode if it was set when the workstation + # was activated. + + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, YES) +end diff --git a/sys/gio/stdgraph/stgctrl.x b/sys/gio/stdgraph/stgctrl.x new file mode 100644 index 00000000..6689de8a --- /dev/null +++ b/sys/gio/stdgraph/stgctrl.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +define SZ_PROGRAM 256 + +# STG_CTRL -- Fetch an encoder format string from the graphcap entry and +# use it to encode zero, one, or two integer arguments into a control string. +# Put the control string to the output device. + +procedure stg_ctrl (cap) + +char cap[ARB] # name of device capability to be encoded +pointer sp, prog +int stg_encode(), ttygets() +include "stdgraph.com" + +begin + call smark (sp) + call salloc (prog, SZ_PROGRAM, TY_CHAR) + + # Fetch the program from the graphcap file. Zero is returned if the + # device does not have the named capability, in which case the function + # is inapplicable and should be ignored. + + if (ttygets (g_tty, cap, Memc[prog], SZ_PROGRAM) > 0) { + # Encode the output string and write the encoded string to the + # output file. + g_reg[E_IOP] = 1 + if (stg_encode (Memc[prog], g_mem, g_reg) == OK) { + g_mem[g_reg[E_IOP]] = EOS + call ttyputs (g_out, g_tty, g_mem, 1) + } + } + + call sfree (sp) +end + + +# STG_CTRL1 -- Encode one integer argument. + +procedure stg_ctrl1 (cap, arg1) + +char cap[ARB] # device capability +int arg1 +include "stdgraph.com" + +begin + g_reg[1] = arg1 + call stg_ctrl (cap) +end + + +# STG_CTRL2 -- Encode two integer arguments. + +procedure stg_ctrl2 (cap, arg1, arg2) + +char cap[ARB] # device capability +int arg1, arg2 +include "stdgraph.com" + +begin + g_reg[1] = arg1 + g_reg[2] = arg2 + call stg_ctrl (cap) +end + + +# STG_CTRL3 -- Encode three integer arguments. + +procedure stg_ctrl3 (cap, arg1, arg2, arg3) + +char cap[ARB] # device capability +int arg1, arg2, arg3 +include "stdgraph.com" + +begin + g_reg[1] = arg1 + g_reg[2] = arg2 + g_reg[3] = arg3 + call stg_ctrl (cap) +end diff --git a/sys/gio/stdgraph/stgdeact.x b/sys/gio/stdgraph/stgdeact.x new file mode 100644 index 00000000..b11e4a07 --- /dev/null +++ b/sys/gio/stdgraph/stgdeact.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_DEACTIVATEWS -- Deactivate the workstation, i.e., disable graphics, +# leaving the terminal in text mode. Note that it is the CW (close +# workstation) sequence which is actually output, since the GD sequence is +# used only to write single lines of text to the status line. + +procedure stg_deactivatews (flags) + +int flags # action modifier flags + +char buf[1] +int stg_readtty(), and() +include "stdgraph.com" + +begin + if (g_out <= 0) + return + + # The g_active and g_out test permits us to be called before the + # kernel is opened and causes redundant calls to be ignored. + + if (g_active == YES) { + # Pause before deactivating? + if (and (flags, AW_PAUSE) != 0) { + call stg_putline (g_out, "\n[Hit return to continue]\n") + while (stg_readtty (STDIN, buf, 1) != EOF) + if (buf[1] == '\r' || buf[1] == '\n') + break + } + + # Deactivate the workstation. + call stgctrl ("CW") + + g_active = NO + g_enable = NO + + # Reenable stty ucaseout mode if it was set when the workstation + # was activated. + + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, YES) + } + + # Clear the text screen? + if (and (flags, AW_CLEAR) != 0 && g_term != NULL) + call ttyclear (g_out, g_term) + + call flush (g_out) +end diff --git a/sys/gio/stdgraph/stgdraw.x b/sys/gio/stdgraph/stgdraw.x new file mode 100644 index 00000000..ae5a4ace --- /dev/null +++ b/sys/gio/stdgraph/stgdraw.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_DRAW -- Output a device draw line-segment instruction to draw from the +# current position to the position (x,y) in GKI coordinates. + +procedure stg_draw (x, y) + +int x, y # destination +int stg_encode() +include "stdgraph.com" + +begin + # Transform the first point from GKI coords to device coords and + # draw to the transformed point. + + call ttyputs (g_out, g_tty, Memc[SG_STARTDRAW(g_sg)], 1) + + g_reg[1] = x * g_dx + g_x1 + g_reg[2] = y * g_dy + g_y1 + g_reg[E_IOP] = 1 + if (stg_encode (Memc[g_xy], g_mem, g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + + call ttyputs (g_out, g_tty, Memc[SG_ENDDRAW(g_sg)], 1) +end diff --git a/sys/gio/stdgraph/stgdrawch.x b/sys/gio/stdgraph/stgdrawch.x new file mode 100644 index 00000000..fd317d2b --- /dev/null +++ b/sys/gio/stdgraph/stgdrawch.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stdgraph.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top +define MAXPTS 40 # max points in a char drawing polyline + + +# STG_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure stg_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +pointer pl, tx +real px, py, coso, sino, theta +int stroke, tab1, tab2, i, pen, mx, my +int save_ltype, save_lwidth, save_color +int bitupk() +include "font.com" +include "stdgraph.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + if (SG_TXFONT(g_sg) != font) { + call stg_ctrl1 ("TF", font - GT_ROMAN + 1) + SG_TXFONT(g_sg) = font + } + + # Since we will be using the polyline generator, set the polyline + # linetype to solid and save the current linetype for later restoration. + + pl = SG_PLAP(g_sg) + tx = SG_TXAP(g_sg) + save_color = PL_COLOR(pl) + save_ltype = PL_LTYPE(pl) + save_lwidth = PL_WIDTH(pl) + PL_COLOR(pl) = TX_COLOR(tx) + PL_LTYPE(pl) = GL_SOLID + PL_WIDTH(pl) = 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + mx = x + px * coso + py * sino + my = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call sgch_move (mx, my) + else + call sgch_draw (mx, my) + } + + # Flush any remaining points. + call sgch_flush() + + # Restore polyline linetype and color. + PL_LTYPE(pl) = save_ltype + PL_WIDTH(pl) = save_lwidth + PL_COLOR(pl) = save_color +end + + +# SGCH_MOVE -- Start accumulating a new polyline. + +procedure sgch_move (mx, my) + +int mx, my +short pl[MAXPTS], op +common /sgchcm/ pl, op + +begin + call sgch_flush() + + pl[1] = mx + pl[2] = my + op = 3 +end + + +# SGCH_DRAW -- Add a point to the polyline. + +procedure sgch_draw (mx, my) + +int mx, my +short pl[MAXPTS], op +common /sgchcm/ pl, op + +begin + pl[op] = mx + pl[op+1] = my + op = min (MAXPTS, op + 2) +end + + +# SGCH_FLUSH -- Flush the polyline to the output device. + +procedure sgch_flush() + +int npts +short pl[MAXPTS], op +common /sgchcm/ pl, op + +begin + if (op > 2) { + npts = op / 2 + call stg_polyline (pl, npts) + } + op = 1 +end diff --git a/sys/gio/stdgraph/stgencode.x b/sys/gio/stdgraph/stgencode.x new file mode 100644 index 00000000..3c7a6ffb --- /dev/null +++ b/sys/gio/stdgraph/stgencode.x @@ -0,0 +1,539 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +.help stg_encode +.nf _________________________________________________________________________ +STG_ENCODE -- Table driven binary encoder/decoder. The encoder (which can +also decode) processes a format string, also referred to as a program, to +either encode an output string or decode an input string. Internally the +encoder operates in two modes, copy mode and execute mode. In copy mode +all format characters are copied to the output except the following special +characters: + + ' escape next character (literal) + % begin a formatted output string + ( switch to execute mode (stack driven, RPN interpreter) + +An ( appearing in the format string causes a mode switch to execute mode. +In execute mode characters are metacode instructions to be executed. An +unescaped ) causes reversion to copy mode. Parens may not be nested; an +( in execute mode is an instruction to push the binary value of ( on the +stack, and an ) in copy mode is copied to the output as a character. In +execute mode the following characters are recognized as special instructions. +All other characters are instructions too, telling the encoder to push the +ASCII value of the character on the stack. + + ' escape next character (recognized everywhere) + % formatted output + ) revert to copy mode + #nnn push signed decimal integer number nnn + $ switch case construct + . pop number from stack and place in output string + , get next character from input string and push on stack + & modulus (similar to AND of low bits) + + add (similar to OR) + - subtract (similar to AND) + * multiply (shift left if pwr of 2) + / divide (shift right if pwr of 2) + < less than (0=false, 1=true) + > greater than (0=false, 1=true) + = equals (0=false, 1=true) + ; branch if: ;. The ; is at offset zero. + 0-9 push register + !N pop stack into register N + !! pop N from stack and output an N millisecond delay + +The encoder communicates with the outside world via three general purpose +data structures. + + registers 0-9 (integer only) + memory char array + program char array + +The registers are used for parameter input and output as well as for storing +intermediate results. R 1-3 are used for input and output arguments. R 4-9 +and R0 (R10) are reserved for use by the program. R11 is the i/o pointer into +encoder memory, used for character input and output. R12 should contain the +maximum memory address upon input. Memory may be used for anything but is +normally used only for the input string or output string. The program is the +format string. + +Further documentation is given in the GIO reference manual. +.endhelp _____________________________________________________________________ + +define SZ_FORMAT 10 # max length printf format +define SZ_NUMSTR 10 # encoded numeric string + +define R1 registers[1] # argument +define R2 registers[2] # argument +define R3 registers[3] # argument +define R4 registers[4] # scratch +define R5 registers[5] # scratch +define R6 registers[6] # scratch +define R7 registers[7] # scratch +define R8 registers[8] # scratch +define R9 registers[9] # scratch +define R0 registers[10] # scratch +define IOP registers[11] # i/o pointer into encoder memory +define TOP registers[12] # max memory location + +# Inline macros. + +define memory_overflow_ 1 +define stack_underflow_ 2 +define stack_overflow_ 3 + +define input {$1=memory[iop];iop=iop+1} +define output {memory[iop]=($1);iop=iop+1;if(iop>top)goto memory_overflow_} +define push {stack[sp]=($1);sp=sp+1} +define pop {sp=sp-1;$1=stack[sp]} + + +# STG_ENCODE -- Interpret a program, encoding values passed in registers into +# memory, or decoding memory into registers. + +int procedure stg_encode (program, memory, registers) + +char program[ARB] # program to be executed +char memory[ARB] # data space +int registers[NREGISTERS] # general purpose registers + +int x, y, num, ch, status +int stack[LEN_STACK] +int sp, pc, iop, top, incase +common /sgecom/ pc, sp, iop, top, incase, stack +int sge_execute() +include "stdgraph.com" + +begin + # TEK format, %t. This format deserves special treatment due to the + # prevalence of tektronix compatible graphics terminals. + + if (program[1] == '%' && program[2] == 't') { + x = R1 + y = R2 + iop = IOP + 4 + if (iop > top) + goto memory_overflow_ + + memory[iop-4] = g_hixy[y+1] + memory[iop-3] = g_loy[y+1] + memory[iop-2] = g_hixy[x+1] + memory[iop-1] = g_lox[x+1] + + IOP = iop + if (program[3] == EOS) + return (OK) + } + + # Process a general format string (as well as any chars following the + # %t format). + + incase = NO + iop = IOP + top = TOP + pc = 1 + sp = 1 + + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + if (ch == '%' && program[pc] != EOS) { + if (program[pc] == 't') { + # Tek format again. + pc = pc + 1 + x = R1 + y = R2 + iop = iop + 4 + if (iop > top) + goto memory_overflow_ + + memory[iop-4] = g_hixy[y+1] + memory[iop-3] = g_loy[y+1] + memory[iop-2] = g_hixy[x+1] + memory[iop-1] = g_lox[x+1] + + } else { + # Extract a general format specification and use it to + # encode the number on top of the stack. + pop (num) + if (sp < 1) { + IOP = iop + return (stack_underflow_) + } else + call sge_printf (num, memory, iop, top, program, pc) + } + + } else if (ch == '(' && program[pc] != EOS) { + # Switch to execute mode. + status = sge_execute (program, memory, registers) + if (status != OK) + return (status) + + } else if (ch == '\'' && program[pc] != EOS) { + # Escape next character. + output (program[pc]) + pc = pc + 1 + + } else { + # Copy an ordinary character to the output string. + output (ch) + } + } + + IOP = iop + return (OK) + +memory_overflow_ + IOP = iop + return (memory_overflow_) +end + + +# SGE_EXECUTE -- Execute a metacode program stored in encoder memory starting +# at the location of the PC. The stack, program counter, i/o pointer, and +# registers are shared by the copy and execute mode procedures via common. + +int procedure sge_execute (program, memory, registers) + +char program[ARB] # program to be executed +char memory[ARB] # data space +int registers[NREGISTERS] # general purpose registers + +int num, ch, a, b, neg, x, y +int stack[LEN_STACK] +int sp, pc, iop, top, incase, msec, npad, baud, envgeti(), btoi() +common /sgecom/ pc, sp, iop, top, incase, stack +include "stdgraph.com" +errchk envgeti + +begin + # Execute successive single character instructions until either ) or + # EOS is seen. On a good host machine this case will be compiled as + # a vectored goto with a loop overhead of only a dozen or so machine + # instructions per loop. + + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + + switch (ch) { + case '\'': + # Escape next character (recognized everywhere). + ch = program[pc] + if (ch != EOS) { + # Push ASCII value of character. + push (ch) + pc = pc + 1 + } + + case '%': + if (program[pc] == 't') { + # Tek format again. + pc = pc + 1 + x = R1 + y = R2 + iop = iop + 4 + if (iop > top) + goto memory_overflow_ + + memory[iop-4] = g_hixy[y+1] + memory[iop-3] = g_loy[y+1] + memory[iop-2] = g_hixy[x+1] + memory[iop-1] = g_lox[x+1] + + } else { + # Formatted output. + if (program[pc] != EOS) { + pop (num) + call sge_printf (num, memory, iop, top, program, pc) + } else + output (ch) + } + + case ')': + # End interpreter mode. + return (OK) + + case '#': + # Push signed decimal integer number. + neg = NO + if (program[pc] == '-') { + neg = YES + pc = pc + 1 + } + + num = 0 + while (IS_DIGIT (program[pc])) { + num = num * 10 + TO_INTEG (program[pc]) + pc = pc + 1 + } + + if (neg == YES) + push (-num) + else + push (num) + + case '$': + # Switch case instruction. + + if (incase == NO) { + # Pop the switch off the stack. + pop (num) + + # Search for case number 'num'. + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + if (ch == '$') { + # End of switch statement. + pc = pc + 1 + incase = NO + break + + } else if (program[pc+1] == '-') { + # Range of cases. + a = TO_INTEG (ch) + b = TO_INTEG (program[pc+2]) + pc = pc + 3 + if (a <= num && num <= b) { + incase = YES + break + } + } else if (ch == 'D' || TO_INTEG(ch) == num) { + # Default or requested case. + pc = pc + 1 + incase = YES + break + + } + + # Advance to the next case. Leave pc pointing to the + # N of case $N. + + if (ch != '$' && incase == NO) { + while (program[pc] != EOS && program[pc] != '$') + pc = pc + 1 + if (program[pc] == '$') + pc = pc + 1 + } + } + + } else { + # $ encountered delimiting a case. Search forward for + # $$ or EOS. + + if (program[pc] != '$') + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + if (ch == '$' && program[pc] == '$') + break + } + + if (program[pc] == '$') + pc = pc + 1 + + incase = NO + } + + case '.': + # Pop number from stack and place in output string as a + # binary character. + pop (num) + output (num) + + case ',': + # Get next character from input string and push on stack. + input (num) + push (num) + + case '&': + # Modulus (similar to AND of low bits). + pop (b) + pop (a) + push (mod (a, b)) + + case '+': + # Add (similar to OR). + pop (b) + pop (a) + push (a + b) + + case '-': + # Subtract (similar to AND). + pop (b) + pop (a) + push (a - b) + + case '*': + # Multiply (shift left if pwr of 2). + pop (b) + pop (a) + push (a * b) + + case '/': + # Divide (shift right if pwr of 2). + pop (b) + pop (a) + push (a / b) + + case '<': + # Less than (0=false, 1=true). + pop (b) + pop (a) + push (btoi (a < b)) + + case '>': + # Greater than (0=false, 1=true). + pop (b) + pop (a) + push (btoi (a > b)) + + case '=': + # Equals (0=false, 1=true). + pop (b) + pop (a) + push (btoi (a == b)) + + case ';': + # If 2nd value on stack is true add 1st value on stack to PC. + # Example: "12<#-8;". The ; is at offset zero. + pop (a) + pop (b) + if (b != 0) + pc = pc - 1 + a + + case '0': + # Push contents of register 0 (10). + push (R0) + case '1': + # Push contents of register 1. + push (R1) + case '2': + # Push contents of register 2. + push (R2) + case '3': + # Push contents of register 3. + push (R3) + case '4': + # Push contents of register 4. + push (R4) + case '5': + # Push contents of register 5. + push (R5) + case '6': + # Push contents of register 6. + push (R6) + case '7': + # Push contents of register 7. + push (R7) + case '8': + # Push contents of register 8. + push (R8) + case '9': + # Push contents of register 9. + push (R9) + + case '!': + if (program[pc] == '!') { + # !!: Pop stack and generate delay. + pc = pc + 1 + pop (msec) + iferr (baud = envgeti ("ttybaud")) + baud = 9600 + npad = real(msec) * (real(baud) / 8. / 1000.) + while (npad > 0) { + output (PADCHAR) + npad = npad - 1 + } + } else { + # !N: Pop stack into register N. + num = TO_INTEG (program[pc]) + if (num >= 0 && num <= 9) { + if (num == 0) + num = 10 + pop (registers[num]) + pc = pc + 1 + } else + output (ch) + } + + default: + # Push ASCII value of character. + push (ch) + } + + if (sp <= 0) + return (stack_underflow_) + if (sp > LEN_STACK) + return (stack_overflow_) + } + + return (OK) + +memory_overflow_ + return (memory_overflow_) +end + + +# SGE_PRINTF -- Process a %.. format specification. The number to be encoded +# has already been popped from the stack into the first argument. The encoded +# number is returned in memory at IOP, leaving IOP positioned to the first +# char following the encoded number. The format used to encode the number is +# extracted from the program starting at PC. PC is left pointing to the first +# character following the format. + +procedure sge_printf (number, memory, iop, top, program, pc) + +int number # number to be encoded +char memory[top] # output buffer +int iop # index of first char to be written (in/out) +int top # size of output buffer +char program[ARB] # contains printf format string +int pc # index of first char of format string (in/out) + +char format[SZ_FORMAT] +char numstr[SZ_NUMSTR] +int op, ch, junk +int gstrcpy(), itoc() + +begin + # Extract format %w.dC, a string of digits, -, or ., delimited by a + # letter. The format %w.dr is followed by a single character which + # must also be included in the format string. + + format[1] = '%' + op = 2 + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + format[op] = ch + op = op + 1 + if (IS_LOWER(ch)) { + if (ch == 'r' && program[pc] != EOS) { + # Radix digit follows %r. + format[op] = program[pc] + op = op + 1 + pc = pc + 1 + } + break + } + } + format[op] = EOS + + # Encode the number using the extracted format string. The case of + # a simple decimal encoding is optimized. + + if (format[2] == 'd') + junk = itoc (number, numstr, SZ_NUMSTR) + else { + iferr { + call sprintf (numstr, SZ_NUMSTR, format) + call pargi (number) + } then + numstr[1] = EOS + } + + # Move the encoded number to encoder memory, advancing the i/o + # pointer and taking care not to overrun memory. Leave the iop + # pointing AT, not after, the EOS output by gstrcpy. + + iop = iop + gstrcpy (numstr, memory[iop], top - iop + 1) +end diff --git a/sys/gio/stdgraph/stgescape.x b/sys/gio/stdgraph/stgescape.x new file mode 100644 index 00000000..b52ffd0c --- /dev/null +++ b/sys/gio/stdgraph/stgescape.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STGESCAPE.X -- Stdgraph kernel escape handing code. This is the interface +# between the stdgraph kernel and any supported escape packages. These driver +# routines return TRUE if they recognize the escape and it is private to the +# package, FALSE if the other escape packages may also be interested in the +# routine. +# +# stg_escape standard GKI escape entry point +# +# sge_wstran transform and output escape +# sge_spoolesc process and escape into frame buffer +# +# To add support for a new package of escapes, and entry for the driver routine +# for each family of escapes must be added to each of these procedures. + + +# STG_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The stdgraph kernel does not have any escape functions at present. + +procedure stg_escape (fn, instruction, nwords) + +int fn #I function code +short instruction[ARB] #I instruction data words +int nwords #I length of instruction + +bool sgm_execute() # GIM (Gterm) imaging excapes + +begin + if (sgm_execute (fn, instruction, nwords)) + return +end + + +# SGE_WSTRAN -- Stdgraph escape handling routine called by an interactive +# client (e.g the CL in cursor mode) to apply the workstation transformation +# to a escape and execute the escape. This routine is called for all +# escapes regardless of whether any transformation is necessary, leaving +# it up to the escape code to decide what to do. + +procedure sge_wstran (fn, instruction, x1,y1, x2,y2) + +int fn #I escape sequence function opcode +short instruction[ARB] #I escape instruction data +real x1, y1 #I NDC coords of display rect +real x2, y2 #I NDC coords of display rect + +bool sgm_wstran() # GIM (Gterm) imaging excapes + +begin + if (sgm_wstran (fn, instruction, x1,y1, x2,y2)) + return +end + + +# SGE_WSENABLE -- Stdgraph escape handling routine called by an +# interactive client (e.g the CL in cursor mode) to test whether cursor mode +# scaling of graphics instructions is enabled when cursor mode zoom/pan is +# done. Cursor mode scaling may be disabled if the kernel or graphics device +# does the scaling itself. + +bool procedure sge_wsenable () + +bool enable +bool sgm_wsenable() + +begin + if (sgm_wsenable (enable)) + return (enable) +end + + +# SGE_SPOOLESC -- Stdgraph escape handling routine called by an interactive +# client (e.g the CL in cursor mode) to retain, delete, or edit an escape +# instruction stored in a frame buffer. Ordinary drawing instructions are +# normally retained. If the instruction should only be executed when issued +# it should be deleted. Sometimes an instruction is edited or replaced by +# a different one to be executed the next time the buffered graphics is drawn. +# Sometimes when an instruction is seen earlier instructions must be edited +# or deleted. This routine is called for all escapes, it is up to the escape +# code to decide what to do. The delete instruction callback is called as +# delete_fcn(tr,gki) to delete the instruction pointed to by GKI. + +procedure sge_spoolesc (tr, gki, fn, instruction, bp, buftop, delete_fcn) + +pointer tr #I arg to delete_fcn +pointer gki #I pointer to escape instruction +int fn #U escape sequence function opcode +short instruction[ARB] #U escape instruction data +pointer bp #I frame buffer pointer +pointer buftop #I top+1 of buffered data +int delete_fcn #I function called to delete an instruction + +bool sgm_spoolesc() # GIM (Gterm) imaging excapes + +begin + if (sgm_spoolesc (tr, gki, fn, instruction, bp, buftop, delete_fcn)) + return +end diff --git a/sys/gio/stdgraph/stgfa.x b/sys/gio/stdgraph/stgfa.x new file mode 100644 index 00000000..10cf4d61 --- /dev/null +++ b/sys/gio/stdgraph/stgfa.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_FILLAREA -- Fill a closed area. The area is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs outlining the +# area to be filled. + +procedure stg_fillarea (p, npts) + +short p[ARB] #I points defining area outline +int npts #I number of points, i.e., (x,y) pairs + +pointer fa +bool tek_encoding +int lowres_x, lowres_y +int ip, n, sx, sy, len_p, iop, i +int stg_encode() +include "stdgraph.com" + +begin + if (g_enable == NO) + call stg_genab() + + len_p = npts * 2 + + # Update fillarea attributes if necessary. + + fa = SG_FAAP(g_sg) + if (SG_COLOR(g_sg) != FA_COLOR(fa)) { + call stg_ctrl1 ("FC", FA_COLOR(fa)) + SG_COLOR(g_sg) = FA_COLOR(fa) + } + if (SG_FASTYLE(g_sg) != FA_STYLE(fa)) { + call stg_ctrl1 ("FT", FA_STYLE(fa)) + SG_FASTYLE(g_sg) = FA_STYLE(fa) + } + + # Tektronix encoding is treated as a special case for max efficiency. + tek_encoding = + (Memc[g_xy] == '%' && Memc[g_xy+1] == 't' && Memc[g_xy+2] == EOS) + + # Draw the fillarea. If the startfill sequence is defined we assume + # that the device can draw a multipoint fillarea. + + if (Memc[SG_STARTFILL(g_sg)] != EOS) { + for (ip=1; ip <= len_p; ip=ip+2) { + # Output start fillarea sequence. + call ttyputs (g_out, g_tty, Memc[SG_STARTFILL(g_sg)], 1) + n = len_p + + # Encode the points of the fillarea outline (or move to the + # single point to be drawn). + + g_lastx = -1 # clip unresolved points only in the interior + g_lasty = -1 # of the area being drawn. + + g_reg[E_IOP] = 1 + do i = ip, n, 2 { + sx = p[i] + sy = p[i+1] + + # Discard the point if it is not resolved. + lowres_x = sx / g_dxres + lowres_y = sy / g_dyres + if (lowres_x == g_lastx && lowres_y == g_lasty) + next + + g_lastx = lowres_x + g_lasty = lowres_y + + # Transform point into the device window. + sx = int (sx * g_dx) + g_x1 + sy = int (sy * g_dy) + g_y1 + + # Encode the point, appending encoded bytes to g_mem. + # Tek encoding is treated as a special case since it is + # so common; the encoder is used for non-Tek encodings. + + if (tek_encoding) { + iop = g_reg[E_IOP] + 4 + g_mem[iop-4] = g_hixy[sy+1] + g_mem[iop-3] = g_loy[sy+1] + g_mem[iop-2] = g_hixy[sx+1] + g_mem[iop-1] = g_lox[sx+1] + g_reg[E_IOP] = iop + } else { + g_reg[1] = sx + g_reg[2] = sy + if (stg_encode (Memc[g_xy], g_mem, g_reg) != OK) + break + } + + # Flush buffer if nearly full. + if (g_reg[E_IOP] > FLUSH_MEMORY) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + } + ip = n + + # Flush any output remaining in encoder memory. + if (g_reg[E_IOP] > 1) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + + # Output end polymarker sequence, or draw the point. + call ttyputs (g_out, g_tty, Memc[SG_ENDFILL(g_sg)], 1) + } + } else { + # If can't do a fill area, just draw the area outline. + call stg_polyline (p, npts) + } +end diff --git a/sys/gio/stdgraph/stgfaset.x b/sys/gio/stdgraph/stgfaset.x new file mode 100644 index 00000000..d5b4c4e7 --- /dev/null +++ b/sys/gio/stdgraph/stgfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_FASET -- Set the fillarea attributes. + +procedure stg_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "stdgraph.com" + +begin + fa = SG_FAAP(g_sg) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/stdgraph/stgfilter.x b/sys/gio/stdgraph/stgfilter.x new file mode 100644 index 00000000..674f190f --- /dev/null +++ b/sys/gio/stdgraph/stgfilter.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stdgraph.h" + +define MAXCH 16 +define RESET "reset" + + +# SGF_POST_FILTER -- Post the stdgraph tty input filter to the VOS tty driver. +# This input filter is used to intercept and process escape sequences sent by +# the terminal to the IRAF client, to notify the client of events such as a +# terminal reset. + +procedure sgf_post_filter (fd) + +int fd #I terminal file + +int locpr() +extern sgf_ttyfilter() + +begin + # Install stdgraph filter in terminal driver. + call ttseti (fd, TT_FILTER, locpr(sgf_ttyfilter)) + call ttseti (fd, TT_FILTERKEY, ESC) + + # Register escapes with terminal. + call stg_outstr ("EZ", RESET) + call stg_outstr ("ER", "R") +end + + +# SGF_TTYFILTER -- Terminal input filter. + +procedure sgf_ttyfilter (fd, buf, maxch, status) + +int fd #I input file +char buf[ARB] #U input buffer +int maxch #I max chars in buffer +int status #U number of chars in buffer + +char escape[MAXCH] +char svbuf[MAXCH+4] +int ip, op, sp, ch, iomode + +bool streq() +int sgf_getchar(), fstati() +include "stdgraph.com" +define failed_ 91 + +begin + # Disable the filter if reading from the terminal in nonblocking + # raw mode. We shouldn't receive a stdgraph escape at such a time, + # and this code isn't prepared to deal with nonblocking i/o. This + # case occurs, e.g., during a screen size query, where the terminal + # returns an escape sequence to the client (in nonblocking raw mode). + + iomode = fstati (STDIN, F_IOMODE) + if (and (iomode, IO_NDELAY) != 0) + return + + # The escape sequence is of the form "ESC P ESC \", the ANSI + # device control string (DCS). This escape sequence is recognized by + # the vt100 terminal emulator in xgterm, which will accumulate and + # ignore the sequence. This is important because when a terminal + # (xgterm) reset occurs when IRAF is not reading from the terminal in + # raw mode, the character are echoed to the terminal and would be + # printed on the screen if not recognized by the terminal as an + # escape. By using a known escape which xgterm ignores the escape is + # transmitted without being seen by (and probably confusing) the + # user. If the reset occurs while in graphics mode and a cursor read + # is in progress, the terminal will be in raw mode and the sequence + # will not be echoed, hence the problem does not occur. + + ip = 1 + sp = 1 + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + if (ch != ESC) + goto failed_ + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + if (ch != 'P') + goto failed_ + + # Accumulate escape data string. + op = 1 + repeat { + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + if (ch < 0 || op > MAXCH) + goto failed_ + if (ch == ESC) { + escape[op] = EOS + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + break + } else { + escape[op] = ch + op = op + 1 + } + } + + # Process the escape. + if (streq (escape, RESET)) { + call stg_reset() + call ttseti (fd, TT_FILTER, NULL) + if (g_sg != NULL) + SG_UIFDATE(g_sg) = 0 + } else # add additional escapes here + goto failed_ + + # Edit the input buffer to remove the escape. + op = 1 + for ( ; ip <= status && op <= maxch; ip=ip+1) { + buf[op] = buf[ip] + op = op + 1 + } + status = op - 1 + return + +failed_ + # Unrecognized escape. Append any newly read data to the input + # buffer and return all the data. + + if (sp > 1) { + call amovc (svbuf, buf[status+1], sp - 1) + status = status + sp - 1 + } +end + + +# SGF_GETCHAR -- Get a character from the input terminal. ERR or EOF is +# returned if the input is exhausted. If reading in raw mode additional +# reads will be performed as necessary. + +int procedure sgf_getchar (fd, svbuf, sp, buf, ip, maxch, nchars) + +int fd #I input file +char svbuf[ARB] #O save chars as they are read +int sp #U pointer into save buffer +char buf[ARB] #U input buffer +int ip #I input index +int maxch #I max chars in buffer +int nchars #U number of chars in buffer + +int ch +int status + +begin + if (ip > nchars) { + if (maxch == 1) { + call zgetty (fd, svbuf[sp], maxch, status) + if (status <= 0) + return (ERR) + ch = svbuf[sp] + sp = sp + 1 + return (ch) + } else + return (EOF) + } + + ch = buf[ip] + ip = ip + 1 + + return (ch) +end diff --git a/sys/gio/stdgraph/stgflush.x b/sys/gio/stdgraph/stgflush.x new file mode 100644 index 00000000..aada3927 --- /dev/null +++ b/sys/gio/stdgraph/stgflush.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_FLUSH -- Flush output. + +procedure stg_flush (dummy) + +int dummy # not used at present +include "stdgraph.com" + +begin + call flush (g_out) +end diff --git a/sys/gio/stdgraph/stggcell.x b/sys/gio/stdgraph/stggcell.x new file mode 100644 index 00000000..2a9aea8c --- /dev/null +++ b/sys/gio/stdgraph/stggcell.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STG_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure stg_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. Won't do much for a graphics terminal, + # but should be functionional. +end diff --git a/sys/gio/stdgraph/stggcur.x b/sys/gio/stdgraph/stggcur.x new file mode 100644 index 00000000..08f2b8b7 --- /dev/null +++ b/sys/gio/stdgraph/stggcur.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GETCURSOR -- Get the position of a cursor. The cursor value is returned +# as a GKI structure on the graphics metacode stream. + +procedure stg_getcursor (cursor) + +int cursor #I cursor to be read or 0 + +int cur, cn +int key, sx, sy, raster, rx, ry +include "stdgraph.com" + +begin + # If cursor=0 read the last cursor referenced, e.g., in a write. + if (cursor > 0) { + SG_CURSOR(g_sg) = cursor + cur = cursor + } else + cur = max (1, SG_CURSOR(g_sg)) + + # Restore graphics mode in case the user has forgotten the \n while + # writing to the status line. + + if (g_enable == NO) + call stg_genab() + + # If the user has locked the logical cursor override runtime selection. + if (g_cursor > 0) + cur = g_cursor + + # Restore the software cursor position before reading? + if (SG_UPDCURSOR(g_sg) == YES) { + sx = SG_CURSOR_X(g_sg) + sy = SG_CURSOR_Y(g_sg) + if (sx != 0 && sy != 0) + call stg_setcursor (sx, sy, cur) + } + + # Physically read the cursor and return value to caller. + call stg_readcursor (cur, cn, key, sx, sy, raster, rx, ry) + call gki_retcursorvalue (g_stream, cn, key, sx, sy, raster, rx, ry) + call flush (g_stream) + + # Save the new position of the cursor for next time. + if (SG_UPDCURSOR(g_sg) == YES) { + SG_CURSOR_X(g_sg) = sx + SG_CURSOR_Y(g_sg) = sy + } +end diff --git a/sys/gio/stdgraph/stggdisab.x b/sys/gio/stdgraph/stggdisab.x new file mode 100644 index 00000000..42ddec62 --- /dev/null +++ b/sys/gio/stdgraph/stggdisab.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GDISAB -- Disable graphics, i.e., issue the GD control sequence. + +procedure stg_gdisab() + +include "stdgraph.com" + +begin + if (g_active == YES && g_out > 0) { + call stgctrl ("GD") + call flush (g_out) + g_enable = NO + } +end diff --git a/sys/gio/stdgraph/stggenab.x b/sys/gio/stdgraph/stggenab.x new file mode 100644 index 00000000..5e350e33 --- /dev/null +++ b/sys/gio/stdgraph/stggenab.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GENAB -- Enable graphics, i.e., issue the GE control sequence. + +procedure stg_genab() + +include "stdgraph.com" + +begin + if (g_active == YES && g_out > 0) { + call stgctrl ("GE") + call flush (g_out) + g_enable = YES + } +end diff --git a/sys/gio/stdgraph/stggim.x b/sys/gio/stdgraph/stggim.x new file mode 100644 index 00000000..a71cd448 --- /dev/null +++ b/sys/gio/stdgraph/stggim.x @@ -0,0 +1,919 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "stdgraph.h" + +# STGGIM.X -- GIO.GIM gterm imaging escapes for the stdgraph kernel. The +# routines in this file decode GKI escape instructions and encode serial +# byte sequences which are sent to the server to execute the instruction. +# In some cases the server returns a response which is decoded here and +# encoded as a GKI return value which is returned to the client. + +define SZ_PATBUF 512 +define MAX_ARGS 32 +define TIMEOUT 10000 + + +# SGM_EXECUTE -- Test whether the given instruction is a GIM escape, and +# if so execute it. Return true if the instruction was recognized and +# executed. + +bool procedure sgm_execute (fn, gim, nwords) + +int fn #I function code +short gim[ARB] #I instruction data words +int nwords #I length of gim + +int raster +common /sgmcom/ raster + +begin + switch (fn) { + case GKI_OPENWS, GKI_CLEAR: + call sgm_output ("RI", gim, GIM_RASTERINIT_LEN) + return (false) + + case GIM_RASTERINIT: + call sgm_output ("RI", gim, GIM_RASTERINIT_LEN) + case GIM_CREATERASTER: + call sgm_output ("CR", gim, GIM_CREATERASTER_LEN) + case GIM_DESTROYRASTER: + call sgm_output ("DR", gim, GIM_DESTROYRASTER_LEN) + case GIM_QUERYRASTER: + call sgm_queryraster (gim) + case GIM_SETRASTER: + raster = gim[GIM_SETRASTER_RN] + call sgm_output ("SR", gim, GIM_SETRASTER_LEN) + case GIM_WRITEPIXELS: + call sgm_writepixels (gim) + case GIM_READPIXELS: + call sgm_readpixels (gim) + case GIM_REFRESHPIXELS: + call sgm_output ("RX", gim, GIM_REFRESHPIXELS_LEN) + case GIM_SETPIXELS: + call sgm_output ("SP", gim, GIM_SETPIXELS_LEN) + case GIM_WRITECMAP: + call sgm_writecmap (gim) + case GIM_READCMAP: + call sgm_readcmap (gim) + case GIM_LOADCMAP: + call sgm_output ("LM", gim, GIM_LOADCMAP_LEN) + case GIM_FREECMAP: + call sgm_output ("FL", gim, GIM_FREECMAP_LEN) + case GIM_WRITEIOMAP: + call sgm_iomapwrite (gim) + case GIM_READIOMAP: + call sgm_iomapread (gim) + case GIM_INITMAPPINGS: + call sgm_output ("IM", gim, GIM_INITMAPPINGS_LEN) + case GIM_FREEMAPPING: + call sgm_output ("FM", gim, GIM_FREEMAPPING_LEN) + case GIM_COPYRASTER: + call sgm_output ("CP", gim, GIM_COPYRASTER_LEN) + case GIM_SETMAPPING: + call sgm_output ("SM", gim, GIM_SETMAPPING_LEN) + case GIM_GETMAPPING: + call sgm_getmapping (gim) + case GIM_ENABLEMAPPING: + call sgm_output ("MN", gim, GIM_ENABLEMAPPING_LEN) + case GIM_DISABLEMAPPING: + call sgm_output ("MD", gim, GIM_DISABLEMAPPING_LEN) + case GIM_REFRESHMAPPING: + call sgm_output ("RF", gim, GIM_REFRESHMAPPING_LEN) + + default: + return (false) + } + + return (true) +end + + +# SGM_WSTRAN -- Transform and output a GIM escape. Ignore escapes we +# know nothing about. TRUE is returned if the escape is one which is private +# to the GIM interface. + +bool procedure sgm_wstran (fn, gim, rx1,ry1, rx2,ry2) + +int fn #I escape sequence function opcode +short gim[ARB] #I escape instruction data +real rx1,ry1 #I NDC coords of display rect +real rx2,ry2 #I NDC coords of display rect + +real scale +pointer sp, n_gim +bool status, xflip, yflip +int width, height, dst, src, dt +int wx1, wy1, wx2, wy2, p1, p2 +int sx1, sy1, sx2, sy2, snx, sny +int dx1, dy1, dx2, dy2, dnx, dny +int n_dx1, n_dy1, n_dx2, n_dy2, n_dnx, n_dny +int n_sx1, n_sy1, n_sx2, n_sy2 +int w_dx1, w_dy1, w_dx2, w_dy2 +bool sgm_execute() +define exe_ 91 + +begin + switch (fn) { + case GIM_RASTERINIT, GIM_INITMAPPINGS, + GIM_CREATERASTER, GIM_DESTROYRASTER, GIM_QUERYRASTER, + GIM_GETMAPPING, GIM_ENABLEMAPPING, GIM_DISABLEMAPPING, + GIM_REFRESHMAPPING, GIM_FREEMAPPING, + GIM_READPIXELS, GIM_WRITEPIXELS, GIM_REFRESHPIXELS, GIM_SETPIXELS, + GIM_WRITECMAP, GIM_READCMAP, GIM_LOADCMAP, GIM_FREECMAP, + GIM_WRITEIOMAP, GIM_READIOMAP, + GIM_COPYRASTER, GIM_SETRASTER: + + # These instructions do not require any transformation. + status = sgm_execute (fn, gim, 0) + + case GIM_SETMAPPING: + # Edit setmapping instructions which write to the display window. + # Raster 0 is the display window; only display window coordinates + # are affected by the workstation transformation. + + src = gim[GIM_SETMAPPING_SR] + dst = gim[GIM_SETMAPPING_DR] + dt = gim[GIM_SETMAPPING_DT] + + if (dst == 0 && src != dst) { + call smark (sp) + call salloc (n_gim, GIM_SETMAPPING_LEN, TY_SHORT) + + xflip = false + yflip = false + + # Convert the display rect NDC coordinates to window pixels + # or GKI units, depending upon which coordinate system is + # in use. Note that for NDC the Y axis is flipped relative + # to display window pixel coordinates. + + if (dt == CT_PIXEL) { + call sgm_winsize (width, height) + wx1 = rx1 * (width - 1); wy1 = (1.0 - ry2) * (height - 1) + wx2 = rx2 * (width - 1); wy2 = (1.0 - ry1) * (height - 1) + } else { + width = GKI_MAXNDC + 1; height = GKI_MAXNDC + 1 + wx1 = rx1 * (width - 1); wy1 = ry1 * (height - 1) + wx2 = rx2 * (width - 1); wy2 = ry2 * (height - 1) + } + + sx1 = gim[GIM_SETMAPPING_SX] + snx = gim[GIM_SETMAPPING_SW] + sy1 = gim[GIM_SETMAPPING_SY] + sny = gim[GIM_SETMAPPING_SH] + sx2 = sx1 + snx - 1; sy2 = sy1 + sny - 1 + + dx1 = gim[GIM_SETMAPPING_DX] + dnx = gim[GIM_SETMAPPING_DW] + if (dnx < 0) { + dnx = -dnx + xflip = !xflip + } + dy1 = gim[GIM_SETMAPPING_DY] + dny = gim[GIM_SETMAPPING_DH] + if (dny < 0) { + dny = -dny + yflip = !yflip + } + dx2 = dx1 + dnx - 1; dy2 = dy1 + dny - 1 + + # Compute the intersection of the destination (screen) rect + # of the mapping with the region of the screen WS mapped by + # the workstation transformation. + + n_dx1 = max (wx1, dx1); n_dy1 = max (wy1, dy1) + n_dx2 = min (wx2, dx2); n_dy2 = min (wy2, dy2) + + # If the rectangles do not intersect set up a null mapping + # to temporarily disable the mapping. + + n_dnx = n_dx2 - n_dx1 + 1; n_dny = n_dy2 - n_dy1 + 1 + if (n_dnx <= 0 || n_dny <= 0) { + call amovs (gim, Mems[n_gim], GIM_SETMAPPING_LEN) + Mems[n_gim+GIM_SETMAPPING_SX-1] = 0 + Mems[n_gim+GIM_SETMAPPING_SW-1] = 0 + Mems[n_gim+GIM_SETMAPPING_SY-1] = 0 + Mems[n_gim+GIM_SETMAPPING_SH-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DX-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DW-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DY-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DH-1] = 0 + goto exe_ + } + + # Compute the source rect which maps to the new (intersection) + # destination rect. + + if (snx == 1 || dnx == 1) { + n_sx1 = sx1 + n_sx2 = sx2 + } else { + scale = real(snx - 1) / real(dnx - 1) + n_sx1 = max(0, min(GKI_MAXNDC, + nint((n_dx1 - dx1) * scale + sx1))) + n_sx2 = max(0, min(GKI_MAXNDC, + nint((n_dx2 - dx2) * scale + sx2))) + if (xflip) { + p1 = sx1 + (sx2 - n_sx2) + p2 = sx2 - (n_sx1 - sx1) + n_sx1 = p1; n_sx2 = p2 + } + } + + if (sny == 1 || dny == 1) { + n_sy1 = sy1 + n_sy2 = sy2 + } else { + scale = real(sny - 1) / real(dny - 1) + n_sy1 = max(0, min(GKI_MAXNDC, + nint((n_dy1 - dy1) * scale + sy1))) + n_sy2 = max(0, min(GKI_MAXNDC, + nint((n_dy2 - dy2) * scale + sy2))) + if (yflip) { + p1 = sy1 + (sy2 - n_sy2) + p2 = sy2 - (n_sy1 - sy1) + n_sy1 = p1; n_sy2 = p2 + } + } + + # Scale the destination rect by the amount needed to make the + # WS rect fill the full display window. + + if (wx1 == wx2) { + w_dx1 = 0 + w_dx1 = width - 1 + } else { + scale = real(width - 1) / real(wx2 - wx1) + w_dx1 = max(0, min(GKI_MAXNDC, + nint((n_dx1 - wx1) * scale))) + w_dx2 = max(0, min(GKI_MAXNDC, + nint((n_dx2 - wx1) * scale))) + } + + if (wy1 == wy2) { + w_dy1 = 0 + w_dy1 = height - 1 + } else { + scale = real(height - 1) / real(wy2 - wy1) + w_dy1 = max(0, min(GKI_MAXNDC, + nint((n_dy1 - wy1) * scale))) + w_dy2 = max(0, min(GKI_MAXNDC, + nint((n_dy2 - wy1) * scale))) + } + + # Construct the edited instruction. + call amovs (gim, Mems[n_gim], GIM_SETMAPPING_LEN) + Mems[n_gim+GIM_SETMAPPING_SX-1] = n_sx1 + Mems[n_gim+GIM_SETMAPPING_SW-1] = n_sx2 - n_sx1 + 1 + Mems[n_gim+GIM_SETMAPPING_SY-1] = n_sy1 + Mems[n_gim+GIM_SETMAPPING_SH-1] = n_sy2 - n_sy1 + 1 + Mems[n_gim+GIM_SETMAPPING_DX-1] = w_dx1 + Mems[n_gim+GIM_SETMAPPING_DY-1] = w_dy1 + + n_dnx = max(0, min(GKI_MAXNDC, w_dx2 - w_dx1 + 1)) + if (gim[GIM_SETMAPPING_DW] < 0) + n_dnx = -n_dnx + Mems[n_gim+GIM_SETMAPPING_DW-1] = n_dnx + + n_dny = max(0, min(GKI_MAXNDC, w_dy2 - w_dy1 + 1)) + if (gim[GIM_SETMAPPING_DH] < 0) + n_dny = -n_dny + Mems[n_gim+GIM_SETMAPPING_DH-1] = n_dny + +exe_ + # Execute the edited instruction. + status = sgm_execute (fn, Mems[n_gim], 0) + call sfree (sp) + + } else + status = sgm_execute (fn, gim, 0) + + default: + status = false + } + + return (status) +end + + +# SGM_WSENABLE -- Test if client scaling of graphics drawing instructions is +# enabled. For the stdgraph kernel, these transformations are disabled if +# the raster is other than zero, in which case the graphics server does the +# scaling. + +bool procedure sgm_wsenable (enable) + +bool enable +int raster +common /sgmcom/ raster + +begin + enable = (raster == 0) + return (true) +end + + +# SGM_SPOOLESC -- Process a GIM escape into a frame buffer. All GIM escapes +# are executed when first issued; we just determine whether the escapes are +# preserved in the frame buffer to be executed when the frame is redrawn. +# Ignore escapes we know nothing about. TRUE is returned if the escape is +# one which is private to the GIM interface, i.e., if the escape has been +# processed fully by sgm_spoolesc. + +bool procedure sgm_spoolesc (tr, gki, fn, gim, bp, buftop, delete_fcn) + +pointer tr #I arg to delete_fcn +pointer gki #I pointer to escape instruction +int fn #U escape sequence function opcode +short gim[ARB] #U escape instruction data +pointer bp #I frame buffer pointer +pointer buftop #I top+1 of buffered data +int delete_fcn #I function called to delete an instruction + +pointer ip, itop, esc +int nleft, length, opcode, escape, mp + +begin + switch (fn) { + case GIM_RASTERINIT, GIM_INITMAPPINGS, GIM_FREEMAPPING, + GIM_CREATERASTER, GIM_DESTROYRASTER, GIM_QUERYRASTER, + GIM_GETMAPPING, GIM_ENABLEMAPPING, GIM_DISABLEMAPPING, + GIM_REFRESHMAPPING, GIM_WRITEPIXELS, GIM_READPIXELS, + GIM_REFRESHPIXELS, GIM_SETPIXELS, GIM_COPYRASTER, + GIM_WRITEIOMAP, GIM_READIOMAP, GIM_WRITECMAP, GIM_READCMAP, + GIM_LOADCMAP, GIM_FREECMAP: + + # These escapes are only executed once. + call zcall2 (delete_fcn, tr, gki) + + case GIM_SETRASTER: + ; # Preserve this instruction. + + case GIM_SETMAPPING: + # This escape is saved in the frame buffer and rexecuted when + # the frame is redrawn. This allows the server to buffer the + # image data, but still allows the graphics to be redrawn and + # possibly rescaled in cursor mode. Rexecution of copyraster + # after a screen clear will cause any rasters created and written + # to with createraster/writepixels to be redrawn on the screen. + + ip = bp + itop = gki + + while (ip < itop) { + # Search for the beginning of the next instruction. + while (Mems[ip] != BOI && ip < itop) + ip = ip + 1 + + nleft = itop - ip + if (nleft < 3) + break + else { + length = Mems[ip+GKI_HDR_LENGTH-1] + if (length > nleft) + break + + opcode = Mems[ip+GKI_HDR_OPCODE-1] + escape = Mems[ip+GKI_ESCAPE_FN-1] + + # Disable instruction if same mapping number. + if (opcode == GKI_ESCAPE && escape == GIM_SETMAPPING) { + esc = ip + GKI_ESCAPE_DC - 1 + mp = Mems[esc+GIM_SETMAPPING_MP-1] + if (mp == gim[GIM_SETMAPPING_MP]) + Mems[ip+GKI_HDR_OPCODE-1] = GKI_UNKNOWN + } + + ip = ip + length + } + } + + default: + return (false) + } + + return (true) +end + + +# SGM_WINSIZE -- Get the graphics window size in display pixels. + +procedure sgm_winsize (width, height) + +int width, height #O window size + +short gim_query[GIM_QUERYRASTER_LEN] +short retval[GIM_RET_QRAS_LEN] + +begin + gim_query[GIM_QUERYRASTER_RN] = 0 + call sgm_query ("QR", gim_query, GIM_QUERYRASTER_LEN, + "Qr", retval, GIM_RET_QRAS_LEN) + width = retval[GIM_RET_QRAS_NX] + height = retval[GIM_RET_QRAS_NY] +end + + +# SGM Private Functions. +# --------------------------- + +# SGM_QUERYRASTER -- Return the attributes of a raster. + +procedure sgm_queryraster (gim) + +short gim[ARB] #I encoded instruction +short retval[GIM_RET_QRAS_LEN] +include "stdgraph.com" + +begin + call sgm_query ("QR", gim, GIM_QUERYRASTER_LEN, + "Qr", retval, GIM_RET_QRAS_LEN) + call write (g_stream, retval, GIM_RET_QRAS_LEN * SZ_SHORT) + call flush (g_stream) +end + + +# SGM_WRITEPIXELS -- Write a block of pixels to a raster. + +procedure sgm_writepixels (gim) + +short gim[ARB] #I encoded instruction + +char bias +pointer sp, bp +int nx, ny, npix, i +include "stdgraph.com" + +begin + # Send the write-pixels escape sequence. + call sgm_output ("WP", gim, GIM_WRITEPIXELS_LEN) + + # For the moment this code assumes 8 bit pixels. + nx = gim[GIM_WRITEPIXELS_NX] + ny = gim[GIM_WRITEPIXELS_NY] + npix = nx * ny + + call smark (sp) + call salloc (bp, npix, TY_CHAR) + bias = 040B + + # Send the pixel data encoded in printable ASCII. + call achtbc (gim[GIM_WRITEPIXELS_DATA], Memc[bp], npix) + do i = 1, npix + Memc[bp+i-1] = Memc[bp+i-1] + bias + call write (g_out, Memc[bp], npix) + call putci (g_out, GS) + + call sfree (sp) +end + + +# SGM_READPIXELS -- Read a block of pixels from a raster and return it +# to the client. + +procedure sgm_readpixels (gim) + +short gim[ARB] #I encoded instruction + +pointer sp, bp +int sv_iomode, ch +int npix, nx, ny, i +short retval[GIM_RET_RPIX_LEN] +int fstati(), getci() +include "stdgraph.com" + +begin + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Send the read-pixels escape sequence. + call sgm_output ("RP", gim, GIM_READPIXELS_LEN) + call flush (g_out) + + # For the moment this code assumes 8 bit pixels. + nx = gim[GIM_READPIXELS_NX] + ny = gim[GIM_READPIXELS_NY] + npix = nx * ny + + call smark (sp) + call salloc (bp, npix, TY_CHAR) + + # Get the pixel data. This is a block of pixel data encoded as for + # writepixels (040 bias), bracked by ESC at the front and a single + # control character such as \r or \n at the end. + + while (getci (g_in, ch) != EOF) + if (ch == ESC) + break + for (i=0; getci (g_in, ch) >= 040B; ) + if (i < npix) { + Memc[bp+i] = ch - 040B + i = i + 1 + } + npix = i + + # Send the RPIX header to the client. + retval[GIM_RET_RPIX_NP] = npix + call write (g_stream, retval, GIM_RET_RPIX_LEN * SZ_SHORT) + + # Return the data to the client. + call achtcb (Memc[bp], Memc[bp], npix) + call write (g_stream, Memc[bp], (npix + SZB_CHAR-1) / SZB_CHAR) + call flush (g_stream) + + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end + + +# SGM_WRITECMAP -- Write to a segment of the colormap. + +procedure sgm_writecmap (gim) + +short gim[ARB] #I encoded instruction + +short mask +pointer sp, bp, op +int ncells, nchars, ip, i +include "stdgraph.com" + +begin + call smark (sp) + + # Send the write-colormap escape sequence. + call sgm_output ("WM", gim, GIM_WRITECMAP_LEN) + + # Each cell consists of a RGB triplet encoded 2 chars per color. + ncells = gim[GIM_WRITECMAP_NC] + nchars = ncells * 3 * 2 + + call salloc (bp, nchars, TY_CHAR) + ip = GIM_WRITECMAP_DATA + op = bp + + mask = 017B + do i = 1, ncells*3 { + Memc[op] = gim[ip] / 16 + 040B; op = op + 1 + Memc[op] = and (gim[ip], mask) + 040B; op = op + 1 + ip = ip + 1 + } + + call write (g_out, Memc[bp], nchars) + call putci (g_out, GS) + + call sfree (sp) +end + + +# SGM_READCMAP -- Read a segment of the colormap. + +procedure sgm_readcmap (gim) + +short gim[ARB] #I encoded instruction + +pointer sp, bp, cm, ip +int sv_iomode, ncells, nchars, ch, i +short retval[GIM_RET_RCMAP_LEN] +int fstati(), getci() +include "stdgraph.com" + +begin + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Send the read-cmap escape sequence. + call sgm_output ("RM", gim, GIM_READCMAP_LEN) + call flush (g_out) + + # Each cell consists of a RGB triplet encoded 2 chars per color. + ncells = gim[GIM_READCMAP_NC] + nchars = ncells * 3 * 2 + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + call salloc (cm, ncells * 3, TY_SHORT) + + # Get the colormap data. This is a block of RGB colormap triplets + # encoded 2 bytes per color, bracked by a ESC at the front and a + # single control character such as \r or \n at the end. + + while (getci (g_in, ch) != EOF) + if (ch == ESC) + break + for (i=0; getci (g_in, ch) >= 040B; ) + if (i < nchars) { + Memc[bp+i] = ch - 040B + i = i + 1 + } + ncells = i / (3 * 2) + + # Decode the packed colormap data. + ip = bp + do i = 1, ncells * 3 { + Mems[cm+i-1] = (Memc[ip] - 040B) * 16 + (Memc[ip+1] - 040B) + ip = ip + 2 + } + + # Send the read-cmap header to the client. + retval[GIM_RET_RCMAP_NC] = ncells + call write (g_stream, retval, GIM_RET_RCMAP_LEN * SZ_SHORT) + + # Return the colormap data to the client. + call write (g_stream, Mems[cm], (ncells * 3) * SZ_SHORT) + call flush (g_stream) + + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end + + +# SGM_IOMAPWRITE -- Write to the iomap. + +procedure sgm_iomapwrite (gim) + +short gim[ARB] #I encoded instruction + +short mask +pointer sp, bp, op +int ncells, nchars, ip, i +include "stdgraph.com" + +begin + call smark (sp) + + # Send the write-iomap escape sequence. + call sgm_output ("WO", gim, GIM_WRITEIOMAP_LEN) + + # Each cell consists of a single short integer colormap index + # encoded 2 chars per cell. + + ncells = gim[GIM_WRITEIOMAP_NC] + nchars = ncells * 2 + + call salloc (bp, nchars, TY_CHAR) + ip = GIM_WRITEIOMAP_DATA + op = bp + + mask = 017B + do i = 1, ncells { + Memc[op] = gim[ip] / 16 + 040B; op = op + 1 + Memc[op] = and (gim[ip], mask) + 040B; op = op + 1 + ip = ip + 1 + } + + call write (g_out, Memc[bp], nchars) + call putci (g_out, GS) + + call sfree (sp) +end + + +# SGM_IOMAPREAD -- Read a segment of the iomap. + +procedure sgm_iomapread (gim) + +short gim[ARB] #I encoded instruction + +pointer sp, bp, data, ip +int sv_iomode, ncells, nchars, ch, i +short retval[GIM_RET_RIOMAP_LEN] +int fstati(), getci() +include "stdgraph.com" + +begin + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Send the read-iomap escape sequence. + call sgm_output ("RO", gim, GIM_READIOMAP_LEN) + call flush (g_out) + + # The data is encoded two bytes per short integer value. + ncells = gim[GIM_READIOMAP_NC] + nchars = ncells * 2 + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + call salloc (data, ncells, TY_SHORT) + + # Get the iomap data. This is a block of iomap values encoded + # 2 bytes per value, bracked by a ESC at the front and a single + # control character such as \r or \n at the end. + + while (getci (g_in, ch) != EOF) + if (ch == ESC) + break + for (i=0; getci (g_in, ch) >= 040B; ) + if (i < nchars) { + Memc[bp+i] = ch - 040B + i = i + 1 + } + ncells = i / 2 + + # Decode the packed iomap data. + ip = bp + do i = 1, ncells { + Mems[data+i-1] = (Memc[ip] - 040B) * 16 + (Memc[ip+1] - 040B) + ip = ip + 2 + } + + # Send the read-iomap header to the client. + retval[GIM_RET_RIOMAP_NC] = ncells + call write (g_stream, retval, GIM_RET_RIOMAP_LEN * SZ_SHORT) + + # Return the iomap data to the client. + call write (g_stream, Mems[data], ncells * SZ_SHORT) + call flush (g_stream) + + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end + + +# SGM_GETMAPPING -- Return the attributes of a mapping. + +procedure sgm_getmapping (gim) + +short gim[ARB] #I encoded instruction +short retval[GIM_RET_GMAP_LEN] +include "stdgraph.com" + +begin + call sgm_query ("GM", gim, GIM_GETMAPPING_LEN, + "Gm", retval, GIM_RET_GMAP_LEN) + call write (g_stream, retval, GIM_RET_GMAP_LEN * SZ_SHORT) + call flush (g_stream) +end + + +# SGM_OUTPUT -- Format and output a control sequence to the graphics server +# device. + +procedure sgm_output (cap, gim, nargs) + +char cap[ARB] #I graphcap capability name +short gim[ARB] #I instruction (array of int args) +int nargs #I number of arguments + +int ival, i +pointer sp, fmt, ctrl +include "stdgraph.com" +int ttygets() +errchk ttygets + +begin + call smark (sp) + call salloc (fmt, SZ_LINE, TY_CHAR) + call salloc (ctrl, SZ_LINE, TY_CHAR) + + if (ttygets (g_tty, cap, Memc[fmt], SZ_LINE) > 0) { + call sprintf (Memc[ctrl], SZ_LINE, Memc[fmt]) + do i = 1, nargs { + # Pass the argument as an integer to avoid INDEF + # processing of -32767, a valid GKI value. + ival = gim[i] + iferr (call pargi (ival)) + ; + } + call ttyputs (g_out, g_tty, Memc[ctrl], 1) + } + + call sfree (sp) +end + + +# SGM_QUERY -- Output an inquiry control sequence to the server and read and +# decode the server's response. + +procedure sgm_query (query_cap, gim, nargs, retval_cap, retval, nout) + +char query_cap[ARB] #I server query cap name +short gim[ARB] #I query instruction (args) +int nargs #I number of args for server query +char retval_cap[ARB] #I cap name for return value format +short retval[ARB] #O decoded output arguments +int nout #I number of output arguments + +int index[MAX_ARGS] +pointer sp, ctrl, patbuf, pat, buf, ip, op +int sv_iomode, arg, ch, nchars, start, value, ival, i +int patmake(), patindex(), ttyread(), ctoi() +int ttygets(), fstati(), gstrcpy() +include "stdgraph.com" +define done_ 91 +errchk ttygets + +begin + call smark (sp) + call salloc (ctrl, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (pat, SZ_LINE, TY_CHAR) + call salloc (patbuf, SZ_PATBUF, TY_CHAR) + + call aclrs (retval, nout) + + # Set raw mode i/o. + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Pass the query on to the server. + if (ttygets (g_tty, query_cap, Memc[pat], SZ_LINE) > 0) { + call sprintf (Memc[ctrl], SZ_LINE, Memc[pat]) + do i = 1, nargs { + # Pass the argument as an integer to avoid INDEF + # processing of -32767, a valid GKI value. + ival = gim[i] + iferr (call pargi (ival)) + ; + } + call ttyputs (g_out, g_tty, Memc[ctrl], 1) + call flush (g_out) + + } else + goto done_ + + # Encode a pattern to match the server's response as given by the + # pattern in retval_cap. + + if (ttygets (g_tty, retval_cap, Memc[pat], SZ_LINE) <= 0) + goto done_ + + # Process the retval_cap string, used to specify the format of the + # string returned by the server, to map the %N fields therein into + # the pattern strings "%[0-9]*", noting the index positions of the + # pattern substrings for later decoding. + + call aclri (index, MAX_ARGS) + arg = 0 + + op = buf + for (ip=pat; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '%') { + if (Memc[ip+1] == '%') { + Memc[op] = Memc[ip] + op = op + 1 + ip = ip + 1 + } else { + op = op + gstrcpy ("%[0-9]*", Memc[op], ARB) + ip = ip + 1 + + # Arguments are %1 ... %9, %a, %b, etc. + ch = Memc[ip] + if (IS_DIGIT(ch)) + i = TO_INTEG(ch) + else if (IS_UPPER(ch)) + i = ch - 'A' + 10 + else + i = ch - 'a' + 10 + + arg = arg + 1 + i = min(MAX_ARGS, max(1, i)) + index[i] = arg + } + } else if (Memc[ip] == '[') { + Memc[op] = '\\'; op = op + 1 + Memc[op] = '[' ; op = op + 1 + } else { + Memc[op] = Memc[ip] + op = op + 1 + } + } + + Memc[op] = EOS + if (patmake (Memc[buf], Memc[patbuf], SZ_PATBUF) >= SZ_PATBUF) + goto done_ + + # Scan the input stream from the server until data matching the + # response pattern is received, or a timeout occurs. + + nchars = ttyread (g_in, g_tty,Memc[buf],SZ_LINE,Memc[patbuf], TIMEOUT) + if (nchars > 0) { + do i = 1, nout { + value = 0 + if (index[i] > 0) { + start = patindex (Memc[patbuf], index[i]) + if (ctoi (Memc[buf], start, value) <= 0) + value = 0 + } + retval[i] = value + } + } +done_ + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stggrstr.x b/sys/gio/stdgraph/stggrstr.x new file mode 100644 index 00000000..946b52d9 --- /dev/null +++ b/sys/gio/stdgraph/stggrstr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GRSTREAM -- Set the FD of the graphics stream, from which we shall read +# metacode instructions and to which we shall return cell arrays and cursor +# values. + +procedure stg_grstream (stream) + +int stream # FD of the new graphics stream +include "stdgraph.com" + +begin + g_stream = stream +end diff --git a/sys/gio/stdgraph/stginit.x b/sys/gio/stdgraph/stginit.x new file mode 100644 index 00000000..3e393be4 --- /dev/null +++ b/sys/gio/stdgraph/stginit.x @@ -0,0 +1,193 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stdgraph.h" + +# STG_INIT -- Initialize the stdgraph data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine STG_RESET initializes the attribute +# packets when the screen is cleared. + +procedure stg_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +bool first_time +int maxch, i, junk +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +pointer stg_gstring() +int ttygets(), ttygeti(), btoi(), stg_encode(), gstrcpy() +include "stdgraph.com" +data first_time /true/ + +begin + # One time initialization. + if (first_time) { + # Initialize the Tek 4012 coordinate encoding lookup tables. + do i = 1, TEK_XRES { + g_hixy[i] = (i-1) / 40B + 40B + g_lox[i] = mod ((i-1), 40B) + 100B + } + do i = 1, TEK_YRES + g_loy[i] = mod ((i-1), 40B) + 140B + + first_time = false + } + + # Allocate the stdgraph descriptor and the string buffer. + call calloc (g_sg, LEN_SG, TY_STRUCT) + call malloc (SG_SBUF(g_sg), SZ_SBUF, TY_CHAR) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + SG_SZSBUF(g_sg) = SZ_SBUF + SG_NEXTCH(g_sg) = SG_SBUF(g_sg) + 1 + Memc[SG_SBUF(g_sg)] = EOS + + # Set the software device resolution and the coordinate transformations + # to the resolution space and from GKI to device coords. The values + # g_[xy]res were initialized when the kernel was opened by the main + # program. + + call stg_resolution (g_xres, g_yres) + + # Initialize the encoder. The graphcap parameter LR contains encoder + # instructions to perform any device dependent initialization required. + + call aclri (g_reg, NREGISTERS) + nextch = SG_NEXTCH(g_sg) + + g_reg[E_IOP] = 1 + g_reg[E_TOP] = SZ_MEMORY + if (ttygets (tty, "LR", Memc[nextch], SZ_SBUF-1) > 0) + junk = stg_encode (Memc[nextch], g_mem, g_reg) + + # If the device does not support hardware character generation, set + # txquality to high to get software character generation. + + if (!ttygetb (tty, "tx")) + g_hardchar = GT_HIGH + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discrete character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + SG_NCHARSIZES(g_sg) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = SG_NEXTCH(g_sg) + + if (SG_NCHARSIZES(g_sg) <= 0) { + SG_NCHARSIZES(g_sg) = 1 + SG_CHARSIZE(g_sg,1) = 1.0 + } else { + Memc[nextch+2] = EOS + for (i=1; i <= SG_NCHARSIZES(g_sg); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + SG_CHARSIZE(g_sg,i) = char_size + SG_CHARHEIGHT(g_sg,i) = char_height * char_size + SG_CHARWIDTH(g_sg,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the stdgraph + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + SG_POLYLINE(g_sg) = btoi (ttygetb (tty, "PL")) + SG_POLYMARKER(g_sg) = btoi (ttygetb (tty, "pm")) + SG_FILLAREA(g_sg) = btoi (ttygetb (tty, "fa")) + + SG_ENCODEXY(g_sg) = stg_gstring ("XY") + g_xy = SG_ENCODEXY(g_sg) + + SG_STARTDRAW(g_sg) = stg_gstring ("DS") + SG_ENDDRAW(g_sg) = stg_gstring ("DE") + SG_STARTMOVE(g_sg) = stg_gstring ("VS") + SG_ENDMOVE(g_sg) = stg_gstring ("VE") + SG_STARTMARK(g_sg) = stg_gstring ("MS") + SG_ENDMARK(g_sg) = stg_gstring ("ME") + SG_STARTFILL(g_sg) = stg_gstring ("FS") + SG_ENDFILL(g_sg) = stg_gstring ("FE") + SG_STARTTEXT(g_sg) = stg_gstring ("TS") + SG_ENDTEXT(g_sg) = stg_gstring ("TE") + + # Initialize the input parameters. + SG_CURSOR(g_sg) = 0 + SG_UPDCURSOR(g_sg) = btoi (ttygetb (tty, "UC")) + SG_CURSOR_X(g_sg) = 0 + SG_CURSOR_Y(g_sg) = 0 + + # Save the device string in the descriptor. + nextch = SG_NEXTCH(g_sg) + SG_DEVNAME(g_sg) = nextch + maxch = SG_SBUF(g_sg) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + + # Initialize the UIFNAME field. + SG_UIFNAME(g_sg) = nextch + Memc[nextch] = EOS + nextch = nextch + SZ_UIFNAME + 1 + SG_NEXTCH(g_sg) = nextch +end + + +# STG_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure stg_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "stdgraph.com" + +begin + nextch = SG_NEXTCH(g_sg) + maxch = SG_SBUF(g_sg) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = SG_SBUF(g_sg) + + SG_NEXTCH(g_sg) = nextch + return (strp) +end diff --git a/sys/gio/stdgraph/stglkcur.x b/sys/gio/stdgraph/stglkcur.x new file mode 100644 index 00000000..6152534b --- /dev/null +++ b/sys/gio/stdgraph/stglkcur.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_LOCKCURSOR -- Lock the logical cursor number. Called interactively by +# cursor mode in response to a ":.cursor N" command by the user. When the +# cursor is not locked the logical cursor may be selected under program +# control. + +procedure stg_lockcursor (new_cursor) + +int new_cursor # desired new logical cursor +include "stdgraph.com" + +begin + g_cursor = new_cursor +end diff --git a/sys/gio/stdgraph/stgmove.x b/sys/gio/stdgraph/stgmove.x new file mode 100644 index 00000000..5f7396a3 --- /dev/null +++ b/sys/gio/stdgraph/stgmove.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_MOVE -- Output a device move instruction to move to the position (x,y) +# in GKI coordinates. + +procedure stg_move (x, y) + +int x, y # destination +int stg_encode() +include "stdgraph.com" + +begin + # Transform the first point from GKI coords to device coords and + # move to the transformed point. + + call ttyputs (g_out, g_tty, Memc[SG_STARTMOVE(g_sg)], 1) + + g_reg[1] = x * g_dx + g_x1 + g_reg[2] = y * g_dy + g_y1 + g_reg[E_IOP] = 1 + if (stg_encode (Memc[g_xy], g_mem, g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + + call ttyputs (g_out, g_tty, Memc[SG_ENDMOVE(g_sg)], 1) +end diff --git a/sys/gio/stdgraph/stgonerr.x b/sys/gio/stdgraph/stgonerr.x new file mode 100644 index 00000000..047c6152 --- /dev/null +++ b/sys/gio/stdgraph/stgonerr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_ONERROR -- Called when error recovery takes place to deactivate the +# stdgraph workstation, i.e., take the terminal out of graphics mode. If +# this is not done error messages will be written as vectors. + +procedure stg_onerror (errcode) + +int errcode +include "stdgraph.com" + +begin + if (g_active == YES) + call stg_deactivatews (0) +end diff --git a/sys/gio/stdgraph/stgonint.x b/sys/gio/stdgraph/stgonint.x new file mode 100644 index 00000000..2aed03ee --- /dev/null +++ b/sys/gio/stdgraph/stgonint.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_ONINT -- Interrupt handler for the stdgraph kernel. If an interrupt +# occurs while we are posted to an exception, branch to the last ZSVJMP. +# (This library procedure is not currently used by the kernel). + +procedure stg_onint (vex, next_handler) + +int vex # virtual exception +int next_handler # next exception handler in chain +int jmpbuf[LEN_JUMPBUF] +common /stgxin/ jmpbuf + +begin + call xer_reset() + call zdojmp (jmpbuf, vex) +end diff --git a/sys/gio/stdgraph/stgopen.x b/sys/gio/stdgraph/stgopen.x new file mode 100644 index 00000000..47fb2b61 --- /dev/null +++ b/sys/gio/stdgraph/stgopen.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_OPEN -- Install the STDGRAPH kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure stg_open (devname, dd, in, out, xres, yres, hardchar) + +char devname[ARB] # if nonnull, force output to device +int dd[ARB] # device table to be initialized +int in # input file +int out # output file +int xres # number of resolved pixels in X +int yres # number of resolved pixels in Y +int hardchar # use hardware character generator + +bool first_time +pointer sp, devns +int len_devname +int locpr(), strlen() + +extern stg_openws(), stg_closews(), stg_clear(), stg_cancel() +extern stg_flush(), stg_polyline(), stg_polymarker(), stg_text() +extern stg_fillarea(), stg_putcellarray(), stg_setcursor(), stg_plset() +extern stg_pmset(), stg_txset(), stg_faset(), stg_getcursor() +extern stg_getcellarray(), stg_escape() +extern stg_reactivatews(), stg_deactivatews() +include "stdgraph.com" +data first_time /true/ + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + if (first_time) { + g_nopen = 0 + g_sg = NULL + g_tty = NULL + g_term = NULL + g_pbtty = NULL + g_cursor = 0 + first_time = false + } + + g_in = in + g_out = out + g_xres = xres + g_yres = yres + g_nopen = g_nopen + 1 + g_stream = STDGRAPH + g_hardchar = hardchar + g_active = NO + g_enable = NO + g_message = NO + g_msgbuf = NULL + g_msgbuflen = 0 + g_msglen = 0 + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + dd[GKI_OPENWS] = locpr (stg_openws) + dd[GKI_CLOSEWS] = locpr (stg_closews) + dd[GKI_REACTIVATEWS] = locpr (stg_reactivatews) + dd[GKI_DEACTIVATEWS] = locpr (stg_deactivatews) + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (stg_clear) + dd[GKI_CANCEL] = locpr (stg_cancel) + dd[GKI_FLUSH] = locpr (stg_flush) + dd[GKI_POLYLINE] = locpr (stg_polyline) + dd[GKI_POLYMARKER] = locpr (stg_polymarker) + dd[GKI_TEXT] = locpr (stg_text) + dd[GKI_FILLAREA] = locpr (stg_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (stg_putcellarray) + dd[GKI_SETCURSOR] = locpr (stg_setcursor) + dd[GKI_PLSET] = locpr (stg_plset) + dd[GKI_PMSET] = locpr (stg_pmset) + dd[GKI_TXSET] = locpr (stg_txset) + dd[GKI_FASET] = locpr (stg_faset) + dd[GKI_GETCURSOR] = locpr (stg_getcursor) + dd[GKI_GETCELLARRAY] = locpr (stg_getcellarray) + dd[GKI_ESCAPE] = locpr (stg_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call stg_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgopenws.x b/sys/gio/stdgraph/stgopenws.x new file mode 100644 index 00000000..a70a51f7 --- /dev/null +++ b/sys/gio/stdgraph/stgopenws.x @@ -0,0 +1,220 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "stdgraph.h" + +# STG_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, followed by initialization of the device itself. + +procedure stg_openws (devname, n, mode) + +short devname[ARB] #I device name (actually device[,uifname]) +int n #I length of device name +int mode #I access mode + +bool reinit +long fi[LEN_FINFO] +int dummy, init_file +pointer sp, ip, op, buf, device, uifname, fname + +pointer ttygdes(), ttyodes() +bool ttygetb(), strne(), streq() +int ttygets(), open(), ttstati(), finfo(), gstrcpy() +int nowhite(), envfind(), strlen(), fnroot(), access() +extern stg_onerror() +include "stdgraph.com" +define ow_ 91 + +begin + call smark (sp) + call salloc (buf, max (SZ_PATHNAME, n), TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Open a termcap descriptor for the terminal too, in case we need + # to talk to the terminal as a terminal. + + if (g_term == NULL) + iferr (g_term = ttyodes ("terminal")) + g_term = NULL + + # If we are appending merely reactivate the device without performing + # any initialization. + + if (g_sg != NULL && mode == APPEND) { + if (g_active == NO) { + g_ucaseout = ttstati (g_out, TT_UCASEOUT) + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, NO) + + g_active = YES + g_enable = YES + } + goto ow_ + } + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Parse the "device,uifname" specification into the two fields. + device = buf + uifname = NULL + for (ip=buf; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ',') { + Memc[ip] = EOS + if (Memc[ip+1] != EOS) + uifname = ip + 1 + if (nowhite (Memc[uifname], Memc[uifname], ARB) == 0) + uifname = NULL + break + } + + # If the kernel is already open for this device skip most of the + # initialization. If already open for a different device free + # storage before reinitialization. + + reinit = true + if (g_sg != NULL) + if (strne (Memc[device], Memc[SG_DEVNAME(g_sg)])) { + call mfree (SG_SBUF(g_sg), TY_CHAR) + call mfree (g_sg, TY_STRUCT) + reinit = true + } else + reinit = false + + # Reinitialize the kernel datastructures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + + if (reinit) { + if (g_tty != NULL) { + call ttycdes (g_tty) + g_tty = NULL + } + + iferr (g_tty = ttygdes (Memc[device])) { + g_tty = ttygdes ("4012") + call erract (EA_WARN) + } + + # Initialize data structures. + call stg_init (g_tty, Memc[device]) + } + + call stg_reset() + + if (g_active == NO) { + # Must disable stty ucaseout mode when in graphics mode, else + # plotting commands may be modified by the terminal driver. + + g_ucaseout = ttstati (g_out, TT_UCASEOUT) + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, NO) + + # Post ONERROR cleanup routine. + call onerror (stg_onerror) + g_active = YES + g_enable = YES + } + + # If no UI file was specified but the device has the EM capability, + # use the default UI if any specified in the graphcap entry. If the + # EM capability is missing, ignore any uifname specified when the + # device was opened. + + if (ttygetb (g_tty, "EM")) { + if (uifname == NULL) { + uifname = buf + strlen(Memc[device]) + 1 + if (ttygets (g_tty, "ED", Memc[uifname], ARB) <= 0) + uifname = NULL + } + + # If the user has a version of the named UI file in their GUIDIR, + # use that instead. + + if (envfind (GUIDIR, Memc[fname], SZ_PATHNAME) > 0) { + op = fname + strlen (Memc[fname]) + op = op + fnroot (Memc[uifname], Memc[op], + fname + SZ_PATHNAME - op) + op = op + gstrcpy (".gui", Memc[op], fname + SZ_PATHNAME - op) + if (access (Memc[fname], 0, 0) == YES) + uifname = fname + } + + # If the UI is already running and has not been modified there + # is no need to download it again. + + if (g_sg != NULL) + if (streq (Memc[uifname], Memc[SG_UIFNAME(g_sg)])) + if (finfo (Memc[uifname], fi) != ERR) + if (SG_UIFDATE(g_sg) == FI_MTIME(fi)) + uifname = NULL + } else { + # Ignore UI file if no EM capability. + Memc[SG_UIFNAME(g_sg)] = EOS + SG_UIFDATE(g_sg) = 0 + uifname = NULL + } + + # Open and Initialize the device. Output contents of UI definition + # file if any, followed by graphics device initialization file, + # if any. + + if (mode == NEW_FILE) { + # Output UI definition file. + if (uifname != NULL) { + iferr (init_file = open (Memc[uifname], READ_ONLY, TEXT_FILE)) { + call erract (EA_WARN) + call stg_ctrl ("OW") + } else { + call flush (g_out) + call stg_ctrl ("EM") + + # Download the UI. + call putline (g_out, "server ") + iferr (call fcopyo (init_file, g_out)) + call erract (EA_WARN) + call close (init_file) + + # Record particulars of active UI file. + call strcpy (Memc[uifname], Memc[SG_UIFNAME(g_sg)], + SZ_UIFNAME) + if (finfo (Memc[uifname], fi) != ERR) + SG_UIFDATE(g_sg) = FI_MTIME(fi) + call sgf_post_filter (g_out) + + call putci (g_out, US) + call flush (g_out) + } + } else + call stg_ctrl ("OW") + + # Output device graphics initialization file if any. + if (ttygets (g_tty, "IF", Memc[buf], SZ_FNAME) > 0) { + iferr (init_file = open (Memc[buf], READ_ONLY, TEXT_FILE)) + call erract (EA_WARN) + iferr (call fcopyo (init_file, g_out)) + call erract (EA_WARN) + call close (init_file) + } + + # Clear the screen if device is being opened in new_file mode. + call stg_clear (dummy) + + } else +ow_ call stg_ctrl ("OW") + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgoutput.x b/sys/gio/stdgraph/stgoutput.x new file mode 100644 index 00000000..098af6e7 --- /dev/null +++ b/sys/gio/stdgraph/stgoutput.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_OUTPUT2 -- Encode two arguments using the program given and write the +# encoded character string to the output file. + +procedure stg_output2 (fd, program, arg1, arg2) + +int fd # output file +char program[ARB] # encoder program defining encoding +int arg1 # argument to be placed in register 1 +int arg2 # argument to be placed in register 2 + +int stg_encode() +include "stdgraph.com" + +begin + # Set up encoder. + g_reg[1] = arg1 + g_reg[2] = arg2 + g_reg[E_IOP] = 1 + + # Encode the output string and write the encoded string to the output + # file. + if (stg_encode (g_xy, g_mem, g_reg) == OK) + call write (fd, g_mem, g_reg[E_IOP] - 1) +end diff --git a/sys/gio/stdgraph/stgoutstr.x b/sys/gio/stdgraph/stgoutstr.x new file mode 100644 index 00000000..2d854e75 --- /dev/null +++ b/sys/gio/stdgraph/stgoutstr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_OUTSTR -- Format and output a control sequence containing a string +# string argument to the output device. + +procedure stg_outstr (cap, strval) + +char cap[ARB] #I graphcap capability name +char strval[ARB] #I string data + +pointer sp, fmt, ctrl +include "stdgraph.com" +int ttygets() +errchk ttygets + +begin + call smark (sp) + call salloc (fmt, SZ_LINE, TY_CHAR) + call salloc (ctrl, SZ_LINE, TY_CHAR) + + if (ttygets (g_tty, cap, Memc[fmt], SZ_LINE) > 0) { + call sprintf (Memc[ctrl], SZ_LINE, Memc[fmt]) + call pargstr (strval) + call ttyputs (g_out, g_tty, Memc[ctrl], 1) + } + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgpcell.x b/sys/gio/stdgraph/stgpcell.x new file mode 100644 index 00000000..476d90cf --- /dev/null +++ b/sys/gio/stdgraph/stgpcell.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +define ZSTEP 4 # bit to be tested (step function width) + + +# STG_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). The algorithm used here maps 8 bits in into 1 bit +# out, using a step function lookup table. The result is a band-contoured +# image, where the spacing and width of the contour bands decreases as the +# rate of change of intensity in the input cell array increases. + +procedure stg_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int my, i1, i2, v, i, j, k +include "stdgraph.com" +int and() + +begin + # Set polyline width to 1 for max y-res. + call stg_ctrl1 ("LW", 1) + SG_PLWIDTH(g_sg) = 1 + + # Determine the width of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + + # Determine the height of a device pixel in GKI units. + dy = max (1.0, real(GKI_MAXNDC) / real(g_yres)) + + # Process the cell array. The outer loop runs over device pixels in Y; + # each iteration writes one line of the output raster. The inner loop + # runs down a line of the cell array. + + k = 0 + for (my = ay1 + dy/2; my < ay2; my = k * dy + ay1) { + j = max(1, min(ny, int (real(my-ay1) / real(ay2-ay1) * (ny-1)) + 1)) + my = min (my, int (ay2 - dy/2)) + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i1 + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call stg_move (int ((i1-1) * dx + ax1), my) + call stg_draw (int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + + k = k + 1 + } +end diff --git a/sys/gio/stdgraph/stgpl.x b/sys/gio/stdgraph/stgpl.x new file mode 100644 index 00000000..894a92c3 --- /dev/null +++ b/sys/gio/stdgraph/stgpl.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure stg_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +bool tek_encoding +int lowres_x, lowres_y +int ip, n, sx, sy, len_p, iop, i +int stg_encode() +include "stdgraph.com" + +begin + if (g_enable == NO) + call stg_genab() + + len_p = npts * 2 + + # Update polyline attributes if necessary. + + pl = SG_PLAP(g_sg) + if (SG_PLTYPE(g_sg) != PL_LTYPE(pl)) { + call stg_ctrl1 ("LT", PL_LTYPE(pl)) + SG_PLTYPE(g_sg) = PL_LTYPE(pl) + } + if (SG_PLWIDTH(g_sg) != PL_WIDTH(pl)) { + call stg_ctrl1 ("LW", PL_WIDTH(pl)) + SG_PLWIDTH(g_sg) = PL_WIDTH(pl) + } + if (SG_COLOR(g_sg) != PL_COLOR(pl)) { + call stg_ctrl1 ("LC", PL_COLOR(pl)) + SG_COLOR(g_sg) = PL_COLOR(pl) + } + + # Transform the first point from GKI coords to device coords and + # move to the transformed point. + + sx = p[1]; sy = p[2] + call stg_move (sx, sy) + + # Tektronix encoding is treated as a special case for max efficiency. + tek_encoding = + (Memc[g_xy] == '%' && Memc[g_xy+1] == 't' && Memc[g_xy+2] == EOS) + + # Draw the polyline. If the device has the "polyline" capability + # we can encode and output successive points without enclosing each + # individual point in the startdraw and enddraw strings. + + for (ip=3; ip <= len_p; ip=ip+2) { + # Output start draw sequence. + call ttyputs (g_out, g_tty, Memc[SG_STARTDRAW(g_sg)], 1) + + # Determine number of points to output. + if (SG_POLYLINE(g_sg) == YES) + n = len_p + else + n = ip + 2 + + # Encode the points of the polyline. + + g_lastx = -1 # clip unresolved points only in the interior + g_lasty = -1 # of the polyline being drawn. + + g_reg[E_IOP] = 1 + do i = ip, n, 2 { + sx = p[i] + sy = p[i+1] + + # Discard the point if it is not resolved. + lowres_x = sx / g_dxres + lowres_y = sy / g_dyres + if (lowres_x == g_lastx && lowres_y == g_lasty) + next + + g_lastx = lowres_x + g_lasty = lowres_y + + # Transform point into the device window. + sx = int (sx * g_dx) + g_x1 + sy = int (sy * g_dy) + g_y1 + + # Encode the point, appending encoded bytes to g_mem. Tek + # encoding is treated as a special case since it is so common; + # the encoder is used for non-Tek encodings. + + if (tek_encoding) { + iop = g_reg[E_IOP] + 4 + g_mem[iop-4] = g_hixy[sy+1] + g_mem[iop-3] = g_loy[sy+1] + g_mem[iop-2] = g_hixy[sx+1] + g_mem[iop-1] = g_lox[sx+1] + g_reg[E_IOP] = iop + } else { + g_reg[1] = sx + g_reg[2] = sy + if (stg_encode (Memc[g_xy], g_mem, g_reg) != OK) + break + } + + # Flush buffer if nearly full. + if (g_reg[E_IOP] > FLUSH_MEMORY) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + } + ip = n + + # Flush any output remaining in encoder memory. + if (g_reg[E_IOP] > 1) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + + # Output end draw sequence. + call ttyputs (g_out, g_tty, Memc[SG_ENDDRAW(g_sg)], 1) + } +end diff --git a/sys/gio/stdgraph/stgplset.x b/sys/gio/stdgraph/stgplset.x new file mode 100644 index 00000000..c435feb5 --- /dev/null +++ b/sys/gio/stdgraph/stgplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure stg_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "stdgraph.com" + +begin + pl = SG_PLAP(g_sg) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = max (1, nint (GKI_UNPACKREAL (gki[GKI_PLSET_LW]))) + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/stdgraph/stgpm.x b/sys/gio/stdgraph/stgpm.x new file mode 100644 index 00000000..3808d63b --- /dev/null +++ b/sys/gio/stdgraph/stgpm.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs, each of which +# is to be plotted as a point. If the marker start sequence MS is defined the +# polymarker will be drawn as ... , otherwise +# ther marker is draw using the polyline move and draw commands to draw each +# individual point. + +procedure stg_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +bool tek_encoding +int lowres_x, lowres_y +int ip, n, sx, sy, len_p, iop, i +int stg_encode() +include "stdgraph.com" + +begin + if (g_enable == NO) + call stg_genab() + + len_p = npts * 2 + + # Update polymarker attributes if necessary. + + pm = SG_PMAP(g_sg) + if (SG_COLOR(g_sg) != PM_COLOR(pm)) { + call stg_ctrl1 ("MC", PM_COLOR(pm)) + SG_COLOR(g_sg) = PM_COLOR(pm) + } + + # Tektronix encoding is treated as a special case for max efficiency. + tek_encoding = + (Memc[g_xy] == '%' && Memc[g_xy+1] == 't' && Memc[g_xy+2] == EOS) + + # Draw the polymarker. If the startmark sequence is defined we assume + # that the device can draw a multipoint polymarker, else low level move + # and draw sequences are used. + + if (Memc[SG_STARTMARK(g_sg)] != EOS) { + for (ip=1; ip <= len_p; ip=ip+2) { + # Output start marker sequence [revised to use the encoder]. + call ttyputs (g_out, g_tty, Memc[SG_STARTMARK(g_sg)], 1) + n = len_p + + # Encode the points of the polymarker (or move to the single + # point to be drawn). + + g_lastx = -1 # clip unresolved points only in the interior + g_lasty = -1 # of the polymarker being drawn. + + g_reg[E_IOP] = 1 + do i = ip, n, 2 { + sx = p[i] + sy = p[i+1] + + # Discard the point if it is not resolved. + lowres_x = sx / g_dxres + lowres_y = sy / g_dyres + if (lowres_x == g_lastx && lowres_y == g_lasty) + next + + g_lastx = lowres_x + g_lasty = lowres_y + + # Transform point into the device window. + sx = int (sx * g_dx) + g_x1 + sy = int (sy * g_dy) + g_y1 + + # Encode the point, appending encoded bytes to g_mem. + # Tek encoding is treated as a special case since it is + # so common; the encoder is used for non-Tek encodings. + + if (tek_encoding) { + iop = g_reg[E_IOP] + 4 + g_mem[iop-4] = g_hixy[sy+1] + g_mem[iop-3] = g_loy[sy+1] + g_mem[iop-2] = g_hixy[sx+1] + g_mem[iop-1] = g_lox[sx+1] + g_reg[E_IOP] = iop + } else { + g_reg[1] = sx + g_reg[2] = sy + if (stg_encode (Memc[g_xy], g_mem, g_reg) != OK) + break + } + + # Flush buffer if nearly full. + if (g_reg[E_IOP] > FLUSH_MEMORY) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + } + ip = n + + # Flush any output remaining in encoder memory. + if (g_reg[E_IOP] > 1) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + + # Output end polymarker sequence, or draw the point. + call ttyputs (g_out, g_tty, Memc[SG_ENDMARK(g_sg)], 1) + } + } else { + for (ip=1; ip <= len_p; ip=ip+2) { + sx = p[ip]; sy = p[ip+1] + call stg_move (sx, sy) + call stg_draw (sx, sy) + } + } +end diff --git a/sys/gio/stdgraph/stgpmset.x b/sys/gio/stdgraph/stgpmset.x new file mode 100644 index 00000000..6651564f --- /dev/null +++ b/sys/gio/stdgraph/stgpmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_PMSET -- Set the polymarker attributes. + +procedure stg_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "stdgraph.com" + +begin + pm = SG_PMAP(g_sg) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = max (1, nint (GKI_UNPACKREAL (gki[GKI_PMSET_MW]))) + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/stdgraph/stgrcur.x b/sys/gio/stdgraph/stgrcur.x new file mode 100644 index 00000000..e0ab890a --- /dev/null +++ b/sys/gio/stdgraph/stgrcur.x @@ -0,0 +1,425 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include "stdgraph.h" + +define MAX_LENCUR 17 +define MAX_KEYLINES 30 +define KEYSIZE 1 +define QUIT 'q' +define GO 'g' + +# STG_READCURSOR -- Physically read the cursor, returning the cursor position +# in GKI coordinates and the keystroke value as output arguments. The cursor +# value string is read in raw mode with interrupts disabled. Receipt of the +# EOF character or CR causes EOF to be returned as the key value. +# +# The cursor is described by two parameters, a pattern string (CD) and a string +# length parameter (CN). +# +# CD A pattern specifying either the delimiter sequence if +# len_curval > 0, or the entire cursor value string if +# len_curval <= 0. +# +# CN If no pattern is given, CN is the number of characters to be +# read and automatic error detection is not possible. If a +# pattern is given, a negative CN specifies the minimum number +# of characters in the cursor value string, with the pattern +# being used to match the characters in the actual cursor value +# string. A positive CN specifies a fixed length cursor value +# string, which which case the pattern is used only to determine +# when a valid cursor value string has been received. +# +# The cursor read algorithm tries to ignore unsolicited input and recover from +# bad cursor reads, or loss of hardware cursor mode during a cursor read, e.g., +# if the screen is accidentally cleared or the terminal otherwise initialized. +# +# The physical cursor read sequence is implemented by the stg_rdcursor routine. +# The purpose of the higher level routine is to support STTY playback mode. +# In playback mode, terminal input is taken from a logfile rather than from +# the physical terminal; this is used to prepare automatic scripts to test +# software and for demos. If playback mode is enabled and `verify' is enabled, +# the logged cursor position will be read, a WC will be issued to move the +# cursor to that position, and then the physical cursor will be read and the +# return value discard, returning the logged position to the calling program. +# In playback mode with `verify' disabled, we need only disable the RC +# instruction and read the logged cursor position; the physical cursor is +# never turned on. + +procedure stg_readcursor (cursor, cn, key, sx, sy, raster, rx, ry) + +int cursor #I cursor to be read +int cn #O cursor which was read +int key #O keystroke which terminated cursor read +int sx, sy #O screen coordinates of cursor in GKI units +int raster #O raster number +int rx, ry #O raster coordinates of cursor in GKI units + +short texts[4] +char textc[4], ch +pointer sp, pbdevice, tx, o_tx +int delay, nchars, mx, my, i, j, k +bool playback_mode, pbverify_mode + +bool strne() +pointer ttygdes() +int ttstati(), ttstats(), ctocc() +errchk ttygdes, syserr +include "stdgraph.com" +define samedev_ 91 + +begin + playback_mode = (ttstati (STDIN, TT_PLAYBACK) == YES) + + if (!playback_mode) { + call stg_rdcursor (g_tty, cursor, YES, + cn, key, sx, sy, raster, rx, ry) + return + } + + call smark (sp) + call salloc (pbdevice, SZ_GDEVICE, TY_CHAR) + call salloc (o_tx, LEN_TX, TY_STRUCT) + + # The playback script may have been generated on a different graphics + # terminal than the one we are playing it back on. Open the graphcap + # descriptor for the device used when the script was recorded. This + # must be used when decoding cursor input from the logfile. If device + # name not recorded in logfile, try to make do with the descriptor for + # the current stdgraph device. + + if (ttstats (STDIN, TT_GDEVICE, Memc[pbdevice], SZ_GDEVICE) <= 0) { + # Device name not recorded in logfile. + call syserr (SYS_STTYNOGDEV) + + } else if (g_pbtty == NULL || strne (g_pbdevice, Memc[pbdevice])) { + # Device name was recorded; try to load graphcap for it if not + # already loaded. + + if (g_pbtty != NULL) + call ttycdes (g_pbtty) + iferr (g_pbtty = ttygdes (Memc[pbdevice])) { + g_pbtty = NULL + call erract (EA_ERROR) + } + + call strcpy (Memc[pbdevice], g_pbdevice, SZ_GDEVICE) + } + + # Set the playback delay to 0 msec while reading the cursor, else + # the multicharacter cursor read will take forever. We issue the + # delay below, ourselves, one per cursor read. + + delay = ttstati (STDIN, TT_PBDELAY) + call ttseti (STDIN, TT_PBDELAY, 0) + + # Read the logged cursor position with RC disabled. + call stg_rdcursor (g_pbtty, cursor, NO, + cn, key, sx, sy, raster, rx, ry) + + # Determine if verify mode is set for this cursor read. This must + # be done after the call to stg_rdcursor to permit processing of + # any \{ .. \} in the logfile. + + pbverify_mode = (ttstati (STDIN, TT_PBVERIFY) == YES) + + # Set passthru mode to read/write the device directly. + call ttseti (STDIN, TT_PASSTHRU, YES) + + # Encode the logged keystroke as a character string. + if (key == EOF) { + call strcpy ("EOF", textc, 4) + nchars = 3 + } else if (key <= ' ') { + ch = key + nchars = ctocc (ch, textc, 4) + } else { + nchars = 1 + textc[1] = key + } + + # Pack the string in a short array for the GKI operator. + call achtcs (textc, texts, nchars) + + # Set the text drawing attributes. + tx = SG_TXAP(g_sg) + call amovi (Memi[tx], Memi[o_tx], LEN_TX) + TX_SIZE(tx) = KEYSIZE + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + + # Echo the key character in graphics mode on the top line of the screen, + # duplicating the text drawn at the cursor position. + + mx = nint ((g_keycol + 0.5) * SG_CHARWIDTH(g_sg,1)) + my = GKI_MAXNDC - nint ((g_keyline + 0.2) * SG_CHARHEIGHT(g_sg,KEYSIZE)) + + call stg_text (mx, my, texts, nchars) + g_keyline = g_keyline + 1 + if (g_keyline > MAX_KEYLINES) { + g_keycol = g_keycol + 1 + g_keyline = 1 + } + + # Echo the logged keystroke at the position of the cursor. This may + # not always be readable, but at least it marks the cursor position. + + call stg_text (sx, sy, texts, nchars) + + if (pbverify_mode) { + # Issue a WC to set the cursor position, and perform a normal + # cursor read in passthru mode, discarding the return value. + + call stg_setcursor (sx, sy, cursor) + call stg_rdcursor (g_tty, cursor, YES, i, i, j, k, i, j, k) + + # User wants to terminate playback mode? + if (k == QUIT || k == INTCHAR) { + call ttseti (STDIN, TT_PLAYBACK, NO) + call stg_ctrl ("GD") + call putline (STDOUT, "[playback mode terminated]") + call stg_ctrl ("GE") + call flush (STDOUT) + call zwmsec (500) + if (k == INTCHAR) + key = EOF + } else if (k == GO) + call ttseti (STDIN, TT_PBVERIFY, NO) + } else + call zwmsec (delay) + + # Restore everything modified earlier. + call ttseti (STDIN, TT_PASSTHRU, NO) + call ttseti (STDIN, TT_PBDELAY, delay) + call amovi (Memi[o_tx], Memi[tx], LEN_TX) + + call sfree (sp) +end + + +# STG_RDCURSOR -- Physically read the cursor; an internal routine called only +# by the stg_readcursor procedure. A lower level routine is needed since +# two cursor reads may be required in STTY playback mode, one to read the +# logged cursor position and another to read the physical cursor to synch +# with the user. This is the real cursor read routine; the only concession +# to playback mode is the `output_rc' switch, to disable output of the RC +# instruction to the terminal, so that the routine does only input from the +# logical device. + +procedure stg_rdcursor (tty, cursor, output_rc, cn, key, sx,sy, raster, rx,ry) + +pointer tty #I graphcap descriptor +int cursor #I cursor to be read +int output_rc #I flag to output the RC instruction +int cn #O cursor which was read +int key #O keystroke which terminated cursor read +int sx, sy #O cursor screen position in GKI coords +int raster #O raster number +int rx, ry #O cursor raster position in GKI coords + +pointer decodecur, delimcur, pattern, patbuf, sp, otop +int len_pattern, len_curval, sv_iomode, nchars, ip, op, i1, i2, ch + +bool ttygetb() +int getci(), stg_encode() +int ttygets(), ttygeti(), gstrcpy(), gpatmatch(), patmake(), fstati() +include "stdgraph.com" +define quit_ 91 + +begin + call smark (sp) + call salloc (pattern, SZ_LINE, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call salloc (decodecur, SZ_LINE, TY_CHAR) + call salloc (delimcur, SZ_FNAME, TY_CHAR) + + key = EOF + + # Make sure there is a cursor before going any further. + if (!ttygetb (g_tty, "RC")) + goto quit_ + + len_curval = ttygeti (tty, "CN") + if (ttygets (tty, "SC", Memc[decodecur], SZ_LINE) <= 0) + goto quit_ + + len_pattern = 0 + if (ttygets (tty, "CD", Memc[delimcur], SZ_FNAME) > 0) + len_pattern = gstrcpy (Memc[delimcur], Memc[pattern], SZ_LINE) + + # Either len_curval or pattern must be given, preferably both. + if (len_curval == 0 && len_pattern == 0) + goto quit_ + + # Encode the cursor value pattern, which may be either a pattern + # matching the entire cursor value, or just the delimiter. The value + # of len_curval may be negative if a pattern is given, but must be + # positive otherwise. If the pattern is a delimiter string, append + # the $ metacharacter to match only at the end of the string. + + if (len_pattern > 0) { + if (len_curval > 0) { + Memc[pattern+len_pattern] = '$' + len_pattern = len_pattern + 1 + Memc[pattern+len_pattern] = EOS + } + if (patmake (Memc[pattern], Memc[patbuf], SZ_LINE) == ERR) + goto quit_ + } else if (len_curval < 0) + len_curval = -len_curval + + # Set raw mode on the input file (the graphics terminal). + call flush (STDOUT); call flush (STDERR) + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + repeat { + # Initiate a cursor read. + if (output_rc == YES) { + call stg_ctrl1 ("RC", cursor) + call flush (g_out) + } + + # Read the cursor value string. If a pattern is given accumulate + # at least abs(len_curval) characters and stop when the pattern + # is matched, returning the last len_curval characters if + # len_curval > 0, else the matched substring. If no pattern is + # given simply accumulate len_curval characters. The number of + # characters we will accumulate in one iteration is limited to + # MAX_LENCUR to permit retransmission of the RC control sequence + # in the event that hardware cursor mode is accidentally cleared. + + for (op=1; op <= MAX_LENCUR; op=op+1) { + g_mem[op] = getci (g_in, key) + g_mem[op+1] = EOS + + if (key == EOF) { + # Turn off raw input mode and return EOF. + key = EOF + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + goto quit_ + + } else if (len_pattern > 0) { + # A pattern string was given. Once the minimum number of + # chars have been accumulated, try to match the pattern, + # which may match either the cursor string delimiter (in + # the case of a fixed length cursor value), or the entire + # cursor string (which may then be variable length). + + if (op < abs(len_curval)) + next + else if (gpatmatch (g_mem[1], Memc[patbuf], i1,i2) > 0) { + if (len_curval > 0) + ip = op - len_curval + 1 # fixed length cur + else + ip = i1 # variable length cur + break + } + + } else if (op >= len_curval) { + # No pattern was given. Terminate the cursor read once + # the len_curval characters have been accumulated. + + ip = 1 + break + } + } + + # We have received too many characters, indicating that cursor + # mode was lost and the user has been pounding on the keyboard + # trying to get the cursor back. Discard the chars, restart + # the cursor and try again. + + if (op > MAX_LENCUR) + op = -1 + + } until (op >= abs(len_curval) || len_curval == 0) + + # Decode the cursor value string and return the position and key + # as output values. Return the cursor position in GKI coordinates. + # If extra characters were typed, e.g., before the cursor was turned + # on, and the cursor has a delimiter string, the extra characters will + # have been read into low memory and we should be able to ignore them + # and still get a valid read. + + g_reg[E_IOP] = ip + call aclri (g_reg, 7) + if (stg_encode (Memc[decodecur], g_mem, g_reg) != OK) + call syserr (SYS_GGCUR) + + # Multiple cursors are not implemented yet so just echo input. + cn = cursor + + # Standard cursor value. + sx = nint ((g_reg[1] - g_x1) / g_dx) + sy = nint ((g_reg[2] - g_y1) / g_dy) + key = g_reg[3] + + # Only some devices return the following fields. Note that FX,FY + # are returned by stg_encode in GKI coordinates. + + nchars = g_reg[4] + raster = g_reg[5] + if (raster == 0) { + rx = sx + ry = sy + } else { + rx = g_reg[6] + ry = g_reg[7] + } + + # If the NCHARS field is nonzero then a data block of length nchars + # follows the cursor value struct returned by the terminal. Read this + # into the g_msgbuf message buffer. The client makes a subsequent + # call to stg_readtty to access this data, otherwise it is discarded + # in the next cursor read. + + if (nchars > 0) { + if (nchars > g_msgbuflen) { + g_msgbuflen = (nchars + SZ_MSGBUF - 1) / SZ_MSGBUF * SZ_MSGBUF + call realloc (g_msgbuf, g_msgbuflen, TY_CHAR) + } + + # We should encode this data transfer in a way that permits + # detection and recovery from lost data. For the moment, the + # following assumes that nchars of data will actually be received. + + op = g_msgbuf + otop = g_msgbuf + nchars + while (op < otop && getci (g_in, ch) != EOF) { + Memc[op] = ch + op = op + 1 + } + g_msglen = op - g_msgbuf + Memc[op] = EOS + + } else + g_msglen = 0 + + # Turn off raw input mode. + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + + # Return EOF if any EOF character (e.g., or ) or the + # interrupt character is typed. + + if (key == EOFCHAR || key == INTCHAR || key == '\004' || key == '\032') + key = EOF +quit_ + # Terminate the cursor read. + if (output_rc == YES) { + call stg_ctrl1 ("RE", cursor) + call flush (g_out) + } + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgreact.x b/sys/gio/stdgraph/stgreact.x new file mode 100644 index 00000000..21c2a821 --- /dev/null +++ b/sys/gio/stdgraph/stgreact.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_REACTIVATEWS -- Reactivate the workstation, i.e., enable graphics. + +procedure stg_reactivatews (flags) + +int flags # action flags (handled by cursor mode) + +int junk +int ttstati(), ttyctrl(), and() +extern stg_onerror() +include "stdgraph.com" + +begin + if (g_active == NO) { + junk = ttyctrl (g_out, g_tty, "OW", 1) + + # Post error handler to be called if we abort. + call onerror (stg_onerror) + + g_active = YES + g_enable = YES + + # Must disable stty ucaseout mode when in graphics mode, else + # plotting commands may be modified by the terminal driver. + + g_ucaseout = ttstati (g_out, TT_UCASEOUT) + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, NO) + + # Clear the graphics screen? + if (and (flags, AW_CLEAR) != 0) + call stg_clear (0) + + call flush (g_out) + } +end diff --git a/sys/gio/stdgraph/stgres.x b/sys/gio/stdgraph/stgres.x new file mode 100644 index 00000000..d6355bd9 --- /dev/null +++ b/sys/gio/stdgraph/stgres.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_RESOLUTION -- Set the "soft" device resolution. When plotting GKI +# coordinates are transformed into a space with the indicated resolution and +# unresolved points are discarded, before transforming to device coordinates. +# We must set up both the transformation to resolution space and the +# transformation to device space. + +procedure stg_resolution (xres, yres) + +int xres # device X resolution +int yres # device Y resolution +int nx, ny +int ttygeti() +include "stdgraph.com" + +begin + if (g_tty == NULL) { + g_xres = xres + g_yres = yres + return + } + + # Set the resolution value in the stdgraph common only if a nonzero + # value is given. A value of zero does not change the resolution. + + if (xres > 0) + g_xres = xres + if (yres > 0) + g_yres = yres + + + # If we still have a zero resolution then we use the full resolution + # of the device. The 3/4 reduction in resolution is needed to clip + # points that would be unresolved due to integer truncation effects. + + if (g_xres <= 0) { + g_xres = ttygeti (g_tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_xres = max (2, g_xres * 3 / 4) + } + if (g_yres <= 0) { + g_yres = ttygeti (g_tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + g_yres = max (2, g_yres * 3 / 4) + } + + # Set up coordinate transformations. The first transformation is from + # GKI coordinates to device resolution coordinates (0:xres-1,0:yres-1) + # and is defined by xres, yres, and GKI_MAXNDC. Clipping of unresolved + # points is performed after this first transformation. The second + # transformation maps resolved points into the device window. + + # GKI -> resolution coords. + g_dxres = max (1, (GKI_MAXNDC + 1) / g_xres) + g_dyres = max (1, (GKI_MAXNDC + 1) / g_yres) + + g_x1 = ttygeti (g_tty, "X1") + g_y1 = ttygeti (g_tty, "Y1") + g_x2 = ttygeti (g_tty, "X2") + g_y2 = ttygeti (g_tty, "Y2") + nx = g_x2 - g_x1 + 1 + ny = g_y2 - g_y1 + 1 + + if (nx <= 1 || ny <= 1) { + call eprintf ("openws: illegal graphics device window\n") + nx = g_xres + ny = g_yres + } + + # GKI -> window coords. + g_dx = real (nx - 1) / GKI_MAXNDC + g_dy = real (ny - 1) / GKI_MAXNDC + + # The last point in resolution coords is used to clip unresolved + # points when drawing polylines. + + g_lastx = -1 + g_lasty = -1 +end diff --git a/sys/gio/stdgraph/stgreset.x b/sys/gio/stdgraph/stgreset.x new file mode 100644 index 00000000..0f2fd1e2 --- /dev/null +++ b/sys/gio/stdgraph/stgreset.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_RESET -- Reset the state of the stdgraph common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure stg_reset() + +pointer pl, pm, fa, tx +include "stdgraph.com" + +begin + # Set pointers to attribute substructures. + pl = SG_PLAP(g_sg) + pm = SG_PMAP(g_sg) + fa = SG_FAAP(g_sg) + tx = SG_TXAP(g_sg) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = 1 + PL_COLOR(pl) = 1 + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = 1 + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + SG_COLOR(g_sg) = -1 + SG_TXSIZE(g_sg) = -1 + SG_TXFONT(g_sg) = -1 + SG_PLTYPE(g_sg) = -1 + SG_FASTYLE(g_sg) = -1 + SG_PLWIDTH(g_sg) = -1 + g_lastx = -1 + g_lasty = -1 + g_keycol = 1 + g_keyline = 1 + g_message = NO + g_msglen = 0 +end diff --git a/sys/gio/stdgraph/stgrtty.x b/sys/gio/stdgraph/stgrtty.x new file mode 100644 index 00000000..237a7c7b --- /dev/null +++ b/sys/gio/stdgraph/stgrtty.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_READTTY -- Read a line of text from the graphics terminal. +# If the workstation is currently activated the read is performed in raw mode, +# presumably with the cursor positioned to the end of a prompt string on the +# status line. The workstation will have been put into text mode and the +# cursor positioned to the status line by an immediately preceding call to +# stg_writetty, which is called by pseudofile i/o when the user task writes +# to STDOUT or STDERR while the workstation is activated. The input sequence +# terminates when the user types return or newline, causing exit with +# transmission of the GE sequence to restore the terminal to graphics mode. + +int procedure stg_readtty (fd, obuf, maxch) + +int fd #I input stream [NOT USED] +char obuf[ARB] #O output buffer +int maxch #I max chars to read + +int nchars, op, ch +int read(), getci(), fstati() +include "stdgraph.com" +errchk read, getci, ttyctrl +string delstr "\010 \010" + +begin + call flush (STDERR) + call flush (STDOUT) + + if (g_active == NO) { + # Workstation in normal text mode; normal text input. + return (read (STDIN, obuf, maxch)) + + } else if (g_msglen > 0) { + # The message data has already been transmitted and resides in + # the message buffer. + + nchars = min (maxch, g_msglen) + call amovc (Memc[g_msgbuf], obuf, nchars) + obuf[nchars+1] = EOS + g_msglen = 0 + return (nchars) + + } else { + # Workstation is activated; read status line in raw mode. + # If already in rew mode, read a single char with no echo. + # Note that genable is not automatic in raw input mode. + + if (g_enable == YES) + call stg_gdisab() + + if (fstati (g_in, F_RAW) == YES) { + if (getci (g_in, ch) == EOF) { + obuf[1] = EOS + return (EOF) + } else if (ch == '\004' || ch == '\032') { + obuf[1] = EOS + return (EOF) + } else { + obuf[1] = ch + obuf[2] = EOS + return (1) + } + } else + call fseti (g_in, F_RAW, YES) + + for (op=1; getci (g_in, ch) != EOF; op=min(maxch,op)) { + switch (ch) { + case EOF, '\004', '\032': # EOF + call stg_genab() + break + case '\n', '\r': + obuf[op] = '\n' + op = op + 1 + call putline (g_out, "\r\n") + call stg_genab() + break + case INTCHAR, '\025': # + for (; op > 1; op=op-1) + call putline (g_out, delstr) + case BS, '\177': + if (op > 1) { + call putline (g_out, delstr) + op = op - 1 + } else { + call stg_genab() + break # exit + } + default: + call putci (g_out, ch) + obuf[op] = ch + op = op + 1 + } + call flush (g_out) + } + + obuf[op] = EOS + call fseti (g_in, F_RAW, NO) + + if (op > 1) + return (op - 1) + else + return (EOF) + } +end + + +# STG_GETLINE -- Get a line of text from the graphics terminal, reading from +# the status line if the workstation is activated, and doing a normal text +# read otherwise. + +int procedure stg_getline (fd, obuf) + +int fd #I input file +char obuf[SZ_LINE] #O output buffer + +int stg_readtty() + +begin + return (stg_readtty (fd, obuf, SZ_LINE)) +end + + +# STG_MSGLEN -- This routine is called to determine if there is any message +# data buffered in the kernel, to be returned in the next call to stg_readtty. + +int procedure stg_msglen (fd) + +int fd #I input file +include "stdgraph.com" + +begin + return (g_msglen) +end diff --git a/sys/gio/stdgraph/stgscur.x b/sys/gio/stdgraph/stgscur.x new file mode 100644 index 00000000..e40d4a3d --- /dev/null +++ b/sys/gio/stdgraph/stgscur.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_SETCURSOR -- Set the position of a cursor. + +procedure stg_setcursor (x, y, cursor) + +int x, y # new position of cursor +int cursor # cursor to be set +int mx, my, cur +include "stdgraph.com" + +begin + # If cursor=0, write the cursor last referenced. + if (cursor > 0) { + SG_CURSOR(g_sg) = cursor + cur = cursor + } else + cur = max (1, SG_CURSOR(g_sg)) + + # If the user has locked the logical cursor override runtime selection. + if (g_cursor > 0) + cur = g_cursor + + # Restore the software cursor position before reading? + if (SG_UPDCURSOR(g_sg) == YES) { + SG_CURSOR_X(g_sg) = x + SG_CURSOR_Y(g_sg) = y + } + + mx = max(g_x1, min(g_x2, nint (x * g_dx) + g_x1)) + my = max(g_y1, min(g_y2, nint (y * g_dy) + g_y1)) + + call stg_ctrl3 ("WC", mx, my, cur) +end diff --git a/sys/gio/stdgraph/stgtx.x b/sys/gio/stdgraph/stgtx.x new file mode 100644 index 00000000..ff5abae2 --- /dev/null +++ b/sys/gio/stdgraph/stgtx.x @@ -0,0 +1,528 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stdgraph.h" + +# STG_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. Two levels of character quality are implemented: MEDIUM and HIGH, +# wherein characters are generated in software, and everything else, wherein +# the characters are generated by the hardware. + +procedure stg_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +bool hard +real x, y +int x1, x2, y1, y2, mx, my +int x0, y0, dx, dy, ch, cw, sz +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen, orien, hwsz +pointer sp, seg, ip, op, tx, first +int stx_segment(), stg_encode() +include "stdgraph.com" + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + if (g_enable == NO) + call stg_genab() + + # Set pointer to the text attribute structure. + tx = SG_TXAP(g_sg) + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, dx,dy, polytext, orien) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. If software (!hard) + # character generation is indicated then size 1 is simply scaled by + # the indicated factor, otherwise the text size is converted to a + # hardware size index by stg_txsize. + + call stx_chars (tx, ch, cw, hwsz, hard, orien) + sz = TX_SIZE(tx) + + if (hard) + if (SG_TXSIZE(g_sg) != sz) { + call stg_ctrl1 ("TH", hwsz) + SG_TXSIZE(g_sg) = sz + } + + if (TX_COLOR(tx) != SG_COLOR(g_sg)) { + call stg_ctrl1 ("TC", TX_COLOR(tx)) + SG_COLOR(g_sg) = TX_COLOR(tx) + } + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + # All computations are in GKI coordinates. + + x = x0 + y = y0 + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + if (hard) + if (SG_TXFONT(g_sg) != font) { + call stg_ctrl1 ("TF", font - GT_ROMAN + 1) + SG_TXFONT(g_sg) = font + } + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= 0 && x2 <= GKI_MAXNDC && + y1 >= 0 && y2 <= GKI_MAXNDC) { + + break + + } else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= 0 || x2 >= GKI_MAXNDC || + y1 <= 0 || y2 >= GKI_MAXNDC) { + + break + + } else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + if (hard) { + g_reg[1] = xstart * g_dx + g_x1 + g_reg[2] = ystart * g_dy + g_y1 + g_reg[E_IOP] = 1 + if (stg_encode (Memc[SG_STARTTEXT(g_sg)],g_mem,g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + } + + first = ip + x = xstart + y = ystart + + # Draw the characters. + while (seglen > 0 && (polytext == YES || ip == first)) { + if (hard) + call putc (g_out, Memc[ip]) + else { + mx = nint(x) + my = nint(y) + call stg_drawchar (Memc[ip], mx,my, cw, ch, orien, font) + x = x + dx + y = y + dy + } + + ip = ip + 1 + seglen = seglen - 1 + } + + x = newx + y = newy + ip = op + + if (hard) { + g_reg[E_IOP] = 1 + if (stg_encode (Memc[SG_ENDTEXT(g_sg)], g_mem, g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + } + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +bool hard +int up, path, hwsz, ch, cw, i +real dir, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "stdgraph.com" + +begin + tx = SG_TXAP(g_sg) + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Get character sizes in GKI(NSPP) coords. + call stx_chars (tx, ch, cw, hwsz, hard, orien) + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # If hardware character generation is enabled the character up vector + # is constrained to 90 degrees. Flip the direction in which characters + # will be drawn if necessary to draw from left to right or from top + # down, the readable directions. + + if (hard) { + # Constrain the up vector. + orien = 0 + + # Flip direction vector if in 2nd or 3rd quadrant. + i = nint(dir) + if (i < 0) + i = i + 360 + if (i >= 90 && i < 180) + i = i + 180 + if (i >= 360) + i = i - 360 + dir = real(i) + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if ((path == GT_UP || path == GT_DOWN) || + (hard && abs(cosv) < .9)) { + p = ch * space + } else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end + + +# STX_CHARS -- Get the character drawing parameters, i.e., the size of a +# character in X and Y and whether or not to use the hardware character +# generator. The decision whether or not to use the hardware character +# generator is based on the text attribute QUALITY, unless overridden by +# the g_hardchar switch in common (set explicitly in cursor mode or by a +# stdgraph task parameter). + +procedure stx_chars (tx, ch, cw, hwsz, hard, orien) + +pointer tx # pointer to text attribute structure +int ch, cw # character height, width, GKI coords +int hwsz # size index if hardware character +bool hard # use/dontuse hardware character generation +int orien # rotation angle of character (0=normal) + +int sz, quality +real txsize, aspect, q +int stg_txsize() +real ttygetr() +include "stdgraph.com" + +begin + sz = TX_SIZE(tx) + if (g_hardchar == 0) + quality = TX_QUALITY(tx) + else + quality = g_hardchar + hard = (quality != GT_MEDIUM && quality != GT_HIGH) + + # Get character size in GKI units. + if (hard) { + hwsz = stg_txsize (sz) + ch = SG_CHARHEIGHT(g_sg,hwsz) + cw = SG_CHARWIDTH (g_sg,hwsz) + + } else { + # If character generation is in software scale character sizes + # by the size of the size 1 hardware character. If the character + # is rotated correct for the device aspect ratio so that the + # character comes out the same size regardless of the orientation. + + txsize = GKI_UNPACKREAL(sz) + cw = SG_CHARWIDTH (g_sg,1) * txsize + ch = SG_CHARHEIGHT(g_sg,1) * txsize + + if (orien != 0) { + aspect = ttygetr (g_tty, "ar") + if (aspect > EPSILON && abs (aspect - 1.0) > .01) { + q = 1.0 + abs(sin(real(orien))) * (aspect - 1.0) + cw = cw / q + ch = ch * q + } + } + } +end diff --git a/sys/gio/stdgraph/stgtxqual.x b/sys/gio/stdgraph/stgtxqual.x new file mode 100644 index 00000000..122cf303 --- /dev/null +++ b/sys/gio/stdgraph/stgtxqual.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_TXQUALITY -- Select the type of character generator to be used. If the +# selected flag value is 0 this decision will be deferred to the set text +# attribute instruction at runtime (default). + +procedure stg_txquality (quality) + +int quality # text generation quality flag +include "stdgraph.com" + +begin + g_hardchar = quality +end diff --git a/sys/gio/stdgraph/stgtxset.x b/sys/gio/stdgraph/stgtxset.x new file mode 100644 index 00000000..8db3e8c3 --- /dev/null +++ b/sys/gio/stdgraph/stgtxset.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_TXSET -- Set the text drawing attributes. + +procedure stg_txset (gki) + +short gki[ARB] # attribute structure +pointer tx +include "stdgraph.com" + +begin + tx = SG_TXAP(g_sg) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + # Unpack the packed-real character spacing parameter. + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + + # The character size is left as a packed real as we must defer the + # decision to use a discreet hardware character size or to draw + # characters in software. + + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/stdgraph/stgtxsize.x b/sys/gio/stdgraph/stgtxsize.x new file mode 100644 index 00000000..71829e04 --- /dev/null +++ b/sys/gio/stdgraph/stgtxsize.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_TXSIZE -- Given the relative character size as a packed real, select +# the discreet closest device character size. + +int procedure stg_txsize (pksize) + +int pksize # packed real relative character size +int i, best_size +real txsize, diff, least_diff +include "stdgraph.com" + +begin + txsize = GKI_UNPACKREAL (pksize) + + best_size = 1 + least_diff = abs (txsize - SG_CHARSIZE(g_sg,1)) + + do i = 2, SG_NCHARSIZES(g_sg) { + diff = abs (txsize - SG_CHARSIZE(g_sg,i)) + if (diff < least_diff) { + best_size = i + least_diff = diff + } + } + + return (best_size) +end diff --git a/sys/gio/stdgraph/stgunkown.x b/sys/gio/stdgraph/stgunkown.x new file mode 100644 index 00000000..55327b62 --- /dev/null +++ b/sys/gio/stdgraph/stgunkown.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STG_UNKNOWN -- The unknown instruction. Called by the interpreter whenever +# an unrecognized opcode is encountered. Should never be called. + +procedure stg_unknown (gki) + +short gki[ARB] # the GKI instruction +int fd, verbose +common /stgcom/ fd, verbose + +begin + call fprintf (fd, "unknown\n") +end diff --git a/sys/gio/stdgraph/stgwtty.x b/sys/gio/stdgraph/stgwtty.x new file mode 100644 index 00000000..c01bd93c --- /dev/null +++ b/sys/gio/stdgraph/stgwtty.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_WRITETTY -- Write one or more lines of text to the terminal in text +# mode. If the workstation is currently activated normal output is to the +# status line, otherwise output is to the indicated stream (STDOUT or +# STDERR). If the worstation is activated and the text to be output is +# preceded by the EM code, the text is a message being sent by GIO to a user +# interface parameter, and the text is passed on as is without formatting for +# the status line. +# +# Terminal output is directed to the status line by the GD sequence, and +# graphics output is reenabled by the GE sequence. The output text should +# consist of only a single line, but if multiple lines are present they are +# output line by line, without the trailing newline, since the status line +# can display only a single line of text. +# +# NOTE - If output occurs while in graphics mode and the output text is newline +# terminated, the GE (graphics enable) sequence is output to restore the +# terminal to graphics mode before exiting. If the text is not newline +# terminated, e.g., if it is a prompt, the workstation is left in alpha mode, +# ready for a read from STDIN. Thus one can write a prompt to STDOUT and read +# the user response from STDIN, while in graphics mode. +# +# This procedure is called by pseudofile i/o (gio/cursor/prpsio) whenever a +# task writes to STDOUT or STDERR. + +procedure stg_writetty (fd, text, nchars) + +int fd #I output stream +char text[ARB] #I text to be output +int nchars #I nchars to be written + +int ip, delim +pointer sp, lbuf, op +include "stdgraph.com" +bool ttygetb() +errchk write + +begin + if (g_active == NO) { + # Workstation not activated (normal text mode); normal text output. + call write (fd, text, nchars) + call flush (fd) + + } else if (text[1] == EM || g_message == YES) { + # Workstation is activated; the output text is a message to be + # sent to a UI parameter. The output stream is assumed to be + # flushed before and after a UI message, so we assume that the + # control codes used to bracket the message are the first and + # last characters in the output write packets. Multiple writes + # may be used to write output text, and messages can be any + # length. If the output device does not support messaging (no + # "EM" capability) the messages are discarded. + + g_message = YES + if (ttygetb (g_tty, "EM")) + call write (g_out, text, nchars) + delim = text[nchars] + if (delim == GS || delim == US) + g_message = NO + + } else { + # Workstation is activated; write to status line. Writing + # anything when graphics is enabled causes the status line to be + # cleared; newline causes a graphics enable; the string "\n\n" + # will always clear the status line and leave the terminal in + # graphics mode, regardless of the state of g_enable when issued. + + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + if (g_enable == YES) + call stg_gdisab() + + op = lbuf + for (ip=1; ip <= nchars; ip=ip+1) { + if (text[ip] == '\n') { + if (g_enable == YES) + call stg_gdisab() + if (op > lbuf) + call write (g_out, Memc[lbuf], op-lbuf) + call stg_genab() + op = lbuf + } else { + Memc[op] = text[ip] + op = min (lbuf+SZ_LINE, op+1) + } + } + + # Output a partial line, leaving graphics disabled. + if (op > lbuf) { + if (g_enable == YES) + call stg_gdisab() + call write (g_out, Memc[lbuf], op-lbuf) + } + + call flush (g_out) + call sfree (sp) + } +end + + +# STG_PUTLINE -- Output an EOS delimited line of text to the graphics terminal +# with stg_writetty. + +procedure stg_putline (fd, text) + +int fd # output file +char text[ARB] # EOS delimited line of text +int strlen() + +begin + call stg_writetty (fd, text, strlen(text)) +end diff --git a/sys/gio/stdgraph/t_gkideco.x b/sys/gio/stdgraph/t_gkideco.x new file mode 100644 index 00000000..200cf33a --- /dev/null +++ b/sys/gio/stdgraph/t_gkideco.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKIDECODE -- Decode the contents of one or more metacode files, printing +# the decoded metacode instructions in readable form on the standard output. + +procedure t_gkidecode() + +int fd, list, verbose, gkiunits +pointer gki, sp, fname +int dd[LEN_GKIDD] + +bool clgetb() +int clpopni(), clgfil(), clplen(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + if (clgetb ("generic")) { + verbose = NO + gkiunits = NO + } else { + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Set up the decoding graphics kernel. + call gkp_install (dd, STDOUT, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Print header if new file. + if (clplen (list) > 1) { + call printf ("\n# METAFILE '%s':\n") + call pargstr (Memc[fname]) + } + + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } else + call gkp_grstream (fd) + + # Process the metacode. + while (gki_fetch_next_instruction (fd, gki) != EOF) + call gki_execute (Mems[gki], dd) + + call close (fd) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/stdgraph/t_showcap.x b/sys/gio/stdgraph/t_showcap.x new file mode 100644 index 00000000..ddb8407c --- /dev/null +++ b/sys/gio/stdgraph/t_showcap.x @@ -0,0 +1,210 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +define SZ_PROGRAM 256 +define MAXARGSTR 15 + + +# SHOWCAP - Show the ascii control string sent to a device to implement a +# control function. Useful for testing graphcap entries. + +procedure t_showcap() + +char cap[2] +int g_reg[NREGISTERS] +char g_mem[SZ_MEMORY] +char argstr[MAXARGSTR] +int arg1, arg2, arg3, op, len_prog, status, nchars +pointer tty, sp, prog, ip, cmd +pointer ttygdes(), ttycaps() +int stg_encode(), ctoi(), getline(), strncmp() +int ttygets(), ctowrd(), strlen() +bool ttygetb(), streq() +define getargs_ 91 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (prog, SZ_PROGRAM, TY_CHAR) + + # Print instructions. + call printf ("cmd : `set' device\n") + call printf (" | `*' (to dump full graphcap entry\n") + call printf (" | cc [arg1 [arg2 [arg3]]]\n") + call printf (" ;\n") + call printf ("\n") + call printf ("cc : a two chararacter capcode (e.g., 'cm')\n") + call printf (" | an encoder program (non alpha first char)\n") + call printf (" ;\n") + call printf ("\n") + + # Interpret and translate control commands until EOF or "bye" + # is typed. + + tty = NULL + + repeat { + # Prompt for input. + call printf ("* ") + call flush (STDOUT) + + if (getline (STDIN, Memc[cmd]) == EOF) { + call printf ("\n") + break + } + + for (ip=cmd; IS_WHITE (Memc[ip]); ip=ip+1) + ; + + if (Memc[ip] == '\n') { + next + } else if (strncmp (Memc[ip], "set", 3) == 0) { + ip = ip + 3 + len_prog = ctowrd (Memc, ip, Memc[prog], SZ_PROGRAM) + if (tty != NULL) + call ttycdes (tty) + tty = ttygdes (Memc[prog]) + call sgc_dump (STDOUT, Memc[ttycaps(tty)], + strlen (Memc[ttycaps(tty)])) + next + } else if (Memc[ip] == '*') { + call sgc_dump (STDOUT, Memc[ttycaps(tty)], + strlen (Memc[ttycaps(tty)])) + next + } else if (!IS_ALPHA (Memc[ip])) { + len_prog = ctowrd (Memc, ip, Memc[prog], SZ_PROGRAM) + cap[1] = EOS + goto getargs_ + } else if (strncmp (Memc[ip], "bye", 3) == 0) + break + + # Parse command with optional arguments, e.g., "RC 1". + # Extract 2 character capability name (required). + + op = 1 + while (IS_ALNUM(Memc[ip])) { + cap[op] = Memc[ip] + ip = ip + 1 + op = min (2, op + 1) + } + cap[3] = EOS +getargs_ + # Argument type depends on whether encoding or decoding. + if (streq ("SC", cap)) { + nchars = ctowrd (Memc, ip, argstr, MAXARGSTR) + if (nchars == 0) { + call printf ("SC must have 1 contiguous string argument\n") + next + } + + } else { + # Extract up to three arguments (optional). + if (ctoi (Memc, ip, arg1) <= 0) + arg1 = 0 + if (ctoi (Memc, ip, arg2) <= 0) + arg2 = 0 + if (ctoi (Memc, ip, arg3) <= 0) + arg3 = 0 + } + + # Fetch the program from the graphcap file. Zero is returned if + # the device does not have the named capability, in which case + # the function is inapplicable and should be ignored. + + if (cap[1] != EOS) + if (tty == NULL) { + call printf ("use `set' to specify device name\n") + next + } else + len_prog = ttygets (tty, cap, Memc[prog], SZ_PROGRAM) + + if (len_prog > 0) { + if (Memc[prog] == '#') + call sgc_dump (STDOUT, Memc[prog+1], len_prog - 1) + else { + # Dump the program on the standard output. + if (cap[1] != EOS) { + call printf ("program: ") + call sgc_dump (STDOUT, Memc[prog], len_prog) + } + + # Set memory or registers depending on whether encoding or + # decoding. + if (streq ("SC", cap)) + call strcpy (argstr, g_mem, nchars) + + else { + g_reg[1] = arg1 + g_reg[2] = arg2 + g_reg[3] = arg3 + } + g_reg[E_IOP] = 1 + g_reg[E_TOP] = SZ_MEMORY + + # If scan_cursor, decode the input string and write the + # registers to the output file. Else, encode the output + # string and write the encoded string to the output file. + + status = stg_encode (Memc[prog], g_mem, g_reg) + if (status == OK) { + nchars = g_reg[E_IOP] - 1 + + if (streq ("SC", cap)) { + call printf ("X(R1)=%d, Y(R2)=%d, key=%c\n") + call pargi (g_reg[1]) + call pargi (g_reg[2]) + call pargi (g_reg[3]) + } else { + call printf ("encoding: ") + call sgc_dump (STDOUT, g_mem, nchars) + } + + } else + call printf ("error encoding control string\n") + call printf (" status = %d\n") + call pargi (status) + } + + } else if (len_prog == 0) + if (ttygetb (tty, cap)) + call printf ("boolean capability is true\n") + + else { + call printf ("device capability `%s' not found\n") + call pargstr (cap) + } + } + + if (tty != NULL) + call ttycdes (tty) + call sfree (sp) +end + + +# SGC_DUMP -- Dump a sequence of ascii characters in printable form. + +procedure sgc_dump (fd, data, nchars) + +int fd # output file +char data[ARB] # chars to be dumped +int nchars + +int ip +int col + +begin + col = 1 + for (ip=1; ip <= nchars; ip=ip+1) { + call putcc (fd, data[ip]) + if (data[ip] == ':' && col > 60) { + call putci (fd, '\\') + call putci (fd, '\n') + col = 1 + } else + col = col + 1 + } + + call putci (fd, '\n') +end diff --git a/sys/gio/stdgraph/t_stdgraph.x b/sys/gio/stdgraph/t_stdgraph.x new file mode 100644 index 00000000..8d6856fc --- /dev/null +++ b/sys/gio/stdgraph/t_stdgraph.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_TXQUALITY 1 + +# STDGRAPH -- Graphics kernel for the standard graphics output (interactive +# graphics terminal). + +procedure t_stdgraph() + +int fd, list +char txquality[SZ_TXQUALITY] +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits, xres, yres, quality +bool clgetb() +int clpopni(), clgfil(), open(), btoi(), clgeti() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + quality = 0 + xres = 0 + yres = 0 + + } else { + debug = btoi (clgetb ("debug")) + if (debug == YES) { + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Get the quality parameter for the text generator. + call clgstr ("txquality", txquality, SZ_TXQUALITY) + switch (txquality[1]) { + case 'l': + quality = GT_LOW + case 'm': + quality = GT_MEDIUM + case 'h': + quality = GT_HIGH + default: + quality = 0 + } + + xres = clgeti ("xres") + yres = clgeti ("yres") + } + + # Open the graphics kernel. + + call stg_open (Memc[devname], dev, STDIN, STDOUT, xres, yres, quality) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } else + call stg_grstream (fd) + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) + switch (Mems[gki+GKI_HDR_OPCODE-1]) { + case GKI_CLOSEWS, GKI_DEACTIVATEWS, GKI_REACTIVATEWS: + # These instructions are passed directly to the kernel via + # the PSIOCTRL stream at runtime, but are ignored in + # metacode to avoid unnecessary mode switching of the + # terminal. + ; + default: + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + # Make sure we finish with CLOSEWS so that the terminal is left in + # text mode. + + call stg_closews (NULL, NULL) + + # Finish up. + call gkp_close() + call stg_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/stdgraph/x_stdgraph.x b/sys/gio/stdgraph/x_stdgraph.x new file mode 100644 index 00000000..37c5a055 --- /dev/null +++ b/sys/gio/stdgraph/x_stdgraph.x @@ -0,0 +1,5 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task gkidecode = t_gkidecode, + stdgraph = t_stdgraph, + showcap = t_showcap diff --git a/sys/gio/stdgraph/zzdebug.x b/sys/gio/stdgraph/zzdebug.x new file mode 100644 index 00000000..ce11d4ea --- /dev/null +++ b/sys/gio/stdgraph/zzdebug.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task slio = t_slio + +procedure t_slio() + +pointer gp +char lbuf[SZ_LINE] +real x[5], y[5] + +pointer gopen() +int getline() + +begin + x[1] = .25; y[1] = .25 + x[2] = .75; y[2] = .25 + x[3] = .75; y[3] = .75 + x[4] = .25; y[4] = .75 + x[5] = .25; y[5] = .25 + + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + call gpline (gp, x, y, 5) + call gflush (gp) + + call putline (STDOUT, "enter text: ") + call flush (STDOUT) + + if (getline (STDIN, lbuf) != EOF) { + call zwmsec (3000) + call printf ("text = %s") + call pargstr (lbuf) + call flush (STDOUT) + } + + call zwmsec (3000) + call gclose (gp) +end diff --git a/sys/gio/wcstogki.x b/sys/gio/wcstogki.x new file mode 100644 index 00000000..e0591402 --- /dev/null +++ b/sys/gio/wcstogki.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPL_WCSTOGKI -- Transform world coordinates to GKI coordinates using the +# cached transformation parameters. There are three possible types of scaling +# on either axis, linear, log, and "elog". The latter is a piecewise log +# scaling function defined for all X, i.e., for negative as well as positive +# X (see elogr.x). If a negative number is transformed with normal log +# scaling it is treated as an indefinite, i.e., plotted as a gap in the plot. + +procedure gpl_wcstogki (gp, wx, wy, mx, my) + +pointer gp # graphics device descriptor +real wx, wy # world coordinates of point +real mx, my # metacode coordinates of point + +real x, y +real elogr() +include "gpl.com" + +begin + # Update cached transformation parameters if device changes, cache + # has been invalidated, or the current WCS has been changed. + + if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Transform the coordinates. + + if (xtran == LINEAR) { + x = wx + } else if (xtran == LOG) { + if (wx <= 0) { + call gpl_flush() + return + } else + x = log10 (wx) + } else + x = elogr (wx) + + if (ytran == LINEAR) { + y = wy + } else if (ytran == LOG) { + if (wy <= 0) { + call gpl_flush() + return + } else + y = log10 (wy) + } else + y = elogr (wy) + + # Return real rather than int GKI coordinates to avoid digitization + # errors in a sequence of draws relative to the current pen position. + + mx = max (0.0, min (real(GKI_MAXNDC), + ((x - wxorigin) * xscale) + mxorigin)) + my = max (0.0, min (real(GKI_MAXNDC), + ((y - wyorigin) * yscale) + myorigin)) +end diff --git a/sys/gio/zzdebug.x b/sys/gio/zzdebug.x new file mode 100644 index 00000000..e806ee23 --- /dev/null +++ b/sys/gio/zzdebug.x @@ -0,0 +1,392 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define MAXPTS 20 + +task plot1, plot2, plot3, plot4, plot5, plot6, plot7, plot8, + balls, ticks, vdm + + +procedure plot1() + +real v[5] +int i +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 5 + v[i] = i ** 2 + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gswind (gp, 1., 5., INDEF, INDEF) + call gascale (gp, v, 5, 2) + call glabax (gp, "Y = X ** 2", "X-AXIS", "Y-AXIS") + call gvline (gp, v, 5, 1., 5.) + + call gclose (gp) + call close (fd) +end + + +procedure plot2() + +int i +real x[512], y[512] +real xc, yc, xs, ys +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = ((i - 256.0) / 16.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 512) + + xc = 8 + yc = .25 + xs = 3.2 + ys = 0.1 + + do i = 1, 10 { + call gmark (gp, xc, yc, GM_CIRCLE, -xs, -ys) + xc = xc + xs / 5 + yc = yc + ys / 5 + xs = xs * 1.25 + ys = ys * 1.5 + } + + call gclose (gp) + call close (fd) +end + + +procedure plot3() + +int i +real x[512], y[512] +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = ((i - 256.0) / 8.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_DRAWGRID, YES) + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 512) + + call gclose (gp) + call close (fd) +end + + +procedure plot4() + +int i +real x[512], y[512] +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = (i - 256.0) / 4. + if (abs(x[i]) < EPSILON) + y[i] = 2.0 * 1E4 + else + y[i] = (sin (x[i]) / x[i] + 1.0) * 1E4 + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_YTRAN, GW_LOG) + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "Log of The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 512) + + call gclose (gp) + call close (fd) +end + + +procedure plot5() + +int fd +int open(), clgeti() +real x1, x2, clgetr() +pointer gp, gopen() + +begin + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + x1 = clgetr ("x1") + x2 = clgetr ("x2") + + call gseti (gp, G_NMINOR, clgeti ("nminor")) + call gseti (gp, G_XTRAN, GW_LOG) + call gseti (gp, G_YTRAN, GW_LOG) + call gsetr (gp, G_MINORWIDTH, 1.0) + call gswind (gp, x1, x2, 0.001, 1000.0) + call glabax (gp, "Log Scaling", "X-AXIS", "Y-AXIS") + + call gclose (gp) + call close (fd) +end + + +procedure plot6() + +int i +long seed +real size, urand() +int fd, open(), clgeti() +pointer gp, gopen() +data seed /3/ + +begin + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_ASPECT, clgeti("aspect")) + call glabax (gp, "", "", "") + + do i = 1, 300 { + size = real (nint (urand(seed) * 4 + .5)) + call gmark (gp, urand(seed), urand(seed), GM_BOX, size, size) + } + + call gclose (gp) + call close (fd) +end + + +procedure plot7() + +int i +real x[8192], y[8192] +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 8192 { + x[i] = ((i - 4096.0) / 128.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + y[i] = y[i] + cos ((i-1) * 0.392699) * .001 + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_DRAWGRID, YES) + call gascale (gp, x, 8192, 1) + call gascale (gp, y, 8192, 2) + call glabax (gp, "The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 8192) + + call gclose (gp) + call close (fd) +end + + +procedure balls() + +int i, j, m, npts, nsteps +long seed +real p[MAXPTS,2], d[MAXPTS,2] +real urand() +int fd, open(), clgeti() +pointer gp, gopen() + +begin + npts = max(1, min(MAXPTS, clgeti ("npoints"))) + nsteps = max (10, clgeti ("nsteps")) + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + # call glabax (gp, "Bouncing Balls", "", "") + + # Set the initial conditions. + do i = 1, npts + do j = 1, 2 { + p[i,j] = urand (seed) + d[i,j] = max (0.01, urand (seed) * .1) + if (mod (i, 2) == 0) + d[i,j] = -d[i,j] + } + + # Draw the trajectories. + do m = 1, nsteps + do i = 1, npts { + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, p[i,1], p[i,2], GM_DIAMOND, 4., 4.) + + do j = 1, 2 { + p[i,j] = p[i,j] + d[i,j] + if (p[i,j] < 0) { + p[i,j] = -p[i,j] + d[i,j] = -d[i,j] + } else if (p[i,j] > 1) { + p[i,j] = 1 - (p[i,j] - 1) + d[i,j] = -d[i,j] + } + } + + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gmark (gp, p[i,1], p[i,2], GM_DIAMOND, 4., 4.) + + call gflush (gp) + } + + call gclose (gp) + call close (fd) +end + + +procedure ticks() + +real x1, x2, p1, p2 +int rough_nticks +int logflag +real tick1, step, linearity + +bool clgetb() +int btoi(), clgeti() +real gt_linearity(), clgetr(), elogr() + +begin + x1 = clgetr ("x1") + x2 = clgetr ("x2") + rough_nticks = clgeti ("nticks") + logflag = btoi (clgetb ("log")) + + if (logflag == YES) { + p1 = elogr (x1) + p2 = elogr (x2) + } else { + p1 = x1 + p2 = x2 + } + + linearity = gt_linearity (x1, x2) + call gtickr (p1, p2, rough_nticks, logflag, tick1, step) + + call printf ("tick1=%g, step=%g, linearity=%g\n") + call pargr (tick1) + call pargr (step) + call pargr (linearity) +end + + +procedure plot8() + +int i +real x[512], y[512] +int fd +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = ((i - 256.0) / 8.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + } + + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_DRAWAXES, 1) + call gseti (gp, G_SETAXISPOS, YES) + call gsetr (gp, G_AXISPOS1, 0.0) + + call gseti (gp, G_DRAWGRID, YES) + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "", "", "") + call gpline (gp, x, y, 512) + call gtext (gp, -20., 0.80, "The Sinc Function", "hj=c,vj=b") + call gtext (gp, -20., 0.75, "y = sin(x) / x", "hj=c,vj=b") + + call gclose (gp) + call close (fd) +end + + +# VDM -- Test output of a plot to the virtual device metafile. + +procedure vdm() + +real v[5] +int i +pointer gp, gopen() + +begin + do i = 1, 5 + v[i] = i ** 2 + + gp = gopen ("vdm", NEW_FILE, STDGRAPH) + + call gswind (gp, 1., 5., INDEF, INDEF) + call gascale (gp, v, 5, 2) + call glabax (gp, "Y = X ** 2", "X-AXIS", "Y-AXIS") + call gvline (gp, v, 5, 1., 5.) + + call gclose (gp) +end -- cgit