700 lines
20 KiB
Fortran
700 lines
20 KiB
Fortran
C PLOT89
|
|
C AUTHOR: RODGER STADEN
|
|
C
|
|
C 13-8-92 new organisation: let pl4010 do device scaling and hardwire
|
|
C it for 1023x768
|
|
C
|
|
C
|
|
C 25-1-90 XHAIRN changed order of arguments to diabox and fmt4ln
|
|
C so that horizontal and vertical sequences were consistent
|
|
C with rest of sip
|
|
C 5-4-90 Removed ndc and put it in pl4010. added redir
|
|
C 4-5-90 Added the new routines for sap
|
|
C 14-11-90 Replaced radio by radion
|
|
C 2-3-92 set filnam = ' ' for calls to openf1
|
|
C ROUTINES IN THIS LIBRARY
|
|
C
|
|
C LINE
|
|
C POINT
|
|
C FRAME
|
|
C TEXT
|
|
C RULER
|
|
C SCALES
|
|
C BLIP
|
|
C XHAIRS
|
|
C XHAIRN
|
|
C INQGT
|
|
C REDIR
|
|
C line
|
|
SUBROUTINE LINE(XF,XT,YF,YT,XMAX,XMIN,YMAX,YMIN,
|
|
+IX0,IXLEN,IY0,IYLEN,ISXMAX,ISYMAX)
|
|
C AUTHOR: RODGER STADEN
|
|
C DRAWS A LINE FROM XF,YF TO XT,YT. COORDINATE SYSTEMS ARE
|
|
C 1) WORLD SYSTEM: XMIN TO XMAX, YMIN TO YMAX
|
|
C 2) DRAWING BOARD 0 TO ISXMAX, 0 TO ISYMAX
|
|
C 3) DEVICE COORDINATES 0 TO MAXDVX, 0 TO MAXDVY
|
|
C THE POSITION OF THE PLOT IS DEFINED IN THE DRAWING BOARD SYSTEM BY A
|
|
C BOX STARTING AT IX0,IY0 WITH SIDES IXLEN, IYLEN (IN DRAWING BOARD UNITS)
|
|
C RANGE IN WORLD COORDS
|
|
RANGWX=XMAX-XMIN
|
|
IF(RANGWX.EQ.0.0)RETURN
|
|
RANGWY=YMAX-YMIN
|
|
IF(RANGWY.EQ.0.0)RETURN
|
|
C CLIP
|
|
CALL CLIP(XF,XMAX,XMIN,YF,YMAX,YMIN,XFF,YFF)
|
|
CALL CLIP(XT,XMAX,XMIN,YT,YMAX,YMIN,XTT,YTT)
|
|
C PROPORTIONAL X POSITIONS
|
|
XWF=(XFF-XMIN)/RANGWX
|
|
XWT=(XTT-XMIN)/RANGWX
|
|
C PROPORTIONAL Y POSITIONS
|
|
YWF=(YFF-YMIN)/RANGWY
|
|
YWT=(YTT-YMIN)/RANGWY
|
|
C POSITIONS IN DRAWING BOARD UNITS
|
|
XDF=IX0+XWF*IXLEN
|
|
XDT=IX0+XWT*IXLEN
|
|
YDF=IY0+YWF*IYLEN
|
|
YDT=IY0+YWT*IYLEN
|
|
C POSITIONS IN DEVICE UNITS
|
|
IXF=NINT(XDF)
|
|
IXT=NINT(XDT)
|
|
IYF=NINT(YDF)
|
|
IYT=NINT(YDT)
|
|
C DRAW IT
|
|
CALL MOVEGR(IXF,IYF)
|
|
CALL DRAWGR(IXT,IYT)
|
|
END
|
|
C POINT
|
|
SUBROUTINE POINT(XF,YF,XMAX,XMIN,YMAX,YMIN,
|
|
+IX0,IXLEN,IY0,IYLEN,ISXMAX,ISYMAX)
|
|
C AUTHOR: RODGER STADEN
|
|
C DRAWS A POINT AT XF,YF. COORDINATE SYSTEMS ARE
|
|
C 1) WORLD SYSTEM: XMIN TO XMAX, YMIN TO YMAX
|
|
C 2) DRAWING BOARD 0 TO ISXMAX, 0 TO ISYMAX
|
|
C 3) DEVICE COORDINATES 0 TO MAXDVX, 0 TO MAXDVY
|
|
C THE POSITION OF THE PLOT IS DEFINED IN THE DRAWING BOARD SYSTEM BY A
|
|
C BOX STARTING AT IX0,IY0 WITH SIDES IXLEN, IYLEN (IN DRAWING BOARD UNITS)
|
|
C RANGE IN WORLD COORDS
|
|
RANGWX=XMAX-XMIN
|
|
IF(RANGWX.EQ.0.0)RETURN
|
|
RANGWY=YMAX-YMIN
|
|
IF(RANGWY.EQ.0.0)RETURN
|
|
C CLIP
|
|
CALL CLIP(XF,XMAX,XMIN,YF,YMAX,YMIN,XFF,YFF)
|
|
C PROPORTIONAL X POSITIONS
|
|
XWF=(XFF-XMIN)/RANGWX
|
|
C PROPORTIONAL Y POSITIONS
|
|
YWF=(YFF-YMIN)/RANGWY
|
|
C POSITIONS IN DRAWING BOARD UNITS
|
|
XDF=IX0+XWF*IXLEN
|
|
YDF=IY0+YWF*IYLEN
|
|
IXF=NINT(XDF)
|
|
IYF=NINT(YDF)
|
|
C PLOT IT
|
|
CALL POINTG(IXF,IYF)
|
|
END
|
|
SUBROUTINE FRAME(IX0,IXLEN,IY0,IYLEN,ISXMAX,ISYMAX)
|
|
C AUTHOR: RODGER STADEN
|
|
C DRAWS A BOX FROM IX0,IY0 OF SIDES IXLEN,IYLEN COORDINATE SYSTEMS ARE
|
|
C 2) DRAWING BOARD 0 TO ISXMAX, 0 TO ISYMAX
|
|
C 3) DEVICE COORDINATES 0 TO MAXDVX, 0 TO MAXDVY
|
|
IXF=IX0
|
|
IXT=IX0+IXLEN
|
|
IYF=IY0
|
|
IYT=IY0+IYLEN
|
|
CALL MOVEGR(IXF,IYF)
|
|
CALL DRAWGR(IXF,IYT)
|
|
CALL DRAWGR(IXT,IYT)
|
|
CALL DRAWGR(IXT,IYF)
|
|
CALL DRAWGR(IXF,IYF)
|
|
END
|
|
C TEXT
|
|
SUBROUTINE TEXT(XF,YF,CHARS,NCHARS,ISIZE,XMAX,XMIN,YMAX,YMIN,
|
|
+IX0,IXLEN,IY0,IYLEN,ISXMAX,ISYMAX)
|
|
C AUTHOR: RODGER STADEN
|
|
C CHARACTER CHARS(NCHARS)
|
|
CHARACTER CHARS*(*)
|
|
C WRITE TEXT AT XF,YF. COORDINATE SYSTEMS ARE
|
|
C 1) WORLD SYSTEM: XMIN TO XMAX, YMIN TO YMAX
|
|
C 2) DRAWING BOARD 0 TO ISXMAX, 0 TO ISYMAX
|
|
C 3) DEVICE COORDINATES 0 TO MAXDVX, 0 TO MAXDVY
|
|
C THE POSITION OF THE PLOT IS DEFINED IN THE DRAWING BOARD SYSTEM BY A
|
|
C BOX STARTING AT IX0,IY0 WITH SIDES IXLEN, IYLEN (IN DRAWING BOARD UNITS)
|
|
C RANGE IN WORLD COORDS
|
|
RANGWX=XMAX-XMIN
|
|
IF(RANGWX.EQ.0.0)RETURN
|
|
RANGWY=YMAX-YMIN
|
|
IF(RANGWY.EQ.0.0)RETURN
|
|
C CLIP
|
|
C IF OFF SCREEN DONT WRITE
|
|
IF(XF.GT.XMAX)RETURN
|
|
IF(XF.LT.XMIN)RETURN
|
|
IF(YF.GT.YMAX)RETURN
|
|
IF(YF.LT.YMIN)RETURN
|
|
C PROPORTIONAL X POSITIONS
|
|
XWF=(XF-XMIN)/RANGWX
|
|
C PROPORTIONAL Y POSITIONS
|
|
YWF=(YF-YMIN)/RANGWY
|
|
C POSITIONS IN DRAWING BOARD UNITS
|
|
XDF=IX0+XWF*IXLEN
|
|
YDF=IY0+YWF*IYLEN
|
|
IXF=NINT(XDF)
|
|
IYF=NINT(YDF)
|
|
C PLOT IT
|
|
CALL WRITET(IXF,IYF,CHARS,NCHARS)
|
|
END
|
|
SUBROUTINE SCALES(XMAX,XMIN,YMAX,YMIN,
|
|
+IX0,IXLEN,IY0,IYLEN,ISXMAX,ISYMAX,
|
|
+BIT,IBLIPH,FIRST,ISCALE)
|
|
C AUTHOR: RODGER STADEN
|
|
C ROUTINE TO PUT A SCALE ALONG AN AXIS EITHER X OR Y
|
|
C DEPENDING ON ISCALE (1=X,2=Y AXES)
|
|
C BLIPS OF HEIGHT IBLIPH ARE PLACED ALONG THE AXIS EVERY
|
|
C BIT OF LENGTH STARTING FROM FIRST. FIRST CAN BE USED
|
|
C TO MAKE SURE THAT A BLIP OCCURS AT A PARTICULAR POSITION
|
|
C FOR EXAMPLE AT A ZERO POINT, OTHERWISE FIRST IS SET TO
|
|
C XMIN OR YMIN
|
|
C 1) WORLD SYSTEM: XMIN TO XMAX, YMIN TO YMAX
|
|
C 2) DRAWING BOARD 0 TO ISXMAX, 0 TO ISYMAX
|
|
C 3) DEVICE COORDINATES 0 TO MAXDVX, 0 TO MAXDVY
|
|
C THE POSITION OF THE PLOT IS DEFINED IN THE DRAWING BOARD SYSTEM BY A
|
|
C BOX STARTING AT IX0,IY0 WITH SIDES IXLEN, IYLEN (IN DRAWING BOARD UNITS)
|
|
IF(ISCALE.EQ.1)THEN
|
|
C NUMBER OF POINTS
|
|
NP=1+(XMAX-FIRST)/BIT
|
|
C RANGE IN WORLD COORDS
|
|
RANGWX=XMAX-XMIN
|
|
IF(RANGWX.EQ.0.0)RETURN
|
|
C GET END POINTS IN Y
|
|
IYF=IY0
|
|
IYT=IY0+IBLIPH
|
|
C CALC AND PLOT POINTS
|
|
DO 10 I=1,NP
|
|
C PROPORTIONAL X POSITIONS
|
|
XFF=FIRST+(I-1)*BIT
|
|
XWF=(XFF-XMIN)/RANGWX
|
|
C POSITION IN DRAWING BOARD UNITS
|
|
XDF=IX0+XWF*IXLEN
|
|
IXF=NINT(XDF)
|
|
CALL MOVEGR(IXF,IYF)
|
|
CALL DRAWGR(IXF,IYT)
|
|
10 CONTINUE
|
|
END IF
|
|
IF(ISCALE.EQ.2)THEN
|
|
C NUMBER OF POINTS
|
|
NP=1+(YMAX-FIRST)/BIT
|
|
C RANGE IN WORLD COORDS
|
|
RANGWY=YMAX-YMIN
|
|
IF(RANGWY.EQ.0.0)RETURN
|
|
C GET END POINTS IN X
|
|
IXF=IX0
|
|
IXT=IX0+IBLIPH
|
|
C CALC AND PLOT POINTS
|
|
DO 20 I=1,NP
|
|
C PROPORTIONAL Y POSITIONS
|
|
YFF=FIRST+(I-1)*BIT
|
|
YWF=(YFF-YMIN)/RANGWY
|
|
C POSITION IN DRAWING BOARD UNITS
|
|
YDF=IY0+YWF*IYLEN
|
|
IYF=NINT(YDF)
|
|
CALL MOVEGR(IXF,IYF)
|
|
CALL DRAWGR(IXT,IYF)
|
|
20 CONTINUE
|
|
END IF
|
|
END
|
|
INTEGER FUNCTION IPSEP(XMAX,XMIN,NMAX)
|
|
C FIND SENSIBLE DEFAULT BLIP SEPARATION (SAY NMAX BLIPS PER PLOT)
|
|
D=XMAX-XMIN
|
|
IPSEP=D
|
|
IF(NMAX.LT.1)RETURN
|
|
NSEP=0
|
|
1 CONTINUE
|
|
NSEP=NSEP+1
|
|
D=D/NMAX
|
|
IF(D.GT.1.0)GO TO 1
|
|
IPSEP=NMAX**(NSEP-1)
|
|
END
|
|
SUBROUTINE XHAIRS(XMAX,XMIN,YMAX,YMIN,IX0,IXLEN,IY0,
|
|
+IYLEN,ISXMAX,ISYMAX,IHX,IHY,NCHAR,KBOUT)
|
|
C AUTHOR: RODGER STADEN
|
|
C WRITE(KBOUT,*)' CROSS HAIRS'
|
|
CHARACTER TERM,COMMA
|
|
PARAMETER (COMMA=',')
|
|
C RANGE IN WORLD COORDS
|
|
RANGWX=XMAX-XMIN
|
|
IF(RANGWX.EQ.0.0)RETURN
|
|
RANGWY=YMAX-YMIN
|
|
IF(RANGWY.EQ.0.0)RETURN
|
|
XFF=IHX
|
|
YFF=IHY
|
|
C PROPORTIONAL X POSITIONS
|
|
XWF=(XFF-XMIN)/RANGWX
|
|
C PROPORTIONAL Y POSITIONS
|
|
YWF=(YFF-YMIN)/RANGWY
|
|
C POSITIONS IN DRAWING BOARD UNITS
|
|
XDF=IX0+XWF*IXLEN
|
|
YDF=IY0+YWF*IYLEN
|
|
IXF=NINT(XDF)
|
|
IYF=NINT(YDF)
|
|
10 CONTINUE
|
|
CALL XHAIR(IXF,IYF,TERM)
|
|
C RETURNS POSITION IN DB UNITS. CONVERT TO DRAWING BOARD UNITS
|
|
C RELATIVE POSITIONS
|
|
XFF=IXF-IX0
|
|
YFF=IYF-IY0
|
|
XFF=XFF/IXLEN
|
|
YFF=YFF/IYLEN
|
|
C CONVERT TO WORLD UNITS
|
|
XFW=XMIN+XFF*RANGWX
|
|
YFW=YMIN+YFF*RANGWY
|
|
IHX=NINT(XFW)
|
|
IHY=NINT(YFW)
|
|
C BACK TO VT100 MODE
|
|
CALL VT100M
|
|
WRITE(KBOUT,1014)IHX,IHY
|
|
1014 FORMAT(' Cross hair at',2I7)
|
|
IF(TERM.EQ.COMMA)GO TO 10
|
|
END
|
|
SUBROUTINE LABLER(KBIN,KBOUT,
|
|
+ISXMAX,ISYMAX,
|
|
+IHELPS,IHELPE,HELPF,IDEVH)
|
|
CHARACTER LABEL*80,HELPF*(*)
|
|
CHARACTER LEFT,RIGHT,TERM,TUPPER
|
|
INTEGER CSIZE
|
|
EXTERNAL NOTIRL,TUPPER
|
|
PARAMETER (CSIZE=80)
|
|
PARAMETER (LEFT='L',RIGHT='R')
|
|
C FIDDLE TO CHECK ON GOING OFF SCREEN. ASSUME 80 CHARS PER SCREEN WIDTH
|
|
C NEED TO FIND WIDTH OF SCREEN IN DEVICE UNITS
|
|
CSCALE=ISXMAX/CSIZE
|
|
CALL CLEARV
|
|
WRITE(KBOUT,1004)
|
|
1004 FORMAT(
|
|
+' Type label then drive cross hair to left or right end',/,
|
|
+' of label position then hit "L" to write label left',/,
|
|
+' justified or "R" to write label right justified or',/,
|
|
+' the space bar to quit')
|
|
CALL BPAUSE(KBIN,KBOUT,IOK)
|
|
IF(IOK.NE.0) RETURN
|
|
10 CONTINUE
|
|
CALL VT100M
|
|
CALL CLEARV
|
|
LENGTH = 0
|
|
CALL GTSTR('Label',' ',LABEL,LENGTH,KBOUT,KBIN,INFLAG)
|
|
IF(INFLAG.EQ.1) THEN
|
|
CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
|
|
GO TO 10
|
|
END IF
|
|
IF(INFLAG.EQ.2) RETURN
|
|
IF(LENGTH.EQ.0) RETURN
|
|
20 CONTINUE
|
|
CALL XHAIR(IHX,IHY,TERM)
|
|
TERM = TUPPER(TERM)
|
|
IF((TERM.EQ.RIGHT).OR.(TERM.EQ.LEFT))THEN
|
|
IF(TERM.EQ.RIGHT)IHX=NINT(REAL(IHX)-LENGTH*CSCALE)
|
|
IF((IHX.LT.1).OR.((IHX+LENGTH*CSCALE).GT.ISXMAX))GO TO 10
|
|
CALL WRITET(IHX,IHY,LABEL,LENGTH)
|
|
GO TO 20
|
|
END IF
|
|
GO TO 10
|
|
END
|
|
SUBROUTINE CLIP(X1,XMAX,XMIN,Y1,YMAX,YMIN,X2,Y2)
|
|
C AUTHOR RODGER STADEN
|
|
C CLIPS COORDINATES IN USER UNITS
|
|
X2=MAX(X1,XMIN)
|
|
X2=MIN(X2,XMAX)
|
|
Y2=MAX(Y1,YMIN)
|
|
Y2=MIN(Y2,YMAX)
|
|
RETURN
|
|
END
|
|
SUBROUTINE XHAIRN(XMAX,XMIN,YMAX,YMIN,IX0,IXLEN,IY0,
|
|
+IYLEN,ISXMAX,ISYMAX,IHX,IHY,NCHAR,KBOUT,
|
|
+SEQ1,ISTAR1,IDIM1,SEQ2,ISTAR2,IDIM2,NSEQ)
|
|
C AUTHOR: RODGER STADEN
|
|
C WRITE(KBOUT,*)' CROSS HAIRS'
|
|
CHARACTER TERM,COMMA
|
|
PARAMETER (COMMA=',',ISPAN = 19)
|
|
CHARACTER SEQ1(IDIM1),SEQ2(IDIM2),MATCH(ISPAN)
|
|
C RANGE IN WORLD COORDS
|
|
RANGWX=XMAX-XMIN
|
|
IF(RANGWX.EQ.0.0)RETURN
|
|
RANGWY=YMAX-YMIN
|
|
IF(RANGWY.EQ.0.0)RETURN
|
|
XFF=IHX
|
|
YFF=IHY
|
|
C PROPORTIONAL X POSITIONS
|
|
XWF=(XFF-XMIN)/RANGWX
|
|
C PROPORTIONAL Y POSITIONS
|
|
YWF=(YFF-YMIN)/RANGWY
|
|
C POSITIONS IN DRAWING BOARD UNITS
|
|
XDF=IX0+XWF*IXLEN
|
|
YDF=IY0+YWF*IYLEN
|
|
IXF=NINT(XDF)
|
|
IYF=NINT(YDF)
|
|
10 CONTINUE
|
|
CALL XHAIR(IXF,IYF,TERM)
|
|
C RETURNS POSITION IN Db UNITS. CONVERT TO DRAWING BOARD UNITS
|
|
C RELATIVE POSITIONS
|
|
XFF=IXF-IX0
|
|
YFF=IYF-IY0
|
|
XFF=XFF/IXLEN
|
|
YFF=YFF/IYLEN
|
|
C CONVERT TO WORLD UNITS
|
|
XFW=XMIN+XFF*RANGWX
|
|
YFW=YMIN+YFF*RANGWY
|
|
IHX=NINT(XFW)
|
|
IHY=NINT(YFW)
|
|
C BACK TO VT100 MODE
|
|
CALL CLEARV
|
|
IF((TERM.EQ.'S').OR.(TERM.EQ.'s'))THEN
|
|
K1 = MAX(1,IHX) - ISTAR1 + 1
|
|
K2 = MIN(IHX+ISPAN,IDIM1) - ISTAR1 + 1
|
|
IF(NSEQ.NE.2)THEN
|
|
WRITE(KBOUT,1015)K1+ISTAR1-1,(SEQ1(K),K=K1,K2)
|
|
1015 FORMAT(' ',I7,' ',21A1)
|
|
ELSE IF(NSEQ.EQ.2)THEN
|
|
KK1 = MAX(1,IHY) - ISTAR2 + 1
|
|
KK2 = MIN(IHY+ISPAN,IDIM2) - ISTAR2 + 1
|
|
L = MIN(K2-K1,KK2-KK1) + 1
|
|
IF(L.GT.0) THEN
|
|
CALL SQMTCH(SEQ1(K1),SEQ2(KK1),MATCH,L)
|
|
CALL FMT4LN(SEQ2(KK1),SEQ1(K1),MATCH,L,
|
|
+ KK1+ISTAR2-1,K1+ISTAR1-1,KBOUT)
|
|
END IF
|
|
END IF
|
|
GO TO 10
|
|
END IF
|
|
IF((TERM.EQ.'M').OR.(TERM.EQ.'m').AND.(NSEQ.EQ.2))THEN
|
|
K1 = MAX(1,IHX) - ISTAR1 + 1
|
|
K2 = MIN(IHX+ISPAN,IDIM1) - ISTAR1 + 1
|
|
KK1 = MAX(1,IHY) - ISTAR2 + 1
|
|
KK2 = MIN(IHY+ISPAN,IDIM2) - ISTAR2 + 1
|
|
L = MIN(K2-K1,KK2-KK1) + 1
|
|
IF(L.GT.0) THEN
|
|
CALL DIABOX(SEQ2,IDIM2,SEQ1,IDIM1,KK1,K1,L,MATCH,KBOUT)
|
|
END IF
|
|
GO TO 10
|
|
END IF
|
|
WRITE(KBOUT,1014)IHX,IHY
|
|
1014 FORMAT(' Cross hair at',2I7)
|
|
IF(TERM.EQ.COMMA)GO TO 10
|
|
RETURN
|
|
END
|
|
SUBROUTINE DIABOX(SEQ1,IDIM1,SEQ2,IDIM2,I11,I21,
|
|
+LENGTH,LINE,KBOUT)
|
|
C AUTHOR: RODGER STADEN
|
|
CHARACTER SEQ1(IDIM1),SEQ2(IDIM2),LINE(LENGTH)
|
|
INTEGER CTONUM
|
|
EXTERNAL CTONUM
|
|
WRITE(KBOUT,*)
|
|
I12 = I11 + LENGTH - 1
|
|
I22 = I21 + LENGTH - 1
|
|
WRITE(KBOUT,1000)(SEQ2(K),K=I21,I22)
|
|
DO 100 I=I12,I11,-1
|
|
CALL FILLC(LINE,LENGTH,'.')
|
|
L=0
|
|
DO 50 J=I21,I22
|
|
L=L+1
|
|
IF(CTONUM(SEQ1(I)).EQ.CTONUM(SEQ2(J)))
|
|
+ LINE(L) = SEQ1(I)
|
|
50 CONTINUE
|
|
WRITE(KBOUT,1001)SEQ1(I),(LINE(K),K=1,L),SEQ1(I)
|
|
100 CONTINUE
|
|
WRITE(KBOUT,1000)(SEQ2(K),K=I21,I22)
|
|
1000 FORMAT(4X,36A1)
|
|
1001 FORMAT(3X,A1,36A1,A1)
|
|
END
|
|
SUBROUTINE RULER(J1,J2,IX0,IXLEN,IY0,IYLEN,
|
|
+ISXMAX,ISYMAX,KBIN,KBOUT,ISCALE,
|
|
+IHELPS,IHELPE,HELPF,IDEVH)
|
|
C AUTHOR: RODGER STADEN
|
|
CHARACTER HELPF*(*)
|
|
EXTERNAL IPSEP
|
|
C RULER DRAWS A SCALE ON THE X OR Y AXIS. THE CURRENT ACTIVE REGION IS
|
|
C J1,J2. THE USER CAN GIVE THE COORDINATE OF THE FIRST CHARACTER POSIITON
|
|
C TO BE MARKED (THE DEFAULT IS J1). THE SEPARATION AND HEIGHT IS ALSO
|
|
C DEFINED BY THE USER
|
|
IBH1=ISYMAX/100
|
|
IF(ISCALE.EQ.2)IBH1=ISXMAX/100
|
|
XMAX=J2
|
|
XMIN=J1
|
|
YMAX=J2
|
|
YMIN=J1
|
|
WRITE(KBOUT,1000)
|
|
1000 FORMAT(' Draw a scale')
|
|
MMN = J1
|
|
MMX = J2
|
|
ISTART = J1
|
|
CALL GETINT(MMN,MMX,ISTART,'Put first tick at',IVAL,KBIN,KBOUT,
|
|
+IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF((IOK.NE.0).OR.(IVAL.EQ.0)) THEN
|
|
CALL CLEARV
|
|
RETURN
|
|
END IF
|
|
ISTART = IVAL
|
|
FIRST=J1
|
|
C SET DEFAULT NUMBER OF BLIPS TO 10
|
|
NMAX=10
|
|
C CHECK ON SEPARATION (NO CLOSER THAT 1 EVERY 5 PIXELS)
|
|
UMIN=ABS(XMIN-XMAX)
|
|
SMIN=IXLEN
|
|
ISEP=IPSEP(XMAX,XMIN,NMAX)
|
|
IF(ISCALE.EQ.2)THEN
|
|
UMIN=ABS(YMAX-YMIN)
|
|
SMIN=IYLEN
|
|
ISEP=IPSEP(YMAX,YMIN,NMAX)
|
|
END IF
|
|
IF(SMIN.EQ.0.0)THEN
|
|
WRITE(KBOUT,*)' ERROR IN SCREEN DEFINITION'
|
|
RETURN
|
|
END IF
|
|
C FIVE PIXELS IS
|
|
ONEPIX=UMIN/SMIN
|
|
IFIVEP=ONEPIX*5.0
|
|
100 CONTINUE
|
|
MMN = IFIVEP
|
|
MMX = J2 - J1
|
|
INC = ISEP
|
|
CALL GETINT(MMN,MMX,INC,'Tick spacing',IVAL,KBIN,KBOUT,
|
|
+IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF((IOK.NE.0).OR.(IVAL.EQ.0)) THEN
|
|
CALL CLEARV
|
|
RETURN
|
|
END IF
|
|
INC = IVAL
|
|
BIT=INC
|
|
MMN = 0
|
|
IF(ISCALE.EQ.1) MMX = IYLEN
|
|
IF(ISCALE.EQ.2) MMX = IXLEN
|
|
IBH = IBH1
|
|
CALL GETINT(MMN,MMX,IBH,'Tick height',IVAL,KBIN,KBOUT,
|
|
+IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF((IOK.NE.0).OR.(IVAL.EQ.0)) THEN
|
|
CALL CLEARV
|
|
RETURN
|
|
END IF
|
|
IBH = IVAL
|
|
IF(ISTART.GT.0)FIRST=ISTART
|
|
CALL CLEARV
|
|
CALL VECTOM
|
|
CALL SCALES(XMAX,XMIN,YMAX,YMIN,
|
|
+IX0,IXLEN,IY0,IYLEN,ISXMAX,ISYMAX,
|
|
+BIT,IBH,FIRST,ISCALE)
|
|
CALL VT100M
|
|
GO TO 100
|
|
END
|
|
SUBROUTINE REDIR(IDEV,DEVOUT,IDEVGR,GORT,FILNAM,KBIN,KBOUT,
|
|
+IHELPS,IHELPE,HELPF,IDEVH,KOPT)
|
|
CHARACTER HELPF*(*)
|
|
C AUTHOR: RODGER STADEN
|
|
C routine to allow the user to select disk output
|
|
C if GORT = 0 redirection off
|
|
C if GORT = 1 redirection of text
|
|
C if GORT = 2 redirection of graphics
|
|
C
|
|
C notice the redirection is handled differently for text and graphics:
|
|
C text is done by changing idev to devout and opening idev
|
|
C graphics is done by closing idevgr and opening devout and changing
|
|
C the value of idevgr in the graphics common block. Note also that
|
|
C IGORF is used by the graphics to suppress clearv and xhair
|
|
C
|
|
C Postscript output: file opened here, flag is posto: 0 off, 1 open
|
|
C All output controlled from c but implemented by modifying move
|
|
C and draw subroutines in pl4010
|
|
C
|
|
C Can do one job at a time: if opening only one, if closing only one
|
|
C ie 2 visits to close both postcript and redirection
|
|
C if either is open and we come in to open the other we will first
|
|
C be asked if we want to close the open one
|
|
C
|
|
CHARACTER FILNAM*(*)
|
|
INTEGER DEVOUT,GORT,POSTO
|
|
PARAMETER (MAXPRM = 19)
|
|
CHARACTER PROMPT(3)*(MAXPRM)
|
|
CHARACTER FNDFIL*1024, FIL2*1024
|
|
INTEGER OPENP
|
|
EXTERNAL FNDFIL, OPENP
|
|
SAVE POSTO
|
|
DATA POSTO/0/
|
|
IF(GORT.NE.0) THEN
|
|
CALL YESNO(IN,'Close redirection file',
|
|
+ IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
|
|
IF(IN.EQ.0) THEN
|
|
IF(GORT.EQ.1) THEN
|
|
CLOSE(UNIT=DEVOUT)
|
|
IDEV = KBOUT
|
|
ELSE IF(GORT.EQ.2) THEN
|
|
CLOSE(UNIT=DEVOUT)
|
|
CALL OPENGR(IDEVGR)
|
|
END IF
|
|
GORT = 0
|
|
RETURN
|
|
END IF
|
|
END IF
|
|
IF(POSTO.NE.0) THEN
|
|
CALL YESNO(IN,'Close postscript file',
|
|
+ IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
|
|
IF(IN.EQ.0) THEN
|
|
IJUNK=OPENP(' ',0,0,0,0,0,0)
|
|
POSTO = 0
|
|
RETURN
|
|
END IF
|
|
END IF
|
|
IN = 1
|
|
PROMPT(1) = 'Redirect text'
|
|
PROMPT(2) = 'Redirect graphics'
|
|
PROMPT(3) = 'Open postscipt file'
|
|
CALL RADION('Select redirection',PROMPT,3,IN,
|
|
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
|
|
IF(IN.EQ.1) THEN
|
|
IF (GORT.NE.0) THEN
|
|
CALL ERROM(KBOUT,
|
|
+ 'Output already redirected: please close file')
|
|
RETURN
|
|
END IF
|
|
FILNAM = ' '
|
|
CALL OPENF1(DEVOUT,FILNAM,1,IOK,KBIN,KBOUT,
|
|
+ 'Text file name',IHELPS,IHELPE,HELPF,IDEVH)
|
|
IF(IOK.NE.0)RETURN
|
|
IDEV=DEVOUT
|
|
GORT = 1
|
|
ELSE IF(IN.EQ.2) THEN
|
|
IF (GORT.NE.0) THEN
|
|
CALL ERROM(KBOUT,
|
|
+ 'Output already redirected: please close file')
|
|
RETURN
|
|
END IF
|
|
CLOSE(UNIT = IDEVGR)
|
|
FILNAM = ' '
|
|
CALL OPENF1(DEVOUT,FILNAM,1,IOK,KBIN,KBOUT,
|
|
+ 'Graphics file name',IHELPS,IHELPE,HELPF,IDEVH)
|
|
IF(IOK.NE.0) THEN
|
|
CALL OPENGR(IDEVGR)
|
|
GORT = 0
|
|
RETURN
|
|
END IF
|
|
CALL OPENGF(DEVOUT)
|
|
GORT = 2
|
|
ELSE IF(IN.EQ.3) THEN
|
|
IF (POSTO.NE.0) THEN
|
|
CALL ERROM(KBOUT,
|
|
+ 'Postscript already selected: please close file')
|
|
RETURN
|
|
END IF
|
|
10 CONTINUE
|
|
FILNAM = ' '
|
|
LIN = 0
|
|
CALL GTSTR('Postcript file name',' ',FILNAM,LIN,
|
|
+ KBOUT,KBIN,INFLAG)
|
|
IF(INFLAG.EQ.1) THEN
|
|
CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
|
|
GO TO 10
|
|
END IF
|
|
POSTO = 0
|
|
IF ((INFLAG.EQ.2).OR.(LIN.EQ.0)) THEN
|
|
RETURN
|
|
END IF
|
|
CALL CROUTINE
|
|
IF (KOPT.EQ.1) THEN
|
|
CALL YESNO(LNDSCP, 'Print in portrait mode',
|
|
+ IHELPS, IHELPE, HELPF, IDEVH, KBIN, KBOUT)
|
|
IF (LNDSCP.EQ.-1) THEN
|
|
RETURN
|
|
ENDIF
|
|
CALL GETINT(0, 9999, 0, 'Bottom left X co-ord of region',
|
|
+ IX1, KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF (IOK.EQ.1) THEN
|
|
RETURN
|
|
ENDIF
|
|
CALL GETINT(0, 9999, 0, 'Bottom left Y co-ord of region',
|
|
+ IY1, KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF (IOK.EQ.1) THEN
|
|
RETURN
|
|
ENDIF
|
|
CALL GETINT(IX1,9999,9999,'Top right X co-ord of region',
|
|
+ IX2, KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF (IOK.EQ.1) THEN
|
|
RETURN
|
|
ENDIF
|
|
CALL GETINT(IY1,9999,9999,'Top right Y co-ord of region',
|
|
+ IY2, KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF (IOK.EQ.1) THEN
|
|
RETURN
|
|
ENDIF
|
|
CALL GETINT(1,20,5,'Line thickness',
|
|
+ IWIDTH, KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
|
|
IF (IOK.EQ.1) THEN
|
|
RETURN
|
|
ENDIF
|
|
ELSE
|
|
LNDSCP = 0
|
|
IX1 = 0
|
|
IX2 = 9999
|
|
IY1 = 0
|
|
IY2 = 9999
|
|
IWIDTH = 5
|
|
END IF
|
|
FIL2 = FNDFIL(FILNAM)
|
|
POSTO = OPENP(FIL2, IX1, IY1, IX2, IY2, IWIDTH, LNDSCP)
|
|
END IF
|
|
END
|
|
SUBROUTINE SHUTD
|
|
C
|
|
C routine to contain all necessary shutdown procedures
|
|
C
|
|
IJUNK=OPENP(' ',0,0,0,0,0,0)
|
|
END
|
|
SUBROUTINE XHAIRR(ISXMAX,ISYMAX,IX,IY,TERM,DBTDUX,DBTDUY)
|
|
CHARACTER TERM
|
|
CALL XHAIR(IX,IY,TERM)
|
|
END
|
|
REAL FUNCTION CWORLD(I,I0,ILEN,RMIN,RMAX)
|
|
CWORLD = RMIN + (REAL(I-I0)/ILEN) * (RMAX-RMIN)
|
|
END
|
|
INTEGER FUNCTION NOPWIN(IY,IY0,IYLEN,MAXOPT)
|
|
INTEGER IY0(MAXOPT),IYLEN(MAXOPT)
|
|
DO 20 I = 29,MAXOPT
|
|
IF(IY.GT.IY0(I)) THEN
|
|
IF(IY.LT.(IY0(I)+IYLEN(I))) THEN
|
|
NOPWIN = I
|
|
RETURN
|
|
END IF
|
|
END IF
|
|
20 CONTINUE
|
|
NOPWIN = 0
|
|
END
|
|
SUBROUTINE MOVEGR(IX,IY)
|
|
C
|
|
C
|
|
C
|
|
CALL CROUTINE
|
|
CALL MOVEP(IX,IY)
|
|
CALL MOVEXY(IX,IY)
|
|
END
|
|
SUBROUTINE DRAWGR(IX,IY)
|
|
C
|
|
C
|
|
C
|
|
CALL CROUTINE
|
|
CALL DRAWP(IX,IY)
|
|
CALL DRAWXY(IX,IY)
|
|
END
|
|
SUBROUTINE WRITET(IX,IY,CHARS,NCHARS)
|
|
CHARACTER CHARS*(*)
|
|
C
|
|
C
|
|
C
|
|
CALL CROUTINE
|
|
CALL WRITEP(IX,IY,CHARS,NCHARS)
|
|
CALL WRITXY(IX,IY,CHARS,NCHARS)
|
|
END
|
|
SUBROUTINE POINTG(IX,IY)
|
|
CALL C ROUTINE
|
|
CALL POINTP(IX,IY)
|
|
CALL DOTXY(IX,IY)
|
|
END
|
|
SUBROUTINE CLEARG
|
|
CALL C ROUTINE HERE
|
|
CALL CLEARP
|
|
CALL BLANKG
|
|
END
|