diff options
Diffstat (limited to 'sys/gio/nspp')
69 files changed, 3285 insertions, 0 deletions
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 <mach.h> +include <error.h> +include <ctype.h> + +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 <error.h> + +# 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 <nspp.h> + +# 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 <mach.h> + +# 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 <mach.h> + +# 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 <ctype.h> <error.h> <mach.h> + fulib.x <error.h> + intt.x <nspp.h> + ishift.x <mach.h> + loc.x <mach.h> + mcswap.x + ncgchr.x + ncpchr.x + packum.x <mach.h> <nspp.h> 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 <mach.h> +include <nspp.h> + +# 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 |