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 Ichar = Ittinr() Write(5,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 I = Ittinr() c If (I .EQ. 13) Then I = Ittinr() Else Write(7,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(7,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(7,100) 27,(127,I=1,Icnt),7 200 Format('+',A1,'[2A',A1,$) c Go To 10 End Subroutine Rnum(Val) 10 Continue c c Read in a value c Isign = 1 Iflag = 1 Per = 0.0 Sum = 0.0 20 Continue I = Ittinr() c If (I .EQ. 13) Then I = Ittinr() If (Iflag .EQ. 1) Go To 20 Else If (I .EQ. 45) Then Isign = -1 Write(7,100) 27,I Go To 20 Else If (I .EQ. 46) Then Per = 10.0 Write(7,100) 27,I Go To 20 Else Write(7,100) 27,I 100 Format('+',A1,'[2A',A1,$) If (I .GE. 48 .AND. I .LE. 57) Then Iflag = 0 If (Per .EQ. 0.0) Then Sum = Sum * 10.0 + (I-48) Else Sum = Sum + (I-48)/Per Per = Per / 10.0 End If Else Write(7,100) 27,7 End If Go To 20 End If c c See if the value lies within the a given range c Val = Sum * Isign Return End Subroutine NrLeg(Xpos,Ypos,N,Xog,Yog,Xlen,Ylen) c Common/Scrdat/Xsl,Xsr,Ysb,Yst Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Dimension D(9) c Dx = (Xpos-Xsmin)/(Xsmax-Xsmin)*(Xsr-Xsl) + Xsl Dy = (Ypos-Ysmin)/(Ysmax-Ysmin)*(Yst-Ysb) + Ysb Rmin = 100.0 * (Xsr**2 + Yst**2) N = 0 c Xo = (Xog-Xsmin)/(Xsmax-Xsmin)*(Xsr-Xsl) + Xsl Yo = (Yog-Ysmin)/(Ysmax-Ysmin)*(Yst-Ysb) + Ysb Xl = Xlen/(Xsmax-Xsmin)*(Xsr-Xsl) Yl = Ylen/(Ysmax-Ysmin)*(Yst-Ysb) c D(1) = (Dx-Xo)**2 + (Dy-Yo-Yl)**2 D(2) = (Dx-Xo)**2 + (Dy-Yo)**2 D(3) = (Dx-Xo-Xl)**2 + (Dy-Yo-Yl)**2 D(4) = (Dx-Xo-Xl)**2 + (Dy-Yo)**2 D(5) = (Dx-Xo-Xl/2.0)**2 + (Dy-Yo-Yl/2.0)**2 D(6) = (Dx-Xo)**2 + (Dy-Yo-Yl/2.0)**2 D(7) = (Dx-Xo-Xl)**2 + (Dy-Yo-Yl/2.0)**2 D(8) = (Dx-Xo-Xl/2.0)**2 + (Dy-Yo-Yl)**2 D(9) = (Dx-Xo-Xl/2.0)**2 + (Dy-Yo)**2 c Do 10 I=1,9 If (Rmin .GT. D(I)) Then N = I Rmin = D(I) End If 10 Continue c Return End Subroutine NewLeg(Xpos,Ypos,N,Xo,Yo,Xlen,Ylen) c If (N .EQ. 1) Then Xo = Xpos Yo = Ypos - Ylen Else If (N .EQ. 2) Then Xo = Xpos Yo = Ypos Else If (N .EQ. 3) Then Xo = Xpos - Xlen Yo = Ypos - Ylen Else If (N .EQ. 4) Then Xo = Xpos - Xlen Yo = Ypos Else If (N .EQ. 5) Then Xo = Xpos - Xlen/2.0 Yo = Ypos - Ylen/2.0 Else If (N .EQ. 6) Then Xo = Xpos Yo = Ypos - Ylen/2.0 Else If (N .EQ. 7) Then Xo = Xpos - Xlen Yo = Ypos - Ylen/2.0 Else If (N .EQ. 8) Then Xo = Xpos - Xlen/2.0 Yo = Ypos - Ylen Else Xo = Xpos - Xlen/2.0 Yo = Ypos End If c Return End Subroutine SizLeg(Xpos,Ypos,N,Xlen,Ylen,Ratio) c If (N .EQ. 1) Then Ypos = Ypos + Ylen - Ylen * Ratio Else If (N .EQ. 3) Then Xpos = Xpos + Xlen - Xlen * Ratio Ypos = Ypos + Ylen - Ylen * Ratio Else If (N .EQ. 4) Then Xpos = Xpos + Xlen - Xlen * Ratio Else If (N .EQ. 5) Then Xpos = Xpos + Xlen/2.0 - Xlen/2.0 * Ratio Ypos = Ypos + Ylen/2.0 - Ylen/2.0 * Ratio Else If (N .EQ. 6) Then Ypos = Ypos + Ylen/2.0 - Ylen/2.0 * Ratio Else If (N .EQ. 7) Then Xpos = Xpos + Xlen - Xlen * Ratio Ypos = Ypos + Ylen/2.0 - Ylen/2.0 * Ratio Else If (N .EQ. 8) Then Xpos = Xpos + Xlen/2.0 - Xlen/2.0 * Ratio Ypos = Ypos + Ylen - Ylen * Ratio Else If (N .EQ. 9) Then Xpos = Xpos + Xlen/2.0 - Xlen/2.0 * Ratio End If c Xlen = Xlen * Ratio Ylen = Ylen * Ratio c Return End Subroutine Neartb(Xpos,Ypos,N) Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Common/Textbl/Ntxbl Common/Txplot/Xtxorg(10),Ytxorg(10),Xtlen(10),Ytlen(10), $ Loctx(10),Txszrt(10),Txspac(10),Txlen(10) Common/Scrdat/Xsl,Xsr,Ysb,Yst c 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,Ntxbl Xo = (Xtxorg(I)-Xsmin)/(Xsmax-Xsmin)*(Xsr-Xsl) + Xsl Yo = (Ytxorg(I)-Ysmin)/(Ysmax-Ysmin)*(Yst-Ysb) + Ysb Xl = Xtlen(I)/(Xsmax-Xsmin)*(Xsr-Xsl) Yl = Ytlen(I)/(Ysmax-Ysmin)*(Yst-Ysb) c Xint = Amin1(Xo+Xl,Amax1(Xo,Dx)) Yint = Amin1(Yo+Yl,Amax1(Yo,Dy)) Delta = (Dx-Xint)**2 + (Dy-Yint)**2 c If (Rmin .GT. Delta) Then Rmin = Delta N = I End If c 10 Continue Return End Subroutine NrLab(Akeep,Xpos,Ypos,N) c Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax Virtual Akeep(28,50) Integer Spchar,Atxclr,Xtop Common/Ptype/Idev,Xtop,Spchar,Chscal,Chsc1 Common/Scrdat/Xsl,Xsr,Ysb,Yst Common/Labs/Nlab c 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 Call Vunlod(Akeep,I,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Angle = Irot/180.*3.1415926 Cosine = Cos(Angle) Sine = Sin(Angle) Xo = (Xlabel-Xsmin)/(Xsmax-Xsmin)*(Xsr-Xsl) + Xsl $ - Xlen/2.0 * (Jlabel - 1) * Cosine Yo = (Ylabel-Ysmin)/(Ysmax-Ysmin)*(Yst-Ysb) + Ysb $ - Xlen/2.0 * (Jlabel - 1) * Sine c Sizes = (Size * 0.042 + 0.03) * Chscal X1 = Xo Y1 = Yo X2 = Xo - Sizes * Sine Y2 = Yo + Sizes * Cosine X4 = Xo + Xlen * Cosine Y4 = Yo + Xlen * 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 Subroutine UnLoad(Xxp,Line,N) Character*80 Line,Linep Byte Lineb(80) Virtual Xxp(28,50) Dimension Y(20) Equivalence (Linep,Lineb),(Lineb,Y) Do 10 I=1,20 Y(I) = Xxp(I,N) 10 Continue Line = Linep Return End Subroutine Load(Xxp,Line,N) Character*80 Line,Linep Byte Lineb(80) Virtual Xxp(28,50) Dimension Y(20) Equivalence (Linep,Lineb),(Lineb,Y) Linep = Line Do 10 I=1,20 Xxp(I,N) = Y(I) 10 Continue Return End Subroutine Cross(Checkr,Ncheck,Xpos,Ypos,Iflag) c Common/Tmdata/TmDvTy,TmGrSt,TmGrOf,TmGrCl,TmGrOn, $ CrHrOn,CrHrOf Character*20 TmDvTy,TmGrSt,TmGrOf,TmGrCl,TmGrOn,CrHrOn,CrHrOf Character*30 Checkr,Holds,Vthold Character Chr*1 Byte Bytes,Byt(30) Equivalence (Bytes,Chr),(Byt,Holds) c Common/Cross/Xsmin,Xsmax,Ysmin,Ysmax c If (Tmdvty .NE. 'VT12' .OR. Nchars .EQ. 0) Then Call Croson Else Write(7,250) 27,Vthold(1:Nchars) 250 Format(1X,1A1,'PpP',A,';R(P(I));') End If c Iflag = 0 If (Tmdvty .EQ. '4105' .OR. Tmdvty .EQ. '4014') Then 1 Continue Nchars = 0 2 Continue I = Ittinr() If (I .NE. 13) Then Nchars = Nchars + 1 Byt(Nchars) = I Go To 2 End If If (Nchars .GT. 3) Then Bytes = Byt(1) Do 5 I=1,Ncheck If (Checkr(I:I) .EQ. Chr) Iflag = I 5 Continue Else Go To 1 End If I = Ittinr() 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 (Tmdvty .EQ. 'VT12') Then c c Dec terminal c Ipos = 1 Nchars = 0 57 Continue I = Ittinr() Nchars = Nchars + 1 Byt(Nchars) = I If (Byt(Nchars) .EQ. '[') Ipos = Max0(1,Nchars-1) If (Byt(Nchars) .NE. ']') Go To 57 I = Ittinr() Do 61 I=1,Ncheck If (Checkr(I:I) .EQ. Holds(Ipos:Ipos)) 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 Decode(Last,300,Holds) Intx,Inty 300 Format(2I10) 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 Crosof Return End Subroutine Pltcmd c Common/Tmdata/TmDvTy,TmGrSt,TmGrOf,TmGrCl,TmGrOn, $ CrHrOn,CrHrOf Character*20 TmDvTy,TmGrSt,TmGrOf,TmGrCl,TmGrOn,CrHrOn,CrHrOf c Entry Plton Call PlCmdW(TmGrOn) Return c Entry Pltoff Call Plflsh Call PlCmdw(TmGrOf) Return c Entry PltClr Call Plflsh Call PlCmdW(TmGrCl) Return c Entry PltSt Call PlCmdW(TmGrSt) Return c Entry Croson Call PlCmdW(CrHrOn) 150 Format('+',1A1,$) Return c Entry Crosof Call PlCmdW(CrHrOf) Return c End Subroutine Plcmdw(String) Character*20 String c Do 10 I=20,1,-1 If (String(I:I) .NE. ' ') Then Write(5,100) String(1:I) 100 Format('+',A,$) Return End If 10 Continue c Return End Subroutine Linedt(Line,Nchars,Maxlen) c c *********************************************************************** c * * c * Subroutine Linedt - To enable the user to "EDIT" lines * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Line(1),Char Equivalence (Char,I) c Iecho = 1 c Write(5,100) (Line(I),I=1,Nchars) 100 Format('+',A1,$) 150 Format('+',1A1,$) c c Initialize locations c Iesc = 0 Iloc = Nchars + 1 c 10 Continue c c Get the character input c I = Ittinr() 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. 11 .OR. I .GT. 255) Go To 10 c If (I .EQ. 127) Then c c Delete from the text c Write(5,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(5,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(5,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(5,250) 27,I,27 Else Write(5,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(5,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(5,150) 7 Go To 10 Else If (Char .EQ. 'C') Then Write(5,350) 27,I 350 Format('+',1A1'[',1A1,$) Iloc = Iloc + 1 Else If (Char .EQ. 'D') Then Write(5,350) 27,I Iloc = Max0(Iloc - 1,1) Else If (Char .EQ. 'B') Then Write(5,350) (27,'C',J=1,Nchars-Iloc+1) Iloc = Nchars + 1 Else If (Char .EQ. 'A' .AND. Iloc .GT. 1) Then Write(5,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 I = Ittinr() Return End Subroutine Vunlod(Akeep,I,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) Virtual Akeep(28,50) c Xlabel = Akeep(21,I) Ylabel = Akeep(22,I) Xlen = Akeep(23,I) Size = Akeep(24,I) Nchars = Akeep(25,I) Jlabel = Akeep(26,I) Iprot = Akeep(27,I) Irot = Akeep(28,I) c Return End Subroutine Vload(Akeep,I,Xlabel,Ylabel,Xlen,Size,Nchars,Jlabel, $ Iprot,Irot) c Virtual Akeep(28,50) c Akeep(21,I) = Xlabel Akeep(22,I) = Ylabel Akeep(23,I) = Xlen Akeep(24,I) = Size Akeep(25,I) = Nchars Akeep(26,I) = Jlabel Akeep(27,I) = Iprot Akeep(28,I) = Irot c Return End