Functions and subroutines within this library:
colnam sqgrmkEnd of directory
C *********************************************************
C * *
C * SUBROUTINE 04.03.02/colnam *
C * *
C * PHIGS Validation Tests, produced by NIST *
C * *
C *********************************************************
SUBROUTINE COLNAM (U,V, INCODE, CDEX, CNAM)
C COLNAM returns the English phrase corresponding to the color
C indicated by the u-v CIELUV coordinates (luminance is ignored).
C COLNAM returns "none" for locations near borders or outside the
C color region.
C
C Input parameters:
C U,V : the u', v' CIELUV coordinates
C Output parameters:
C INCODE : status of u', v' point: 1-inside color region,
C 2-on edge of color region, 3-outside color region
C CDEX : integer identifier of region; 0 if none
C CNAM : English description of color, taken from CIELUV diagram
INTEGER NUMREG
PARAMETER (NUMREG=20)
INTEGER REGDX(NUMREG), INCODE, PRV, THIS, IX, INAREA, CDEX
REAL U,V, REGX(226),REGY(226)
CHARACTER CNAM*(*), REGLBL(NUMREG)*16
C label for 20 CIELUV color regions
DATA REGLBL / 'purple', 'purplish blue', 'blue', 'greenish blue',
1 'bluish green', 'green', 'yellowish green', 'yellow green',
1 'greenish yellow', 'yellow', 'orange yellow', 'orange',
1 'reddish orange', 'red', 'purplish red', 'reddish purple',
1 'yellowish pink', 'pink', 'purplish pink', 'white' /
C list of end-points of color regions
DATA REGDX / 15, 33, 47, 58, 69, 81, 94,101,107,113,117,123,
1 133,146,159,169,178,189,200,226 /
DATA (REGX(IX), IX=1,90) /
1 .25484,.23237,.21495,.20258,.19648,.19294,.19700,.20583,.22099,
2 .23745,.25769,.29662,.32923,.36687,.40575,.18325,.17465,.16730,
3 .16249,.16390,.17037,.17809,.18313,.19195,.18800,.18660,.18895,
4 .20126,.20990,.22359,.23853,.25103,.20456,.07929,.09838,.12126,
5 .14667,.15545,.17306,.16407,.15752,.15980,.16466,.17698,.14187,
6 .11304,.09178,.03059,.06726,.10519,.13300,.13418,.14292,.12893,
7 .10735,.08954,.07553,.05056,.00086,.06389,.10422,.14200,.13564,
8 .13303,.10774,.06856,.02810,.01691,.00574,.00872,.05280,.09182,
9 .13207,.15469,.14581,.11180,.06265,.02862,.00089,.00100,.00490,
O .13108,.15366,.17496,.16736,.15850,.13713,.10443,.05786,.01379 /
DATA (REGX(IX), IX=91,226) /
1 .02390,.03528,.05294,.08319,.20041,.19780,.19772,.18002,.16874,
2 .15370,.13739,.22436,.21546,.21036,.20278,.20285,.20419,.26973,
3 .25200,.23560,.21667,.22429,.23066,.30124,.27216,.25830,.27603,
4 .35796,.32258,.29858,.28600,.27719,.30754,.52182,.47515,.42344,
5 .38305,.36665,.35659,.34274,.33014,.35035,.36930,.59218,.54429,
6 .50143,.43964,.38415,.38294,.37419,.40827,.44612,.48648,.53188,
7 .57476,.63148,.48565,.44540,.40387,.36360,.33843,.35490,.37138,
8 .38028,.38413,.41314,.46484,.52157,.58837,.40828,.38070,.32299,
9 .28910,.30933,.33337,.36987,.41518,.45670,.48311,.35907,.32877,
O .28964,.26439,.26949,.29477,.31877,.33389,.35279,.37525,.33365,
1 .28574,.25673,.26184,.28078,.31108,.36409,.37541,.37914,.37908,
2 .28534,.26400,.23136,.24655,.25418,.28823,.33615,.37397,.35873,
3 .33720,.31189,.25519,.24000,.22607,.20334,.18441,.16554,.15048,
4 .14297,.13924,.13807,.14194,.15973,.17365,.20149,.22169,.23935,
5 .25449,.26709,.28219,.28974,.26446,.25936,.25297,.24026,.22631,
6 .24012 /
DATA (REGY(IX), IX=1,90) /
1 .01485,.06971,.12720,.18469,.23305,.29317,.35723,.35855,.36381,
2 .37822,.39395,.35219,.30911,.26212,.21122,.08662,.14150,.19247,
3 .24998,.28397,.32450,.35981,.35851,.35722,.31800,.28401,.24218,
4 .17162,.12719,.08146,.03574,.00962,.05659,.26028,.29953,.34271,
5 .38720,.37415,.36241,.32449,.26696,.21076,.16501,.09576,.14536,
6 .18845,.23024,.37653,.39751,.41980,.43424,.41594,.39373,.36756,
7 .33353,.29690,.26550,.32558,.50458,.49685,.48908,.47608,.46300,
8 .44208,.42765,.40666,.38306,.42225,.46537,.57518,.55827,.54004,
9 .51266,.49441,.48263,.49302,.50208,.50855,.51111,.53856,.56602,
O .57933,.54931,.51667,.50881,.49964,.51660,.53876,.56220,.57911 /
DATA (REGY(IX), IX=91,226) /
1 .58567,.59222,.59226,.58708,.56900,.54808,.52978,.51929,.53626,
2 .55846,.57934,.56512,.54811,.53503,.53240,.54940,.56901,.55737,
3 .54034,.54031,.53766,.54944,.56514,.55220,.53515,.53904,.55700,
4 .54315,.52871,.51951,.52602,.53124,.55090,.51862,.51853,.51713,
5 .51183,.50918,.51701,.52352,.52611,.53268,.54056,.45339,.46245,
6 .46760,.47141,.47392,.48568,.50397,.50926,.51194,.51202,.51080,
7 .51088,.50183,.31594,.34070,.36415,.38499,.39802,.41504,.43599,
8 .45300,.46738,.46744,.46492,.45980,.44816,.21253,.25300,.32609,
9 .36525,.37574,.39409,.37585,.35241,.32896,.31071,.50739,.50087,
O .49304,.48783,.49957,.51261,.52174,.51913,.51261,.45652,.46174,
1 .46435,.46435,.48000,.48522,.49304,.50217,.49304,.48130,.46696,
2 .37043,.39522,.43043,.44478,.45913,.45783,.45522,.45130,.42652,
3 .40435,.38478,.39913,.38609,.37304,.36522,.36391,.37435,.39261,
4 .40565,.42000,.44087,.46174,.49304,.50478,.52565,.52957,.53217,
5 .53217,.52826,.52174,.51652,.50478,.49043,.46957,.44739,.43043,
6 .41478 /
PRV = 0
DO 400 IX = 1,NUMREG
THIS = REGDX(IX)
INCODE = INAREA (U,V, THIS-PRV,REGX(PRV+1),REGY(PRV+1))
PRV = THIS
IF (INCODE .EQ. 1 .OR. INCODE .EQ. 2) THEN
CDEX = IX
CNAM = REGLBL(IX)
RETURN
ENDIF
400 CONTINUE
CDEX = 0
CNAM = 'none'
END
C *********************************************************
C * *
C * SUBROUTINE 04.03.02/sqgrmk *
C * *
C * PHIGS Validation Tests, produced by NIST *
C * *
C *********************************************************
SUBROUTINE SQGRMK (START, FINISH, STEP)
C SQGRMK draws a square grid of polymarkers. They are drawn one
C row at a time to avoid array overflow.
C Input parameters:
C START : First x and y locations
C FINISH : Upper limit for x and y locations
C STEP : Distance between markers
INTEGER SIZ, ARRSIZ
PARAMETER (ARRSIZ=200)
REAL XLOC,YLOC, START, FINISH, STEP, XA(ARRSIZ),YA(ARRSIZ)
IF ((FINISH-START)/STEP .GT. ARRSIZ) THEN
CALL UNMSG ('Number of polymarkers exceeds array size in ' //
1 'SQGRMK.')
ENDIF
DO 215 XLOC = START, FINISH, STEP
SIZ = 0
DO 210 YLOC = START, FINISH, STEP
SIZ = SIZ + 1
XA(SIZ) = XLOC
YA(SIZ) = YLOC
210 CONTINUE
CALL PPM (SIZ, XA, YA)
215 CONTINUE
END