diff options
Diffstat (limited to 'sys/gio/ncarutil/dashsmth.f')
| -rw-r--r-- | sys/gio/ncarutil/dashsmth.f | 1224 |
1 files changed, 1224 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/dashsmth.f b/sys/gio/ncarutil/dashsmth.f new file mode 100644 index 00000000..2fe25185 --- /dev/null +++ b/sys/gio/ncarutil/dashsmth.f @@ -0,0 +1,1224 @@ + SUBROUTINE FDVDLD (IENTRY,IIX,IIY) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SOFTWARE DASHED LINE PACKAGE WITH CHARACTER CAPABILITY AND SMOOTHING +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE DASHSMTH IS A SOFTWARE DASHED LINE PACKAGE WITH +C SMOOTHING CAPABILITIES. DASHSMTH IS DASHCHAR +C WITH SMOOTHING FEATURES ADDED. +C +C USAGE FIRST, EITHER +C CALL DASHDB (IPAT) +C WHERE IPAT IS A 16-BIT DASH PATTERN AS +C DESCRIBED IN THE SUBROUTINE DASHDB (SEE +C DASHLINE DOCUMENTATION), OR +C CALL DASHDC (IPAT,JCRT,JSIZE) +C AS DESCRIBED BELOW. +C +C THEN, CALL ANY OF THE FOLLOWING: +C CALL CURVED (X,Y,N) +C CALL FRSTD (X,Y) +C CALL VECTD (X,Y) +C CALL LASTD +C +C LASTD IS CALLED ONLY AFTER THE LAST +C POINT OF A LINE HAS BEEN PROCESSED IN VECTD. +C +C THE FOLLOWING MAY ALSO BE CALLED, BUT NO +C SMOOTHING WILL RESULT: +C CALL LINED (XA,YA,XB,YB) +C +C +C ARGUMENTS IPAT +C ON INPUT A CHARACTER STRING OF ARBITRARY LENGTH +C TO DASHDC (60 CHARACTERS SEEMS TO BE A PRACTICAL +C LIMIT) WHICH SPECIFIES THE DASH PATTERN +C TO BE USED. A DOLLAR SIGN IN IPAT +C INDICATES SOLID; AN APOSTROPHE INDICATES +C A GAP; BLANKS ARE IGNORED. ANY CHARACTER +C IN IPAT WHICH IS NOT A DOLLAR SIGN, +C APOSTROPHE, OR BLANK IS CONSIDERED TO BE +C PART OF A LINE LABEL. EACH LINE LABEL +C CAN BE AT MOST 15 CHARACTERS IN LENGTH. +C SUFFICIENT WHITE SPACE IS RESERVED IN THE +C DASHED LINE FOR WRITING LINE LABELS. +C +C JCRT +C THE LENGTH IN PLOTTER ADDRESS UNITS PER +C $ OR APOSTROPHE. +C +C JSIZE +C IS THE SIZE OF THE PLOTTED CHARACTERS: +C . IF BETWEEN 0 AND 3 , IT IS 1., 1.5, 2. +C AND 3. TIMES AN 8 PLOTTER ADDRESS UNIT +C WIDTH. +C . IF GREATER THAN 3, IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C +C ARGUMENTS TO CURVED(X,Y,N) +C OTHER LINE-DRAWING X AND Y ARE ARRAYS OF WORLD COORDINATE VALUES +C ROUTINES OF LENGTH N OR GREATER. LINE SEGMENTS OBEYING +C THE SPECIFIED DASH PATTERN ARE DRAWN TO +C CONNECT THE N POINTS. +C +C FRSTD(X,Y) +C THE CURRENT PEN POSITION IS SET TO +C THE WORLD COORDINATE VALUE (X,Y) +C +C VECTD(X,Y) +C A LINE SEGMENT IS DRAWN BETWEEN THE +C WORLD COORDINATE VALUE (X,Y) AND THE +C MOST RECENT PEN POSITION. (X,Y) THEN +C BECOMES THE MOST RECENT PEN POSITION. +C +C LINED(XA,XB,YA,YB) +C A LINE IS DRAWN BETWEEN WORLD COORDINATE +C VALUES (XA,YA) AND (XB,YB). +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED FOR ALL ROUTINES. +C +C NOTE WHEN USING FRSTD AND VECTD, LASTD MUST BE +C CALLED (NO ARGUMENTS NEEDED). LASTD SETS UP +C THE CALLS TO THE SMOOTHING ROUTINES KURV1S AND +C KURV2S. +C +C WHEN SWITCHING FROM THE REGULAR PLOTTING +C ROUTINES TO A DASHED LINE PACKAGE THE FIRST +C CALL SHOULD NOT BE TO VECTD. +C +C ENTRY POINTS DASHDB, DASHDC, CURVED, FRSTD, VECTD, LINED, +C RESET, LASTD, KURV1S, KURV2S, CFVLD, FDVDLD, +C DRAWPV, DASHBD +C +C COMMON BLOCKS INTPR, DASHD1, DASHD2, DDFLAG, DCFLAG, DSAVE1, +C DSAVE2, DSAVE3, DSAVE5, CFFLAG, SMFLAG, DFFLAG, +C FDFLAG +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SOLID OR DASHED LINES, POSSIBLY WITH +C CHARACTERS AT INTERVALS IN THE LINE. +C THE LINES MAY ALSO BE SMOOTHED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN OCTOBER 1973. +C MADE PORTABLE IN SEPTEMBER 1977 FOR USE +C WITH ALL MACHINES WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BIT RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JUNE, 1984. +C +C ALGORITHM POINTS FOR EACH LINE +C SEGMENT ARE PROCESSED AND PASSED TO THE +C ROUTINES, KURV1S AND KURV2S, WHICH COMPUTE +C SPLINES UNDER TENSION PASSING THROUGH THESE +C POINTS. NEW POINTS ARE GENERATED BETWEEN THE +C GIVEN POINTS, RESULTING IN SMOOTH LINES. +C +C ACCURACY PLUS OR MINUS .5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C TIMING ABOUT THREE TIMES AS LONG AS DASHCHAR. +C +C +C +C +C +C +C +C +C*********************************************************************** +C +C FDVDLD RECEIVES IN ITS ARGUMENTS THE POINTS TO BE PROCESSED FOR A +C LINE SEGMENT. IT PASSES THESE POINTS TO THE ROUTINES KURV1S AND KURV2S +C WHICH COMPUTE SPLINES UNDER TENSION PASSING THROUGH THESE POINTS. +C FDVDLD THEN CALLS CFVLD TO CONNECT THE POINTS GENERATED IN KURV2S. +C + DIMENSION XP(70), YP(70), TEMP(70) +C +C THE VARIABLES IN DSAVE5 HAVE TO BE SAVED FOR THE NEXT CALL TO FDVDLD. +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C +C IOFFS IS AN INTERNAL PARAMETER. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN FDVDLD AND DRAWPV. +C + COMMON /SMFLAG/ IOFFS +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED. +C + COMMON /DFFLAG/ IFSTF2 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C + COMMON /FDFLAG/ IFLAG +C +C NOTE THAT THIS IFSTF2 FLAG CANNOT BE IDENTICAL TO THE IFSTFL FLAG +C IN THE ROUTINE CFVLD, BECAUSE A CALL TO THE FRSTD ENTRY OF FDVDLD DOES +C NOT ELIMINATE THE NECESSITY OF A CALL TO THE FRSTD ENTRY OF CFVLD, +C AND REVERSE. +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE +C +C +C OTHER CONSTANTS. +C + DATA PI /3.14159265358/ + DATA IDUMMY /0/ +C +C + GO TO (10,15,35),IENTRY +C +C ************************************* +C +C ENTRY FRSTD (XX,YY) +C + 10 DEG = 180./PI +C + MX = IIX + MY = IIY + IFSTF2 = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 + IF (IOFFS .GE. 1) CALL CFVLD (1,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 15 CONTINUE +C +C TEST FOR PREVIOUS FRSTD CALL +C + IF (IFSTF2 .EQ. 0) GO TO 20 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER(' FDVDLD- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 10 + 20 MX = IIX + MY = IIY +C +C VECTD SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + IF (IOFFS .GE. 1) CALL CFVLD (2,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C IF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 40 + RETURN +C +C ************************************* +C +C ENTRY LASTD +C + 35 CONTINUE + IF (IFSTF2 .NE. 0) RETURN + IFSTF2 = 1 +C +C LASTD CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C + IF (IOFFS .GE. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + IF (IOFFS .GE. 1) RETURN +C +C IFLAG = 0 OK TO CALL LASTD DIRECTLY +C IFLAG = 1 LASTD WAS JUST CALLED FROM BY VECTD +C IGNORE CALL TO LASTD +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 40 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 60 + IF (N-2) 150,140,50 + 50 IF (N .GE. 4) GO TO 60 +C + IF (IPRD .NE. 0) GO TO 60 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 100 + 60 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 80 + IF (NSEG .GE. 1) GO TO 70 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 100 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 70 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 100 + 80 IF (NSEG .GE. 1) GO TO 90 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 100 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 90 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 100 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 110 + NPRIME = FLOAT(NP)-(S*FLOAT(NP)*.5)/32767. + IF (S .GE. 32767.) NPRIME = .5*FLOAT(NP) + NPL = AMAX1(FLOAT(NPRIME)*S/32767.,2.5) + 110 DT = 1./FLOAT(NPL) + IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + IF (NSEG .LE. 0) GO TO 112 + CALL DRAWPV (IX,IY,0) + GO TO 114 + 112 CONTINUE + CALL CFVLD (1,IX,IY) + 114 CONTINUE + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + DO 120 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + IX = IFIX(XS) + IY = IFIX (YS) + CALL CFVLD (2,IX,IY) + 120 CONTINUE + IF (IPRD .NE. 0) GO TO 130 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + IX = IFIX (XSV1) + IY = IFIX (YSV1) + CALL CFVLD (2,IX,IY) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 130 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + GO TO 150 +C +C FOR THE CASE WHEN THERE ARE ONLY 2 DISTINCT POINTS ON A LINE. +C + 140 IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + CALL CFVLD (1,IX,IY) + IX = IFIX (XSAVE(N)) + IY = IFIX (YSAVE(N)) + CALL CFVLD (2,IX,IY) + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) +C + 150 CONTINUE + RETURN + END + SUBROUTINE RESET +C +C THIS USER ENTRY POINT IS HERE ONLY FOR COMPATIBILITY WITH USE IN +C THE CONREC FAMILY WHICH CALL RESET WHEN USED WITH DASHSUPR. +C + RETURN + END + SUBROUTINE DASHDC (IPAT,JCRT,JSIZE) +C +C +C +C +C +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C USER ENTRY POINT. +C DASHDC GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENTS. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*(*) IPAT + CHARACTER*1 IBLK, IGAP, ISOL, ICR + CHARACTER*16 IPC(100) +C +C DASHD1 AND DASHD2 ARE USED +C FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB, DASHDC AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB AND DASHDC. +C IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB AND DASHDC ARE SAVED IN DSAVE2 +C FOR THE NEXT CALL +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C SAVE ALL VARIABLES + SAVE +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C +C NPD IS THE NUMBER OF WORDS IN IP +C + DATA NPD/100/ +C +C INITIALIZE CHARACTER FLAGS +C + DATA IBLK,IGAP,ISOL/' ','''','$'/ +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDC', 'VERSION 1') +C +C NC IS THE NUMBER OF CHARACTERS IN IPAT +C + NC = LEN(IPAT) + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDC -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN TO BE PASSED TO OPTN (65535=177777B). +C + MASK=IOR(ISHIFT(32767,1),1) +C +C + IFCFLG = 2 +C +C NCHRTS - NUMBER OF CHARS IN THIS HOLLERITH STRING. +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C +C RETRIEVE THE RESOLUTION AS SET BY THE USER. +C + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) +C +C IADJUS - TO ADJUST NUMBERS TO THE GIVEN RESOLUTION. +C + IADJUS = ISHIFT(1,15-LXSAVE) + ICRT = JCRT*IADJUS + ISIZE = JSIZE + CHARW = FLOAT(ISIZE*IADJUS) + IF (ISIZE .GT. 3) GO TO 30 + CHARW = 256. + FLOAT(ISIZE)*128. + IF (ISIZE .EQ. 3) CHARW = 768. +C + 30 CONTINUE + IF (ICRT .LT. 1) GO TO 230 + MODE = 2 +C +C START MAIN LOOP +C +C THIS LOOP GENERATES THE IP ARRAY (NEEDED BY CURVED,VECTD,ETC.) FROM +C THE CHARACTER STRING IN IPAT. EACH ITERATION OF THE LOOP PROCESSES +C ONE CHAR OF IPAT. A SOLID OR GAP IS CONSIDERED TO BE A TYPE 1 ENTRY, +C AND A LABEL CHARACTER IS CONSIDERED TO BE A TYPE 2 ENTRY. +C +C IN THE CODE, L IS THE NUMBER OF CHANGES IN THE LINESTYLE (FROM GAP +C TO SOLID, SOLID TO CHARACTER, ETC.) THE IP AND IPFLAG ARRAYS DESCRIBE +C THE LINE TO BE DRAWN, AND THESE ARRAYS ARE INDEXED FROM 1 TO L. THE +C RELATIONSHIP BETWEEN IP AND IPFLAG IS: +C +C IPFLAG(N) IP(N) +C --------- ----- +C 1 LENGTH (IN PLOTTER ADDRESS UNITS) OF SOLID LINE TO +C BE DRAWN. +C 0 NUMBER OF CHARACTERS TO BE PLOTTED. +C -1 LENGTH (IN PLOTTER ADDRESS UNITS) OF GAP. +C +C THE 160 LOOP HANDLES 5 CASES: +C +C 1.) CONTINUE TYPE 2 ENTRY (60-80) +C 2.) START TYPE 2 ENTRY (80-90) +C 3.) END TYPE 2 ENTRY AND START TYPE 1 ENTRY (90-160) +C 4.) START TYPE 1 ENTRY, OR SWITCH TYPE 1 ENTRY FROM SOLID TO +C GAP OR FROM GAP TO SOLID (140-160) +C 5.) CONTINUE TYPE 1 ENTRY (150-160) +C + DO 160 J=1,NC +C +C GET NEXT CHAR INTO ICR, RIGHT JUSTIFIED ZERO FILLED. +C + ICR = IPAT(J:J) +C +C MODE SPECIFIES WHAT THE LAST CHARACTER PROCESSED WAS: +C +C LAST ICR WAS $ (SOLID), MODE IS 8 +C LAST ICR WAS ' (GAP), MODE IS 2 +C LAST ICR WAS HOLLERITH CHAR, MODE IS 5 +C +C NMODE SPECIFIES WHAT THE CURRENT CHARACTER TO BE PROCESSED IS: +C +C ICR NMODE +C --- ----- +C $ 1 +C CHAR 0 +C ' -1 +C + NMODE = 0 + IF (ICR .EQ. IBLK) GO TO 160 + IF (ICR .EQ. IGAP) NMODE = -1 + IF (ICR .EQ. ISOL) NMODE = 1 + IF (L.EQ.0 .AND. NMODE.EQ.-1) MODE = 8 +C +C NGO DETERMINES WHERE TO BRANCH BASED ON CASE TO BE PROCESSED. +C COMPUTE MODE FOR NEXT ITERATION. +C + NGO = NMODE+MODE + MODE = NMODE*3+5 + GO TO (150,80,140,90,60,90,140,80,150),NGO +C +C CHAR TO CHAR +C +C CASE 1) - CONTINUE TYPE 2 ENTRY. +C + 60 IF (NCHRTS .EQ. MNCSTR) GO TO 160 + NCHRTS = NCHRTS + 1 + IP(L) = NCHRTS + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C BLANK OR SOLID TO CHAR +C +C CASE 2) - START STRING ENTRY. LGBSTR POINTS TO THE GAP WHICH +C WILL CONTAIN THE STRING. +C + 80 LGBSTR = MIN0(L+1,NPD) + L = MIN0(LGBSTR+1,NPD) + IPFLAG(L) = 0 + NCHRTS = 1 + IP(L) = 1 + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C CHAR TO SOLID OR GAP +C +C CASE 3) - END STRING ENTRY. ICR IS A $ OR '. +C + 90 CONTINUE + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS) + .5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C BLANK TO SOLID OR SOLID TO BLANK +C +C CASE 4) - START TYPE 1 ENTRY. +C + 140 L = MIN0(L+1,NPD) + IP(L) = 0 +C +C ADD TO A BLANK OR SOLID LINE +C +C CASE 5) - CONTINUE TYPE 1 ENTRY. ICR IS A $ OR '. +C ADD ICRT UNITS TO THE PLOTTER ADDRESS UNITS IN IP(L). +C NMODE INDICATES IF IT IS A GAP OR A SOLID. +C + 150 IP(L) = IP(L) + ICRT + IPFLAG(L) = NMODE + 160 CONTINUE +C +C IF LAST ICR PROCESSED WAS A LABEL CHARACTER, MUST END STRING +C ENTRY. +C + IF (NGO.NE.2 .AND. NGO.NE.5 .AND. NGO.NE.8) GO TO 220 + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS)+.5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C IF IP ARRAY HAS ONLY ONE TYPE 1 ENTRY, SET ISL FLAG. +C + 220 IF (L .GT. 1) RETURN + IBIG = ISHIFT(1,MAX0(LXSAVE,LYSAVE)) + IF (IP(L) .GE. IBIG) GO TO 230 + IF (IPFLAG(L)) 240,240,230 + 230 ISL = 1 + RETURN + 240 ISL = -1 + RETURN + END + SUBROUTINE DASHDB (IPAT) +C +C ARGUMENTS IPAT +C ON INPUT IPAT IS A 16-BIT DASH PATTERN. BY DEFAULT +C EACH BIT IN THE PATTERN REPRESENTS 3 PLOTTER +C ADDRESS UNITS (1=SOLID, 0=BLANK) +C +C +C +C USER ENTRY POINT. +C DASHDB GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENT. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + DIMENSION IPAT(1) + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C DASHD1 IS FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB. IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB HAS BEEN CALLED. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. IT IS +C INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB ARE SAVED IN DSAVE2 FOR THE NEXT CALL TO +C DASHDB. +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C + SAVE +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDB', 'VERSION 1') + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDB -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN +C + MASK=IOR(ISHIFT(32767,1),1) +C + IFCFLG = 2 +C +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C + ICRT = IPAU*ISHIFT(1,15-10) + IF (IPAT(1) .NE. 0) GO TO 260 + ISL = -1 + RETURN + 260 IF (IPAT(1) .NE. MASK) GO TO 270 + ISL = 1 + RETURN + 270 NMODE1 = IAND(ISHIFT(IPAT(1),-15),1) + DO 290 I = 1,16 + IF (NMODE1 .NE. IAND(ISHIFT(IPAT(1),I-16),1)) GO TO 280 + NMODE1 = 1 - NMODE1 + L = L + 1 + IP(L) = 0 + IPFLAG(L) = 1 - 2*NMODE1 + 280 IP(L) = IP(L) + ICRT + 290 CONTINUE + RETURN + END + SUBROUTINE DRAWPV (IX,IY,IND) +C +C DRAWPV INTERCEPTS THE CALL TO PLOTIT TO CHECK IF THE PEN HAS TO BE +C MOVED OR IF IT IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C IF IND=2 NEVER MOVE PEN, JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C +C IN IXSTOR AND IYSTOR THE CURRENT POSITION OF THE PEN IS SAVED. +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE + IIND = IND + 1 + GOTO (100,90,105), IIND +C + 90 CONTINUE +C +C DRAW LINE AND SAVE POSITION OF PEN. +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,1) + GOTO 110 +C + 100 CONTINUE +C +C CHECK IF PEN IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C + DIFF = FLOAT(IABS(IXSTOR-IX)+IABS(IYSTOR-IY)) + IF (DIFF .LE. FLOAT(ICLOSE)) GO TO 110 +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,0) + GOTO 110 +C + 105 CONTINUE +C +C DO NOT MOVE PEN. JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C + IXSTOR = IX + IYSTOR = IY +C + 110 CONTINUE +C + RETURN + END +C + SUBROUTINE CFVLD (IENTRY,IIX,IIY) +C +C CFVLD CONNECTS POINTS WHOSE COORDINATES ARE SUPPLIED IN THE ARGUMENTS, +C ACCORDING TO THE DASH PATTERN WHICH IS PASSED FROM ROUTINE DASHDB +C OR DASHDC IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*16 IPC(100) +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C THE VARIABLES IN DASHD1 AND DASHD2 ARE USED FOR COMMUNICATION WITH +C DASHDC AND DASHDB. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C THE VARIABLES IN DSAVE1 HAVE TO BE SAVED FOR THE NEXT CALL TO CFVLD. +C + COMMON /DSAVE1/ X,Y,X2,Y2,X3,Y3,M,BTI,IB,IX,IY +C +C THE FLAGS IFSTFL AND IVCTFG ARE INITIALIZED IN THE BLOCK DATA DASHBD. +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED. +C IVCTFG IS A FLAG TO INDICATE IF CFVLD IS BEING CALLED FROM VECTD OR +C LASTD. +C + COMMON /DCFLAG/ IFSTFL + COMMON /CFFLAG/ IVCTFG + SAVE +C +C +C CMN IS USED TO DETERMINE WHEN TO STOP DRAWING A LINE SEGMENT +C + DATA CMN/1.5/ +C +C IMPOS IS USED AS AN IMPOSSIBLE PEN POSITION. +C + DATA IMPOS /-9999/ +C +C +C ISL= -1 ALL BLANK ) FLAG TO AVOID MOST CALCULATIONS +C 0 DASHED ) IF PATTERN IS ALL SOLID OR +C 1 ALL SOLID ) ALL BLANK +C +C X,IX,Y,IY CURRENT POSITION +C X1,Y1 START OF A USER LINE SEGMENT +C X2,Y2 END OF A USER LINE SEGMENT +C X3,Y3 START OF A GAP PATTERN SEGMENT +C +C SYMBOLS,IF PRESENT ARE CENTERED IN AN IMMEDIATLY PRECEEDING +C GAP SEGMENT, OR DONE AT THE CURRENT POSITION OTHERWISE +C +C SEGMENT TYPES ARE RECOGNIZED AS FOLLOWS +C SOLID - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS 1. +C GAP - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS -1. +C SYMBOL - WORD IN IP-ARRAY CONTAINS CHARACTER REPRESENTATIONS. +C CORRESPONDING ELEMENT IN IPFLAG IS 0. +C SYMBOL COUNT FOR CHAR STRING IN CHAR NUMBER MNCSTR+1. +C THE IP ARRAY AND THE IPFLAG ARRAY ARE COMPOSED OF L ELEMENTS. +C +C BTI - BITS THIS INCREMENT +C BPBX,BPBY BITS PER BIT X(Y) +C +C +C BRANCH DEPENDING ON FUNCTION TO BE PERFORMED. +C + GO TO (330,305,350),IENTRY +C +C INITIALIZE VARIABLES (ENTRY FRSTD ONLY) +C + 30 CONTINUE + X = IX + Y = IY + X2 = X + X3 = X + Y2 = Y + Y3 = Y + M = 1 + IB = IPFLAG(1) + IF (IPFLAG(1) .NE. 0) GO TO 40 + IB = 0 + BTI = 0 + 40 CONTINUE + BTI = FLOAT(IP(1))*FPART + GO TO 300 +C +C MAIN LOOP START +C + 50 CONTINUE + X1 = X2 + Y1 = Y2 + MX = IIX + MY = IIY + X2 = MX + Y2 = MY + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .LT. CMN) GO TO 190 + 60 BPBX = DX/D + BPBY = DY/D + CALL DRAWPV (IX,IY,0) + 70 BTI = BTI-D + IF (BTI) 100,100,80 +C +C LINE SEGMENT WILL FIT IN CURRENT PATTERN ELEMENT +C + 80 X = X2 + Y = Y2 + IX = X2 + IY = Y2 + IF (IB) 200,160,90 + 90 CALL DRAWPV (IX,IY,1) + GO TO 200 +C +C LINE SEGMENT WONT FIT IN CURRENT PATTERN ELEMENT +C DO IT TO END OF ELEMENT, SAVE HOW MUCH OF SEGMENT LEFT TO DO (D) +C + 100 BTI = BTI+D + D = D-BTI + X = X+BPBX*BTI + Y = Y+BPBY*BTI + IX = X+.5 + IY = Y+.5 + IF (IB) 110,160,120 + 110 CALL DRAWPV (IX,IY,0) + GO TO 130 + 120 CALL DRAWPV (IX,IY,1) +C +C GET THE NEXT PATTERN ELEMENT +C + 130 M = MOD(M,L)+1 + IB = IPFLAG(M) + IF (IB) 140,160,150 + 140 X3 = X + Y3 = Y + BTI = FLOAT(IP(M)) + GO TO 70 + 150 X3 = -1. + BTI = FLOAT(IP(M)) + GO TO 70 +C +C CHARACTER GENERATION +C + 160 S = 0. + IF (IGP .NE. 9) GO TO 162 +C + DX = X-X3 + DY = Y-Y3 + GO TO 164 +C + 162 CONTINUE + DX = X - X1 + DY = Y - Y1 + 164 CONTINUE +C + IF (DY) 170,180,170 + 170 S = ATAN2(DY,DX) + IF (ABS(S-.00005) .GT. 1.5708) S = S-SIGN(3.14159,S) + 180 IF (IGP .NE. 9) GO TO 182 +C + MX = X3 + DX*.5 + MY = Y3 + DY*.5 + LIGP = 0 + GO TO 184 +C + 182 CONTINUE + MX = X + MY = Y + LIGP = 1 +C + 184 CONTINUE + IS = IFIX(S*180./3.14 + .5) + IF (IS .LT. 0) IS = 360+IS + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) + MX = ISHIFT (MX,LXSAVE-15) + MY = ISHIFT(MY,LYSAVE-15) + CALL WTSTR(CPUX(MX),CPUY(MY),IPC(M)(1:IP(M)),ISIZE,IS,LIGP) + CALL DRAWPV (IMPOS,IMPOS,2) + CALL DRAWPV (IX,IY,0) + GO TO 130 + 190 X2 = X1 + Y2 = Y1 + 200 CONTINUE +C +C EXIT IF CALL WAS TO VECTD. +C + IF (IVCTFG .NE. 2) GO TO 210 + IVCTFG = 1 + GO TO 300 +C +C EXIT IF NOT PLOTTING A GAP +C + 210 IF (IB .GE. 0) GO TO 300 +C +C MUST BE IN A GAP AT END OF LASTD. EXIT IF NOT A LABEL GAP. +C + MO = M + M = MOD(M,L) + 1 + IF (IPFLAG(M) .NE. 0) GO TO 300 +C +C CHECK PREVIOUS PLOTTED ELEMENT. WAS IT A GAP OR A LINE. +C + MPREV = M - 2 + IF (MPREV .LE. 0) MPREV = MPREV + L + IB = IPFLAG(MPREV) + IF (IB .GE. 0) GO TO 250 +C +C PREVIOUS ELEMENT WAS A GAP - LOOK FOR NEXT LINE. +C EXIT IF NO LINES IN PATTERN. +C + 230 CONTINUE + 240 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 300 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 245 + BTI = FLOAT(IP(M)) + 245 CONTINUE +C +C IF IP(M) NOT A LINE, CONTINUE LOOKING. +C + IF (IB) 240,230,280 +C +C PREVIOUS ELEMENT WAS A LINE - LOOK FOR NEXT GAP. +C IF NO NON-LABEL GAPS IN PATTERN, GO TO 290. +C + 250 CONTINUE + 260 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 290 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 265 + BTI = FLOAT(IP(M)) + 265 CONTINUE +C +C IF IP(M) NOT A GAP, CONTINUE LOOKING. +C + IF (IB) 270,250,260 +C +C FOUND A GAP. IF ITS A LABEL GAP, GO LOOK FOR NEXT GAP. +C + 270 MT = M + M = MOD(M,L)+1 + IF (IPFLAG(M) .EQ. 0) GO TO 250 + M = MT +C +C M POINTS TO NEXT ELEMENT TO PLOT. SET UP AND GO PLOT. +C + 280 X1 = X3 + Y1 = Y3 + X = X3 + Y = Y3 + IX = X+0.5 + IY = Y+0.5 + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .GE. CMN) GO TO 60 + GO TO 300 +C +C NO NON-LABEL GAPS IN THE PATTERN - FILL IN WITH SOLID LINE. +C + 290 IX = X3+0.5 + IY = Y3+0.5 + CALL DRAWPV (IX,IY,0) + IX = X2 + IY = Y2 + CALL DRAWPV (IX,IY,1) + 300 RETURN +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 305 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD. +C + IF (IFSTFL .EQ. 2) GO TO 310 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER ('CFVLD -- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 330 + 310 K = 1 + IVCTFG = 2 + IF (ISL) 300,50,320 + 320 IX = IIX + IY = IIY + CALL DRAWPV (IX,IY,1) + GO TO 300 +C +C ************************************* +C +C ENTRY FRSTD (FLDX,FLDY) +C + 330 IX = IIX + IY = IIY + IFSTFL = 2 +C AVOID UNEXPECTED PEN POSITION IF CALLS TO SYSTEM PLOT PACKAGE +C ROUTINES WERE MADE. + CALL DRAWPV (IMPOS,IMPOS,2) + IF (ISL) 300,30,340 + 340 CALL DRAWPV (IX,IY,0) + GO TO 300 +C +C ************************************* +C +C ENTRY LASTD +C + 350 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD +C + IF (IFSTFL .NE. 2) GO TO 300 + IFSTFL = 1 + K = 1 + IF (ISL .NE. 0) GO TO 300 + GO TO 210 + END + SUBROUTINE FRSTD (X,Y) +C USER ENTRY PPINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (1,IIX,IIY) + RETURN + END + SUBROUTINE VECTD (X,Y) +C USER ENTRY POINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (2,IIX,IIY) + RETURN + END + SUBROUTINE LASTD +C USER ENTRY POINT. SEE DOCUMENTATION FOR PURPOSE. + DATA IDUMMY /0/ + CALL FDVDLD (3,IDUMMY,IDUMMY) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE CURVED (X,Y,N) +C USER ENTRY POINT. +C + DIMENSION X(N),Y(N) +C + CALL FRSTD (X(1),Y(1)) + DO 10 I=2,N + CALL VECTD (X(I),Y(I)) + 10 CONTINUE +C + CALL LASTD +C + RETURN + END + SUBROUTINE LINED (XA,YA,XB,YB) +C USER ENTRY POINT. +C + DATA IDUMMY /0/ + CALL FL2INT (XA,YA,IXA,IYA) + CALL FL2INT (XB,YB,IXB,IYB) +C + CALL CFVLD (1,IXA,IYA) + CALL CFVLD (2,IXB,IYB) + CALL CFVLD (3,IDUMMY,IDUMMY) +C + RETURN +C +C------REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN77 AND GKS +C +C DECEMBER 1979 ADDED REVISION HISTORY AND STATISTICS +C CALL +C +C----------------------------------------------------------------------- +C + END |