Subroutine STARTI c *********************************************************************** c * * c * Subroutine STARTI - To initialize the plotting proceedure * c * and to select the plot device. * c * * c * Variables set: * c * * c * Iterm - If plot device is a terminal, set Iterm = 1 * c * Otherwise, set Iterm = 0 * c * Irot - If plot device can plot a rotated plot, set * c * Irot = 1; otherwise, set Irot = 0 * c * Igraph - If the device is to plot on graph paper, set * c * Igraph = 1; otherwise, set Igraph = 0 * c * Xplotl - The length of the plot region in the X direction * c * Yplotl - The length of the plot region in the Y direction * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Integer Spchar,Xtop Common/Ptype/Idev,Xtop,Spchar,Chscal,Chsc1 Common/Center/Xpmin,Xpmax,Ypmin,Ypmax,Xorg,Yorg,Xplotl,Yplotl c c Setups for the various plot devices. Here we set the plot region c size, flags for terminals, graph paper, and plot rotation, c initialize the plot, and set up the command when program execution c halts. c Irot = 0 Igraph = 0 Iterm = 1 Call Iostart(Iterms) Write(6,100) 27,27 100 Format(1X,1A1,'[H',1A1,'[J') Call Plot_Start Call Terminal_Type(Terminal,Iterminal) Xplotl = 10.25 Yplotl = 7.75 c c Increase the area to plot so labels can go outside c of this region easily c Dx = Xpmax - Xpmin Dy = Ypmax - Ypmin Xpmax = Xpmax + 0.1 * Dx Xpmin = Xpmin - 0.1 * Dx Ypmax = Ypmax + 0.30 * Dy Ypmin = Ypmin - 0.15 * Dy c Call Plopen('TT:',6,Terminal,'VMS ') c Call Scaler(Irot,Irotat,Igraph) Call Scinit Call Scrdef(0.0,Xplotl,0.0,Yplotl) c Return End Subroutine Update c *********************************************************************** c * * c * Subroutine Update - To move, change, add, and * c * delete labels from a plot, using the graphics crosshairs. * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Common/Textbl/Ntxbl Common/Legmov/Xorig,Yorig,Xlegln,Ylegln,Lesize,Legcnr,Leglin, $ Gblspc c Call Labset(Lset) Call Rpldat If (Lset .NE. 0) Call Stcstn(Lset) Call Set_Scale Call Gtscrn(Xsl,Xsr,Ysb,Yst) Call Plot_Off Write(6,100) 27,27 100 Format(1A1,'[1;2r',1A1,'[H') c 10 Continue c Write(6,200) 27,7,27 200 Format(A,'[HPLOT MODIFICATION: Select (L)abels, L(E)gend,', $ ' (T)ext Blocks, or (S)top ',2A,'[K') c Call Instrg('LlEeTtSs',8,Ich) Ich = (Ich+1)/2 c If (Ich .EQ. 1) Then Call Label_Update(Lset) Else If (Ich .EQ. 2) Then If (Legcnr .NE. 0) Call Movleg Else If (Ich .EQ. 3) Then If (Ntxbl .NE. 0) Call Movtxbl Else Write(6,300) 27,27 300 Format(1A1,'[1;24r',1A1,'[H') Return End If Go To 10 c End Subroutine Label_Update(Lset) c *********************************************************************** c * * c * Subroutine Label_Update - To move, change, add, and * c * delete labels from a plot, using the graphics crosshairs. * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Character*132 Labelc,Lhold,String*4 Byte Labelb Equivalence (Labelc,Labelb) c Character*132 Labels(100) Common/Labs/Labels,Xlabel(100),Ylabel(100),Size(100),Jlabel(100), $ Xlen(100),Nchars(100),Irot(100),Iprot(100),Nlab Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Common/Ptype/Idev,Xtop,Spchar,Chscal c If (Lset .NE. 0) Call Stcstn(Lset) Call Gtscrn(Xsl,Xsr,Ysb,Yst) c c Set default character set c String = '@@@'//Char(Lset+48) c 10 Continue c Write(6,150) 27,7,27 150 Format(1A1,'[HLABELS: Select (A)dd, (D)elete, (M)ove,', $ ' (C)hange, (R)edraw, or (S)top ',2A,'[K') c Call Instrg('AaDdMmCcRrSs',12,Ido) c Ido = (Ido+1)/2 c If (Ido .EQ. 1) Then c c Add a label to the plot c Write(6,200) 27,27,27,27 200 Format(A1,'[HText: ',A1,'[K',A1,'[2H',A1,'[K') Read(6,250) Nchars(Nlab+1),Labelc 250 Format(Q,A) c Write(6,300) 27,27 300 Format(A,'[HEnter (L)eft, (C)enter, or (R)ight', $ ' justification ',A,'[K') Call Instrg('LlCcRr',6,In) Jlabel(Nlab+1) = (In+1)/2 c Write(6,350) 27,27 350 Format(A,'[HEnter the text size (1-10) ',A,'[K') Call Inchek(1,10,Is) If (Is .EQ. 1) Then Size(Nlab+1) = 1.7 Else If (Is .EQ. 2) Then Size(Nlab+1) = 2.3 Else Size(Nlab+1) = Is End If c Write(6,400) 27,27 400 Format(A,'[HMove cursors to the label position on the plot', $ A,'[K') Call Crosshair('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 c c Draw the label on the plot c Nlab = Nlab + 1 Call Plot_On Call Stcrot(0.0) Call Stjust(Jlabel(Nlab)) Call Stccsz(Size(Nlab)*0.03*Chscal,Size(Nlab)*0.042*Chscal) Labelc(Nchars(Nlab)+1:Nchars(Nlab)+4) = String Call Gtstln(Nchars(Nlab),Labelb,Xlen(Nlab)) Call Movawc(Xpos,Ypos) Call Grtxcp(Nchars(Nlab)+4,Labelb) Call Plot_Off Labels(Nlab) = Labelc(1:Nchars(Nlab)) Xlabel(Nlab) = Xpos Ylabel(Nlab) = Ypos Irot(Nlab) = 0 c Else If (Ido .EQ. 2) Then c c Delete a label from the plot c 15 Continue c Write(6,450) 27,27 450 Format(A,'[HMove cursors to label to delete',A,'[K') Call Crosshair('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Near_Label(Xpos,Ypos,N) c c "Box" in the label c Call Plot_On Call Boxes(N) Call Plot_Off c Write(6,475) 27,27 475 Format(A,'[HIs this the label to delete? (y/n) ',A,'[K') Call Instrg('YyNn',4,Iyn) c Call Plot_Delete_Start Call Boxes(N) Call Plot_Delete_End c If (Iyn .GT. 2) Go To 15 c c Removing the label from the plot c Call Plot_Delete_Start Call Stcrot(Irot(N)*1.0) Call Stjust(Jlabel(N)) Call Stccsz(Size(N)*0.03*Chscal,Size(N)*0.042*Chscal) Call Movawc(Xlabel(N),Ylabel(N)) Labelc = Labels(N)(1:Nchars(N))//String Call Grtxcp(Nchars(N)+4,Labelb) Call Stcrot(0.0) Call Plot_Delete_End c c Updating the pointers c Nlab = Nlab - 1 Do 20 I=N,Nlab Xlabel(I) = Xlabel(I+1) Ylabel(I) = Ylabel(I+1) Jlabel(I) = Jlabel(I+1) Labels(I) = Labels(I+1) Nchars(I) = Nchars(I+1) Iprot(I) = Iprot(I+1) Size(I) = Size(I+1) Xlen(I) = Xlen(I+1) Irot(I) = Irot(I+1) 20 Continue c Else If (Ido .EQ. 3) Then c c Move a label on the plot c 25 Continue Write(6,500) 27,27 500 Format(A,'[HMove cursors to label to move',A,'[K') Call Crosshair('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Near_Label(Xpos,Ypos,N) Call Plot_On Call Boxes(N) Call Plot_Off c Write(6,525) 27,27 525 Format(A,'[HIs this the right label to move? (y/n) ',A,'[K') Call Instrg('YyNn',4,Iyn) Call Plot_Delete_Start Call Boxes(N) Call Plot_Delete_End If (Iyn .GT. 2) Go To 25 c c c Draw a reference cross on the label c Delta = 0.007 * Sqrt((Xsr-Xsl)**2 + (Yst-Ysb)**2) Deltax = Delta*(Xsmax-Xsmin)/(Xsr-Xsl) Deltay = Delta*(Ysmax-Ysmin)/(Yst-Ysb) Call Plot_On Call Movawc(Xlabel(N)-Deltax,Ylabel(N)) Call Drwawc(Xlabel(N)+Deltax,Ylabel(N)) Call Movawc(Xlabel(N),Ylabel(N)-Deltay) Call Drwawc(Xlabel(N),Ylabel(N)+Deltay) Call Plot_Off c c Get the new label position c Write(6,550) 27,27 550 Format(A,'[HMove the crosshairs - The cross below the', $ ' label will position it',A,'[K') Call Crosshair('Ss ',3,Xpos,Ypos,Nflag) c c Remove the cross on the label c Call Plot_Delete_Start Call Movawc(Xlabel(N)-Deltax,Ylabel(N)) Call Drwawc(Xlabel(N)+Deltax,Ylabel(N)) Call Movawc(Xlabel(N),Ylabel(N)-Deltay) Call Drwawc(Xlabel(N),Ylabel(N)+Deltay) Call Plot_Delete_End If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 c c Delete the old label c Call Plot_Delete_Start Call Stcrot(Irot(N)*1.0) Call Stjust(Jlabel(N)) Call Stccsz(Size(N)*0.03*Chscal,Size(N)*0.042*Chscal) Call Movawc(Xlabel(N),Ylabel(N)) Labelc = Labels(N)(1:Nchars(N))//String Call Grtxcp(Nchars(N)+4,Labelb) Call Plot_Delete_End c c Draw the new label on the plot c Call Plot_On Xlabel(N) = Xpos Ylabel(N) = Ypos Call Movawc(Xlabel(N),Ylabel(N)) Call Grtxcp(Nchars(N)+4,Labelb) Call Stcrot(0.0) Call Plot_Off c Else If (Ido .EQ. 4) Then c c Change a label on the plot c 30 Continue c Write(6,600) 27,27 600 Format(A,'[HMove cursors to label to change', $ ' (or "S" to stop) ',A,'[K') Call Crosshair('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Near_Label(Xpos,Ypos,N) c Call Plot_On Call Boxes(N) Call Plot_Off c Write(6,625) 27,27 625 Format(A,'[HIs this the right label to change? (y/n) ',A,'[K') Call Instrg('YyNn',4,Iyn) Call Plot_Delete_Start Call Boxes(N) Call Plot_Delete_End If (Iyn .GT. 2) Go To 30 c Write(6,650) 27,27 650 Format(A,'[HEnter (L)abel text, (T)ext size,' $ ' (J)ustification, (R)otation, or (S)top ',A,'[K') c Call Instrg('LlTtJjRrSs',10,Ich) Ich = (Ich+1)/2 c If (Ich .EQ. 1) Then Write(6,700) 27,27,27,27 700 Format(A,'[HEdit:',A1,'[K',A1,'[2H',A1,'[K') Labelc = Labels(N) Nch = Nchars(N) Call Linedtx(Labelb,Nch,132,1) If (Labelc(1:Nch) .EQ. Labels(N)(1:Nchars(N))) Go To 30 Else If (Ich .EQ. 2) Then Write(6,750) 27,Int(Size(N)),27 750 Format(A,'[HEnter the label character size (currently', $ I3,') ',A,'[K') Call Inchek(1,10,Is) If (Is .EQ. Int(Size(N))) Go To 30 Else If (Ich .EQ. 3) Then Write(6,300) 27,27 Call Instrg('LlCcRr',6,I) Jl = (I+1)/2 If (Jl .EQ. Jlabel(N)) Go To 30 Else If (Ich .EQ. 4) Then 35 Continue Write(6,775) 27,27 775 Format(A,'[HEnter the text rotation angle ',A,'[K') Read(5,*,ERR=35,END=35) Ro If (Int(Ro) .EQ. Irot(N)) Go To 30 Else Go To 10 End If c c Erase the old label c Call Plot_Delete_Start Call Stcrot(Irot(N)*1.0) Call Stjust(Jlabel(N)) Call Stccsz(Size(N)*0.03*Chscal,Size(N)*0.042*Chscal) Call Movawc(Xlabel(N),Ylabel(N)) Lhold = Labelc Labelc = Labels(N)(1:Nchars(N))//String Call Grtxcp(Nchars(N)+4,Labelb) Call Plot_Delete_End c c Update the label parameters to the new values c If (Ich .EQ. 1) Then Labels(N) = Lhold Nchars(N) = Nch Labelc = Labels(N)(1:Nchars(N))//String Write(6,780) 27,27,27 780 Format(A,'[H',A,'[K'/A,'[K') Else If (Ich .EQ. 2) Then If (Is .EQ. 1) Then Size(N) = 1.7 Else If (Is .EQ. 2) Then Size(N) = 2.3 Else Size(N) = Is End If Else If (Ich .EQ. 3) Then Jlabel(N) = Jl Else Irot(N) = Ro End If c c Draw in the changed label c Call Plot_On Call Stcrot(Irot(N)*1.0) Call Stjust(Jlabel(N)) Call Stccsz(Size(N)*0.03*Chscal,Size(N)*0.042*Chscal) Call Gtstln(Nchars(N),Labelb,Xlen(N)) Call Movawc(Xlabel(N),Ylabel(N)) Call Grtxcp(Nchars(N)+4,Labelb) Call Stcrot(0.0) Call Plot_Off Go To 30 c Else If (Ido .EQ. 5) Then c c Redraw a label. This is useful if another c label was drawn on top of it, and then moved. c Write(6,800) 27,27 800 Format(A,'[HMove cursors to label to redraw',A,'[K') Call Crosshair('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Near_Label(Xpos,Ypos,N) Call Plot_On Call Stcrot(Irot(N)*1.0) Call Stjust(Jlabel(N)) Call Stccsz(Size(N)*0.03*Chscal,Size(N)*0.042*Chscal) Call Movawc(Xlabel(N),Ylabel(N)) Labelc = Labels(N)(1:Nchars(N))//String Call Grtxcp(Nchars(N)+4,Labelb) Call Stcrot(0.0) Call Plot_Off Else Return End If c Go To 10 c End Subroutine Plot_Delete_Start c Call Terminal_Type(Terminal,Iterm) Call Plot_On c If (Terminal .EQ. '4105') Then Call Sttxco(8) Call Staxco(8) Call Stplco(8) Call Stsyco(8) Call Stcols(8) Else If (Terminal .EQ. '4014') Then Call Plflsh Write(6,100) 27 100 Format(1X,1A1,'/1d',$) Else If (Terminal .EQ. 'VT12') Then Call Plflsh Call Plot_Off Write(6,200) 27 200 Format(1X,1A1,'PpW(E);') End If Return End Subroutine Plot_Delete_End c Call Terminal_Type(Terminal,Iterm) c If (Terminal .EQ. '4105') Then Call Sttxco(1) Call Staxco(1) Call Stplco(1) Call Stsyco(1) Call Stcols(1) Call Plflsh Else If (Terminal .EQ. '4014') Then Call Plflsh Else If (Terminal .EQ. 'VT12') Then Call Plflsh Write(6,100) 27 100 Format(1X,1A1,'PpW(V);') End If Call Plot_Off c Return End Subroutine Set_Scale Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax c Call Gtwind(Xwmin,Xwmax,Ywmin,Ywmax) Call Gtview(Xvmin,Xvmax,Yvmin,Yvmax) Call Gtscrn(Xleft,Xright,Ybot,Ytop) c Dxw = (Xwmax-Xwmin)/(Xvmax-Xvmin) Dyw = (Ywmax-Ywmin)/(Yvmax-Yvmin) c Xsmin = Xwmin - (Xvmin-Xleft)*Dxw Ysmin = Ywmin - (Yvmin-Ybot)*Dyw c Xsmax = Xsmin + (Xright-Xleft)*Dxw Ysmax = Ysmin + (Ytop-Ybot)*Dyw c Return End Subroutine Crosshair(Checker,Ncheck,Xpos,Ypos,Iflag) c Character*30 Checker,Holds,Vthold Character Chr*1 Byte Bytes,Byt(30) Equivalence (Bytes,Chr),(Byt,Holds) c Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax c Call Terminal_Type(Terminal,Iterm) If (Terminal .NE. 'VT12' .OR. Nchars .EQ. 0) Then Call Cross_On Else Write(6,250) 27,Vthold(1:Nchars) 250 Format(1X,1A1,'PpP',A,';R(P(I));') End If c Iflag = 0 If (Terminal .EQ. '4105') Then 1 Continue Nchars = 0 2 Continue Call Ittinr(I) If (I .GT. 13) Then Nchars = Nchars + 1 Byt(Nchars) = I Go To 2 End If If (Nchars .GT. 0) Then Bytes = Byt(1) Do 5 I=1,Ncheck If (Checker(I:I) .EQ. Chr) Iflag = I 5 Continue Else Go To 1 End If N1 = Byt(Nchars-3) N2 = Byt(Nchars-2) N3 = Byt(Nchars-1) N4 = Byt(Nchars) Ix = 1024 Iy = 780 Intx = (N1-32)*32+(N2-32) Inty = (N3-32)*32+(N4-32) Else If (Terminal .EQ. '4014') Then 10 Continue c c See which key was pushed - if valid, then continue c Call Ittinr(Ii) Bytes = Ii If (Ii .NE. 13) Then Do 20 I=1,Ncheck If (Checker(I:I) .EQ. Chr) Iflag = I 20 Continue c If (Iflag .EQ. 0) Go To 10 End If c c Read in the crosshair location c Call Ittinr(N1) Call Ittinr(N2) Call Ittinr(N3) Call Ittinr(N4) Call Ittinr(Nreturn) Ix = 1024 Iy = 780 Intx = (N1-32)*32+(N2-32) Inty = (N3-32)*32+(N4-32) Else If (Terminal .EQ. 'VT12') Then c c Dec terminal c Nchars = 0 57 Continue Call Ittinr(I) Nchars = Nchars + 1 Byt(Nchars) = I If (Byt(Nchars) .NE. ']') Go To 57 Call Ittinr(I) Do 61 I=1,Ncheck If (Checker(I:I) .EQ. Holds(1:1)) Iflag = I 61 Continue c Do 65 I=1,Nchars If (Byt(I) .EQ. '[') Vthold = Holds(I:Nchars) If (Byt(I) .NE. ',' .AND. (Byt(I) .LT. 48 .OR. $ Byt(I) .GT. 57)) Byt(I) = ' ' If (Byt(I) .NE. ' ') Last = I 65 Continue Byt(I+1) = ' ' Ix = 767 Iy = 479 Read(Holds(1:Last),'(2I10)',ERR=68,END=68) Intx,Inty 68 Continue Inty = Iy - Inty End If Intx = Min0(Intx,Ix) Inty = Min0(Inty,Iy) c c Scale the location to the drawing coordinates c Xpos = Intx/(Ix*1.0)*(Xsmax-Xsmin)+Xsmin Ypos = Inty/(Iy*1.0)*(Ysmax-Ysmin)+Ysmin Call Cross_Off Return End Subroutine Plot_Commands c Common/Term_Data/Iterm,Term_Device_Type,Term_Graph_Start, $ Term_Graph_Off,Term_Graph_Clear,Term_Graph_On, $ Cross_Hair_On,Cross_Hair_Off Character*80 Term_Graph_Start,Term_Graph_Off,Term_Graph_Clear, $ Term_Graph_On,Cross_Hair_On,Cross_Hair_Off c Entry Plot_On Call Plot_Command_Write(Term_Graph_On) Return c Entry Plot_Off Call Plflsh Call Plot_Command_Write(Term_Graph_Off) Return c Entry Plot_Clear Call Plflsh Call Plot_Command_Write(Term_Graph_Clear) Return c Entry Plot_Start Call Plot_Command_Write(Term_Graph_Start) Return c Entry Cross_On Call Plot_Command_Write(Cross_Hair_On) Return c Entry Cross_Off Call Plot_Command_Write(Cross_Hair_Off) Return c Entry Terminal_Type(Terminal,Iterminal) Terminal = Term_Device_Type Iterminal = Iterm Return End Subroutine Linedtx(Line,Nchars,Maxlen,Iflag) c *********************************************************************** c * * c * Subroutine Linedt - To enable the user to "EDIT" lines * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Byte Line(1),Char Equivalence (Char,I) c 150 Format(1A1) c c Write out the line of test to "edit" c Write(6,100) (Line(I),I=1,Nchars) 100 Format(A1) c c Initialize locations c Iesc = 0 Iloc = Nchars + 1 c 10 Continue c c Get the character input c Call Ittinr(I) c c See if a return was entered c If (I .EQ. 13) Go To 40 c c See if arrow keys were pressed c If (I .EQ. 27) Iesc = 1 If (I .EQ. 91 .AND. Iesc .EQ. 1) Iesc = 2 c c See if the character is in range c If ((I .LT. 32 .OR. I .GT. 255) .AND. I .NE. 27 .AND. $ I .NE. 11 .AND. I .NE. 21) Go To 10 c If (I .EQ. 127) Then c c Delete from the text c Write(6,200) 27,27 200 Format(1A1,'[1D',1A1,'[1P') c c Update the character string c If (Nchars .GT. 1) Then Do 20 J=Iloc,Nchars Line(J-1) = Line(J) 20 Continue End If Nchars = Max0(Nchars - 1,0) Iloc = Max0(Iloc - 1,1) c Else If (I .EQ. 11) Then c c Delete to end of line c Write(6,275) 27,27,27 275 Format(1A1,'7',1A1,'[K',1A1,'8') Nchars = Iloc-1 Iloc = Max0(Iloc,1) c Else If (I .EQ. 21) Then c c Delete to start of line c Do 35 J=Iloc,Nchars Line(J-Iloc+1) = Line(J) 35 Continue If (Iloc .GT. 1) Then I1 = Int(Log10(Iloc-1.)) + 1 Write(6,285) 27,Iloc-1,27,Iloc-1 285 Format(1A1,'[',I,'D',1A1,'[',I,'P') End If Nchars = Max0(Nchars - Iloc + 1,0) Iloc = 1 c Else If (Iesc .EQ. 0) Then c c Add to the text c If (Nchars .LT. Maxlen) Then If (Iloc .LE. Nchars) Then Write(6,250) 27,I,27 Else Write(6,150) I End If 250 Format(1A1,'[4h',2A1,'[4l') c c Update the character string c Do 30 J=Nchars,Iloc,-1 Line(J+1) = Line(J) 30 Continue Line(Iloc) = I Nchars = Nchars + 1 Iloc = Iloc + 1 Else Write(6,150) 7 End If c Else If (Iesc .EQ. 2) Then c c Move curser along the text string c If (Iloc .GE. Nchars+1 .AND. (Char .EQ. 'C' .OR. Char .EQ. $ 'B')) Then Iesc = 0 Write(6,150) 7 Go To 10 Else If (Char .EQ. 'C') Then Write(6,350) 27,I 350 Format(1A1'[',1A1) Iloc = Iloc + 1 Else If (Char .EQ. 'D') Then Write(6,350) 27,I Iloc = Max0(Iloc - 1,1) Else If (Char .EQ. 'B') Then Write(6,350) (27,'C',J=1,Nchars-Iloc+1) Iloc = Nchars + 1 Else If (Char .EQ. 'A' .AND. Iloc .GT. 1) Then Write(6,350) (27,'D',J=1,Iloc-1) Iloc = 1 End If c End If c c Turn off the arrow key flag c If (Iesc .EQ. 2 .AND. I .NE. 91) Iesc = 0 c Go To 10 c 40 Continue c c Move down a line, and turn on echos, and c turn off single character activation c Write(6,150) 13 Return End Subroutine Instrg(String,Nochar,Choice) c c ********************************************************************** c * * c * Subroutine INSTRG - to determine if a desired character was * c * read in * c * * c * Input Values: * c * * c * String - Character string containing the desired characters * c * to scan for * c * Nochar - Number of characters in "String" * c * * c * Output Value: * c * * c * Choice - Position of the input character within "String" * c * (integer) * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c ********************************************************************** c Byte String(Nochar),Char Integer Choice,Ichar Equivalence(Ichar,Char) 10 Continue c c Get the users input c Call Ittinr(Ichar) Write(6,100) 27,Char 100 Format(A1,'[2A',A1) c Choice = 0 c c See if the input character is in the string c Do 20 I=1,Nochar If (Char .EQ. String(I)) Choice = I 20 Continue c c If found, return c If (Choice .NE. 0) Return 30 Continue Go To 10 End Subroutine Inchek(Ifirst,Ilast,Isum) c *********************************************************************** c * * c * Subroutine INCHEK - To check keyboard input to ensure that * c * a read error does not occur, and to ensure that the value * c * is within a certain limit * c * * c * Input Values: * c * * c * Ifirst - The minimum permissable value for Ivalue * c * Ilast - The maximum permissable value for Ivalue * c * * c * Output Value: * c * * c * Isum - The desired value to read * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c 10 Continue c c Read in a value c Isum = 0 Icnt = 0 20 Continue Call Ittinr(I) c If (I .EQ. 13) Then c Call Ittinr(I) Else Write(6,100) 27,I 100 Format(A1,'[2A',A1) If (I .GE. 48 .AND. I .LE. 57) Then Isum = Isum * 10 + (I-48) Icnt = Icnt + 1 Else Write(6,100) 27,7 End If Go To 20 End If c c See if the value lies within the a given range c If (Isum .GE. Ifirst .AND. Isum .LE. Ilast) Return c c It didn't - so try again c Write(6,100) 27,(127,I=1,Icnt),7 200 Format(A1,'[2A',A1) c Go To 10 End Subroutine Boxes(N) c *********************************************************************** c * * c * Subroutine Boxes - To draw a box around some text * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Character*132 Labels(100) Common/Labs/Labels,Xlabel(100),Ylabel(100),Size(100),Jlabel(100), $ Xlen(100),Nchars(100),Irot(100),Iprot(100),Nlab Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Common/Ptype/Idev,Xtop,Spchar,Chscal,Chsc1 c Call Gtscrn(Xsl,Xsr,Ysb,Yst) Angle = Irot(N)/180.*3.1415926 Cosine = Cos(Angle) Sine = Sin(Angle) Xlx = (Xsmax-Xsmin)/(Xsr-Xsl) * Xlen(N) Xly = (Ysmax-Ysmin)/(Yst-Ysb) * Xlen(N) Xo = Xlabel(N) - (Jlabel(N)-1)*Xlx*Cosine/2.0 Yo = Ylabel(N) - (Jlabel(N)-1)*Xly*Sine/2.0 c Sizex = (Size(N) * 0.042 + 0.03) * Chscal * (Xsmax-Xsmin)/ $ (Xsr-Xsl) Sizey = (Size(N) * 0.042 + 0.03) * Chscal * (Ysmax-Ysmin)/ $ (Yst-Ysb) X1 = Xo Y1 = Yo X2 = Xo - Sizex * Sine Y2 = Yo + Sizey * Cosine X3 = Xo + Xlx * Cosine - Sizex * Sine Y3 = Yo + Xly * Sine + Sizey * Cosine X4 = Xo + Xlx * Cosine Y4 = Yo + Xly * Sine Call Movawc(X1,Y1) Call Drwawc(X2,Y2) Call Drwawc(X3,Y3) Call Drwawc(X4,Y4) Call Drwawc(X1,Y1) c Return End Subroutine Plot_Command_Write(String) c *********************************************************************** c * Character*(*) String Lens = Len(String) Do 10 I=Lens,1,-1 If (String(I:I) .NE. ' ') Then Write(6,100) String(1:I) 100 Format(A) Return End If 10 Continue c Return End Subroutine Wrtqio(Answer,Len) c Integer*2 Irow,Icol,Ichr,Len Integer*4 Status,Write_Len,Code Character*132 Answer Integer*2 Out_Chan,Input_Chan c Common/QIOchan/Input_Chan,Out_Chan c c Status block for Qio c Structure/Iostat_Block/ Integer*2 Iostat,Byte_Count, $ Lines_Output Byte Column,Line End Structure Record /Iostat_Block/ Iosb c c Routines c Integer*4 SYS$Qiow c Include '($IODEF)' c Write_Len = Len Code = Io$_Writevblk .OR. Io$M_Noformat Status = SYS$Qiow(,%Val(Out_Chan),%Val(Code), $ Iosb,,,%Ref(Answer(1:Write_Len)), $ %Val(Write_Len),, $ ,,) If (.NOT. Status) Call Lib$Signal(%Val(Status)) If (.NOT. Iosb.Iostat) Call Lib$Signal(%Val(Iosb.Iostat)) c Return End Subroutine Ittinr(Iret) c Integer*4 Status Integer*2 Iret c c Qiow Structures c Integer*2 Input_Chan,Out_Chan Integer*4 Code, ! Type of I/O operation $ Input_Buff_Size, ! Size of input buffer $ Prompt_Size, ! Size of prompt $ Input_Size ! Size of input line as read Parameter (Prompt_Size = 0,Input_Buff_Size = 1) Character*1 Input c Common/QIOchan/Input_Chan,Out_Chan c Include '($IODEF)' c c Status block for Qiow c Structure /Iostat_Block/ Integer*2 Iostat, ! Return status $ Term_Offset, ! Location of line terminator $ Terminator, ! Value of terminator $ Term_Size ! Size of terminator End Structure Record /Iostat_Block/ Iosb c c Subprograms c Integer*4 Sys$Qiow c Code = Io$_Readvblk .OR. Io$M_Noecho .OR. Io$M_Nofiltr 10 Continue Status = SYS$Qiow(,%Val(Input_Chan),%Val(Code),Iosb, $ ,,%Ref(Input),%Val(Input_Buff_Size),,, $ ,%Val(Prompt_Size)) c c Check Qiow status c If(.NOT. Status) Call Lib$Signal(%Val(Status)) c c Check status of I/O operation c If (.NOT. Iosb.Iostat) Call Lib$Signal(%Val(Iosb.Iostat)) c Iret = Ichar(Input(1:1)) Return End Subroutine Iostart(Iterm) c c Subroutine Iostart - to get the input c and output channel numbers c Integer*2 Out_Chan,Input_Chan,Len Integer*4 Status,Sys$Assign c Common/QIOchan/Input_Chan,Out_Chan c Include '($IODEF)' c c Get the output channel number c Status = SYS$Assign('SYS$Output',Out_Chan,,) If (.NOT. Status) Call Lib$Signal(%Val(Status)) c c Get the input channel number c Status = Sys$Assign('Sys$Input',Input_Chan,,) If (.NOT. Status) Call Lib$Signal(%Val(Status)) c c Get the output channel number c Call Term_Type(Iterm) Call Termset(Iterm) Call Term_Device_Init c Return End Subroutine Term_Type(Iterm) c Integer*2 Ichr,Len Character*5 Getpos Byte Ichar Equivalence (Ichr,Ichar) Dimension Idata(10,3),Inum(3),Ivalue(20) Data Idata/62,1,2,3,4,6,7,8,0,0, ! VT 240 Regis Terminal $ 62,1,2,6,7,8,9,0,0,0, ! HDS 2200GX Terminal $ 1,2,0,0,0,0,0,0,0,0/ ! Tektronix 4111 Data Inum/8,7,2/ c Getpos(1:3) = Char(27)//'[c' Len = 3 Call Wrtqio(Getpos,Len) Nvals = 0 c 10 Continue Call Ittinr(Ichr) If (Ichar .NE. '?') Go To 10 c c Get the value of the number c 20 Continue Ival = 0 Nvals = Nvals + 1 30 Continue Call Ittinr(Ichr) If (Ichar .NE. ';' .AND. Ichar .NE. 'c') Then Ival = Ival * 10 + Ichr - 48 Go To 30 End If Ivalue(Nvals) = Ival If (Ichar .EQ. ';') Go To 20 c c Compare the Number c Do 50 I=1,3 If (Inum(I) .NE. Nvals) Go To 50 Do 40 J=1,Inum(I) If (Ivalue(J) .NE. Idata(J,I)) Go To 50 40 Continue Iterm = I Return 50 Continue c c Set unknown terminal types - VT240 for REGIS, c or Tektronix 4014 type if no Regis c Iterm = 2 Do 60 I=1,Nvals If (Ivalue(I) .EQ. 3) Iterm = 1 60 Continue Return End Subroutine Termset(Iterm_Val) Common/Term_Data/Iterm,Term_Device_Type,Term_Graph_Start, $ Term_Graph_Off,Term_Graph_Clear,Term_Graph_On, $ Cross_Hair_On,Cross_Hair_Off Iterm = Iterm_Val Return End Subroutine Term_Device_Init c Common/Term_Data/Iterm,Term_Device_Type,Term_Graph_Start, $ Term_Graph_Off,Term_Graph_Clear,Term_Graph_On, $ Cross_Hair_On,Cross_Hair_Off Character*80 Term_Graph_Start,Term_Graph_Off,Term_Graph_Clear, $ Term_Graph_On,Cross_Hair_On,Cross_Hair_Off c Character Esc,Ff,Ctrly,Ctrl_Z,Returns Data Esc,FF,Returns,Ctrly,Ctrl_Z/27,12,13,25,26/ c If (Iterm .EQ. 1) Then Term_Device_Type = 'VT12' Term_Graph_Clear = ' '//Esc//'[H'//Esc//'[J' Term_Graph_Off = ' '//Esc//'/ '//Esc//'[0;0H' Term_Graph_Start = ' '//Esc//'PpW(V);' Term_Graph_On = ' '//Esc//'PpW(V);' Cross_Hair_On = ' '//Esc//'PpW(V)R(P(I));' Cross_Hair_Off = ' '//Esc//'/'//Esc//'[0;0H' c Else If (Iterm .EQ. 2) Then Term_Device_Type = '4014' Term_Graph_Off = ' '//Esc//'[?38l' Term_Graph_Clear = ' '//Esc//'[?38h'//Ctrly//Esc//'[3/v'//Esc $ //'[?38l' Term_Graph_Start = ' '//Esc//'[?38h' Term_Graph_On = ' '//Esc//'[0/w' Cross_Hair_On = ' '//Esc//'[0/w'//Esc//Ctrl_Z Cross_Hair_Off = Returns//Esc//'[?38l' c Else If (Iterm .EQ. 3) Then Term_Device_Type = '4105' Term_Graph_Start = ' '//Esc//'%!0' Term_Graph_On = ' '//Esc//'%!0' Term_Graph_Clear = ' '//Esc//'%!0'//Esc//Ff//Esc//'%!1' Term_Graph_Off = Esc//'%!1' Cross_Hair_On = Esc//'%!0'//Esc//Ctrl_Z Cross_Hair_Off = Returns//Esc//'%!1' c Write(6,300) 27,27,27,27,27 300 Format(1X,1A1,'%!0 ',1A1,'LCH4 ',1A1,'LLC0 ', $ 1A1,'LV1 ',1A1,'%!1',$) c End If c Return End Subroutine Labset(Lset) c *********************************************************************** c Dimension Xmin(2),Ymin(2),Xmax(2),Ymax(2),Xinc(2),Yinc(2) Integer Xnumbr,Ynumbr,Axchst,Axtypx,Axtypy,Axcolr,Ticdir Byte Xaxis(2,80),Yaxis(2,80) c Byte Titl(80),Char c Integer Atxclr,Spchar,Xtop c Common/Ptype/Idev,Xtop,Spchar,Chscal Common/Labls/Nold,Lachst,Lacolr,Nleg,Lechst,Lecolr,Legtit,Labcrd, $ Iprtot,Irott Common/Axis/Xmin,Xmax,Ymin,Ymax,Xinc,Yinc,Xlen,Ylen,Xnumbr, $ Ynumbr,Xaxis,Yaxis,Axthik,Axchst,Axtypx,Axtypy,Axcolr,Textsz, $ Ticdir,Atxclr c c Set the labels coordinate system c If (Labcrd .EQ. 0) Then c c Set up local coordinate system c Call Plcord(Xmin(1),Xmax(1),Ymin(1),Ymax(1),Xlen,Ylen) c Else c c Set up global coordinate system c Call Plcord(0.0,1.0,0.0,1.0,Xlen,Ylen) c End If c c Set the viewport clipping off, and then loop for the labels c Call Stclof Call Sttxco(Lacolr) ! Set the labels colors c c Set the character set c If (Lachst .GT. 0) Then Call Stsoft Call Stcstn(Lachst) If(Spchar .GT. 1) Call Stcspa(1,0,0) Else Call Sthard End If c Call Sttpol(0) ! Do not outline the protected text Call Stlint(1) Call Stlthc(Axthik) Lset = Lachst c Return End Subroutine RPLDAT c *********************************************************************** c * * c * Subroutine RPLDAT - To read the current plot presentation * c * file used by PLOTFL. Routine reads files written by Wpldat. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Character*80 Dummy Character*132 Labelc Byte Labelb(132) Equivalence (Labelc,Labelb) Character*132 Labels(100) Common/Labs/Labels,Xlabel(100),Ylabel(100),Size(100),Jlabel(100), $ Xlen(100),Nchars(100),Irot(100),Iprot(100),Nlab Common/Ptype/Idev,Xtop,Spchar,Chscal c c Read presentation from file "PLTPRG.PLT" c Open(Unit=12,NAME='PLTPRG.PLT',Type='OLD') c Read(12,100) (Dummy,I=1,14) 100 Format(A) Read(12,*) NLab,Lachst,Ntxbl,Nleg,Lechst,Legtit,Labcrd,Iz c If (Nleg .GT. 0) Read(12,100) (Dummy,I=1,Nleg*2+1) c c Read in the text block data: c If (Ntxbl .NE. 0) Then Read(12,100) Dummy Do 30 I=1,Ntxbl c c Read the text block parameters c Read(12,*) Ntxl c c Read the text block label data c Read(12,100) (Dummy,J=1,Ntxl*2) 30 Continue End If c If (Nlab .GT. 0) Then c c Read the labels c Do 40 I=1,Nlab Read(12,*) Nchars(I),Xlabel(I),Ylabel(I), $ Size(I),Jlabel(I),Iprot(I),Irot(I) If (Size(I) .EQ. 1.0) Size(I) = 1.7 If (Size(I) .EQ. 2.0) Size(I) = 2.3 Read(12,100) Labels(I) Call Stccsz(Size(I)*0.03*Chscal,Size(I)*0.042*Chscal) Labelc = '@@@'//Char(48+Lachst)//Labels(I)(1:Nchars(I)) Call Gtstln(Nchars(I)+4,Labelb,Xlen(I)) 40 Continue End If c c Finished reading the presentation data c Close(Unit=12) c Return End Subroutine WPLDAT c *********************************************************************** c * * c * Subroutine WPLDAT - To write the new plot presentation * c * file after the labels have been modified. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Character*80 Dummy Character*132 Labels(100) Common/Labs/Labels,Xlabel(100),Ylabel(100),Size(100),Jlabel(100), $ Xlen(100),Nchars(100),Irot(100),Iprot(100),Nlab Common/Legmov/Xorig,Yorig,Xlegln,Ylegln,Lesize,Legcnr,Leglin, $ Gblspc Common/Txplot/Xtxorg(20),Ytxorg(20),Xtlen(20),Ytlen(20), $ Loctx(20),Txszratio(20),Txspac(20),Txlen(20) c c Read presentation from file "PLTPRG.PLT" c Open(Unit=12,NAME='PLTPRG.PLT',Type='OLD',ReadOnly) Open(Unit=14,Name='PLTPRG.PLT',Type='NEW') c Do 10 I=1,14 Read(12,100) Nch,Dummy Write(14,200) Dummy(1:Nch) 100 Format(Q,A) 200 Format(A) 10 Continue c Read(12,*) Nlab_Old,Lachst,Ntxbl,Nleg,Lechst,Legtit, $ Labcrd,Iz Write(14,300) Nlab,Lachst,Ntxbl,Nleg,Lechst,Legtit, $ Labcrd,Iz 300 Format(8I5) c If (Nleg .GT. 0) Then Read(12,*) Xleg,Yleg,Locleg,Iboxleg,Sizleg,Legsz,Idummy,Gb Call Size_Legend(Xorig,Yorig,Legcnr,Xlegln,Ylegln,0.0) Write(14,325) Xorig,Yorig,Legcnr,Iboxleg,Lesize,Legsz, $ Idummy,Gblspc 325 Format(2F19.7,5I5,G12.5) Do 20 I=1,Nleg*2 Read(12,100) Nch,Dummy Write(14,200) Dummy(1:Nch) 20 Continue End If c c Read in the text block data: c If (Ntxbl .NE. 0) Then Read(12,100) Nch,Dummy Write(14,200) Dummy(1:Nch) Do 30 I=1,Ntxbl c c Read the text block parameters c Read(12,*) Ntxl,Txtblx,Txtbly, $ Itxblch,Itxblcl,Txbloc,Itxbord,Txblsp Call Size_Legend(Xtxorg(I),Ytxorg(I),Loctx(I),Xtlen(I), $ Ytlen(I),0.0) Write(14,350) Ntxl,Xtxorg(I),Ytxorg(I),Itxblch,Itxblcl, $ Loctx(I),Itxbord,Txspac(I) 350 Format(I5,2G19.7,4I5,F12.5) Do 25 J=1,Ntxl*2 Read(12,100) Nch,Dummy Write(14,200) Dummy(1:Nch) 25 Continue 30 Continue End If c If (Nlab .GT. 0) Then c c Read the labels c Do 40 I=1,Nlab Write(14,400) Nchars(I),Xlabel(I),Ylabel(I), $ Int(Size(I)),Jlabel(I),Iprot(I),Irot(I) 400 Format(I5,2E19.7,4I5) Write(14,200) Labels(I)(1:Nchars(I)) 40 Continue End If c c Read up the old labels c Do 45 I=1,Nlab_Old*2 Read(12,100) Nch,Dummy 45 Continue c c Write the plot curve information c 50 Continue Read(12,100,END=60,ERR=60) Nch,Dummy Write(14,200) Dummy(1:Nch) Go To 50 c 60 Continue c c Finished reading the presentation data c Close(Unit=12) Close(Unit=14) Open(Unit=12,Name='PLTPRG.PLT;-1',Type='OLD',Dispose= $ 'DELETE') Close(Unit=12) c Return End Subroutine Enderi c *********************************************************************** c * * c * Subroutine ENDERI - To finish up a plot, & restart PLTPRG. * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Write(6,200) 27,7,27 200 Format(A,'[HDo you want to keep the changes? (y/n) ',2A,'[K') Call Instrg('YyNn',4,Iyn) If (Iyn .LT. 3) Call Wpldat c Call Plot_On Call Scfini Call Plot_Clear c c Sound the bell c Write(6,100) 7,7 100 Format(1X,2A1) c Call Exit c End Subroutine Near_Label(Xpos,Ypos,N) c Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Character*132 Labels(100) Common/Labs/Labels,Xlabel(100),Ylabel(100),Size(100),Jlabel(100), $ Xlen(100),Nchars(100),Irot(100),Iprot(100),Nlab Common/Ptype/Idev,Xtop,Spchar,Chscal,Chsc1 c Call Gtscrn(Xsl,Xsr,Ysb,Yst) Rmin = 100.0 * (Xsr**2 + Yst**2) Dx = (Xpos-Xsmin)/(Xsmax-Xsmin)*(Xsr-Xsl) + Xsl Dy = (Ypos-Ysmin)/(Ysmax-Ysmin)*(Yst-Ysb) + Ysb N = 0 c c Loop over the labels to see which is closest c to the crosshairs. Use screen units. c Do 10 I=1,Nlab Angle = Irot(I)/180.*3.1415926 Cosine = Cos(Angle) Sine = Sin(Angle) Xo = (Xlabel(I)-Xsmin)/(Xsmax-Xsmin)*(Xsr-Xsl) + Xsl $ - Xlen(I)/2.0 * (Jlabel(I) - 1) * Cosine Yo = (Ylabel(I)-Ysmin)/(Ysmax-Ysmin)*(Yst-Ysb) + Ysb $ - Xlen(I)/2.0 * (Jlabel(I) - 1) * Sine c Sizes = (Size(I) * 0.042 + 0.03) * Chscal X1 = Xo Y1 = Yo X2 = Xo - Sizes * Sine Y2 = Yo + Sizes * Cosine c X3 = Xo + Xlen(I) * Cosine - Sizes * Sine c Y3 = Yo + Xlen(I) * Sine + Sizes * Cosine X4 = Xo + Xlen(I) * Cosine Y4 = Yo + Xlen(I) * Sine c If (Abs(X4-X1) .GT. 1E-4) Then Slope1 = (Y4-Y1)/(X4-X1) Else Slope1 = 10000.0 End If c If (Abs(X2-X1) .GT. 1E-4) Then Slope2 = (Y2-Y1)/(X2-X1) Else Slope2 = 10000.0 End If c If (Abs(Slope2-Slope1) .LT. 1E-4) Go To 10 c Xint = (Y1-Slope1*X1 - (Dy-Slope2*Dx))/(Slope2-Slope1) Yint = Slope1*(Xint-X1) + Y1 D1 = ((Dx-Xint)**2 + (Dy-Yint)**2) c Xint = (Y2-Slope1*X2 - (Dy-Slope2*Dx))/(Slope2-Slope1) Yint = Slope1*(Xint-X2) + Y2 D2 = ((Dx-Xint)**2 + (Dy-Yint)**2) c Xint = (Y1-Slope2*X1 - (Dy-Slope1*Dx))/(Slope1-Slope2) Yint = Slope2*(Xint-X1) + Y1 D3 = ((Dx-Xint)**2 + (Dy-Yint)**2) c Xint = (Y4-Slope2*X4 - (Dy-Slope1*Dx))/(Slope1-Slope2) Yint = Slope2*(Xint-X4) + Y4 D4 = ((Dx-Xint)**2 + (Dy-Yint)**2) c If (Rmin .GT. D1) Then Rmin = D1 N = I End If c If (Rmin .GT. D2) Then Rmin = D2 N = I End If c If (Rmin .GT. D3) Then Rmin = D3 N = I End If c If (Rmin .GT. D4) Then Rmin = D4 N = I End If c 10 Continue Return End