Subroutine Labin c c *********************************************************************** c * * c * Subroutine LABIN - To Enter in labels for the plot * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctxblk' Include 'Clegnd' Include 'Clabls' c Character*6 Jus(3) Data Jus/'Left ','Center','Right '/ c c Set label & legend coordinate flag to off c Labcrd = -1 Nlab = 0 c c See if the user wishes to enter labels c Write(7,100) 100 Format(/' Do you wish to enter labels for the plot? (y/n) '$) Call Instrg('YyNn',4,Ichose) c If (Ichose .LT. 3) Then c c Find out what the coordinate system is for the labels c Call Lacord(Labcrd) c c Loop here for labels c Do 20 N = 1,50 c Call Getlab(N,Iflag,0) c If (Iflag .EQ. 1) Go To 25 Nlab = N 20 Continue End If c 25 Continue c Return End Subroutine MODLAB c c *********************************************************************** c * * c * Subroutine MODLAB - To modify the plot labels and legend. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Clabls' Include 'Ctxblk' Include 'Caxis' Include 'Cflags' Include 'Clegnd' c Character*6 Jus(3),Coord(2) Real Onoff(2) Data Jus,Coord/'Left ','Center','Right ','Local ','Global'/ Data Onoff/'On ','Off '/ c Write(7,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',1X,1A1,'#6 LABEL MOD', $ 'IFICATIONS'//) c Ntlab = 0 Do 5 I=1,Ntxbl Ntlab = Ntlab + Ntxl(I) 5 Continue c 10 Continue c Write(7,150) Coord(Labcrd + 1) 150 Format(' Select one:'//' A (A)dd labels'/' C (C)hange labels'/ $ ' L (L)ist labels'/' D (D)elete labels'/' O C(O)ordinate', $ ' system of labels and legend (currently ',A6,')'/ $ ' S (S)top'//' Enter A, C, L, D, O, or S: ',$) Call Instrg('AaCcLlDdOoSs',12,Ichose) Ichose = (Ichose + 1) / 2 c c Execute the selections: c If (Ichose .EQ. 1) Then c c ********* Add Labels ******** c Call Lacord(Labcrd) c 20 Continue N = Nlab + 1 If (N+Ntlab .GT. 50) Go To 30 Call Getlab(N,Iflag,0) If (Iflag .EQ. 1) Go To 30 Nlab = Nlab + 1 c Ipflag = 1 Go To 20 30 Continue c Else If (Ichose .EQ. 2) Then c c Change the Label characteristics c 40 Continue Write(7,425) 425 Format(' Enter the label number to change (enter "S" to', $ ' stop) ',$) Call Inpt(X,N,Iflag,2) If (Iflag .NE. 0) Go To 10 Ilab = X(1) If (Ilab .LT. 1 .OR. Ilab .GT. Nlab .OR. N .NE. 1) Then Write(7,430) 430 Format(' Error - Try Again') Go To 40 End If c c List the label data c Call Name(Titl,Ilab,Label,Llabel) Write(7,450) (Titl(I),I=1,Llabel(Ilab)) 450 Format(/' Select to change:'//' L (L)abel: ',A1) Write(7,475) Xlabel(Ilab),Ylabel(Ilab),Jus(Just(Ilab)), $ Sizlab(Ilab),Onoff(Iprot(Ilab)+1),Irot(Ilab) 475 Format(' X (X) location = ',G12.5/' Y (Y) location = ',G12.5/ $ ' J (J)ustification = ',A6/' T (T)ext Size = ',I2/ $ ' P (P)rotection = ',1A4/' R (R)otation angle = ',I5/ $ ' A (A)ll'/' S (S)top'/) 45 Continue Write(7,485) 485 Format(' Enter L, X, Y, J, T, P, R, A or S : ',$) Call Instrg('LlXxYyJjTtPpRrAaSs',18,Ichan) Ichan = (Ichan + 1) / 2 If (Ichan .LE. 7) Ipflag = 1 If (Ichan .EQ. 1) Then Write(7,500) Ilab 500 Format(' Edit label no. ',I2) J = Llabel(Ilab) Call Name(Titl,Ilab,Label,Llabel) Call Linedt(Titl,J,80,1) If (J .EQ. 0) Then ! Zero Length label Write(7,515) 515 Format(' ERROR - Label cannot have zero length') Go To 45 End If Call Point(K,Nlab+1+Ntlab,Llabel) Call Point(K1,Ilab,Llabel) Call Rep(Label,K,K1,Llabel(Ilab),Titl,J) Llabel(Ilab) = J Else If (Ichan .EQ. 2) Then Write(7,525) 'X' 525 Format(' Enter the new ',1A1,' Coordinate ',$) Call Indata(1,'R',Xlabel(Ilab)) Else If (Ichan .EQ. 3) Then Write(7,525) 'Y' Call Indata(1,'R',Ylabel(Ilab)) Else If (Ichan .EQ. 4) Then Write(7,300) 300 Format(' Enter L, C, or R, for (L)eft, (C)enter, or ', $ '(R)ight justification of the label ',$) Call Instrg('LlCcRr',6,Ich) Just(Ilab) = (Ich + 1 ) / 2 Else If (Ichan .EQ. 5) Then Write(7,250) 250 Format(' Enter the letter size for the label (0-10) ',$) Call Inchek(0,10,Sizlab(Ilab)) Else If (Ichan .EQ. 6) Then Iprot(Ilab) = 1 - Iprot(Ilab) Else If (Ichan .EQ. 7) Then Write(7,275) 275 Format(' Enter the angle for the text (degrees): ',$) Call Inchek(0,360,Irot(Ilab)) Else If (Ichan .EQ. 8) Then Call Getlab(Ilab,Iflag,1) Else Go To 60 End If Go To 45 ! Loop back for the next change 60 Continue Else If (Ichose .EQ. 3) Then c c List out the label data c Write(7,550) 27,27 ! Clear screen 550 Format(1X,1A1,'[H',1A1,'[J') Do 70 I=1,Nlab Call Name(Titl,I,Label,Llabel) Write(7,575) I,(Titl(J),J=1,Llabel(I)),Xlabel(I), $ Ylabel(I),Jus(Just(I)),Sizlab(I),Onoff(Iprot(I)+1), $ Irot(I) 575 Format(1X,30('*'),2X,'Label no. ',I2,2X,30('*')/' Text: ', $ A1/' X=',G12.5,2X,'Y=',G12.5,2X,A6, $ ' Just',2X,'Textsize=',I2,2X,'Protect=',1A4,2X, $ 'Rot=',I3) If ((I/7)*7 .EQ. I .OR. I .EQ. Nlab) Call Spause 70 Continue Else If (Ichose .EQ. 4) Then c c Delete Labels c Write(7,650) 650 Format(' Label deletion routine...enter the label number(s) ', $ 'to delete ') Call Inpt(X,N,Iflag,0) If (N .EQ. 0) Go To 85 If (N .GT. 1) Call Sort(X,Y,N) ! Sort causes error for only 1 point Do 75 I=1,N If (X(I) .LT. 1.0 .OR. X(I) .GT. Nlab) Then Write(7,675) 675 Format(' Error - input value out of range - no ', $ 'deletions made') Go To 85 End If 75 Continue Ipflag = 1 c c Delete data here c Do 80 I=1,N Icol = X(N+1-I) Call Point(K,Nlab+1+Ntlab,Llabel) Call Point(K1,Icol,Llabel) Call Rep(Label,K,K1,Llabel(Icol),' ',0) Nlab = Nlab - 1 If (Icol .LE. Nlab+Ntlab) Then Do 77 J=Icol,Nlab+Ntlab Xlabel(J) = Xlabel(J+1) Ylabel(J) = Ylabel(J+1) Sizlab(J) = Sizlab(J+1) Just(J) = Just(J+1) Llabel(J) = Llabel(J+1) Iprot(J) = Iprot(J+1) Irot(J) = Irot(J+1) 77 Continue End If 80 Continue 85 Continue Else If (Ichose .EQ. 5) Then c c Change the coordinate system of labels and legend c Call Lacord(Labcrd) Write(7,700) Coord(1 - Labcrd + 1) 700 Format(' Label and legend coordinate system...Did user:'// $ ' 1 Wish to switch to a ',A6,' coordinate system'/ $ ' 2 Selected one coordinate system, and entered the ', $ 'locations in another?'/' 3 Stop'//' Enter 1-3 ',$) Call Inchek(1,3,Ich) If (Ich .LE. 2) Ipflag = 1 If (Ich .EQ. 1) Then If(Xmin(1) .GE. Xmax(1) .OR. Ymin(1) .GE. Ymax(1)) Then Write(7,710) 710 Format(' ERROR in the user input axes data - command ', $ 'ignored') Go To 98 End If If (Labcrd .EQ. 0) Then Labcrd = 1 If (Nlab .GT. 0) Then Do 90 I=1,Nlab Xlabel(I) = (Xlabel(I)-Xmin(1))/(Xmax(1)-Xmin(1)) Ylabel(I) = (Ylabel(I)-Ymin(1))/(Ymax(1)-Ymin(1)) 90 Continue End If Xleg = (Xleg-Xmin(1))/(Xmax(1)-Xmin(1)) Yleg = (Yleg-Ymin(1))/(Ymax(1)-Ymin(1)) c If (Ntxbl .GT. 0) THen Do 92 I=1,Ntxbl Txtblx(I) = (Txtblx(I)-Xmin(1))/(Xmax(1)-Xmin(1)) Txtbly(I) = (Txtbly(I)-Ymin(1))/(Ymax(1)-Ymin(1)) 92 Continue End If c Write(7,725) Coord(Labcrd + 1) 725 Format(/' Labels and legend are now assumed to lie in', $ ' a ',A6,' coordinate'/' system having the lower', $ ' left corner as 0,0; and'/ $ ' the upper right corner as 1,1.'/) Else Labcrd = 0 If (Nlab .GT. 0) Then Do 95 I=1,Nlab Xlabel(I) = Xlabel(I) * (Xmax(1)-Xmin(1)) + Xmin(1) Ylabel(I) = Ylabel(I) * (Ymax(1)-Ymin(1)) + Ymin(1) 95 Continue End If Xleg = Xleg * (Xmax(1) - Xmin(1)) + Xmin(1) Yleg = Yleg * (Ymax(1) - Ymin(1)) + Ymin(1) c If (Ntxbl .GT. 0) Then Do 97 I=1,Ntxbl Txtblx(I) = Txtblx(I) * (Xmax(1)-Xmin(1)) + Xmin(1) Txtbly(I) = Txtbly(I) * (Ymax(1)-Ymin(1)) + Ymin(1) 97 Continue End If c Write(7,750) Coord(Labcrd + 1) 750 Format(/' Labels and legend are now assumed to lie in', $ ' a ',A6,' coordinate'/' system having the lower', $ ' left corner as the primary axes Xmin, Ymin;'/ $ ' and the upper right corner as Xmax, Ymax'/) End If 98 Continue Else If (Ich .EQ. 2) Then Labcrd = 1 - Labcrd Write(7,775) Coord(Labcrd+1) 775 Format(' Label and legend coordinate system is now ',A6) End If Else c c Exit subroutine here c Return c End If c c Loop back for next selection c Go To 10 End Subroutine GETLAB(Ilab,Iflag,Inflag) c c *********************************************************************** c * * c * Subroutine GETLAB - To input the labels from the keyboard * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctxblk' Include 'Clegnd' Include 'Clabls' c Character*6 Jus(3) Data Jus/'Left ','Center','Right '/ c Iflag = 0 Write(7,200) Ilab 200 Format(/' Enter label no. ',I2,' (press return to stop)') Call Linedt(Titl,J,80,0) If (J .EQ. 0) Then Iflag = 1 Return End If c c If we are adding labels, and c there is a text block c If (Ntxbl .NE. 0 .AND. Inflag .EQ. 0) Then Ntlab = Nlab Do 10 I=1,Ntxbl Ntlab = Ntlab + Ntxl(I) 10 Continue Do 12 I=Ntlab+1,Ilab+1,-1 Irot(I) = Irot(I-1) Iprot(I) = Iprot(I-1) Sizlab(I) = Sizlab(I-1) Xlabel(I) = Xlabel(I-1) Ylabel(I) = Ylabel(I-1) Just(I) = Just(I-1) Llabel(I) = Llabel(I-1) 12 Continue Len = 0 Else Ntlab = Nlab Len = Llabel(Ilab) End If c Iprot(Ilab) = 0 Irot(Ilab) = 0 Call Point(K,Ntlab+1,Llabel) Call Point(K1,Ilab,Llabel) Call Rep(Label,K,K1,Len,Titl,J) Llabel(Ilab) = J Write(7,250) 250 Format(/' Enter the letter size for the label (1-10) ',$) Call Inchek(1,10,Sizlab(Ilab)) Write(7,300) 300 Format(/' Enter L, C, or R, for (L)eft, (C)enter, or ', $ '(R)ight justification of the label ',$) Call Instrg('LlCcRr',6,Ichose) Just(Ilab) = (Ichose + 1 ) / 2 15 Write(7,350) Jus(Just(Ilab)) 350 Format(/' Enter the X and Y coordinates for the label at ', $ 'the ',A6,' point:') Call Inpt(X,N,Iflag,2) If (N .NE. 2) Then Write(7,400) 400 Format(/' Error - Try Again') Go To 15 End If Xlabel(Ilab) = X(1) Ylabel(Ilab) = X(2) c Return End c