diff options
| author | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
|---|---|---|
| committer | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
| commit | 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 (patch) | |
| tree | 4464880c571602d54f6ae114729bf62a89518057 /sys/gio/nspp/portlib | |
| download | iraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz | |
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'sys/gio/nspp/portlib')
49 files changed, 2315 insertions, 0 deletions
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 |