/usr/share/ncarg/tests/tppack.f is in libncarg-data 6.3.0-6build1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 | PROGRAM TPPACK
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1, IWKID=1) ! NCGM
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8, IWKID=1) ! X Windows
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1) ! PDF
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1) ! PostScript
C
PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1, IWKID=1)
C
C Open GKS, open a workstation of type 1, activate the workstation.
C
CALL GOPKS (IERRF, ISZDM)
CALL GOPWK (IWKID, LUNIT, IWTYPE)
CALL GACWK (IWKID)
C
C Invoke the demo driver.
C
CALL PPACK(IERR)
C
C Deactivate and close the workstation and close GKS.
C
CALL GDAWK (IWKID)
CALL GCLWK (IWKID)
CALL GCLKS
C
C Done.
C
STOP
C
END
SUBROUTINE PPACK (IERR)
C
C PURPOSE To provide a simple demonstration of the use
C of a couple of the POLYPACK routines.
C
C USAGE CALL PPACK (IERR)
C
C ARGUMENTS
C
C ON OUTPUT IERR
C
C an error parameter
C = 0, if the test is successful.
C
C I/O If the test is successful, the message
C
C POLYPACK TEST EXECUTED--SEE PLOTS TO CERTIFY
C
C is written on unit 6.
C
C PRECISION Single.
C
C REQUIRED LIBRARY POLYPACK, SPPS
C FILES
C
C REQUIRED GKS LEVEL 0A
C
C LANGUAGE FORTRAN
C
C HISTORY Written in June, 1994.
C
C ALGORITHM TPPACK defines a simple clip polygon and a
C simple subject polygon, displays them both,
C and uses the POLYPACK routines PPINPO and
C PPINTR to fill the intersection.
C
C PORTABILITY FORTRAN 77
C
C Declare arrays in which to define the clip polygon and the subject
C polygon.
C
DIMENSION XCCP(5),YCCP(5),XCSP(11),YCSP(11)
C
C Declare the required work arrays.
C
PARAMETER (NWRK=999)
C
DIMENSION RWRK(NWRK),IWRK(NWRK)
C
C The EQUIVALENCE line is commented out below. If memory storage is an
C issue for you, *and* RWRK is not a DOUBLE PRECISION variable, then you
C can uncomment this line.
C
C EQUIVALENCE (RWRK(1),IWRK(1))
C
C Tell the compiler that the fill routines for polygons and trapezoids
C and the merge routine for polygons are EXTERNALs, not REALs.
C
EXTERNAL FILLPO,FILLTR,MERGPO
C
C Merge polygons are formed in the common block MERGCM:
C
COMMON /MERGCM/ XCMP(999),YCMP(999),NCMP
SAVE /MERGCM/
C
C Define the clip polygon to be a small square.
C
DATA NCCP / 5 /
C
DATA XCCP( 1),YCCP( 1) / -5. , -5. /
DATA XCCP( 2),YCCP( 2) / 5. , -5. /
DATA XCCP( 3),YCCP( 3) / 5. , 5. /
DATA XCCP( 4),YCCP( 4) / -5. , 5. /
DATA XCCP( 5),YCCP( 5) / -5. , -5. /
C
C Define the subject polygon to be a diamond with a hole in it.
C
DATA NCSP / 11 /
C
DATA XCSP( 1),YCSP( 1) / 0. , 9. /
DATA XCSP( 2),YCSP( 2) / 0. , 6. /
DATA XCSP( 3),YCSP( 3) / 6. , 0. /
DATA XCSP( 4),YCSP( 4) / 0. , -6. /
DATA XCSP( 5),YCSP( 5) / -6. , 0. /
DATA XCSP( 6),YCSP( 6) / 0. , 6. /
DATA XCSP( 7),YCSP( 7) / 0. , 9. /
DATA XCSP( 8),YCSP( 8) / -9. , 0. /
DATA XCSP( 9),YCSP( 9) / 0. , -9. /
DATA XCSP(10),YCSP(10) / 9. , 0. /
DATA XCSP(11),YCSP(11) / 0. , 9. /
C
C Initialize the error flag to zero.
C
IERR=0
C
C Enable solid fill instead of the default hollow fill.
C
CALL GSFAIS (1)
C
C Turn off clipping by GKS.
C
CALL GSCLIP (0)
C
C Put a label on the whole plot.
C
CALL SET (0.,1.,0.,1.,0.,1.,0.,1.,1)
CALL PLCHHQ (.5,.975,'DEMONSTRATING THE USE OF POLYPACK',
+ .015,0.,0.)
C
C In the upper left-hand corner, draw just the clip polygon and the
C subject polygon.
C
CALL SET (.05,.475,.525,.95,-10.,10.,-10.,10.,1)
CALL PLCHHQ (0.,-9.5,'The subject polygon (hollow diamond) and c
+lip polygon (square).',.008,0.,0.)
CALL GPL (NCCP,XCCP,YCCP)
CALL GPL (NCSP,XCSP,YCSP)
C
C In the upper right-hand corner, fill the difference polygon, using
C PPDIPO and FILLPO.
C
CALL SET (.525,.95,.525,.95,-10.,10.,-10.,10.,1)
CALL PLCHHQ (0.,-9.5,'The difference (subject polygon minus clip
+ polygon).',.008,0.,0.)
CALL GPL (NCCP,XCCP,YCCP)
CALL GPL (NCSP,XCSP,YCSP)
CALL PPDIPO (XCCP,YCCP,NCCP,XCSP,YCSP,NCSP,
+ RWRK,IWRK,NWRK,FILLPO,IERR)
IF (IERR.NE.0) THEN
WRITE (6,*) 'POLYPACK ROUTINE PPDIPO RETURNS IERR = ',IERR
RETURN
END IF
C
C In the lower left-hand corner, fill the intersection polygon, using
C PPINTR and FILLTR.
C
CALL SET (.05,.475,.05,.475,-10.,10.,-10.,10.,1)
CALL PLCHHQ (0.,-9.5,'The intersection of the subject and clip p
+olygons.',.008,0.,0.)
CALL GPL (NCCP,XCCP,YCCP)
CALL GPL (NCSP,XCSP,YCSP)
CALL PPINTR (XCCP,YCCP,NCCP,XCSP,YCSP,NCSP,
+ RWRK,IWRK,NWRK,FILLTR,IERR)
IF (IERR.NE.0) THEN
WRITE (6,*) 'POLYPACK ROUTINE PPINTR RETURNS IERR = ',IERR
RETURN
END IF
C
C In the lower right-hand corner, fill the union polygon, using PPUNPO
C and MERGPO.
C
CALL SET (.525,.95,.05,.475,-10.,10.,-10.,10.,1)
CALL PLCHHQ (0.,-9.5,'The union of the subject and clip polygons
+.',.008,0.,0.)
CALL GPL (NCCP,XCCP,YCCP)
CALL GPL (NCSP,XCSP,YCSP)
NCMP=0
CALL PPUNPO (XCCP,YCCP,NCCP,XCSP,YCSP,NCSP,
+ RWRK,IWRK,NWRK,MERGPO,IERR)
IF (IERR.NE.0) THEN
WRITE (6,*) 'POLYPACK ROUTINE PPUNPO RETURNS IERR = ',IERR
RETURN
END IF
IF (NCMP.EQ.0) THEN
WRITE (6,*) 'MERGE POLYGON IS NULL'
RETURN
ELSE IF (NCMP.EQ.1000) THEN
WRITE (6,*) 'MERGE POLYGON WAS TOO BIG TO HANDLE'
RETURN
ELSE
CALL GFA (NCMP-1,XCMP,YCMP)
END IF
C
C Advance the frame.
C
CALL FRAME
C
C Write the appropriate message.
C
WRITE (6,*) 'POLYPACK TEST EXECUTED--SEE PLOTS TO CERTIFY'
C
C Done.
C
RETURN
C
END
SUBROUTINE FILLPO (XCRA,YCRA,NCRA)
C
DIMENSION XCRA(NCRA),YCRA(NCRA)
C
C This routine processes polygons generated by the routines PPDIPO,
C PPINPO, and PPUNPO.
C
C Fill the polygon.
C
CALL GFA (NCRA-1,XCRA,YCRA)
C
C Done.
C
RETURN
C
END
SUBROUTINE FILLTR (XCBL,XCBR,YCOB,DXLE,DXRE,YCOT)
C
DIMENSION XCRA(5),YCRA(5)
C
C This routine fills trapezoids generated by the routines PPDITR,
C PPINTR, and PPUNTR.
C
C If the trapezoid is not degenerate, fill it and outline it.
C
IF (YCOT.GT.YCOB) THEN
XCRA(1)=XCBL
YCRA(1)=YCOB
XCRA(2)=XCBR
YCRA(2)=YCOB
XCRA(3)=XCBR+DXRE*(YCOT-YCOB)
YCRA(3)=YCOT
XCRA(4)=XCBL+DXLE*(YCOT-YCOB)
YCRA(4)=YCOT
XCRA(5)=XCBL
YCRA(5)=YCOB
CALL GFA (4,XCRA,YCRA)
CALL GPL (5,XCRA,YCRA)
END IF
C
C Done.
C
RETURN
C
END
SUBROUTINE MERGPO (XCRA,YCRA,NCRA)
C
DIMENSION XCRA(NCRA),YCRA(NCRA)
C
C This routine merges the polygons generated by one of the routines
C PPDIPO, PPINPO, and PPUNPO into a single polygon with holes.
C
C Merge polygons are formed in the common block MERGCM:
C
COMMON /MERGCM/ XCMP(999),YCMP(999),NCMP
SAVE /MERGCM/
C
C Copy the coordinates of the latest polygon into the merge polygon
C coordinate arrays and, if the polygon is not the first of the group,
C repeat the first point of the first polygon. (Actually, the code
C below does something a little more complicated: if necessary, it
C interpolates points to ensure that the connecting lines between
C polygons consist of horizontal and/or vertical steps; this tends
C to prevent problems caused by deficiencies in the fill algorithms
C on some devices.)
C
NTMP=NCMP
C
IF (NTMP+NCRA+4.LE.999) THEN
IF (NCMP.NE.0) THEN
IF (XCMP(NTMP).NE.XCRA(1).AND.YCMP(NTMP).NE.YCRA(1)) THEN
IF (YCMP(NTMP).LT.YCRA(1)) THEN
NTMP=NTMP+1
XCMP(NTMP)=XCRA(1)
YCMP(NTMP)=YCMP(NTMP-1)
ELSE
NTMP=NTMP+1
XCMP(NTMP)=XCMP(NTMP-1)
YCMP(NTMP)=YCRA(1)
END IF
END IF
NTMP=NTMP+1
XCMP(NTMP)=XCRA(1)
YCMP(NTMP)=YCRA(1)
END IF
DO 101 ICRA=1,NCRA
XCMP(NTMP+ICRA)=XCRA(ICRA)
YCMP(NTMP+ICRA)=YCRA(ICRA)
101 CONTINUE
NTMP=NTMP+NCRA
IF (NCMP.NE.0) THEN
IF (XCMP(NTMP).NE.XCMP(1).AND.YCMP(NTMP).NE.YCMP(1)) THEN
IF (YCMP(NTMP).LT.YCMP(1)) THEN
NTMP=NTMP+1
XCMP(NTMP)=XCMP(1)
YCMP(NTMP)=YCMP(NTMP-1)
ELSE
NTMP=NTMP+1
XCMP(NTMP)=XCMP(NTMP-1)
YCMP(NTMP)=YCMP(1)
END IF
END IF
NTMP=NTMP+1
XCMP(NTMP)=XCMP(1)
YCMP(NTMP)=YCMP(1)
END IF
ELSE
NTMP=1000
END IF
C
NCMP=NTMP
C
C Done.
C
RETURN
C
END
|