diff options
Diffstat (limited to 'sys/gio/ncarutil/conlib/condrw.f')
| -rw-r--r-- | sys/gio/ncarutil/conlib/condrw.f | 253 |
1 files changed, 253 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/conlib/condrw.f b/sys/gio/ncarutil/conlib/condrw.f new file mode 100644 index 00000000..df47eae9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condrw.f @@ -0,0 +1,253 @@ + SUBROUTINE CONDRW (SCRARR) +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 DRAW ALL CONTOURS AT THIS LEVEL +C IF NOT EXTRAPOLATING +C SEARCH CONVEX HULL FOR CONTOURS INTERSECTING IT AND DRAW THEM +C SEARCH INTERIOR AND DRAW ALL REMAINING UNDRAWN CONTOURS +C +C IF EXTRAPOLATING +C SEARCH FROM X START TO X END AND Y START TO Y END FOR ALL +C CONTOURS AT THIS LEVEL +C +C INPUT +C SCRARR SCRATCH ARRAY USED FOR FAST CONTOURING +C VIA COMMON BLOCKS BELOW +C CONV-THE CURRENT CONTOUR LEVEL +C ITLOC-THE CONVEX HULL BOUNDRIES RELATIVE TO THE SCRATCH +C ARRAY, SCRARR +C PV-REAL Y COOORDINATES OF THE CONVEX HULL RELATIVE TO THE +C USERS COORDINATE SPACE +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C +C OUTPUT +C CONTOUR LINES OUTPUT TO PLOTTER FILE +C +C NOTE +C THIS ROUTINE WILL DETECT AND CORRECT FOR CONRAN ERROR 9 +C + DIMENSION SCRARR(1) +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C +C FLAGS TO ALLOW COMPRESSION OF CONTOUR STORAGE IF IT IS EXAUSTED +C + DATA ICOMP,NOCOMP/1,0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C CLEAR THE CONTOUR STORAGE LIST +C + NP = 0 +C +C SCAN X BOARDERS FOR INTERSECTIONS +C + JX = 2 + ICASE = 1 + X = XST+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 10 IF (.NOT.EXTRAP) GO TO 20 + JY = 2 + JYE = IYMAX + Y = YST+STPSZ + GO TO 30 +C +C NOT EXTRAPOLATING +C + 20 JY = ITLOC(JX*2-1) + IF (JY.EQ.0) GO TO 60 + JYE = ITLOC(JX*2)+1 + IF (JYE.GT.IYMAX) JYE = IYMAX + Y = PV(JX*2-1) + IF (JY.GE.2) GO TO 30 + JY = 2 + Y = YST+STPSZ + 30 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 40 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 50 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 50 TL = TR + BL = BR + JY = JY+1 + Y = Y+STPSZ + IF (JY.LE.JYE) GO TO 40 + 60 IF (JX.EQ.IXMAX) GO TO 70 + JX = IXMAX + ICASE = 3 + X = XMAX + GO TO 10 +C +C SCAN Y BOARDERS +C + 70 IPOS = 1 + ICASE = 4 + 80 JX = 3 + X = XST+STPSZ+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 90 IF (.NOT.EXTRAP) GO TO 100 + JY = 2 + Y = YST+STPSZ + IF (IPOS.NE.0) GO TO 110 + JY = IYMAX + Y = YED + GO TO 110 +C +C NOT EXTRAPOLATING +C + 100 JY = ITLOC(JX*2 - IPOS ) + IF (JY.EQ.0) GO TO 120 + JY = JY + IPOS + Y = PV(JX*2 - IPOS) + STPSZ*(1*IPOS) + 110 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 120 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 120 JX = JX+1 + X = X+STPSZ + IF (JX.LE.IXMAX-1) GO TO 90 + IF (IPOS.EQ.0) GO TO 130 + IPOS = 0 + ICASE = 2 + GO TO 80 +C +C BOARDER SEARCH DONE CONTOUR INTERIOR +C +C INITIALIZE THE SEARCH +C + 130 JX = 3 + ICASE = 0 + X = XST+STPSZ+STPSZ + JXE = IXMAX-1 +C +C IF EXTRAPOLATING GO FROM BORDER TO BORDER +C + 140 IF (.NOT.EXTRAP) GO TO 150 + JY = 3 + JYE = IYMAX-1 + Y = YST+STPSZ+STPSZ + GO TO 160 +C +C NOT EXTRAPOLATING STAY IN HULL +C + 150 JY = ITLOC(JX*2 - 1)+2 + IF (JY.EQ.2) GO TO 190 + JYE = ITLOC(JX*2)-1 + Y = PV(JX*2 - 1)+STPSZ+STPSZ +C + 160 IF (JY.GT.JYE) GO TO 190 + TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 170 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,ICOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 180 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 180 JY = JY+1 + Y = Y+STPSZ + TL = TR + BL = BR + IF (JY.LE.JYE) GO TO 170 +C +C PROCESS EACH ROW OF INTERIOR +C + 190 X = X+STPSZ + JX = JX+1 + IF (JX.LE.JXE) GO TO 140 +C + RETURN + END |