C-------------------------------------------------------------------- C-------------------------------------------------------------------- C ******************************************** C * A C H T U N G * C * * C * EINIGE SUBROUTINE-NAMEN MUSSTEN ZUR * C * VERWENDUNG DURCH DISSPLA GEAENDERT * C * WERDEN: * C * * C * ORIGINAL AUFRUF IN * C * LG800 DISSPLA * C *------------------------------------------* C * CIRCL LCIRCL * C * LDIN17 * C * LFILL2 * C * GRID LGRID * C * PLOT LPLOT * C * PLOTS LPLOTS * C * * C * MUENCHHOF OR32 31.01.1988 * C * * C *==========================================* C-------------------------------------------------------------------- C C BASIC PLOT SOFTWARE FOR QMS LASERGRAFIX 800 C C DEVELOPED BY C C DEUTSCHE LUFTHANSA AG C C DEPT. FRA OR 3 C C D-6000 FRANKFURT / MAIN 75 C C LUFTHANSA BASIS C C ON VAX 11/750 UNDER VAX/VMS. C C MUENCHHOF FRA OR32 C C TEL: 069 / 696 - 2684 C C-------------------------------------------------------------------- C C CCCCCCCCCCC C C PLOTS (LPLOTS) C CCCCCCCCCCC C C SUBROUTINE LPLOTS (XOVE,YOVE,ITEST) C C LPLOTS IS THE INITIALISATION ROUTINE FOR C BEGINNING PLOTS AND MUST BE THE FIRST C PLOTTING SUBROUTINE CALLED. LPLOTS INITIALIZES C COMMON VARIABLES TO THEIR DEFAULT VALUES. C THE INITIAL PLOTTER ORIGIN (0.0,0.0) IS DESIGNA- C TED AS THE PEN LOCATION WHEN THE LPLOTS SUBROUTINE C IS CALLED. C C XOVE : R*4, MOVE THE UPPER LEFT CORNER OF THE PLOT C TO THE LEFT BY XOVE. IF XOVE .EQ. 0 C PLOT IS CENTERED. ( XOVE IN CENTIMETERS ) C YOVE : R*4, MOVE THE UPPER LEFT CORNER OF THE PLOT C DOWN BY YOVE. IF YOVE .EQ. 0 PLOT IS C CENTERED. ( YOVE IN CENTIMETERS ) C ITEST : I*4, DETERMINES ORIENTATION OF THE PLOT. C 0 IS PORTRAIT, 1 IS LANDSCAPE ORIENTATION. C C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 LOGICAL*1 IN(20),L DATA L/'L'/ DATA IN/20*'P'/ OPEN (UNIT=35, 1 STATUS='NEW', 2 RECL=36, 3 CARRIAGECONTROL='LIST', 4 FORM='FORMATTED', 5 ACCESS='DIRECT', 6 ASSOCIATEVARIABLE=ID35, 7 DISP='DELETE', 8 FILE='LG800.LET') OPEN (UNIT=36, 1 STATUS='NEW', 2 RECL=12, 3 CARRIAGECONTROL='LIST', 4 FORM='FORMATTED', 5 ACCESS='DIRECT', 6 ASSOCIATEVARIABLE=ID36, 7 DISP='DELETE', 8 FILE='LG800.FLL') OPEN (UNIT=37, 1 STATUS='NEW', 2 RECL=12, 3 CARRIAGECONTROL='LIST', 4 FORM='FORMATTED', 5 ACCESS='DIRECT', 6 ASSOCIATEVARIABLE=ID37, 7 DISP='DELETE', 8 FILE='LG800.VEC') OPEN (UNIT=38, 1 STATUS='NEW', 2 RECL=32, 3 CARRIAGECONTROL='LIST', 4 FORM='FORMATTED', 5 ACCESS='DIRECT', 6 ASSOCIATEVARIABLE=ID38, 7 DISP='DELETE', 8 FILE='LG800.GRD') OPEN (UNIT=39, 1 STATUS='NEW', 2 RECL=69, 3 CARRIAGECONTROL='LIST', 4 FORM='FORMATTED', 5 RECORDTYPE='VARIABLE', 6 FILE='LG800.PLT') XMOVE=XOVE YMOVE=YOVE IOR=ITEST C IOR=0 C TYPE 1000 C 1000 FORMAT (1H0,'Bitte geben Sie die Orientierung der Zeichnung', C 1' ein.') C TYPE 1100 C 1100 FORMAT (1H0,'"P" = Portrait ( default )') C TYPE 1200 C 1200 FORMAT (1H ,'"L" = Landscape ? :',$) C ACCEPT 1300,NUM,(IN(I),I=1,NUM) C 1300 FORMAT (Q,20A1) C IF (IN(1).EQ.L) IOR=1 C UNITS=1./2.54 ! UNITS = CENTIMETERS C UNITS=1. ! UNITS = INCHES ID35=1 ID36=1 ID37=1 ID38=1 FACTR=1. XOLD=0. YOLD=0. XLAST=0. YLAST=0. XOFF=0. YOFF=0. OLDX=0. OLDY=0. IENDPL=0 XMIN=1.E6 YMIN=1.E6 XMAX=-1.E6 YMAX=-1.E6 XPAGE=7.5 YPAGE=11.0 ASPCT=1. SLANT=0. SPACE=1. RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C PLOT (LPLOT) C CCCCCCCCCCC C C SUBROUTINE LPLOT (XE,YE,IPEN) C C LPLOT IS THE FUNDAMENTAL PLOTTING SUBROUTINE C WHICH GENERATES A STRAIGHT LINE SEGMENT FROM C THE CURRENT PEN POSITION TA A NEW POSITION. C THE NEW (XE,YE) PASSED TO LPLOT, HOWEVER, C REFERENCES THE CURRENT ORIGIN AND IS THUS C CONSIDERED AN ABSOLUTE REFERENCE. C C XE : R*4, C YE : R*4, C COORDINATES IN INCHES, WITH C RESPECT TO THE CURRENT ORIGIN, C TO WHICH THE PEN MOVES. C IPEN : I*4, +2 DRAWS SOLID LINE C +3 MOVES WITH PEN UP C -2 AND -3 SAME FUNCTION AS ABOVE C EXCEPT THAT A NEW ORIGIN IS SET C AT (XE,YE) C +998 MOVES TO NEXT TOP OF FORM C WITH PEN UP AND STARTS NEW PLOT. C +999 MOVES TO NEXT TOP OF FORM C WITH PEN UP AND TERMINATES PLOTTING. C THE OUTPUT-FILE IS NAMED 'LG800.PLT'. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 LOGICAL*1 UP,DOWN,ERASE,VEC LOGICAL*1 BLANC,OUT(69) DATA UP,DOWN,ERASE/'U','D','E'/ DATA BLANC,OUT/' ','^','A',67*' '/ DATA IRUN/0/ XEIN=XE YEIN=YE IF (XEIN.GT.998.5) XEIN=OLDX IF (YEIN.GT.998.5) YEIN=OLDY C XEIN=XEIN/2.54 C YEIN=YEIN/2.54 XNEW=XEIN+XLAST YNEW=YEIN+YLAST OLDX=XEIN OLDY=YEIN IC=JIABS(IPEN) IF (IC.EQ.998) IENDPL=1 IF (IC.GE.998) GO TO 30 XOLD=XNEW YOLD=YNEW IF (IOR.EQ.0) GO TO 10 WRITE (37'ID37,1000) -YNEW,XNEW,IC 1000 FORMAT (3A4) XMIN=AMIN1(XMIN,-YNEW) XMAX=AMAX1(XMAX,-YNEW) YMIN=AMIN1(YMIN,XNEW) YMAX=AMAX1(YMAX,XNEW) IF (IPEN.GT.0) GO TO 20 XLAST=XOLD YLAST=YOLD OLDX=0. OLDY=0. GO TO 20 10 WRITE (37'ID37,1000) XNEW,YNEW,IC XMIN=AMIN1(XMIN,XNEW) XMAX=AMAX1(XMAX,XNEW) YMIN=AMIN1(YMIN,YNEW) YMAX=AMAX1(YMAX,YNEW) IF (IPEN.GT.0) GO TO 20 XLAST=XOLD YLAST=YOLD OLDX=0. OLDY=0. 20 RETURN 30 IF (ID37.EQ.1) GO TO 250 TYPE 1100,ID37-1,ID38-1 1100 FORMAT (1H0,I10,' Vectors and ',I10,' Gridlines generated.') C IC=3 C IF (IOR.EQ.0) WRITE (37'ID37,1000) XMIN,YMAX,IC C IF (IOR.EQ.1) WRITE (37'ID37,1000) YMAX,XMIN,IC MAXVEC=ID37 WRITE (39,1200) 1200 FORMAT ('ReSeTrEsEtReSeT') WRITE (39,1300) 1300 FORMAT ('^PY^-') WRITE (39,1400) 1400 FORMAT ('^F^-^IS00000^-^X') XMITT=(20.5/2.)/2.54-0.12 YMITT=(29.7/2.)/2.54-0.25 XORI=XMITT-(XMAX-XMIN)*FACTR*UNITS/2. IF (XMOVE.NE.0.) XORI=XMOVE/2.54 YORI=YMITT-(YMAX-YMIN)*FACTR*UNITS/2. IF (YMOVE.NE.0.) YORI=YMOVE/2.54 IWIDTH=3 WIDTH=FLOAT(IWIDTH)/300. IF (ID35.EQ.1) GO TO 100 MAXVEC=ID35 ID35=1 NUMVEC=ID35 40 READ (35'ID35,1500) KENN,IWIDTH,X0,Y0,XM,YM,WA,WE,RAD 1500 FORMAT (9A4) IF (KENN.NE.0) GO TO 50 WRITE (39,1600) IWIDTH 1600 FORMAT ('^A^IGV^PW',I2.2,'^X') 50 IX0=IFIX(((X0-XMIN)*FACTR*UNITS+XORI)*1000.) IY0=IFIX(((YMAX-Y0)*FACTR*UNITS+YORI)*1000.) IXM=IFIX(((XM-XMIN)*FACTR*UNITS+XORI)*1000.) IYM=IFIX(((YMAX-YM)*FACTR*UNITS+YORI)*1000.) IF (KENN.NE.1) GO TO 60 IX2=IFIX(((WA-XMIN)*FACTR*UNITS+XORI)*1000.) IY2=IFIX(((YMAX-WE)*FACTR*UNITS+YORI)*1000.) WRITE (39,1700) IXM,IYM,IX2,IY2 1700 FORMAT ('^A^U',I5.5,':',I5.5,'^D',I5.5,':',I5.5,'^X') 60 IF (KENN.NE.2) GO TO 70 WRITE (39,1800) 1800 FORMAT ('^A^IGE^-^X') 70 IF (KENN.NE.3) GO TO 80 IWA=IFIX(WA/0.36) IWA=JMOD(IWA,1000) IWE=IFIX(WE/0.36) IWE=JMOD(IWE,1000) IRAD=IFIX(RAD*FACTR*UNITS*1000.) IF (IRAD.LT.0) IRAD=0 WRITE (39,1900) IXM,IYM,IRAD,IWA,IWE,IWIDTH 1900 FORMAT ('^A^LAD+',I5.5,'+',2I5.5,2I3.3,I2.2,'^G^X') 80 IF (KENN.NE.4) GO TO 90 WRITE (39,2000) IXM,IYM 2000 FORMAT ('^A^LAF',2I5.5,'20^G^X') c c Wird benoetigt fuer Buchstabentest ! c c WRITE (39,2050) IXM,IYM c 2050 FORMAT ('^A^R^LAD+',I5.5,'+',I5.5, c 1 '00020','000','999','03','^G^R^X') c 90 CONTINUE IF (ID35.EQ.MAXVEC) GO TO 100 GO TO 40 100 CONTINUE IF (ID36.EQ.1) GO TO 180 MAXVEC=ID36 ID36=1 IWIDTH=3 110 NUMVEC=ID36 WRITE (39,2500) IWIDTH 2500 FORMAT ('^A^IGV^PW',I2.2,'^X') ICODE=0 120 READ (36'ID36,1000) XNEW,YNEW,IC IXPOS=JNINT(((XNEW-XMIN)*FACTR*UNITS+XORI)*1000.) IYPOS=JNINT(((YMAX-YNEW)*FACTR*UNITS+YORI)*1000.) IF (IXPOS.LT.0) IXPOS=0 IF (IYPOS.LT.0) IYPOS=0 IF (IC.GE.100) GO TO 140 VEC=UP IF (IC.EQ.2) VEC=DOWN IF (IC.EQ.4) VEC=DOWN ICODE=ICODE+1 ENCODE (15,2600,OUT((ICODE-1)*13+3)) VEC,IXPOS,IYPOS 2600 FORMAT ('^',A1,I5.5,':',I5.5,'^X') IF (ICODE.LT.5) GO TO 120 WRITE (39,2700) OUT 2700 FORMAT (69A1) DO 130 I=3,69 OUT(I)=BLANC 130 CONTINUE ICODE=0 GO TO 120 140 IF (ICODE.NE.0) WRITE (39,2700) (OUT(I),I=1,ICODE*13+4) WRITE (39,2800) 2800 FORMAT ('^A^IGE^-^X') IC=IC-100 WRITE (39,2900) IXPOS,IYPOS,IC 2900 FORMAT ('^A^LAF',2I5.5,I2.2,'^G^X') WRITE (39,2500) IWIDTH ID36=NUMVEC ICODE=0 150 READ (36'ID36,1000) XNEW,YNEW,IC IXPOS=JNINT(((XNEW-XMIN)*FACTR*UNITS+XORI)*1000.) IYPOS=JNINT(((YMAX-YNEW)*FACTR*UNITS+YORI)*1000.) IF (IXPOS.LT.0) IXPOS=0 IF (IYPOS.LT.0) IYPOS=0 IF (IC.GE.100) GO TO 170 VEC=UP IF (IC.EQ.2) VEC=DOWN IF (IC.EQ.4) VEC=ERASE ICODE=ICODE+1 ENCODE (15,2600,OUT((ICODE-1)*13+3)) VEC,IXPOS,IYPOS IF (ICODE.LT.5) GO TO 150 WRITE (39,2700) OUT DO 160 I=3,69 OUT(I)=BLANC 160 CONTINUE ICODE=0 GO TO 150 170 IF (ICODE.NE.0) WRITE (39,2700) (OUT(I),I=1,ICODE*13+4) WRITE (39,2800) IF (ID36.EQ.MAXVEC) GO TO 180 GO TO 110 180 CONTINUE IWIDTH=3 WRITE (39,2500) IWIDTH IC=3 WRITE (37'ID37,1000) XMIN,YMAX,IC MAXVEC=ID37 ID37=1 ICODE=0 190 READ (37'ID37,1000) XNEW,YNEW,IC IXPOS=JNINT(((XNEW-XMIN)*FACTR*UNITS+XORI)*1000.) IYPOS=JNINT(((YMAX-YNEW)*FACTR*UNITS+YORI)*1000.) IF (IXPOS.LT.0) IXPOS=0 IF (IYPOS.LT.0) IYPOS=0 VEC=UP IF (IC.EQ.2) VEC=DOWN ICODE=ICODE+1 ENCODE (15,2600,OUT((ICODE-1)*13+3)) VEC,IXPOS,IYPOS IF (ICODE.LT.5) GO TO 210 WRITE (39,2700) OUT DO 200 I=3,69 OUT(I)=BLANC 200 CONTINUE ICODE=0 210 IF (ID37.EQ.MAXVEC) GO TO 220 GO TO 190 220 IF (ICODE.NE.0) WRITE (39,2700) (OUT(I),I=1,ICODE*13+4) WRITE (39,2800) IF (ID38.EQ.1) GO TO 240 MAXVEC=ID38 ID38=1 230 READ (38'ID38,3000) XNEW,YNEW,DX,DY,LENX,LENY,IDASH,ISPACE 3000 FORMAT (8A4) IXPOS=JNINT(((XNEW-XMIN)*FACTR*UNITS+XORI)*1000.) IYPOS=JNINT(((YMAX-YNEW)*FACTR*UNITS+YORI)*1000.) IF (IXPOS.LT.0) IXPOS=0 IF (IYPOS.LT.0) IYPOS=0 IF (LENX.GT.10) LENX=JNINT(FLOAT(LENX)*FACTR*UNITS) IF (LENY.GT.10) LENY=JNINT(FLOAT(LENY)*FACTR*UNITS) ENCODE (36,3100,OUT(3)) IXPOS,IYPOS,LENX,LENY,IDASH,ISPACE 3100 FORMAT ('^T',I5.5,'^JM',I5.5,'^LD',2I5.5,2I3.3,'^X') WRITE (39,2700) (OUT(I),I=1,38) IF (ID38.EQ.MAXVEC) GO TO 240 GO TO 230 240 WRITE (39,3200) 3200 FORMAT ('^A^-') IF (IPEN.EQ.998) GO TO 260 250 IF (IENDPL.EQ.1) BACKSPACE 39 WRITE (39,3300) 3300 FORMAT ('^O^-^PN^-') CLOSE (UNIT=35,DISP='DELETE') CLOSE (UNIT=36,DISP='DELETE') CLOSE (UNIT=37,DISP='DELETE') CLOSE (UNIT=38,DISP='DELETE') CLOSE (UNIT=39,DISP='KEEP') RETURN 260 ID35=1 ID36=1 ID37=1 ID38=1 XOLD=0. YOLD=0. XLAST=0. YLAST=0. XOFF=0. YOFF=0. FACTR=1. OLDX=0. OLDY=0. XMIN=1.E6 XMAX=-1.E6 YMIN=1.E6 YMAX=-1.E6 WRITE (39,3400) 3400 FORMAT ('^,') RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C NEWPEN (LNEWPN) C CCCCCCCCCCC C C SUBROUTINE LNEWPN (IPEN) C C LNEWPN IS USED WITH MULTIPLE PEN PLOTTERS FOR C PEN SELECTION UNDER PROGRAM CONTROL. C FOR THE QMS LASERGRAFIX THIS SUBROUTINE C IS A DUMMY SUBROUTINE TO BE COMPATIBLE WITH OTHER C PEN PLOTTER SOFTWARE. C C IPEN : I*4, NUMBER OF PEN TO BE SELECTED. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C FACTOR (LFACTR) C CCCCCCCCCCC C C SUBROUTINE LFACTR (FACT) C C LFACTR ENABLES THE USER TO ENLARGE OR TO REDUCE C THE SIZE OF THE ENTIRE PLOT. C C FACT : R*4, SCALE FACTOR USED TO MULTIPLY ALL C PLOTTING DIMENSIONS (INITIALLY C SET TO 1.). C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 FACTR=FACT RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C WHERE (LWHERE) C CCCCCCCCCCC C C SUBROUTINE LWHERE (XACT,YACT,FACT) C C LWHERE RETURNS TO THE CALLING PROGRAM THE CURRENT C POSITION OF THE PEN AND THE CURRENT SCALE FACTOR C (AS SET BY LPLOTS OR LFACTR). C C XACT : R*4, C YACT : R*4, C THE ARGUMENTS ARE RETURNED WITH C COORDINATES OF THE CURRENT POSITION C OF THE PEN (IN CENTIMETERS). C FACT : R*4, ARGUMENT IS RETURNED WITH CURRENT C SCALE FACTOR. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 XACT=OLDX YACT=OLDY FACT=FACTR RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C ITALIC (LITALC) C CCCCCCCCCCC C C SUBROUTINE LITALC (SLA) C C LITALC DEFINES THE SLANT (FORWARD OR BACKWARD) OF C SUBSEQUENT ANNOTATION, AND MAY BE CALLED AS OFTEN C AS DESIRED. IF LITALC IS NOT CALLED, THE DEFAULT IS 0. C C SLA : R*4, |SLA| = SLANT IN DEGREES. C GT.0 SLANT IS FORWARD. C LT.0 SLANT IS BACKWARD. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 SLANT=SLA RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C ASPECT (LASPCT) C CCCCCCCCCCC C C SUBROUTINE LASPCT (ASP) C C LASPCT DEFINES THE WIDTH-TO-HEIGHT RATIO OF SUBSEQUENT C ANNOTATION, AND MAY BE CALLED AS OFTEN AS DESIRED. C LASPCT AFFECTS THE WIDTH OF SYMBOLS LEAVING THE HEIGHT C AS REQUESTED. IF LASPCT IS NOT CALLED, THE DEFAULT IS 1. C C ASP : R*4, |ASP| = WIDTH/HEIGHT C LT.0 CAUSES SYMBOLS TO BE MIRRORED ABOUT C THEIR VERTICAL BASE LINE. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 ASPCT=ASP RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C CHRSPC (LCHRSP) C CCCCCCCCCCC C C SUBROUTINE LCHRSP (SPA) C C LCHRSP DEFINES THE INTER-CHARACTER-SPACING OF C SUBSEQUENT ANNOTATION, AND MAY BE CALLED AS OFTEN C AS DESIRED. LCHRSP AFFECTS THE SPACE BETWEEN SYMBOLS C LEAVING THE HEIGHT AS REQUESTED. IF LCHRSP IS NOT C CALLED, THE DEFAULT IS 1. C C SPA : R*4, |SLA| MULIPLICATION FACTOR OF INTER- C CHARACTER-SPACING. C EQ.0 NO SPACE BETWEEN SYMBOLS. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 SPACE=ABS(SPA) RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C SYMBOL (LSYMBL) C CCCCCCCCCCC C C SUBROUTINE LSYMBL (XE,YE,SIZE,LMESS,ANGLE,N) C C LSYMBL IS A CHARACTER PLOTTING SUBROUTINE TO PRODUCE C PLOT ANNOTATION. THERE ARE THREE CALL TO LSYMBL : C (1) THE CALL USED TO DRAW TEXT SUCH AS TITLES AND C LEGENDS, C (2) THE CALL USED TO DRAW SINGLE CHARACTERS WHERE C THE CHARACTER IS REFERENCED BY ITS INTEGER INDEX, AND C (3) THE CALL IS USED TO DRAW A MARKER CENTERD AT (X,Y). C VARIABLE SLANT, ASPECT AND INTER-CHARACTER-SPACING ARE C AVAILABLE THROUGH THE USE OF THE SUBROUTINES LITALC, C LASPCT AND LCHRSP. C C XE : R*4, C YE : R*4, C IF N.GE.0, XE AND YE ARE THE COORDINATES IN C INCHES OF THE LOWER-LEFT CORNER OF THE FIRST C CHARACTER BEING PLOTTED. C IF N.LT.0, XE AND YE ARE THE COORDINATES OF THE C CENTER OF THE MARKER BEING PLOTTED. C TO CONTINUE ANNOTATION FROM THE CURRENT X, C AND/OR Y POSITION, THE CORRESPONDING XE, AND/OR C YE ARGUMENTS SHOULD EQUAL 999. C SIZE : R*4, |SIZE|= HEIGHT OF THE CHARACTER(S) BEING C PLOTTED. C GT.0 INDICATES LMESS IS IN A(N) FORMAT, WHERE C N IS THE NUMBER OF CHARACTERS PER COMPUTER C WORD. C LE.0 INDICATES LMESS IS IN A(1) FORMAT. C LMESS : L*1, IF N.GT.0, LMESS CONTAINS THE SEQUENCE OF N C CHARACTERS BEING PLOTTED. C IF N.LT.0, LMESS(1) IS THE INDEX INDICATING C THE MARKER BEING DRAWN. C IF N.EQ.0, A SINGLE CHARACTER IS PRODUCED C USING LMESS(1) AS A RIGHT-JUSTIFIED REPRESEN- C TATION (INTEGER INDEX) OF THE CHARACTER. C ANGLE : R*4, THEN ANGLE IN DEGREES OF THE CHARACTER(S) OR C MARKER. C N : I*4, GT.0: NUMBER OF CHARACTERS IN LMESS BEING C PLOTTED INCLUDING TRAILING C BLANKS. C EQ.0: ONE CHARACTER IS PRODUCED. LMESS(1) MUST C CONTAIN THE INTEGER INDEX OF THE C CHARACTER. C EQ.-1: PRODUCES A MARKER WHERE THE MOVE TO C (X,Y) IS MADE WITH PEN UP. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 LOGICAL*1 LMESS DIMENSION LMESS(1) DATA SLA/0./ DATA ASP/1./ DATA SPA/0./ XP=XE YP=YE IF (XE.GT.998.5) XP=OLDX IF (YE.GT.998.5) YP=OLDY NCHAR=N SIZ=ABS(SIZE) IF (SIZE.LT.0.) NCHAR=1 IF (NCHAR.LT.-1) NCHAR=-1 NCHAR=IABS(NCHAR) IPLOT=1 IF (N.LT.0) GO TO 10 IF (N.EQ.0) GO TO 20 C CALL LG8CHR(XP,YP,SIZ,ANGLE,SLANT,ASPCT,SPACE, C 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,YBACK) PEN=SIZ/7. CALL LG8DIN(XP,YP,SIZ*1.2,PEN,ANGLE, 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,YBACK) OLDX=XBACK OLDY=YBACK GO TO 30 10 CONTINUE CALL LG8CHR(XP,YP,SIZ,ANGLE,SLA,ASP,SPA, 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,YBACK) OLDX=XP OLDY=YP GO TO 30 20 CONTINUE IPLOT=0 NCHAR=1 C CALL LG8CHR(XP,YP,SIZ,ANGLE,SLANT,ASPCT,SPACE, C 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,YBACK) PEN=SIZ/7. CALL LG8DIN(XP,YP,SIZ*1.2,PEN,ANGLE, 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,,YBACK) XN=2.*XP-XBACK YN=2.*YP-YBACK IPLOT=1 C CALL LG8CHR(XN,YN,SIZ,ANGLE,SLANT,ASPCT,SPACE, C 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,YBACK) PEN=SIZ/7. CALL LG8DIN(XP,YP,SIZ*1.2,PEN,ANGLE, 1 LMESS,NCHAR,IPLOT,ALEN,XBACK,,YBACK) OLDX=XP OLDY=YP 30 CONTINUE RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C NUMBER (LNUMBR) C CCCCCCCCCCC C C SUBROUTINE LNUMBR (XE,YE,SIZE1,FNUM1,ANGLE,NDEC1) C C THE LNUMBR SUBROUTINE IS USED TO CONVERT A REAL C VARIABLE TO ITS APPROPRIATE FIXED DECIMAL EQUI- C VALENT AND PLOT IT TO ANY DEGREE AF ACCURARCY. C VARIABLE SLANT, ASPECT AND INTER-CHARACTER-SPACING C ARE AVAILABLE THROUGH THE USE OF SUBROUTINES C LITALC, LASPCT AND LCHRSP. C TO PLOT AN INTEGER NUMBER, THE INTEGER NUMBER MUST BE C COVERTED TO A FLOATING POINT NUMBER AND THAN BE C PLOTTED WITH NDEC1 SET TO -1. C C XE : R*4, C YE : R*4, C X AND Y ARE THE COORDINATES IN INCHES C OF THE LOWER LEFT CORNER OF THE FIRST C CHARACTER BEING PLOTTED. C SIZE1 : R*4, HEIGHT OF CHARACTER(S) BEING PLOTTED. C FNUM1 : R*4, THE FLOATING POINT NUMBER BEING PLOTTED. C ANGLE : R*4, ANGLE OF CHARACTER(S) IN DEGREES. C NDEC1 : I*4, GT.0 : NUMBER OF DIGITS TO THE RIGHT C OF THE DECIMAL POINT. C EQ.0 : NUMBER PLOTTED IS AN INTEGER PLUS C DECIMAL POINT. C EQ.-1: NUMBER PLOTTED IS AN INTEGER WITH C NO DECIMAL POINT. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 LOGICAL*1 MINUS,POINT,BLANK,CHAR DATA MINUS/'-'/ DATA POINT/'.'/ DATA BLANK/' '/ XP=XE YP=YE IF (XE.GT.998.5) XP=OLDX IF (YE.GT.998.5) YP=OLDY SIZE=ABS(SIZE1) FNUM=ABS(FNUM1) NDEC=IABS(NDEC1) IF (NDEC1.LT.0) NDEC=0 INUM=IFIX(FNUM*10.**NDEC+0.5) CHAR=BLANK IF (FNUM1.LT.0.) CHAR=MINUS CALL LSYMBL(XP,YP,SIZE,CHAR,ANGLE,1) IPOW=0 IF (INUM.EQ.0) GO TO 10 HELP=ALOG10(FNUM) IPOW=IFIX(HELP) 10 IZIFF=INUM/(10**(IPOW+NDEC)) CALL LSYMBL(999.,999.,SIZE,IZIFF+48,ANGLE,1) INUM=INUM-IZIFF*10**(IPOW+NDEC) IPOW=IPOW-1 IF (IPOW.LE.-1) GO TO 20 GO TO 10 20 CONTINUE IF (NDEC1.GE.0) CALL LSYMBL(999.,999.,SIZE,POINT,ANGLE,1) IF (NDEC1.LE.0) GO TO 40 ICNT=NDEC1 30 ICNT=ICNT-1 IF (ICNT.LE.-1) GO TO 40 IZIFF=INUM/(10**(ICNT)) CALL LSYMBL(999.,999.,SIZE,IZIFF+48,ANGLE,1) INUM=INUM-IZIFF*10**ICNT GO TO 30 40 CONTINUE RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C GRID (LGRID) C CCCCCCCCCCC C C SUBROUTINE LGRID (XEIN,YEIN,NRX,XD,NRY,YD,INPAT) C C SUBROUTINE LGRID ALLOWS TO GENERATE A VARIETY OF GRID C PATTERNS OR OVERLAY FORMS. C C XEIN : R*4, C YEIN : R*4, C STARTING COORDINATES LOWER-LEFT-CORNER. C NRX : I*4, NUMBER OF INTERVALS IN THE X DIRECTION FOR C VERTICAL GRID LINES. IF NRX GT.1000, ARGUMENT C XD WILL BE TREATED AS AN ARRAY OF INTERVAL C VALUES WITH NRX-1000 ELEMENTS. NRX.LE.0 INDICATES C THAT THE ACTUAL VERTICAL LINE GENERATIONS C ARE SUPPRESSED. C NOTE THAT ONE MORE GRID LINE IS GENERATED C THAN SPECIFIED BY NRX. C XD : R*4, DISTANCE BETWEEN UNIFORMLY SPACED VERTICAL C LINES WHEN NRX.LT.1000. AN ARRAY OF VALUES C FOR SPACING VERTICAL LINES AT VARYING INTER- C VALS WHEN NRX.GT.1000. C NRY : I*4, NUMBER OF INTERVALS IN THE Y DIRECTION FOR C HORIZONTAL GRID LINES. IF NRY GT.1000, ARGUMENT C YD WILL BE TREATED AS AN ARRAY OF INTERVAL C VALUES WITH NRY-1000 ELEMENTS. NRY.LE.0 INDICATES C THAT THE ACTUAL HORIZONTAL LINE GENERATIONS C ARE SUPPRESSED. C NOTE THAT ONE MORE GRID LINE IS GENERATED C THAN SPECIFIED BY NRY. C YD : R*4, DISTANCE BETWEEN UNIFORMLY SPACED HORIZONTAL C LINES WHEN NRY.LT.1000. AN ARRAY OF VALUES C FOR SPACING HORIZONTAL LINES AT VARYING INTER- C VALS WHEN NRY.GT.1000. C INPAT : I*4, LINE MASK BIT PATTERN TO BE USED IN GENERATING C THE GRIDDED FORM. A 32 BIT COMPUTER WORD IS C UTILIZED FOR INPAT. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 DIMENSION XD(1),YD(1) DATA ZERO/0./ XP=XEIN YP=YEIN IF (XEIN.GT.998.5) XP=OLDX IF (YEIN.GT.998.5) YP=OLDY OLDX=XEIN OLDY=YEIN XP=XP+XLAST YP=YP+YLAST IGRID=0 IGAP=0 IWIDTH=3 WIDTH=FLOAT(IWIDTH)/1000. IEINS=0 INULL=0 DO 10 I=1,32 CALL MVBITS(INPAT,32-I,1,IBIT,0) IF (IEINS.EQ.1.AND.IGAP.GT.0.AND.IBIT.EQ.1) GO TO 20 IF (INULL.EQ.1.AND.IGRID.GT.0.AND.IBIT.EQ.0) GO TO 20 IF (I.EQ.1.AND.IBIT.EQ.1) IEINS=1 IF (I.EQ.1.AND.IBIT.EQ.0) INULL=1 IF (IBIT.EQ.1) IGRID=IGRID+1 IF (IBIT.EQ.0) IGAP=IGAP+1 10 CONTINUE 20 IGRID=IGRID*3 IGAP=IGAP*3 NX=JMOD(JIABS(NRX),1000) NXT=JIABS(NRX)/1000 XSUM=FLOAT(NX)*XD(1) IF (NXT.EQ.0) GO TO 40 XSUM=0. DO 30 I=1,NX XSUM=XSUM+XD(I) 30 CONTINUE 40 NY=JMOD(JIABS(NRY),1000) NYT=JIABS(NRY)/1000 YSUM=FLOAT(NY)*YD(1) IF (NYT.EQ.0) GO TO 60 YSUM=0. DO 50 I=1,NY YSUM=YSUM+YD(I) 50 CONTINUE 60 CONTINUE C CALL STRTPT(XP,YP) C CALL STRTPT(XP+XSUM,YP+YSUM) C ID37=ID37-2 IF (IOR.EQ.1) GO TO 110 C READ (37'ID37,1000) XS,YS,IC C 1000 FORMAT (3A4) C READ (37'ID37,1000) XE,YE,IC C XLEN=XE-XS C YLEN=YE-YS C LENX=JNINT(XLEN*1000.) C LENY=JNINT(YLEN*1000.) C FACTRX=XLEN/XSUM C FACTRY=YLEN/YSUM XS=XP YS=YP XE=XP+XSUM YE=YP+YSUM LENX=JNINT(XSUM*1000.) LENY=JNINT(YSUM*1000.) FACTRX=1. FACTRY=1. IF (NRX.LE.0) GO TO 80 XSUM=0.-XD(1)*FACTRX DO 70 I=0,NX J=I IF (I.EQ.0) J=1 IF (NXT.EQ.0) J=1 XSUM=XSUM+XD(J)*FACTRX FELD=ZERO IF (I.EQ.NX) FELD=FLOAT(NX) WRITE (38'ID38,1100) 1 XS+XSUM,YE,FELD,ZERO,IWIDTH,LENY,IGRID,IGAP 1100 FORMAT (8A4) 70 CONTINUE 80 IF (NRY.LE.0) GO TO 100 YSUM=0.-YD(1)*FACTRY DO 90 I=0,NY J=I IF (I.EQ.0) J=1 IF (NYT.EQ.0) J=1 YSUM=YSUM+YD(J)*FACTRY FELD=ZERO WRITE (38'ID38,1100) 1 XS,YS+YSUM,XLEN,FELD,LENX,IWIDTH,IGRID,IGAP 90 CONTINUE 100 RETURN 110 CONTINUE C READ (37'ID37,1000) YS,XS,IC C READ (37'ID37,1000) YE,XE,IC C YS=-YS C YE=-YE C XLEN=XE-XS C YLEN=YE-YS C LENX=JNINT(XLEN*1000.) C LENY=JNINT(YLEN*1000.) C FACTRX=XLEN/XSUM C FACTRY=YLEN/YSUM XS=XP YS=YP XE=XP+XSUM YE=YP+YSUM LENX=JNINT(XSUM*1000.) LENY=JNINT(YSUM*1000.) FACTRX=1. FACTRY=1. IF (NRY.LE.0) GO TO 130 YSUM=0.-YD(1)*FACTRY DO 120 I=0,NY J=I IF (I.EQ.0) J=1 IF (NYT.EQ.0) J=1 YSUM=YSUM+YD(J)*FACTRY FELD=ZERO IF (I.EQ.NY) FELD=FLOAT(NY) WRITE (38'ID38,1100) 1 YSUM-YE,XE,FELD,ZERO,IWIDTH,LENX,IGRID,IGAP 120 CONTINUE 130 CONTINUE IF (NRX.LE.0) GO TO 150 XSUM=0.-XD(1)*FACTRX DO 140 I=0,NX J=I IF (I.EQ.0) J=1 IF (NXT.EQ.0) J=1 XSUM=XSUM+XD(J)*FACTRX FELD=ZERO WRITE (38'ID38,1100) 1 -YE,XS+XSUM,YLEN,FELD,LENY,IWIDTH,IGRID,IGAP 140 CONTINUE 150 RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C FILL2 (LFILL2) C CCCCCCCCCCC C C SUBROUTINE LFILL2 (XA1,YA1,N1,XA2,YA2,N2,INPAT) C C SUBROUTINE LFILL2 ALLOWS TO GENERATE AREAFILL BETWEEN C TWO CURVES WITH A VARIETY OF PATTERNS. C C XA1 : R*4, ARRAY OF X VALUES OF CURVE ONE C YA1 : R*4, ARRAY OF Y VALUES OF CURVE ONE C N1 : I*4, NUMBER OF VALUES IN ARRAY ONE C XA2 : R*4, ARRAY OF X VALUES OF CURVE TWO C YA2 : R*4, ARRAY OF Y VALUES OF CURVE TWO C N2 : I*4, NUMBER OF VALUES IN ARRAY TWO C INPAT : I*4, NUMBER OF CURRENTLY AVAILABLE QMS C AREA FILL PATTERN. C NUMBER MAY VARY BETWEEN 0 AND 24. C INPAT WILL BE SET TO 0 (BLANK AREA) C IF A NUMBER OTHER THAN 0 TO 24 IS C DETECTED. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 REAL*4 MINX,MAXX,MINY,MAXY DIMENSION XA1(1),YA1(1),XA2(1),YA2(1) XP=XEIN YP=YEIN IF (XEIN.GT.998.5) XP=OLDX IF (YEIN.GT.998.5) YP=OLDY OLDX=XEIN OLDY=YEIN XP=XP+XLAST YP=YP+YLAST IPAT=INPAT+100 IF (INPAT.LT.0) IPAT=100 IF (INPAT.GT.24) IPAT=100 MINX=XA1(1) MAXX=XA1(1) MINY=YA1(1) MAXY=YA1(1) DO 10 I=1,N1 MINX=AMIN1(MINX,XA1(I)) MAXX=AMAX1(MAXX,XA1(I)) MINY=AMIN1(MINY,YA1(I)) MAXY=AMAX1(MAXY,YA1(I)) 10 CONTINUE DO 20 I=1,N2 MINX=AMIN1(MINX,XA2(I)) MAXX=AMAX1(MAXX,XA2(I)) MINY=AMIN1(MINY,YA2(I)) MAXY=AMAX1(MAXY,YA2(I)) 20 CONTINUE C CALL STRTPT(MINX,MINY) C CALL STRTPT(MAXX,MAXY) C ID37=ID37-2 IF (IOR.EQ.1) GO TO 50 C READ (37'ID37,1000) XS,YS,IC 1000 FORMAT (3A4) C READ (37'ID37,1000) XE,YE,IC C XLEN=XE-XS C YLEN=YE-YS C FACTRX=XLEN/(MAXX-MINX) C FACTRY=YLEN/(MAXY-MINY) FACTRX=1. FACTRY=1. DX0=XS-MINX*FACTRX DY0=YS-MINY*FACTRY XOUT=XA2(1)*FACTRX+DX0 YOUT=YA2(1)*FACTRY+DY0 IC=3 WRITE (36'ID36,1000) XOUT,YOUT,IC IC=4 DO 30 I=1,N1 XOUT=XA1(I)*FACTRX+DX0 YOUT=YA1(I)*FACTRY+DY0 XMIN=AMIN1(XMIN,XOUT) XMAX=AMAX1(XMAX,XOUT) YMIN=AMIN1(YMIN,YOUT) YMAX=AMAX1(YMAX,YOUT) WRITE (36'ID36,1000) XOUT,YOUT,IC 30 CONTINUE DO 40 I=1,N2 J=N2+1-I XOUT=XA2(J)*FACTRX+DX0 YOUT=YA2(J)*FACTRY+DY0 XMIN=AMIN1(XMIN,XOUT) XMAX=AMAX1(XMAX,XOUT) YMIN=AMIN1(YMIN,YOUT) YMAX=AMAX1(YMAX,YOUT) WRITE (36'ID36,1000) XOUT,YOUT,IC 40 CONTINUE XM1=((XA1(1)+XA2(1))*FACTRX)/2. XM2=((XA1(2)+XA2(2))*FACTRX)/2. YM1=((YA1(1)+YA2(1))*FACTRY)/2. YM2=((YA1(2)+YA2(2))*FACTRY)/2. XOUT=(XM1+XM2)/2.+DX0 YOUT=(YM1+YM2)/2.+DY0 WRITE (36'ID36,1000) XOUT,YOUT,IPAT RETURN 50 CONTINUE C READ (37'ID37,1000) YS,XS,IC C READ (37'ID37,1000) YE,XE,IC C YS=-YS C YE=-YE C XLEN=XE-XS C YLEN=YE-YS C FACTRX=XLEN/(MAXX-MINX) C FACTRY=YLEN/(MAXY-MINY) FACTRX=1. FACTRY=1. DX0=XS-FACTRX*MINX DY0=YS-FACTRY*MINY XOUT=XA2(1)*FACTRY+DX0 YOUT=YA2(1)*FACTRX+DY0 IC=3 WRITE (36'ID36,1000) -YOUT,XOUT,IC IC=4 DO 60 I=1,N1 XOUT=XA1(I)*FACTRY+DX0 YOUT=YA1(I)*FACTRX+DY0 XMIN=AMIN1(XMIN,-YOUT) XMAX=AMAX1(XMAX,-YOUT) YMIN=AMIN1(YMIN,XOUT) YMAX=AMAX1(YMAX,XOUT) WRITE (36'ID36,1000) -YOUT,XOUT,IC 60 CONTINUE DO 70 I=1,N2 J=N2+1-I XOUT=XA2(J)*FACTRY+DX0 YOUT=YA2(J)*FACTRX+DY0 XMIN=AMIN1(XMIN,-YOUT) XMAX=AMAX1(XMAX,-YOUT) YMIN=AMIN1(YMIN,XOUT) YMAX=AMAX1(YMAX,XOUT) WRITE (36'ID36,1000) -YOUT,XOUT,IC 70 CONTINUE XM1=((XA1(1)+XA2(1))*FACTRX)/2. XM2=((XA1(2)+XA2(2))*FACTRX)/2. YM1=((YA1(1)+YA2(1))*FACTRY)/2. YM2=((YA1(2)+YA2(2))*FACTRY)/2. XOUT=(XM1+XM2)/2.+DX0 YOUT=(YM1+YM2)/2.+DY0 IC=0 WRITE (36'ID36,1000) -YOUT,XOUT,IPAT RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C CIRCLE (LCIRCL) C CCCCCCCCCCC C C SUBROUTINE LCIRCL (XE,YE,THS,THF,RAD) C C SUBROUTINE LCIRCL PRODUCES CIRCLES AND ARCS OF CIRCLES. C C XE : R*4, C YE : R*4, C COORDINATES OF THE STARTING POINT OF THE C ARC ( OR CIRCLE ). TO START THE ARC FROM C FROM THE CURRENT X AND/OR Y POSITION, THE C CORRESPONDING ARGUMENT(S) SHOULD BE C EQUAL 999. C THS : R*4, ANGLE IN DEGREE OF THE STARTING DIRECTION C OF THE ARC OR CIRCLE. C THF : R*4, ANGLE IN DEGREE OF THE FINISHING DIRECTION C OF THE ARC OR CIRCLE. C IF THF.GT.THS, PEN MOVES COUNTERCLOCKWISE. C IF THF.LT.THS, PEN MOVES CLOCKWISE. C RAD : R*4, RADIUS OF THE ARC OR CIRCLE IN INCHES. C C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 REAL*4 MINX,MAXX,MINY,MAXY XX=XE YY=YE IF(XE.GT.998.5) XX=XOLD IF(YE.GT.998.5) YY=YOLD ALPHA=0.0031/RAD DIFF=THF-THS SIGN=1. IF (DIFF.LT.0.) SIGN=-1. THSTRT=(THS-90.*SIGN)*0.0174532925 THENDE=(THF-90.*SIGN)*0.0174532925 XO=XX-RAD*COS(THSTRT) YO=YY-RAD*SIN(THSTRT) CALL LPLOT (XX,YY,3) ICOUNT=0 10 ICOUNT=ICOUNT+1 RADIAN=ALPHA*SIGN*FLOAT(ICOUNT) IF (ABS(RADIAN/0.0174532925).GT.360.) GO TO 20 ANGLE=THSTRT+RADIAN IF (((ANGLE-THENDE)*SIGN).GT.0.) ANGLE=THENDE XPOS=XO+RAD*COS(ANGLE) YPOS=YO+RAD*SIN(ANGLE) CALL LPLOT (XPOS,YPOS,2) IF (ANGLE.EQ.THENDE) GO TO 60 GO TO 10 20 DIFF=ABS(DIFF) 30 IF (DIFF-360.) 50,50,40 40 DIFF=DIFF-360. GO TO 30 50 ALPHA=DIFF*0.0174532925 ANGLE=THSTRT+ALPHA*SIGN XPOS=XO+RAD*COS(ANGLE) YPOS=YO+RAD*SIN(ANGLE) CALL LPLOT (XPOS,YPOS,3) 60 RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C SCALE (LSCALE) C CCCCCCCCCCC C C SUBROUTINE LSCALE (ARRAY,AXLEN,NPTS,INC1) C C THE LSCALE ROUTINE EXAMINES THE DATA VALUES C IN AN ARRAY AND DETERMINES A STARTING VALUE C AND A SCALING FACTOR SUCH THAT : C (1) SCALE ANNOTATION DRAWN BY THE LAXIS-SUB- C ROUTINE PROPERLY REPRESENTS THE RANGE OF C REAL DATA VALUES IN THE ARRAY. C (2) THE DATA POINTS, WHEN PLOTTED BY THE C LLINE- SUBROUTINE, FIT IA A GIVEN PLOTTING C AREA, AND C (3) THE VALUES ARE SELECTED IN A WAY THAT MAKES C AXIS ANNOTATION EASILY READIBLE. C THE TWO VALUES ARE COMPUTED AND STORED BY C LSCALE AT THE END OF THE ARRAY. C THE ARRAY MUST CONTAIN TWO ADDITIONAL VALUES : C NPTS+1 AND NPTS+2. C C ARRAY : R*4, ARRAY OF DATA VALUES EXAMINED. C AXLEN : R*4, THE AXIS LENGTH OVER WHICH THE C DATA IS SCALED. C NPTS : I*4, THE NUMBER OF VALUES EXAMINED C IN ARRAY. C INC1 : I*4, THE REPEAT CYCLE FOR THE ARRAY. C THIS ARGUMENT IS USED TO SKIP ITEMS C IN A MIXED ARRAY. THE ACTUAL ITEMS C SCANNED BY PSCALE ARE : C ARRAY(1), C ARRAY(1+INC1), C ARRAY(1+2*INC1), C ...... C ARRAY(1+(NPTS-1)*INC1) C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 DIMENSION ARRAY(1) INC=IABS(INC1) AMAX=ARRAY(1) AMIN=AMAX J=1 DO 20 I=2,NPTS J=J+INC X=ARRAY(J) IF(AMAX.GE.X)GO TO 10 AMAX=X GO TO 20 10 IF (AMIN.LE.X) GO TO 20 AMIN=X 20 CONTINUE IF (AMAX.NE.AMIN) GO TO 30 X=AXLEN/3. AMAX=AMAX+X AMIN=AMIN-X 30 FNUM=(AMAX-AMIN)/AXLEN POW=ALOG10(FNUM) IPOW=POW+.01 IF (POW.LT.0.) IPOW=POW-.99 IDIG=(FNUM/10.**IPOW)+.99 40 IF (IDIG-2) 50,110,60 50 IDIG=1 GO TO 110 60 IF (IDIG-5) 70,110,80 70 IDIG=4 GO TO 110 80 IF (IDIG-8) 90,110,100 90 IDIG=8 GO TO 110 100 IPOW=IPOW+1 GO TO 50 110 FUDGE=10.**(IPOW-5) DELTAV=IDIG*10.**IPOW IF (AMIN) 120,130,140 120 FIRST=AINT(AMIN/(DELTAV+FUDGE)-1.) GO TO 150 130 FIRST=0. GO TO 150 140 FIRST=AINT(AMIN/(DELTAV-FUDGE)) 150 FIRSTV=DELTAV*FIRST+FUDGE ALASTV=FIRSTV+(AXLEN*DELTAV) IF (ALASTV.GE.AMAX) GO TO 160 IDIG=IDIG+1 GO TO 40 160 NAME1=NPTS*INC+1 NAME2=NAME1+INC IF (INC1.LT.0) GO TO 170 ARRAY(NAME1)=FIRSTV ARRAY(NAME2)=DELTAV GO TO 180 170 ARRAY(NAME1)=ALASTV ARRAY(NAME2)=-DELTAV 180 RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C LINE (LLINE) C CCCCCCCCCCC C C SUBROUTINE LLINE (XARR,YARR,NPTS,KCYCLE,NDP,ILETT) C C THE LLINE SUBROUTINE PRODUCES A CURVE USING THE C PAIRS OF DATA VALUES IN TWO ARRAYS (XARR,YARR). C THE DATA POINTS MAY BE REPRESENTED BY MARKERS, C CONNECTED BY LINES, OR BOTH. C C XARR : R*4, ARRAY CONTAINING DATA VALUES FOR THE C X DIRECTION (MAY NEED TO INCLUDE C SCALING PARAMETERS). C YRAA : R*4, ARRAY CONTAINING DATA VALUES FOR THE C Y DIRECTION (MAY NEED TO INCLUDE C SCALING PARAMETERS). C NPTS : I*4, NUMBER OF DATA POINTS EXAMINED IN XARR C AND YARR. COUNT DOES NOT INCLUDE THE C EXTRA TWO LOCATIONS FOR SCALING C PARAMETERS. C KCYCLE : I*4, IF NPTS IS GREATER THAN 0, KCYCLE IS C THE INCREMENT USED IN GATHERING DATA C FROM THE TWO ARRAYS. C NDP : I*4, DESCRIBES THE TYPE OF CURVE BEING DRAWN C THROUGH THE DATA POINTS. THE MAGNITUDE C OF NDP DETERMINES THE FREQUENCY OF C PLOTTED SYMBOLS. C EQ.0 : POINTS ARE CONNECTED BY STRAIGHT C LINES AND NO MARKERS ARE DRAWN. C GT.0 : A STRAIGHT LINE CONNECTS EVERY C DATA POINT AND MARKERS ARE DRAWN C EVERY NDP'S DATA POINT. C LT.0 : ONLY MARKERS ARE DRAWN, WITH NO C CONNECTING LINES. C ILETT : I*4, IF NDP NE.0, ILETT IS THE INDEX OF THE C MARKER TO BE CENTERED AT EACH DATA POINT. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 DIMENSION XARR(1),YARR(1) IPTS=IABS(NPTS) INC=KCYCLE IF (NDP) 10,30,20 10 IPEN=3 INCSYM=-NDP GO TO 40 20 IPEN=2 INCSYM=NDP GO TO 40 30 INCSYM=0 40 I=IPTS*INC+1 XO=XARR(I) YO=YARR(I) I=I+INC XF=XARR(I) YF=YARR(I) X=(XARR(1)-XO)/XF Y=(YARR(1)-YO)/YF CALL LPLOT(X,Y,3) IF (INCSYM.GT.0) CALL LSYMBL(999.,999.,.4,ILETT,0.,-1) I=2 J=1 K=1 50 K=K+INC X=(XARR(K)-XO)/XF Y=(YARR(K)-YO)/YF CALL LPLOT(X,Y,IPEN) IF (J.NE.INCSYM) GO TO 60 CALL LSYMBL(999.,999.,.4,ILETT,0.,-1) J=0 60 IF (I.EQ.IPTS) GO TO 70 I=I+1 J=J+1 GO TO 50 70 RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C AXIS (LAXIS) C CCCCCCCCCCC C C SUBROUTINE LAXIS (XE,YE,MESS,NCHARS,AXLEN,ANGLE,FIRVAL,DELVAL) C C SUBROUTINE LAXIS DRAWS AN AXIS, LABELS THE DIVISIONS C WITH APPROPRIATE SCALE VALUES, AND DRAWS A CENTERED C TITLE. WHEN BOTH X AND Y AXES ARE REQUIRED, PAXIS C MUST BE CALLED TWICE. C C XE : R*4, C YE : R*4, C COORDINATES FO THE STARTING POINT OF C THE AXIS. C MESS : L*1, TITLE OF AXIS. C NCHARS : I*4, NUMBER OF CHARACTERS IN MESS. C GT.0 : TITLE, LABELING AND TIC MARKS C ARE ON COUNTERCLOCKWISE SIDE. C EQ.0 : NO TITLE; LABELING AND TIC MARKS C ARE ON COUNTERCLOCKWISE SIDE. C LT.0 : TITLE, LABELING AND TIC MARKS C ARE ON CLOCKWISE SIDE. C AXLEN : R*4, LENGTH OF AXIS IN INCHES. C ANGLE : R*4, ANGLE OF AXIS IN DEGREES. C FIRVAL : R*4, VALUE OF FIRST POINT OF THE AXIS. IF C USING SUBROUTINE PSCALE, THIS SHOULD C BE ARRAY(NPTS*KCYCLE+1). C IF EQ.999 : TITLE AND LABELING ARE C SUPPRESSED. C DELVAL : R*4, VALUE OF INCREMENT ADDED TO FIRVAL FOR C EACH SUCCEEDING ONE INCH DIVISION ALONG C THE AXIS. VALUE MAY BE DETERMINED BY C THE USER OR COMPUTED BY THE PSCALE SUB- C ROUTINE AND REFERENCED IN THE CALL TO C PAXIS AS ARRAY(NPTS*KCYCLE+KCYCLE+1). C IF FIRVAL EQ.999 : DELVAL IS THE DIS- C TANCE BETWEEN TIC C MARKS IN INCHES. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 LOGICAL*1 MESS DIMENSION MESS(1) SAVE1=ASPCT SAVE2=SLANT SAVE3=SPACE ISIDE=ISIGN(1,NCHARS) TEMP1=ANGLE*.0174532925 ANGCOS=COS(TEMP1) ANGSIN=SIN(TEMP1) IF (FIRVAL.NE.999.) GO TO 10 NTIC=AXLEN/DELVAL+1.E-5 TEMP1=ANGCOS*DELVAL TEMP2=ANGSIN*DELVAL GO TO 70 10 IEXPT=0 TEMP1=ABS(DELVAL) 20 IF (TEMP1.GT.0.0099) GO TO 30 TEMP1=TEMP1*10. IEXPT=IEXPT-1 GO TO 20 30 NTIC=AXLEN+1.E-5 TEMP1=FIRVAL+NTIC*DELVAL TEMP1=AMAX1(ABS(FIRVAL),ABS(TEMP1))*10.**(-IEXPT) 40 IF (TEMP1.LT.999.95) GO TO 50 TEMP1=TEMP1/10. IEXPT=IEXPT+1 GO TO 40 50 TEMP1=10.**(-IEXPT) TICVAL=FIRVAL*TEMP1 TICDEL=DELVAL*TEMP1 SIZE1=0.18 TKSIZE=0.1 TEMP1=ISIDE*(TKSIZE+0.1+0.5*SIZE1)-0.5*SIZE1 TEMP2=SIZE1 XX=XE-TEMP1*ANGSIN-TEMP2*ANGCOS YY=YE+TEMP1*ANGCOS-TEMP2*ANGSIN ASPCT=1. SLANT=0. SPACE=1. DO 60 I=0,NTIC-1 CALL LNUMBR(XX,YY,SIZE1,TICVAL,ANGLE,1) XX=XX+ANGCOS YY=YY+ANGSIN TICVAL=TICVAL+TICDEL 60 CONTINUE TEMP1=ANGCOS TEMP2=ANGSIN 70 XX=XE+AXLEN*ANGCOS YY=YE+AXLEN*ANGSIN CALL LPLOT(XX,YY,3) XX=XE+NTIC*TEMP1 YY=YE+NTIC*TEMP2 CALL LPLOT(XX,YY,2) ITEMP=IDASH IDASH=-10 TICX=-TKSIZE*ANGSIN*ISIDE TICY=TKSIZE*ANGCOS*ISIDE CALL LPLOT(XX+TICX,YY+TICY,2) CALL LPLOT(XX,YY,2) DO 80 I=1,NTIC XX=XX-TEMP1 YY=YY-TEMP2 CALL LPLOT(XX,YY,2) CALL LPLOT(XX+TICX,YY+TICY,2) CALL LPLOT(XX,YY,2) 80 CONTINUE ASPCT=SAVE1 SLANT=SAVE2 SPACE=SAVE3 IDASH=ITEMP IF (FIRVAL.GT.998.5) RETURN IF (NCHARS.NE.0) GO TO 90 IF (IEXPT.EQ.0) RETURN 90 ITEMP=IABS(NCHARS) SIZE2=0.4 TEMP1=ISIDE*(TKSIZE+0.5+SIZE1+0.5*SIZE2)-0.5*SIZE2 TEMP2=(FLOAT(ITEMP-1)*(10.+4.*SPACE)+10.)*ASPCT*SIZE2/14. IF (IEXPT.NE.0) 1 TEMP2=TEMP2+(4.*10.+3.*4.*SPACE)*ASPCT*SIZE2/14. TEMP2=(AXLEN-TEMP2)/2. CALL LPLOT(XE+TEMP2*ANGCOS-TEMP1*ANGSIN, 1 YE+TEMP2*ANGSIN+TEMP1*ANGCOS,3) IF (NCHARS.EQ.0) GO TO 110 CALL LSYMBL(999.,999.,SIZE2,MESS,ANGLE,ITEMP) IF (IEXPT.EQ.0) RETURN 110 CALL LSYMBL(999.,999.,SIZE2,4H *10,ANGLE,4) TEMP1=IEXPT CALL LNUMBR(OLDX-SIZE2*ANGSIN/1.5,OLDY+SIZE2*ANGCOS/1.5, 1 SIZE2/3.,TEMP1,ANGLE,-1) RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C ORIGIN (LOGIGN) C CCCCCCCCCCC C C SUBROUTINE LORIGN (XE,YE,IORIG) C C THE LORIGN SUBROUTINE IS USED TO RELOCATE THE ORIGIN C WITHOUT REQUIRING THAT THE "PEN TO BE MOVED" TO THE NEW C ORIGIN. THE POSITION OF THE NEW ORIGIN MAY BE SPECIFIED C RELATIVE TO EITHER THE CURRENT USER DEFINED ORIGIN, OR C THE INITIAL PLOTTER ORIGIN. ALTERNATIVELY, LORIGN CAN C RETURN THE LOCATION OF THE CURRENT USER ORIGIN RELATIVE C TO THE INITIAL PLOTTER ORIGIN. C XE : R*4, C YE : R*4, C IF IORIG.EQ.0 OR 1, XE AND YE ARE THE COOR- C DINATES OF THE NEW ORIGIN. C IF IORIG.EQ.-1,XE AND YE ARE RETURNED AS THE C COORDINATES OF THE CURRENT USER DEFINED C ORIGIN RELATIVE TO THE INITIAL PLOTTER C ORIGIN. C IORIG : I*4, EQ.1 : A NEW ORIGIN IS DEFINED RELATIVE TO C THE LAST USER-DEFINED ORIGIN. C EQ.0 : A NEW ORIGIN IS DEFINED RELATIVE TO C THE INITIAL PLOTTER ORIGIN. C EQ.-1: THE LOCATION OF THE CURRENT USER- C DEFINED ORIGIN IS RETURNED. C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 IF (IORIG) 10,20,30 10 XE=XLAST YE=YLAST RETURN 20 XLAST=XE YLAST=YE RETURN 30 XLAST=XLAST+XE XLAST=YLAST+YE RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C DIN17 (LG8DIN) C CCCCCCCCCCC C C SUBROUTINE LG8DIN (XL,YL,SIZIN,PEN,ANGIN,TEXT, 1 NTEXT,IPLOT,ALEN,XE,YE) C C SUBROUTINE LG8DIN PRODUCES GERMAN STANDARD FONT C C XL : R*4, X - COORDINATE OF LOWER LEFT CORNER C OF TEXT C YL : R*4, Y - COORDINATE OF LOWER LEFT CORNER C OF TEXT C SIZIN : R*4, HEIGHT OF TEXT BEEING WRITTEN IN INCHES C PEN : R*4, WIDTH OF TEXT BEEING WRITTEN IN INCHES C IN THE RANGE OF 1./10. TO 1./7. OF HEIGHT C BUT NOT LESS THAN 0.01 INCH C ANGIN : R*4, ANGLE IN DEGREES OF TEXT BEEING WRITTEN C COUNTERCLOCKWISE STARTING AT HORIZONTAL C LINE C TEXT : L*1, STRING CONTAINING THE TEXT BEEING WRITTEN C NTEXT : I*4, NUMBER OF CHARACTERS IN TEXT. IF NTEXT=100 C THE NUMBER OF CHARACTERS WILL BE FIGURED C AUTOMATICALLY. END - CONDITION IS THAN THE C CHARACTER $. C IPLOT : I*4, IF IPLOT=0 THE TEXT WILL NOT BE PLOTTED. C ALEN, XE AND YE CONTAIN THE LENGTH C OF THE TEXT ON THE PLOT AND THE X - AND C Y - COORDINATES OF OF THE LOWER RIGHT CORNER C OF THE TEXT INCLUDING THE INTER - CHARACTER GAP C AT THE END OF THE TEXT. C IF IPLOT>0 THE TEXT WILL BE PLOTTED. C ALEN, XE AND YE CONTAIN THE LENGTH C OF THE TEXT ON THE PLOT AND THE X - AND C Y - COORDINATES OF OF THE LOWER RIGHT CORNER C OF THE TEXT INCLUDING THE INTER - CHARACTER GAP C AT THE END OF THE TEXT. C IF IPLOT<0 THE TEXT WILL NOT BE PLOTTED. C ALEN, XE AND YE CONTAIN THE LENGTH C OF THE TEXT ON THE PLOT AND THE X - AND C Y - COORDINATES OF OF THE LOWER RIGHT CORNER C OF THE TEXT WITHOUT THE INTER - CHARACTER GAP C AT THE END OF THE TEXT. C ALEN : R*4, LENGTH OF THE TEXT ON THE PLOT IN INCHES C WITH OR WITHOUT THE INTER - CHARACTER GAP C DEPENDING ON THE CONTENTS OF IPLOT. C XE : R*4, X - COORDINATES OF THE LOWER RIGHT CORNER OF C THE TEXT WITH OR WITHOUT THE INTER - CHARACTER C GAP DEPENDING ON THE CONTENTS OF IPLOT. C YE : R*4, Y - COORDINATES OF THE LOWER RIGHT CORNER OF C THE TEXT WITH OR WITHOUT THE INTER - CHARACTER C GAP DEPENDING ON THE CONTENTS OF IPLOT. C C COMMON /LG8001/NUMM,X0,Y0,XOLD,YOLD,XMOVE,YMOVE, * XNEW,YNEW,XLAST,YLAST,XOFF,YOFF, * OLDX,OLDY,XMIN,YMIN,XMAX,YMAX, * XPAGE,YPAGE,XEND,YEND, * ASPCT,SLANT,SPACE,WIDTH, * FACTR,UNITS,IOR,ILET,IENDPL COMMON /LG8002/ID35,ID36,ID37,ID38 INTEGER*2 LEN,NVEC,LET LOGICAL*1 TEXT,DOLLAR,UMLAUT DIMENSION TEXT(1),LET(12),VECTOR(7) DATA DOLLAR/'$'/ DATA UMLAUT/'^'/ DATA ISPACE/1/ OPEN (UNIT=41, 1 STATUS='OLD', 2 RECL=28, 3 FORM='FORMATTED', 4 CARRIAGECONTROL='LIST', 5 ACCESS='DIRECT', 6 ASSOCIATEVARIABLE=ID41, 7 FILE='LG8DIN.VEC') ID41=1 READ (41'ID41,1000) ILET,NUMMAX 1000 FORMAT (2A4,20X) NMESS=IABS(NTEXT) IF (NMESS.NE.100) GO TO 20 DO 10 I=1,100 IF (TEXT(I).EQ.DOLLAR) GO TO 20 NMESS=I 10 CONTINUE 20 LENGTH=0 NUMS=0 DO 30 I=1,NMESS ID41=TEXT(I)+2 READ (41'ID41,1100) LEN,NVEC,LET 1100 FORMAT (14A2) LENGTH=LENGTH+LEN IF (LEN.EQ.0) GO TO 30 IF (TEXT(I).EQ.UMLAUT) GO TO 30 NUMS=NUMS+1 30 CONTINUE I=1 IF (IPLOT.NE.0) I=0 LENGTH=LENGTH+(NUMS-I)*ISPACE IF (LENGTH.LT.0) LENGTH=0 C IF (LENGTH.EQ.0) GO TO 110 SIZE=SIZIN C IF (SIZE.LT.0.09999) SIZE=0.09999 ALEN=FLOAT(LENGTH)*SIZE/7. IF (IPLOT.LE.0) GO TO 110 WIDTH=PEN IF (WIDTH.GT.(SIZE/7.)) WIDTH=SIZE/7. IF (WIDTH.LT.(SIZE/10.)) WIDTH=SIZE/10. IF (WIDTH.LT.0.01) WIDTH=0.01 PW=3. STRI=WIDTH IF (STRI.GE.0.023.AND.STRI.LT.0.043) PW=5. IF (WIDTH.GT.(PW/300.)) WIDTH=WIDTH-PW/300. IWIDTH=JNINT(PW) ANGLE=ANGIN ANGSIN=SIND(ANGLE) ANGCOS=COSD(ANGLE) DX=ALEN*ANGCOS-SIZE*ANGSIN DY=ALEN*ANGSIN+SIZE*ANGCOS SIGN=1. IF (IOR.EQ.0) GO TO 40 SIGN=-1. ANGLE=ANGLE+90. 40 CONTINUE XS=XL+XLAST YS=YL+YLAST FACTRX=1. FACTRY=1. ANGSIN=SIND(ANGLE) ANGCOS=COSD(ANGLE) LENGTH=0 IFLAG=0 DO 100 I=1,NMESS ID41=TEXT(I)+2 READ (41'ID41,1100) LEN,NVEC,LET IF (TEXT(I).EQ.UMLAUT) IFLAG=1 NUMVEC=NVEC IF (NUMVEC.EQ.0) GO TO 100 LENGTH=LENGTH+LEN+ISPACE IF (IFLAG.EQ.1) NUMVEC=NUMVEC+2 IFLAG=0 C K=NLET(J+1)-1 DO 90 L=1,NUMVEC ID41=ILET+LET(L) READ (41'ID41,1300) VECTOR 1300 FORMAT (7A4) C K=K+1 C M=LET(K) IF (VECTOR(1).EQ.0.) GO TO 90 IF (VECTOR(1).NE.1.) GO TO 80 DX=VECTOR(2)*ANGCOS-VECTOR(3)*ANGSIN DY=VECTOR(2)*ANGSIN+VECTOR(3)*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X1=XS+DX*SIZE/14. Y1=YS+DY*SIZE/14. DX=VECTOR(4)*ANGCOS-VECTOR(5)*ANGSIN DY=VECTOR(4)*ANGSIN+VECTOR(5)*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X2=XS+DX*SIZE/14. Y2=YS+DY*SIZE/14. DX=VECTOR(6)*ANGCOS-VECTOR(7)*ANGSIN DY=VECTOR(6)*ANGSIN+VECTOR(7)*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X3=XS+DX*SIZE/14. Y3=YS+DY*SIZE/14. DX=X2-X1 DY=Y2-Y1 IF (DX.EQ.0.) GO TO 50 IF (DY.EQ.0.) GO TO 60 ATANA=DY/DX ALPHA=ATAND(ATANA) IF (DX.LT.0.) ALPHA=ALPHA+180. GO TO 70 50 ALPHA=90. IF (DY.LT.0.) ALPHA=270. GO TO 70 60 ALPHA=0. IF (DX.LT.0.) ALPHA=180. 70 RAD=WIDTH/2. DX=RAD*SIND(ALPHA) DY=-RAD*COSD(ALPHA) DX=DX*FACTRX DY=DY*FACTRY*SIGN BETA=630.-ALPHA KENN=0 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1+DX, 1 Y1+DY,X2+DX,Y2+DY,RAD 1400 FORMAT (9A4) KENN=1 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1+DX, 1 Y1+DY,X2+DX,Y2+DY,RAD WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1-DX, 1 Y1-DY,X2-DX,Y2-DY,RAD IF (STRI.LT.0.043) 1 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1, 2 Y1,X2,Y2,RAD KENN=2 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1-DX, 1 Y1-DY,X2-DX,Y2-DY,RAD KENN=3 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X2, 1 Y2,BETA,BETA-180.,RAD WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1, 1 Y1,BETA-180.,BETA,RAD KENN=4 IF (STRI.GE.0.043) 1 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X3, 2 Y3,X3,Y3,RAD GO TO 90 80 IF (VECTOR(1).NE.2.) GO TO 90 X1=VECTOR(2) Y1=VECTOR(3) DX=X1*ANGCOS-Y1*ANGSIN DY=X1*ANGSIN+Y1*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X1=XS+DX*SIZE/14. Y1=YS+DY*SIZE/14. ALPHA=720.-(VECTOR(5)+ANGLE) BETA=720.-(VECTOR(6)+ANGLE) RAD=VECTOR(4)*SIZE/14. KENN=3 IF (STRI.LT.0.043) 1 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1, 2 Y1,ALPHA,BETA,RAD RAD=RAD-WIDTH/2. WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1, 1 Y1,ALPHA,BETA,RAD RAD=RAD+WIDTH WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1, 1 Y1,ALPHA,BETA,RAD X1=VECTOR(2)+VECTOR(4)*COSD(VECTOR(5)) Y1=VECTOR(3)+VECTOR(4)*SIND(VECTOR(5)) DX=X1*ANGCOS-Y1*ANGSIN DY=X1*ANGSIN+Y1*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X1=XS+DX*SIZE/14. Y1=YS+DY*SIZE/14. X2=VECTOR(2)+VECTOR(4)*COSD(VECTOR(6)) Y2=VECTOR(3)+VECTOR(4)*SIND(VECTOR(6)) DX=X2*ANGCOS-Y2*ANGSIN DY=X2*ANGSIN+Y2*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X2=XS+DX*SIZE/14. Y2=YS+DY*SIZE/14. RAD=WIDTH/2. WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X1, 1 Y1,ALPHA-180.,ALPHA,RAD WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X2, 1 Y2,BETA,BETA-180.,RAD X3=VECTOR(2)+VECTOR(4)*COSD(VECTOR(7)) Y3=VECTOR(3)+VECTOR(4)*SIND(VECTOR(7)) DX=X3*ANGCOS-Y3*ANGSIN DY=X3*ANGSIN+Y3*ANGCOS DX=DX*FACTRX DY=DY*FACTRY*SIGN X3=XS+DX*SIZE/14. Y3=YS+DY*SIZE/14. KENN=4 IF (STRI.GE.0.043) 1 WRITE (35'ID35,1400) KENN,IWIDTH,X0,Y0,X3, 2 Y3,X3,Y3,RAD 90 CONTINUE DX=FLOAT(LENGTH)*ANGCOS*SIZE/7. DY=FLOAT(LENGTH)*ANGSIN*SIZE/7. DX=DX*FACTRX DY=DY*FACTRY*SIGN XS=XL+XLAST+DX YS=YL+YLAST+DY 100 CONTINUE C DX=FLOAT(LENGTH)*ANGCOS*SIZE/7. C DY=FLOAT(LENGTH)*ANGSIN*SIZE/7. C DY=DY*SIGN C XE=XL+XLAST+DX C YE=YL+YLAST+DY CALL LPLOT (XS-XLAST,YS-YLAST,3) 110 CLOSE (UNIT=41,DISP='KEEP') DX=FLOAT(LENGTH)*ANGCOS*SIZE/7. DY=FLOAT(LENGTH)*ANGSIN*SIZE/7. DY=DY*SIGN XE=XL+DX YE=YL+DY RETURN END C-------------------------------------------------------------------- C C CCCCCCCCCCC C C LG8CHR C CCCCCCCCCCC C C SUBROUTINE LG8CHR (X0,Y0,SIZE,ANGLE,SLANT,ASPCT,SPACE, 1 LCHAR,NCHAR,IPLOT,ALEN,XF,YF) C C SUBROUTINE LG8CHR GENERATES CHARACTERS, CHARACTER C STRINGS AND CENTERED SYMBOLS IN ANY DIRECTION, SLANT C ASPECT-RATIO AND INTER-CHARACTER-SPACING. C THIS SUBROUTINE CAN ALSO BE USED TO DETERMINE THE C LENGTH OF A CHARACTER STRING. C C X0 : R*4, C Y0 : R*4, C STARTING COORDINATES OF LOWER LEFT CORNER. C SIZE : R*4, THE SIZE OF THE CHARACTERS OR SYMBOLS. C ANGLE : R*4, THE ANGLE OF THE WRITING DIRECTION. C 0. REPRESENTS THE X DIRECTION. C 90. REPRESENTS THE Y DIRECTION. C SLANT : R*4, THE SLANT ANGLE OF THE CHARACTERS OR SYMBOLS. C ASPCT : R*4, THE WIDTH TO HEIGT RATIO OF THE CHARACTERS C OR SYMBOLS. C SPACE : R*4, MULTIPLICATION FACTOR TO CHANGE THE INTER- C CHARACTER-SPACING BETWEEN CHARACTERS OR C SYMBOLS. C LCHAR : L*1, STRING OR SINGLE OF CHARACTERS OR SYMBOLS. C NCHAR : I*4, NUMBER OF CHARACTERS OR SYMBOLS CONTAINED C IN LCHAR. C IPLOT : I*4, EQ.0 : THE CONTENTS OF LCHAR IS NOT PLOTTED. C THE FINAL COORDINATES WITHOUT LAST C INTER-CHARACTER-SPACING ARE RETURNED. C LT.0 : THE CONTENTS OF LCHAR IS NOT PLOTTED. C THE FINAL COORDINATES INCLUDING THE C LAST INTER-CHARACTER-SPACING ARE C RETURNED. C GT.O : THE CONTENTS OS LCHAR IS PLOTTED. C THE FINAL COORDINATES INCLUDING THE C LAST INTER-CHARACTER-SPACING ARE C RETURNED. C ALEN : R*4, C XF : R*4, C YF : R*4, C ENDING COORDINATES OF LOWER RIGHT CORNER. C IF IPLOT.EQ.0 THE LAST INTER-CHARACTER-SPACE C IS NOT INCLUDED ( LEGTH OF TEXT ). C IF IPLOT.NE.0 THE LAST INTER-CHARACTER-SPACE C IS INCLUDED ( PRESENT POSITION ). C LOGICAL*1 LCHAR INTEGER*2 LETTER DIMENSION LCHAR(1),LETTER(16),VECTOR(4) FACTOR=ABS(ASPCT)/ASPCT ICHAR=NCHAR ANG=ANGLE SLA=SLANT 10 IF (ANG.LT.360.) GO TO 20 ANG=ANG-360. GO TO 10 20 IF (SLA.LT.360.) GO TO 30 SLA=SLA-360. GO TO 20 30 IF (SLA.GT.80.) SLA=80. IF (SLA.LT.-80.) SLA=-80. ANGCOS=COS(ANG*0.0174532925) ANGSIN=SIN(ANG*0.0174532925) SLATAN=TAN(SLA*0.0174532925) IF (IPLOT.LE.0) GO TO 60 OPEN (UNIT=40, 1 STATUS='OLD', 2 RECL=16, 3 FORM='FORMATTED', 4 CARRIAGECONTROL='LIST', 5 ACCESS='DIRECT', 6 ASSOCIATEVARIABLE=ID40, 7 FILE='LG8CHR.VEC') READ (40'1,1000) ILET,NUMMAX 1000 FORMAT (2A4,8X) DO 50 K=1,NCHAR IF (NCHAR.EQ.1.AND.LCHAR(1).LT.17) ICHAR=0 ID40=LCHAR(K) ID40=2*ID40+2 READ (40'ID40,1100) (LETTER(I),I=1,8) 1100 FORMAT (8A2) READ (40'ID40,1100) (LETTER(I),I=9,16) DO 40 I=1,16 IF (LETTER(I).EQ.0) GO TO 50 ID40=LETTER(I)+ILET READ (40'ID40,1200) (VECTOR(L),L=1,4) 1200 FORMAT (4A4) DX=(VECTOR(1)*ANGCOS*ASPCT 1 +VECTOR(2)*ANGCOS*SLATAN*FACTOR 2 -VECTOR(2)*ANGSIN) 3 *SIZE/14. XA=X0+FLOAT(K-1)*(10.+4.*SPACE)*ANGCOS*ASPCT*SIZE/14.+DX DY=(VECTOR(2)*ANGCOS 1 +VECTOR(2)*ANGSIN*SLATAN*FACTOR 2 +VECTOR(1)*ANGSIN*ASPCT) 3 *SIZE/14. YA=Y0+FLOAT(K-1)*(10.+4.*SPACE)*ANGSIN*ASPCT*SIZE/14.+DY CALL LPLOT (XA,YA,3) DX=(VECTOR(3)*ANGCOS*ASPCT 1 +VECTOR(4)*ANGCOS*SLATAN*FACTOR 2 -VECTOR(4)*ANGSIN) 3 *SIZE/14. XE=X0+FLOAT(K-1)*(10.+4.*SPACE)*ANGCOS*ASPCT*SIZE/14.+DX DY=(VECTOR(4)*ANGCOS 1 +VECTOR(4)*ANGSIN*SLATAN*FACTOR 2 +VECTOR(3)*ANGSIN*ASPCT) 3 *SIZE/14. YE=Y0+FLOAT(K-1)*(10.+4.*SPACE)*ANGSIN*ASPCT*SIZE/14.+DY CALL LPLOT (XE,YE,2) 40 CONTINUE 50 CONTINUE ALEN=(FLOAT(ICHAR)*(10.+4.*SPACE))*ASPCT*SIZE/14. XF=X0+FLOAT(ICHAR)*(10.+4.*SPACE)*ANGCOS*ASPCT*SIZE/14. YF=Y0+FLOAT(ICHAR)*(10.+4.*SPACE)*ANGSIN*ASPCT*SIZE/14. CALL LPLOT (XF,YF,3) CLOSE (UNIT=40,DISP='KEEP') RETURN 60 IF (IPLOT.NE.0) GO TO 70 ALEN=(FLOAT(ICHAR-1)*(10.+4.*SPACE)+10.)*ASPCT*SIZE/14. XF=X0+(FLOAT(ICHAR-1)*(10.+4.*SPACE)+10.)*ANGCOS*ASPCT*SIZE/14. YF=Y0+(FLOAT(ICHAR-1)*(10.+4.*SPACE)+10.)*ANGSIN*ASPCT*SIZE/14. C23456789|123456789|123456789|123456789|123456789|123456789|123456789|123456789| RETURN 70 ALEN=(FLOAT(ICHAR)*(10.+4.*SPACE))*ASPCT*SIZE/14. XF=X0+(FLOAT(ICHAR)*(10.+4.*SPACE))*ANGCOS*ASPCT*SIZE/14. YF=Y0+(FLOAT(ICHAR)*(10.+4.*SPACE))*ANGSIN*ASPCT*SIZE/14. RETURN END