diff options
Diffstat (limited to 'sys/gio/ncarutil/conlib/concld.f')
| -rw-r--r-- | sys/gio/ncarutil/conlib/concld.f | 314 |
1 files changed, 314 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/conlib/concld.f b/sys/gio/ncarutil/conlib/concld.f new file mode 100644 index 00000000..6829d5fe --- /dev/null +++ b/sys/gio/ncarutil/conlib/concld.f @@ -0,0 +1,314 @@ + SUBROUTINE CONCLD (ICASE,IOOP) +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 + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + INTEGER GOOP +C + SAVE + DATA GOOP/0/ +C +C STATEMENT FUNCTIONS FOR CONTOUR PLACEMENT WITHIN CELLS +C + CX(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + CY(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + IC = ICASE + ICASE = 0 +C +C SPECIAL PROCESSING IF SHIELDING ACTIVATED +C + IF (.NOT.SHIELD) GO TO 1 +C +C CHECK IF ANY CELL CORNER CONTAINS A SPECIAL VALUE +C IF SO THEN FLAG AND RETURN +C + IF (TR.NE.SPVAL.AND.BR.NE.SPVAL.AND.TL.NE.SPVAL.AND.BL.NE.SPVAL) + 1 GO TO 1 +C +C SPECIAL VALUE IN CELL FLAG AND RETURN +C + ICASE = -1 + RETURN +C +C IF CURRENT BR VALUE LESS THAN CONTOUR THEN NEIGHBOR WILL BE WHERE +C CONTOUR IS DRAWN. +C + 1 CONTINUE +C + IF (BR.LT.CONV) GO TO 90 +C +C CURRENT LOCATION IS WHERE CONTOUR WILL BE DRAWN +C +C TEST FOR VERTICAL CONTOUR BREAK +C + IF (BL.GE.CONV) GO TO 60 +C +C VERTICAL CONTOUR BREAK +C +C CASE 1 LEFT NEIGHBOR LESS THAN CONTOUR LEVEL AND CURRENT +C LOCATION GE CONTOUR VALUE +C + IF (TR.GE.CONV) GO TO 40 +C +C CASE 1A CONTOUR LOWER RIGHT +C +C +C CONTOUR FROM UPPER RIGHT +C + XO = XC-CX(BR,TR) + YO = YC + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 4 + IF (IC.NE.3) GO TO 10 + ICASE = IOC + XN = XO + YN = YO + RETURN + 10 IF (IOOP.NE.GOOP) GO TO 20 + IF (IC.NE.2) GO TO 30 + 20 ICASE = NC + RETURN +C +C CASE 1B CONTOR UPPER LEFT +C + 30 XN = XC-STPSZ + YN = YC-STPSZ+CY(TL,TR) + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + IOC = 2 + NC = 3 + GO TO 180 +C +C CONTOURS FROM ABOVE AND UPPER LEFT +C + 40 IF (TL.LT.CONV) GO TO 50 +C +C CASE 1C CONTOUR LOWER LEFT +C + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 2 + GO TO 180 +C +C CASE 1D CONTOUR FROM ABOVE +C + 50 XO = XC-STPSZ + YO = YC-CY(TR,TL) + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C +C TEST FOR HORIZONTAL CONTOUR BREAK +C + 60 IF (TR.LT.CONV) GO TO 70 + IF (TL.GE.CONV) GO TO 200 +C +C CASE 2A CONTOUR UPPER LEFT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-CX(BL,TL) + YN = YC-STPSZ + NC = 2 + IOC = 3 + GO TO 180 +C + 70 IF (TL.LT.CONV) GO TO 80 +C +C CASE 2B CONTOUR FROM UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 2C CONTOUR FROM LEFT TO RIGHT +C + 80 XO = XC-CX(BL,TL) + YO = YC-STPSZ + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 2 + GO TO 180 +C +C +C CURRENT BR VALUE LESS THAN CONTOUR +C +C + 90 IF (BL.LT.CONV) GO TO 150 +C +C VERTICAL CONTOUR BREAK +C +C CASE 3 CURRENT SPACE LESS THAN CONTOUR LEVEL AND LEFT +C NEIGHBOR GE CONTOUR LEVEL +C + IF (TL.GE.CONV) GO TO 130 +C +C CASE 3A CONTOUR LOWER LEFT +C + XO = XC-CX(BL,TL) + YO = YC-STPSZ + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 2 + IF (IC.NE.3) GO TO 100 + ICASE = IOC + XN = XO + YN = YO + RETURN + 100 IF (IOOP.NE.GOOP) GO TO 110 + IF (IC.NE.4) GO TO 120 + 110 ICASE = NC + RETURN +C +C CASE 3B CONTOUR UPPERRIGHT +C + 120 XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C + 130 IF (TR.GE.CONV) GO TO 140 +C +C CASE 3C CONTOUR FROM ABOVE +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C CASE 3D CONTOUR LOWER RIGHT +C + 140 XO = XC-STPSZ+CX(TR,BR) + YO = YC + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 4 + GO TO 180 +C +C +C +C TEST FOR HORIZONTAL BREAK POINT +C + 150 IF (TR.GE.CONV) GO TO 160 +C + IF (TL.LT.CONV) GO TO 200 +C +C CASE 4A CONTOUR UPPER LEFT +C + XN = XC-STPSZ+CX(TL,BL) + YN = YC-STPSZ + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + NC = 2 + IOC = 3 + GO TO 180 +C + 160 IF (TL.GE.CONV) GO TO 170 +C +C CASE 4B CONTOUR UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 4C CONTOUR FROM LEFT TO RIGHT +C + 170 YO = YC-STPSZ + XO = XC-STPSZ+CX(TL,BL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 2 +C +C DRAW THE CONTOUR LINES NOT ALREADY TAKEN CARE OF +C + 180 IF (IABS(IC-NC).NE.2) GO TO 190 + ICASE = IOC + XN = XO + YN = YO + RETURN + 190 ICASE = NC + 200 RETURN + END |