Subroutine REP(Text,Txtlen,Start,Length,Newtxt,Newlen) c c ************************************************************************ c * * c * Subroutine REP - To insert a new character string into an * c * existing character string (replacement). This is similar * c * to the BASIC function "REP" * c * * c * Input values: * c * * c * Text - The original character string * c * Txtlen - The length of the original character string * c * Start - The starting location of the replacement text * c * Length - The number of characters in the original text to * c * be replaced * c * Newtxt - The new text to be inserted * c * Newlen - The length of the new text * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c ************************************************************************ c Byte Text(1),Newtxt(1) Integer Start,Txtlen c c See If the number of characters in the text has changed - if c so, move the other characters in Text so the new characters c fit in exactly. c If (Newlen .EQ. Txtlen .OR. Length .EQ. Newlen) Go To 40 Ndiff = Newlen-Length Netmov = Txtlen-Start-Length+1 c c If the number of new characters are greater than the number of c original characters, then move the trailing characters in c Text down c If (Newlen .LT. Length) Go To 20 Do 10 I=0,Netmov-1 Text(Txtlen-I+Ndiff) = Text(Txtlen-I) 10 Continue c c Go and Fill in the new data into Text c Go To 40 20 Continue c c For fewer characters than before; move the lower characters c in Text up c Do 30 I=1,Netmov J = Start+Newlen+I-1 Text(J) = Text(J-Ndiff) 30 Continue c c If Text is to be deleted, Newlen = 0. Otherwise, insert the c new characters c If (Newlen .EQ. 0) Go To 60 c 40 Continue c c Store the characters in Newtxt back into Text c Do 50 I=1,Newlen Text(Start-1+I) = Newtxt(I) 50 Continue 60 Continue c c Update the length of the text string c Txtlen = Txtlen-Length+Newlen Return End Subroutine SORT(Xvals,Yvals,Npoint) c c *********************************************************************** c * * c * Subroutine SORT - To Sort numbers in array "Xvals" and * c * "Yvals" in ascending order with respect to "Xvals". * c * The sorting technique used here is called a Heapsort, * c * and is much faster, on the average, than a bubble sort. * c * As an example, for 3000 random elements, the bubble sort * c * (with a flag) took 12 minutes, and the Heapsort took * c * 3 or 4 seconds. I got the routine from the monthly * c * newsletter of the Washington area TI computer users group, * c * in BASIC, so I don't have any internal program comments. * c * * c * Input values: * c * * c * Xvals - The array that contains the data to be sorted * c * Yvals - An array whose elements are sorted with respect * c * to the array Xvals * c * Npoint - The number of points in Xvals * c * * c * Output values: * c * * c * The sorted values in Xvals are returned in Xvals * c * The values in Yvals, sorted with respect to Xvals, are * c * returned in Yvals * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Dimension Xvals(1),Yvals(1) c If (Npoint .EQ. 1) Return ! only one point, so return Lpoint = Npoint/2+1 Mcount = Npoint 10 If (Lpoint .EQ. 1) Go To 20 Lpoint = Lpoint-1 Xhold = Xvals(Lpoint) Yhold = Yvals(Lpoint) Go To 30 20 Xhold = Xvals(Mcount) Yhold = Yvals(Mcount) Xvals(Mcount) = Xvals(1) Yvals(Mcount) = Yvals(1) Mcount = Mcount-1 If (Mcount .EQ. 1) Go To 70 30 Jpoint = Lpoint 40 Ipoint = Jpoint Jpoint = Jpoint*2 If (Jpoint .EQ. Mcount) Go To 50 If (Jpoint .GT. Mcount) Go TO 60 If (Xvals(Jpoint) .GE. Xvals(Jpoint+1)) Go To 50 Jpoint = Jpoint+1 50 If (Xhold .GT. Xvals(Jpoint)) Go To 60 Xvals(Ipoint) = Xvals(Jpoint) Yvals(Ipoint) = Yvals(Jpoint) Go To 40 60 Xvals(Ipoint) = Xhold Yvals(Ipoint) = Yhold Go To 10 70 Xvals(1) = Xhold Yvals(1) = Yhold Return End Subroutine COLCHK(Ixcrv,Iycrv,Iflag,Iunit) c c *********************************************************************** c * * c * Subroutine COLCHK - To check the X and Y columns to * c * see if they are the right ones, and to see if they have * c * the same number of points in each column * c * * c * Input values: * c * * c * Ixcrv - The column number corresponding to the X * c * values * c * Iycrv - The column number corresponding to the Y * c * values * c * Iunit - The unit to print them on * c * * c * Output values: * c * * c * Iflag - A flag to indicate whether the columns are * c * acceptable to the user, and/or whether * c * the number of points in each column agree * c * Iflag = 0 OK * c * Iflag = 1 ERROR * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Integer Choice c Iflag = 1 c c See if the column numbers fall within range c If (Ixcrv .LT. 1 .OR. Ixcrv .GT. Ncols .OR. Iycrv .LT. 1 .OR. $ Iycrv .GT. Ncols) Then Write(7,100) 100 Format(' ERROR - column numbers fall out of range') c c See if the number of pointsin each column match c Else If (Npoint(Ixcrv) .NE. Npoint(Iycrv)) Then Write(7,200) Npoint(Ixcrv),Npoint(Iycrv) 200 Format(' ERROR - X column has',I4,' points, Y column has', $ I4,' points') Else c c Write out the column titles c Call Name(Titl,Ixcrv,Title,Ttllen) Write(Iunit,230) 'X',(Titl(I),I=1,Ttllen(Ixcrv)) 230 Format(1X,A1,' column title: ',132(:,A1)) Call Name(Titl,Iycrv,Title,Ttllen) Write(Iunit,230) 'Y',(Titl(I),I=1,Ttllen(Iycrv)) Iflag = 0 End If Return End Subroutine Spause c c *********************************************************************** c * * c * Subroutine Spause - To pause the program to keep the screen * c * from being cleared. Any sort of input will return to the * c * calling routine. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte In c Write(7,100) 100 Format(' Press Return to continue ',$) Read(5,200,ERR=10,END=10) In 200 Format(1A1) 10 Continue I = In If (I .EQ. 3) Call Abort Return End Subroutine Endabt(Data) c c *********************************************************************** c * * c * Subroutine ENDABT - To end the program when a Ctrl-C * c * has been entered. This routine enables the user to * c * save the data in the program if it has been changed since * c * the last time the scratch files have been updated. * c * Since the scratch files aren't purged, that data won't * c * be lost. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' Include 'Ctable' c c Turn echo on, and single character activiation off c Write(7,150) 29,'T',29,'E' 150 Format('+',1A1,$) c c See if there is anything to save c If (Idflag+Itflag+Ipflag .EQ. 0) Then Call Setcmd(' @DP:PLTPRG.CLR') Call Exit End If c c See if the user wants to save anything c Write(7,200) 27,27 200 Format(1X,1A1,'[1;24r',1A1,'8'// $ ' Do you want to save your information? (y/n) ',$) Call Instrg('YyNn',4,Ich) If (Ich .GT. 2) Then Call Setcmd(' @DP:PLTPRG.CLR') Call Exit End If c c Save the data values c If (Idflag .NE. 0 .AND. Ncols .GT. 0) Then Write(7,300) 'data values? ' 300 Format(/' Do you want to save the ',A13,' (y/n) ',$) Call Instrg('YyNn',4,I) If (I .LE. 2) Call Wrtfil(Data) End If c c Save the presentation data c If (Ipflag .NE. 0) Then Write(7,300) 'presentation?' Call Instrg('YyNn',4,I) If (I .LE. 2) Call Savplt(Data) End If c c Save the table data c If (Itflag .NE. 0 .AND. Ntab .GT. 0) Then Write(7,300) 'table data? ' Call Instrg('YyNn',4,I) If (I .LE. 2) Call Savtab(0) End If Call Setcmd(' @DP:PLTPRG.CLR') Call Exit End Subroutine GETVEC(Xmain,Nptvec,Ncurve,Xvals,Npoint) c c ************************************************************************ c * * c * Subroutine GETVEC - To "grab" arrays stored in single * c * dimensioned main arrays. As an example, instaed of having * c * an array X(5,100), one could store the points as X(500), if * c * one kept track of where the points were located within X. * c * This allows more efficient use of the computer memory than * c * using a two dimensional array. The vector "Nptvec" contains * c * the number of points in each curve; by summing Nptvec, one * c * can compute the location of the next curves' points. This * c * routine pulls single curves stored in main arrays, and puts * c * them in an individual set of arrays. Xmain is virtual in * c * this version. * c * * c * Input values: * c * * c * Xmain - The main X array containing "Numvec" curves * c * Nptvec - The array that contains the number of points * c * per curve * c * Ncurve - The number of the desired curve stored in * c * Xmain, Ymain * c * * c * Output values: * c * * c * Xvals - The X values of the desired curve * c * Npoint - The number of points in the desired curve * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c ************************************************************************ c Dimension Xvals(1),Nptvec(1) Virtual Xmain(1) c c Compute the location of the first point of curve number c Ncurve in the array Xmain c Call Point(Locate,Ncurve,Nptvec) c c Now load the array Xvals with the curves' points c Npoint = Nptvec(Ncurve) Do 20 I=1,Npoint Xvals(I) = Xmain(Locate-1+I) 20 Continue Return End