************************************************************************* * CALCOMP TO REGIS INTERFACE * * * * Developed by Dr. Michael Peterson * * Remote Sensing Applications Lab * * University of Nebraska at Omaha * * Omaha, Nebraska 68182 * * * * (402) 554-2726 * * * * This set of subroutines can be substituted for * * the supplied Calcomp subroutines for use with Regis * * compatible devices. * * * * Known differences: * * * * 1) The subroutine OUTPUT must be used to initialize * * the output unit in the package. * * * * 2) In subroutines SYMBOL and NUMBER, the position * * 999,999 in the parameter list do not work as * * the Calcomp version. (Since the location of the * * plotters pen is not applicable to regis devices) * * * * To compile these subroutines with source code: * * * * $ FORTRAN filename+CAL * * $ LINK filename * * $ run filename * * or * * $ FORTRAN filename * * $ LINK filename,CAL * * $ RUN filename * * * subroutine output (ifile) write(6,890) 890 format(//5x,'Output unit selection:') c 3 /8x,'5 = input unit, not definable as output unit', c 5 /8x,'all other numbers will open an output file called PLOT.OUT', c .. c .. read file specification read (5,*) ifile if(ifile .eq. 5) ifile=6 return end subroutine gginit common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave write(iunit,*) char(155),'Pp' return end subroutine error(istring,ilen) call newpen(7) call symbol(.1,.30,.0625,'*** ERROR ***',0.0,13) call symbol(.1,0.1,.0625,istring,0.0,ilen) return end subroutine screen common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave write(iunit,900) 900 format(' S(e)') return end subroutine plots (x,y,iplot) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave data fact,xorigin,yorigin,iunit/1.0,0.0,0.0,6/ if (iplot .eq. 999) goto 999 if(iplot .eq. 0) goto 200 if (iplot .ne. 6) open (unit=iplot,file='plot.out',status='new') iunit=iplot c ,. c .. initiate gigi graphics call gginit 200 call screen return 999 call efplot return end subroutine plot (x1,y1,iplot) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave x=x1 y=y1 c .. c .. relate x and y to current origin x=(x*fact)+xorigin y=(y*fact)+yorigin c .. c .. save the current x and y value ysave=y xsave=x c .. c .. convert to gigi screen coordinates ix=nint((x*767)/11.5) iy=nint((y*479)/9.0) iy=479-iy c .. c .. check if ix and iy within gigi visible window if (iy.lt.0.or.iy.gt.479.or.ix.lt.0.or.ix.gt.767) 2 call error ('plot: x or y exceeds screen coordinates',39) c .. c .. switch-off based on iplot parameter if (iplot .eq. 2 .or. iplot .eq. 3) goto 200 if (iplot .eq.-2 .or. iplot .eq.-3) goto 500 call error('plot: iplot does not have an acceptable value',45) return 200 if (iplot .eq. 3) goto 300 c .. c .. plot line to x,y position write(iunit,900) ix,iy 900 format(' v[',i3,',',i3,']') return c .. c .. move to x,y position 300 write(iunit,910) ix,iy 910 format(' p[',i3,',',i3,']') return c .. c .. reset origin with a plotted line 500 if (iplot .eq. -3) goto 600 write(iunit,900) ix,iy xorigin=x yorigin=y return c .. c .. reset origin with no line plotted 600 write(iunit,910) ix,iy xorigin=x yorigin=y return end subroutine symbol (x,y,hgt,istr,ang,nchar) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave dimension istr(20) c .. c .. check angle iang=nint(ang) if (iang .ge. 0 .and. iang .le. 360) goto 50 call error ('symbol: angle not within 0 to +360 range',40) return c .. c .. classify height into one of the 17 allowable gigi heights 50 call clashgt (hgt, iht, is) c .. c .. move to position for lettering call plot (x,y,3) c .. c .. compute length of character string ilen=int(nchar/4.0)+1 write(iunit,900) iang,is,iht,iang,(istr(kk),kk=1,ilen), 2 char(39) 900 format(' t(w(r))(d',i3,' s',i2,' h',i2,') (d',i3,')', 2 '''',20a4,a1) return end subroutine number (x,y,hgt,fpn,ang,ndec) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave character*12 istring c .. c .. convert floating point number to string encode (12,900,istring) fpn 900 format(f12.) c .. c .. check angle iang=nint(ang) if (iang .ge. 0 .and. iang .le. 360) go to 50 call error ('number: angle not within 0 to +360 range',40) return c .. c .. classify height into one of the 17 allowable gigi heights 50 call clashgt (hgt, iht, is) c .. c .. move to position for symbol plotting call plot (x,y,3) c .. c .. write number using gigi format write(iunit,910) iang,is,iht,iang,istring,char(39) 910 format(' t(w(r))(d',i3,' s',i2,' h',i2,') (d',i3,')', 2 '''',a12,a1) return end subroutine clashgt (hgt, iht, is) dimension heights(17) data heights /.03125,.0625,.125,.1875,.25,.3125,.3750, 2 .4375,.5,.5625,.6250,.6875,.75,.8125,.875,.9375,1.0/ if (hgt .lt. heights(1)) iht=0 if (hgt .ge. heights(17)) iht=16 if (hgt .lt. heights(1) .or. hgt .gt. heights(17)) goto 400 do 100 i=1,16 hmid=(heights(i)+heights(i+1))/2.0 if (hgt .lt. heights(i+1) .and. hgt .ge. hmid) goto300 if (hgt .lt. hmid .and. hgt .ge. heights(i)) goto200 100 continue 300 iht = i goto 400 200 iht = i-1 c .. c .. variable 'is' represents the width of the letters 400 is = int(iht**0.6) return end subroutine efplot common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave call newpen(7) write(iunit,*) char(155),'\' return end subroutine newpen (icolor) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave if (icolor .lt. 0 .or. icolor .gt. 7) icolor=7 write(iunit,900) icolor 900 format(' w(i',i1,')') return end subroutine maxmin (v,n,vmin,vmax) dimension v(n) vmax=-1000000.0 vmin=1.0e15 do 100 i=1,n vmax = amax1 (v(i), vmax) vmin = amin1 (v(i), vmin) 100 continue return end subroutine xyscale (x,y,n,xlow,xhigh,ylow,yhigh) dimension x(n), y(n) call maxmin (x,n,xmin,xmax) call maxmin (y,n,ymin,ymax) c .. c .. determine delta-x and delta-y in old and new coordinate system dxold = xmax - xmin dyold = ymax - ymin c write(6,*) 'dxold, xmax,xmin', dxold,xmax,xmin dxnew = xhigh - xlow dynew = yhigh - ylow c write(6,*) 'dxnew,dynew,xhigh,xlow,yhigh,ylow' c write(6,*) dxnew,dynew,xhigh,xlow,yhigh,ylow c .. c .. check for division by zero if (dxold .eq. 0.0 .or. dyold .eq. 0.0) return factx = dxnew / dxold facty = dynew / dyold c write(6,*) 'factx,facty,dxnew,dxold,dynew,dyold' c write(6,*) factx,facty,dxnew,dxold,dynew,dyold c .. c .. scale to new coordinate system do 100 i=1,n x(i) = abs (x(i) - xmin) * factx + xlow y(i) = abs (y(i) - ymin) * facty + ylow c write(6,*) x(i),y(i) 100 continue return end subroutine xyline (x,y,n) dimension x(n), y(n) call plot (x(1),y(1),3) do 100 i = 2,n call plot (x(i),y(i),2) 100 continue return end subroutine factor (fac1) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave fact=fac1 return end subroutine where (x1,y1,fac1) common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave x1=xsave y1=ysave fac1=fact return end subroutine paper common /plotvar/fact,xorigin,yorigin,iunit,xsave,ysave write(iunit,900) 900 format(' (H[,0][,479])') return end subroutine rotate (x,y,n,ang) c ************************************************************** c c .. ang = counterclockwise angle that brings the original c points into the desired rotation. c c ************************************************************** dimension x(n), y(n) data radconv /57.29578/ c .. c .. if ang out of range, no rotation is performed if (ang .le. 0.0 .or. ang .ge. 360) return c .. c .. convert ang to a radian measure radang = ang / radconv c .. c .. rotate coordinates by ang u = cos (radang) v = sin (radang) do 100 i = 1, n tempx = x(i) * u + y(i) * v y(i) = -x(i) * v + y(i) * u x(i) = tempx 100 continue return end subroutine vecdisp (x,y,n,nxcol) dimension x(n), y(n) character*1 outmap(200,132) data xchrdim, ychrdim /0.10, 0.125/ c .. c .. initialize imax to a low number imax = -1000000 c .. c .. fill outmap with blanks do 50 i=1,200 do 50 j=1,132 outmap(i,j) = ' ' 50 continue c .. c .. compute the scaling factor for the x-direction xdim = ((nxcol * 13.0) / 132.0) * (xchrdim * 10.0) c .. c .. call scaling subroutine c write(6,905) (x(i),y(i),i=1,n) call xyscale (x, y, n, 0.0, xdim, 0.0, xdim) c .. c write(6,905) (x(i),y(i),i=1,n) 905 format(2f20.4) c .. c .. compute maximum y value call maxmin (y,n,ymin,ymax) c .. c .. loop to do vector to raster conversion do 100 k=1,n i = 1 + int (( ymax - y(k)) / ychrdim ) j = 1 + int ( x(k) / xchrdim ) c write(6,*) 'i= ',i,'j= ',j c .. c .. check if i and j with limits of array outmap if (i .lt. 1 .or. i .gt. 200) goto 100 if (j .lt. 1 .or. j .gt. 132) goto 100 c .. c .. determine maximum value for I imax = amax0 (i,imax) c .. c .. put astericks in outmap character array outmap(i,j) = '*' 100 continue c .. c .. write out outmap character array c write(6,*) imax do 200 i=1,imax write(6,900) (outmap(i,j),j=1,nxcol) 200 continue 900 format(a1) return end