Subroutine Labup(Akeep,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*84 Labelc,Lhold,String*4 Byte Labelb(84),Strinb(4) Equivalence (Labelc,Labelb),(String,Strinb) Virtual Akeep(28,50) c Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Integer Spchar,Atxclr,Xtop Common/Labs/Nlab Common/Ptype/Idev,Xtop,Spchar,Chscal Common/Scrdat/Xsl,Xsr,Ysb,Yst c If (Lset .NE. 0) Call Stcstn(Lset) c c Set default character set c String(1:3) = '@@@' Strinb(4) = Lset+48 c 10 Continue c Write(7,150) 27,27,27,27,7,27 150 Format(1X,1A1,'[H',A1,'[K'/1X,A1,'[K',A1,'[H', $ 'LABELS: Select (A)dd, (D)elete, (M)ove,', $ ' (C)hange, (R)edraw, or (S)top ',2A1,'[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(7,200) 27,27 200 Format(1X,1A1,'[HText: ',1A1,'[K'/ $ 1X,1A1,'[K',$) Nchars = 0 Call Linedt(Labelb,Nchars,80,1) c Write(7,300) 27,27 300 Format(1X,1A1,'[HEnter (L)eft, (C)enter, or (R)ight', $ ' justification ',1A1,'[K',$) Call Instrg('LlCcRr',6,In) Jlabel = (In+1)/2 c Write(7,350) 27,27 350 Format(1X,1A1,'[HEnter the text size (1-10) ',1A1,'[K',$) Call Inchek(1,10,Is) If (Is .EQ. 1) Then Size = 1.7 Else If (Is .EQ. 2) Then Size = 2.3 Else Size = Is End If c Write(7,400) 27,27 400 Format(1X,1A1,'[HMove cursors to the label position on the', $ ' plot ',1A1,'[K',$) Call Cross('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 Plton Call Stcrot(0.0) Call Stjust(Jlabel) Call Stccsz(Size*0.03*Chscal,Size*0.042*Chscal) Labelc(Nchars+1:Nchars+4) = String Call Gtstln(Nchars,Labelb,Xlen) Call Movawc(Xpos,Ypos) Call Grtxcp(Nchars+4,Labelb) Call Pltoff Call Load(Akeep,Labelc,Nlab) Call Vload(Akeep,Nlab,Xpos,Ypos,Xlen,Size,Nchars,Jlabel,0,0) c Else If (Ido .EQ. 2) Then c c Delete a label from the plot c 15 Continue c Write(7,450) 27,27 450 Format(1X,A1,'[HMove cursors to label to delete',A1,'[K',$) Call Cross('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Nrlab(Akeep,Xpos,Ypos,N) c c "Box" in the label c Call Plton Call Boxes(Akeep,N) Call Pltoff c Write(7,475) 27,27 475 Format(1X,A1,'[HIs this the label to delete? (y/n) ',A1, $ '[K',$) Call Instrg('YyNn',4,Iyn) c Call PlDlSt Call Boxes(Akeep,N) Call PlDlEn c If (Iyn .GT. 2) Go To 15 c c Removing the label from the plot c Call PlDlSt Call Vunlod(Akeep,N,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Call Stcrot(Irot*1.0) Call Stjust(Jlabel) Call Stccsz(Size*0.03*Chscal,Size*0.042*Chscal) Call Movawc(Xlabel,Ylabel) Call Unload(Akeep,Labelc,N) Labelc(Nchars+1:Nchars+4) = String Call Grtxcp(Nchars+4,Labelb) Call Stcrot(0.0) Call PlDlEn c c Updating the pointers c Nlab = Nlab - 1 Do 20 I=N,Nlab Call Unload(Akeep,Labelc,I+1) Call Load(Akeep,Labelc,I) Call Vunlod(Akeep,I+1,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Call Vload(Akeep,I,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) 20 Continue c Else If (Ido .EQ. 3) Then c c Move a label on the plot c 25 Continue Write(7,500) 27,27 500 Format(1X,A1,'[HMove cursors to label to move',A1,'[K',$) Call Cross('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Nrlab(Akeep,Xpos,Ypos,N) Call Plton Call Boxes(Akeep,N) Call Pltoff c Write(7,525) 27,27 525 Format(1X,A1,'[HIs this the right label to move? (y/n) ', $ A1,'[K',$) Call Instrg('YyNn',4,Iyn) Call PlDlSt Call Boxes(Akeep,N) Call PlDlEn 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 Plton Call Vunlod(Akeep,N,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Call Movawc(Xlabel-Deltax,Ylabel) Call Drwawc(Xlabel+Deltax,Ylabel) Call Movawc(Xlabel,Ylabel-Deltay) Call Drwawc(Xlabel,Ylabel+Deltay) Call Pltoff c c Get the new label position c Write(7,550) 27,27 550 Format(1X,A1,'[HMove the crosshairs - The cross below the', $ ' label will position it',A1,'[K',$) Call Cross('Ss ',3,Xpos,Ypos,Nflag) c c Remove the cross on the label c Call PlDlSt Call Movawc(Xlabel-Deltax,Ylabel) Call Drwawc(Xlabel+Deltax,Ylabel) Call Movawc(Xlabel,Ylabel-Deltay) Call Drwawc(Xlabel,Ylabel+Deltay) Call PlDlEn If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 c c Delete the old label c Call PlDlSt Call Stcrot(Irot*1.0) Call Stjust(Jlabel) Call Stccsz(Size*0.03*Chscal,Size*0.042*Chscal) Call Movawc(Xlabel,Ylabel) Call Unload(Akeep,Labelc,N) Labelc(Nchars+1:Nchars+4) = String Call Grtxcp(Nchars+4,Labelb) Call PlDlEn c c Draw the new label on the plot c Call Plton Call Vload(Akeep,N,Xpos,Ypos,Xlen,Size,Nchars,Jlabel,Iprot, $ Irot) Call Movawc(Xpos,Ypos) Call Grtxcp(Nchars+4,Labelb) Call Stcrot(0.0) Call Pltoff c Else If (Ido .EQ. 4) Then c c Change a label on the plot c 30 Continue c Write(7,600) 27,27 600 Format(1X,A1,'[HMove cursors to label to change', $ ' (or "S" to stop) ',A1,'[K',$) Call Cross('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Nrlab(Akeep,Xpos,Ypos,N) c Call Plton Call Boxes(Akeep,N) Call Pltoff c Write(7,625) 27,27 625 Format(1X,A1,'[HIs this the right label to change? (y/n) ',A1, $ '[K',$) Call Instrg('YyNn',4,Iyn) Call PlDlSt Call Boxes(Akeep,N) Call PlDlEn If (Iyn .GT. 2) Go To 30 c Write(7,650) 27,27 650 Format(1X,A1,'[HEnter (L)abel text, (T)ext size,' $ ' (J)ustification, (R)otation, or (S)top ',A1,'[K',$) c Call Instrg('LlTtJjRrSs',10,Ich) Ich = (Ich+1)/2 c Call Vunlod(Akeep,N,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) If (Ich .EQ. 1) Then Write(7,700) 27,27,27 700 Format(1X,A1,'[H Edit: ',A1,'[K'/1X,A1,'[K',$) Call Unload(Akeep,Labelc,N) Call Unload(Akeep,Lhold,N) Nch = Nchars Call Linedt(Labelb,Nch,132,1) Write(7,725) 27 725 Format('+',1A1,'[H',$) If (Labelc(1:Nch) .EQ. Lhold(1:Nchars)) Go To 30 Else If (Ich .EQ. 2) Then Write(7,750) 27,Int(Size),27 750 Format(1X,A1,'[HEnter the label character size (currently', $ I3,') ',A1,'[K',$) Call Inchek(1,10,Is) If (Is .EQ. Int(Size)) Go To 30 Else If (Ich .EQ. 3) Then Write(7,300) 27,27 Call Instrg('LlCcRr',6,I) Jl = (I+1)/2 If (Jl .EQ. Jlabel) Go To 30 Else If (Ich .EQ. 4) Then Write(7,775) 27,27 775 Format(1X,A1,'[HEnter the text rotation angle ',A1, $ '[K',$) Call Rnum(Ro) If (Int(Ro) .EQ. Irot) Go To 30 Else Go To 10 End If c c Erase the old label c Call PlDlSt Call Stcrot(Irot*1.0) Call Stjust(Jlabel) Call Stccsz(Size*0.03*Chscal,Size*0.042*Chscal) Call Movawc(Xlabel,Ylabel) Lhold = Labelc Call Unload(Akeep,Labelc,N) Labelc(Nchars+1:Nchars+4) = String Call Grtxcp(Nchars+4,Labelb) Call PlDlEn c c Update the label parameters to the new values c If (Ich .EQ. 1) Then Call Load(Akeep,Lhold,N) Nchars = Nch Labelc = Lhold Labelc(Nchars+1:Nchars+4) = String Write(7,780) 27,27,27 780 Format(1X,A1,'[H',A1,'[K'/1X,A1,'[K',$) Else If (Ich .EQ. 2) Then If (Is .EQ. 1) Then Size = 1.7 Else If (Is .EQ. 2) Then Size = 2.3 Else Size = Is End If Else If (Ich .EQ. 3) Then Jlabel = Jl Else Irot = Ro End If c c Draw in the changed label c Call Plton Call Stcrot(Irot*1.0) Call Stjust(Jlabel) Call Stccsz(Size*0.03*Chscal,Size*0.042*Chscal) Call Gtstln(Nchars,Labelb,Xlen) Call Movawc(Xlabel,Ylabel) Call Grtxcp(Nchars+4,Labelb) Call Stcrot(0.0) Call Vload(Akeep,N,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Call Pltoff 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(7,800) 27,27 800 Format(1X,A1,'[HMove cursors to label to redraw',A1,'[K',$) Call Cross('Ss ',3,Xpos,Ypos,Nflag) If (Nflag .EQ. 1 .OR. Nflag .EQ. 2) Go To 10 Call Nrlab(Akeep,Xpos,Ypos,N) Call Plton Call Vunlod(Akeep,N,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Call Stcrot(Irot*1.0) Call Stjust(Jlabel) Call Stccsz(Size*0.03*Chscal,Size*0.042*Chscal) Call Movawc(Xlabel,Ylabel) Call Unload(Akeep,Labelc,N) Labelc(Nchars+1:Nchars+4) = String Call Grtxcp(Nchars+4,Labelb) Call Stcrot(0.0) Call Pltoff Else Return End If c Go To 10 c End Subroutine Boxes(Akeep,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 Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Integer Spchar,Atxclr,Xtop Common/Ptype/Idev,Xtop,Spchar,Chscal,Chsc1 Common/Scrdat/Xsl,Xsr,Ysb,Yst Virtual Akeep(28,50) c Call Vunlod(Akeep,N,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel,Iprot, $ Irot) Angle = Irot/180.*3.1415926 Cosine = Cos(Angle) Sine = Sin(Angle) Xlx = (Xsmax-Xsmin)/(Xsr-Xsl) * Xlen Xly = (Ysmax-Ysmin)/(Yst-Ysb) * Xlen Xo = Xlabel - (Jlabel-1)*Xlx*Cosine/2.0 Yo = Ylabel - (Jlabel-1)*Xly*Sine/2.0 c Sizex = (Size * 0.042 + 0.03) * Chscal * (Xsmax-Xsmin)/ $ (Xsr-Xsl) Sizey = (Size * 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