diff options
Diffstat (limited to 'sys/gio/ncarutil/conlib')
30 files changed, 5723 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/conlib/README b/sys/gio/ncarutil/conlib/README new file mode 100644 index 00000000..69f73877 --- /dev/null +++ b/sys/gio/ncarutil/conlib/README @@ -0,0 +1,3 @@ +CONLIB -- This directory contains the contents of the NCAR files concom.f and +conterp.f, unpacked one subroutine per file. The unpacking operation is +necessary to permit topological ordering of the library. diff --git a/sys/gio/ncarutil/conlib/concal.f b/sys/gio/ncarutil/conlib/concal.f new file mode 100644 index 00000000..e021fa30 --- /dev/null +++ b/sys/gio/ncarutil/conlib/concal.f @@ -0,0 +1,340 @@ + SUBROUTINE CONCAL (XD,YD,ZD,NT,IPT,NL,IPL,PDD,ITI,XII,YII,ZII, + 1 ITPV) +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 THIS SUBROUTINE PERFORMS PUNCTUAL INTERPOLATION OR EXTRAPO- +C LATION, I.E., DETERMINES THE Z VALUE AT A POINT. +C THE INPUT PARAMETERS ARE +C +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z +C COORDINATES OF DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE END POINTS OF THE BORDER LINE SEGMENTS AND +C THEIR RESPECTIVE TRIANGLE NUMBERS, +C PDD = ARRAY CONTAINING THE PARTIAL DERIVATIVES AT +C THE DATA POINTS, +C ITI = TRIANGLE NUMBER OF THE TRIANGLE IN WHICH LIES +C THE POINT FOR WHICH INTERPOLATION IS TO BE +C PERFORMED, +C XII,YII = X AND Y COORDINATES OF THE POINT FOR WHICH +C INTERPOLATION IS TO BE PERFORMED. +C THE OUTPUT PARAMETER IS +C +C ZII = INTERPOLATED Z VALUE. +C +C DECLARATION STATEMENTS +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,IPT(1) , + 1 IPL(1) ,PDD(1) + DIMENSION X(3) ,Y(3) ,Z(3) ,PD(15) , + 1 ZU(3) ,ZV(3) ,ZUU(3) ,ZUV(3) , + 2 ZVV(3) + REAL LU ,LV + EQUIVALENCE (P5,P50) +C + SAVE +C +C PRELIMINARY PROCESSING +C + IT0 = ITI + NTL = NT+NL + IF (IT0 .LE. NTL) GO TO 100 + IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IF (IL1 .EQ. IL2) GO TO 150 + GO TO 200 +C +C CALCULATION OF ZII BY INTERPOLATION. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 100 IF (IT0 .EQ. ITPV) GO TO 140 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE +C IPI 102 VERTEXES. +C IPI 103 +C + JIPT = 3*(IT0-1) + JPD = 0 + DO 120 I=1,3 + JIPT = JIPT+1 + IDP = IPT(JIPT) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 110 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 110 CONTINUE + 120 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = X(2)-X0 + B = X(3)-X0 + C = Y(2)-Y0 + D = Y(3)-Y0 + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -C/DLT + DP = A/DLT +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE VERTEXES OF THE +C TRIANGLE FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 130 I=1,3 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 130 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P10-P20 + H2 = ZU(2)-P10-ZUU(1) + H3 = ZUU(2)-ZUU(1) + P30 = 10.0*H1-4.0*H2+0.5*H3 + P40 = -15.0*H1+7.0*H2-H3 + P50 = 6.0*H1-3.0*H2+0.5*H3 + H1 = Z(3)-P00-P01-P02 + H2 = ZV(3)-P01-ZVV(1) + H3 = ZVV(3)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + LU = SQRT(AA+CC) + LV = SQRT(BB+DD) + THXU = ATAN2(C,A) + THUV = ATAN2(D,B)-THXU + CSUV = COS(THUV) + P41 = 5.0*LV*CSUV/LU*P50 + P14 = 5.0*LU*CSUV/LV*P05 + H1 = ZV(2)-P01-P11-P41 + H2 = ZUV(2)-P11-4.0*P41 + P21 = 3.0*H1-H2 + P31 = -2.0*H1+H2 + H1 = ZU(3)-P10-P11-P14 + H2 = ZUV(3)-P11-4.0*P14 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + THUS = ATAN2(D-C,B-A)-THXU + THSV = THUV-THUS + AA = SIN(THSV)/LU + BB = -COS(THSV)/LU + CC = SIN(THUS)/LV + DD = COS(THUS)/LV + AC = AA*CC + AD = AA*DD + BC = BB*CC + G1 = AA*AC*(3.0*BC+2.0*AD) + G2 = CC*AC*(3.0*AD+2.0*BC) + H1 = -AA*AA*AA*(5.0*AA*BB*P50+(4.0*BC+AD)*P41)- + 1 CC*CC*CC*(5.0*CC*DD*P05+(4.0*AD+BC)*P14) + H2 = 0.5*ZVV(2)-P02-P12 + H3 = 0.5*ZUU(3)-P20-P21 + P22 = (G1*H2+G2*H3-H1)/(G1+G2) + P32 = H2-P22 + P23 = H3-P22 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 140 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*(P13+V*P14))) + P2 = P20+V*(P21+V*(P22+V*P23)) + P3 = P30+V*(P31+V*P32) + P4 = P40+V*P41 + ZII = P0+U*(P1+U*(P2+U*(P3+U*(P4+U*P5)))) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE RECTANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 150 IF (IT0 .EQ. ITPV) GO TO 190 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE END +C POINTS OF THE BORDER LINE SEGMENT. +C + JIPL = 3*(IL1-1) + JPD = 0 + DO 170 I=1,2 + JIPL = JIPL+1 + IDP = IPL(JIPL) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 160 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 160 CONTINUE + 170 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = Y(2)-Y(1) + B = X(2)-X(1) + C = -B + D = A + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -BP + DP = AP +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE END POINTS OF THE +C BORDER LINE SEGMENT FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 180 I=1,2 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 180 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P01-P02 + H2 = ZV(2)-P01-ZVV(1) + H3 = ZVV(2)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + H1 = ZU(2)-P10-P11 + H2 = ZUV(2)-P11 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + P21 = 0.0 + P23 = -ZUU(2)+ZUU(1) + P22 = -1.5*P23 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 190 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*P13)) + P2 = P20+V*(P21+V*(P22+V*P23)) + ZII = P0+U*(P1+U*P2) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE TRIANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 200 IF (IT0 .EQ. ITPV) GO TO 220 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE VERTEX +C OF THE TRIANGLE. +C + JIPL = 3*IL2-2 + IDP = IPL(JIPL) + X(1) = XD(IDP) + Y(1) = YD(IDP) + Z(1) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 210 KPD=1,5 + JPDD = JPDD+1 + PD(KPD) = PDD(JPDD) + 210 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = PD(1) + P01 = PD(2) + P20 = 0.5*PD(3) + P11 = PD(4) + P02 = 0.5*PD(5) + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 220 U = XII-X(1) + V = YII-Y(1) +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*P02) + P1 = P10+V*P11 + ZII = P0+U*(P1+U*P20) + RETURN + END 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 diff --git a/sys/gio/ncarutil/conlib/concls.f b/sys/gio/ncarutil/conlib/concls.f new file mode 100644 index 00000000..02d97a4d --- /dev/null +++ b/sys/gio/ncarutil/conlib/concls.f @@ -0,0 +1,177 @@ + SUBROUTINE CONCLS (ZD,NDP) +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 GENERATE CONTOUR LEVELS BASED ON THE INPUT DATA +C + DIMENSION ZD(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 IF NOT USER SET COMPUTE CONTOUR LEVELS +C + IF (.NOT.CON) GO TO 150 +C +C OTHERWISE GET HI AND LOW CONTOURS FOR MESSAGE +C + HI = CL(1) + FLO = CL(1) + DO 110 I=1,NCL + IF (HI .GE. CL(I)) GO TO 100 + HI = CL(I) + GO TO 110 + 100 IF (FLO .LE. CL(I)) GO TO 110 + FLO = CL(I) + 110 CONTINUE +C +C GET INCREMENT IF EQUAL SPACED CONTOURS +C + IF (NCL .NE. 1) GO TO 120 + FINC = 0. + RETURN + 120 FINC = ABS(CL(1)-CL(2)) + IF (NCL .EQ. 2) RETURN + DO 130 I=3,NCL + IF (FINC .NE. ABS(CL(I-1)-CL(I))) GO TO 140 + 130 CONTINUE + RETURN + 140 FINC = -1. + RETURN +C +C FIND HIGHEST AND LOWEST INPUT VALUES +C + 150 IF (CHILO) GO TO 180 + FLO = ZD(1) + HI = ZD(1) + DO 170 I=2,NDP + IF (FLO .LE. ZD(I)) GO TO 160 + FLO = ZD(I) + GO TO 170 + 160 IF (HI .GE. ZD(I)) GO TO 170 + HI = ZD(I) + 170 CONTINUE +C +C CALCULATE THE CONTOUR LEVEL INTERVAL +C + 180 IF (CINC) GO TO 200 + FINC = (HI-FLO)/15. + IF (FINC .NE. 0.) GO TO 190 + CALL SETER (' CONCLS - CONSTANT INPUT FIELD',1,1) + RETURN +C +C ROUND FINC TO NICE NUMBER +C + 190 P = 10.**(IFIX(ALOG10(FINC)+500.)-500) + FINC = AINT(FINC/P+0.1)*P +C +C ROUND THE LOW VALUE TO START AT A NICE NUMBER +C + 200 IF (CHILO) GO TO 210 + FLO = AINT(FLO/FINC)*FINC +C +C COMPUTE THE CONTOUR LEVELS +C +C TEST IF BREAK POINT WITHIN RANGE OF HI TO FLO +C + 210 IF (BPSIZ.GE.FLO .AND. BPSIZ.LE.HI) GO TO 240 +C +C BREAK POINT OUT OF RANGE SO GENERATE CONTOURS BASED ON FLO +C + DO 220 I=1,30 + CV = FLO+FLOAT(I-1)*FINC + ICUR = I + CL(I) = CV + IF (CV .GE. HI) GO TO 230 + 220 CONTINUE + 230 NCL = ICUR + HI = CV + RETURN +C +C BREAK POINT WITHIN RANGE SO BASE CONTOURS ON IT +C + 240 DO 250 I=1,30 + CV = BPSIZ-FLOAT(I-1)*FINC + IND = (30-I)+1 + CL(IND) = CV + ICUR = I + IF (CV .LE. FLO) GO TO 260 + 250 CONTINUE +C +C PUT THE CONTOURS IN THE CORRECT ORDER +C + 260 DO 270 I=1,ICUR + IND = (30-ICUR)+I + CL(I) = CL(IND) + 270 CONTINUE +C +C ADD THE GREATER THAN BREAK POINT CONTOURS +C + IEND = 30-ICUR + ISAV = ICUR+1 + DO 280 I=1,IEND + CV = BPSIZ+FLOAT(I)*FINC + CL(ISAV) = CV + ISAV = ISAV+1 + IF (CV .GE. HI) GO TO 290 + 280 CONTINUE +C +C SET NUMBER OF CONTOUR LEVELS AND UPDATE THE HIGH VALUE +C + 290 NCL = ISAV-1 + HI = CV + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concom.f b/sys/gio/ncarutil/conlib/concom.f new file mode 100644 index 00000000..8a5041df --- /dev/null +++ b/sys/gio/ncarutil/conlib/concom.f @@ -0,0 +1,78 @@ + FUNCTION CONCOM (XQ,YQ,XD,YD,ZD,NDP,WK,IWK,LOC) +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 INTERPOLATE A GIVEN X,Y PAIR AND RETURN ITS LOCATION +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,WK(1) , + 1 IWK(1) +C + SAVE +C +C LOCATE PROPER TRIANGLE +C + CALL CONLOC (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),XQ,YQ,LOC, + 1 IWK(JWIWL),WK) +C +C INTERPOLATE THE LOCATION +C + CALL CONCAL (XD,YD,ZD,NT,IWK(JWIPT),NL,IWK(JWIPL),WK(IPR),LOC,XQ, + 1 YQ,TEMP,ITPV) + CONCOM = TEMP + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condet.f b/sys/gio/ncarutil/conlib/condet.f new file mode 100644 index 00000000..6b3a3077 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condet.f @@ -0,0 +1,128 @@ + SUBROUTINE CONDET (NDP,XD,YD,NCP,IPC) +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* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN , CONRAQ AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C THIS SUBROUTINE SELECTS SEVERAL DATA POINTS THAT ARE CLOSEST +C TO EACH OF THE DATA POINT. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS CONTAINING THE X AND Y COORDINATES +C OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS CLOSEST TO EACH DATA +C POINTS. +C THE OUTPUT PARAMETER IS +C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP, WHERE THE +C POINT NUMBERS OF NCP DATA POINTS CLOSEST TO +C EACH OF THE NDP DATA POINTS ARE TO BE STORED. +C THIS SUBROUTINE ARBITRARILY SETS A RESTRICTION THAT NCP MUST +C NOT EXCEED 25 WITHOUT MODIFICATION TO THE ARRAYS DSQ0 AND IPC0. +C DECLARATION STATEMENTS +C + COMMON /CONRA3/ IREC + DIMENSION XD(NDP) ,YD(NDP) ,IPC(1) + DIMENSION DSQ0(25) ,IPC0(25) +C + SAVE +C +C STATEMENT FUNCTION +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 +C +C CALCULATION +C + DO 220 IP1=1,NDP +C +C - SELECTS NCP POINTS. +C + X1 = XD(IP1) + Y1 = YD(IP1) + J1 = 0 + DSQMX = 0.0 + DO 110 IP2=1,NDP + IF (IP2 .EQ. IP1) GO TO 110 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + J1 = J1+1 + DSQ0(J1) = DSQI + IPC0(J1) = IP2 + IF (DSQI .LE. DSQMX) GO TO 100 + DSQMX = DSQI + JMX = J1 + 100 IF (J1 .GE. NCP) GO TO 120 + 110 CONTINUE + 120 IP2MN = IP2+1 + IF (IP2MN .GT. NDP) GO TO 150 + DO 140 IP2=IP2MN,NDP + IF (IP2 .EQ. IP1) GO TO 140 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .GE. DSQMX) GO TO 140 + DSQ0(JMX) = DSQI + IPC0(JMX) = IP2 + DSQMX = 0.0 + DO 130 J1=1,NCP + IF (DSQ0(J1) .LE. DSQMX) GO TO 130 + DSQMX = DSQ0(J1) + JMX = J1 + 130 CONTINUE + 140 CONTINUE +C +C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR. +C + 150 IP2 = IPC0(1) + DX12 = XD(IP2)-X1 + DY12 = YD(IP2)-Y1 + DO 160 J3=2,NCP + IP3 = IPC0(J3) + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .NE. 0.0) GO TO 200 + 160 CONTINUE +C +C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT. +C + NCLPT = 0 + DO 190 IP3=1,NDP + IF (IP3 .EQ. IP1) GO TO 190 + DO 170 J4=1,NCP + IF (IP3 .EQ. IPC0(J4)) GO TO 190 + 170 CONTINUE + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .EQ. 0.0) GO TO 190 + DSQI = DSQF(X1,Y1,XD(IP3),YD(IP3)) + IF (NCLPT .EQ. 0) GO TO 180 + IF (DSQI .GE. DSQMN) GO TO 190 + 180 NCLPT = 1 + DSQMN = DSQI + IP3MN = IP3 + 190 CONTINUE + DSQMX = DSQMN + IPC0(JMX) = IP3MN +C +C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY. +C + 200 J1 = (IP1-1)*NCP + DO 210 J2=1,NCP + J1 = J1+1 + IPC(J1) = IPC0(J2) + 210 CONTINUE + 220 CONTINUE + RETURN + END 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 diff --git a/sys/gio/ncarutil/conlib/condsd.f b/sys/gio/ncarutil/conlib/condsd.f new file mode 100644 index 00000000..0ea5fb43 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condsd.f @@ -0,0 +1,54 @@ + SUBROUTINE CONDSD +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 THE OUTLINE OF THE SHIELD ON THE PLOT +C + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C GET THE START POINT +C + XS = XVS(1) + YS = YVS(1) +C +C MOVE TO THE START OF THE OUTLINE +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,0) +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 2,ICOUNT +C +C DRAW THE OUTLINE OF THE SHIELD +C + CALL FL2INT(XVS(IC),YVS(IC),IX,IY) + CALL PLOTIT(IX,IY,1) +C + 100 CONTINUE +C +C DRAW TO THE START +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conecd.f b/sys/gio/ncarutil/conlib/conecd.f new file mode 100644 index 00000000..56d8a934 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conecd.f @@ -0,0 +1,178 @@ + SUBROUTINE CONECD (VAL,IOUT,NUSED) +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 ENCODE A NUMBER IN THE LEAST AMOUNT OF SPACE +C ON INPUT +C VAL THE NUMBER TO BE ENCODED +C ON OUTPUT +C IOUT CHARACTER STRING FILLED WITH THE ENCODED RESULT, MUST BE ABLE TO +C HOLD UP TO 9 CHARACTERS. +C +C NUSED NUMBER OF CHARACTERS IN IOUT +C +C VALUE INPUT WILL BE SCALED BY SCALE IN CONRA2 +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + CHARACTER*(*) IOUT + CHARACTER*6 IFMT1 +C +C +NOAO - Variables CHTMP and IT are not used. +C +C CHARACTER*9 CHTMP +C CHARACTER*1 IT +C +C -NOAO +C + SAVE +C + V = VAL +C +C IF VAL EQUALS ZERO EASY PROCESSING +C + IF (V.NE.0.) GO TO 20 + IOUT = '0.0' + NUSED = 3 + RETURN +C +C SCALE VALUE +C + 20 V = V*SCALE +C +C GET SIZE OF NUMBER +C + LOG = IFIX(ALOG10(ABS(V))+.1) + IF (IABS(LOG).GT.4) GO TO 60 +C +C COMPUTE FLOATING POINT FIELD +C + NS = IABS(LOG)+3 + ND = 1 + IF (LOG.GT.0) GO TO 40 +C +C LOG = 0 TEST FOR FRACTIONAL PART ONLY +C + IF (ALOG10( ABS(V) ).GE.0.) GO TO 30 +C +C NUMBER LT 1 BUT GREATER THAN ZERO IN ABSOLUTE VALUE +C + NS = 4 + ND = 1 + GO TO 40 +C +C NUMBER LESS THAN 10 BUT GE 1 +C + 30 ND = 1 + NS = 4 +C +C BUILD THE FORMAT +C + 40 IF (V.LT.0) NS = NS+1 + IFMT1 = '(F . )' +C +C INSERT THE FLOATING POINT FORMAT SIZE +C +C +NOAO - Scheme for creating format has been modified because it uses +C FTN internal writes. NOAO mods are written in lower case. +C +C WRITE(IT,'(I1)')NS +C IFMT1(3:3) = IT +C WRITE(IT,'(I1)')ND +C IFMT1(5:5) = IT +C + ifmt1(1:6) = '(f . )' + ifmt1(3:3) = char (ns + ichar ('0') + 1) + ifmt1(5:5) = char (nd + ichar ('0')) +C +C ENCODE THE DESIRED NUMBER +C +C WRITE(CHTMP,IFMT1)V +C IOUT = CHTMP +C + call encode (ns, ifmt1, iout, v) + + NUSED = NS + RETURN +C +C DATA LARGER THAN A NICE SIZE FORCE IT TO BE ENCODED +C +C 60 WRITE(CHTMP,'(E8.3)')V +C IOUT = CHTMP +C + 60 call encode (8, '(E8.3)', iout, v) +C +C -NOAO + NUSED = 8 + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONCOM TO ULIB * +C* AUGUST 1980 FIXED BOARDER CONTOUR DETECTION * +C* DECEMBER 1980 FIXED ERROR TRAP, CONTOUR REORDERING ALGORITHM * +C* AND ERROR MESSAGE 10 * +C* AUGUST 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED (MACHINE DEPENDENT) FUNCTION LOC; CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/congen.f b/sys/gio/ncarutil/conlib/congen.f new file mode 100644 index 00000000..c70cfe05 --- /dev/null +++ b/sys/gio/ncarutil/conlib/congen.f @@ -0,0 +1,454 @@ + SUBROUTINE CONGEN (XI,YI,IPACK,SCRARR,ICA) +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 A CONTOUR AT THE CURRENT LEVEL +C +C INPUT +C XI YI LOWER RIGHT CORNER OF CELL +C IPACK-FLAG TO ALLOW REDUCTION OF COORDINATE PAIR STORAGE +C IF REQUIRED +C SCRARR-SCRATCH ARRAY OF CONTOUR VALUES +C ICA-ENTERING CASE CONDITIONS IF ANY REQUIRED +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(1) ,IXMOV(2) ,IYMOV(2) + CHARACTER*64 IHOLD + CHARACTER*23 IVOUT + INTEGER GOOP +C + SAVE + DATA NOOP,GOOP/1,0/ +C +C STATEMENT FUNCTIONS FOR MAPPING GRAPHICS OUTPUT +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C DRAW AN ENTIRE CONTOUR LINE WHEN A POTENTIAL START POINT IS +C PROVIDED +C +C SAVE STARTING CELL +C + XCS = XI + YCS = YI +C +C TEST IF VALID START POINT +C + ICASE = ICA + XC = XI + YC = YI + CALL CONCLD (ICASE,NOOP) +C +C IF NO CONTOUR RETURN +C + IF (ICASE.EQ.-1) RETURN + IF (ICASE.EQ.0) RETURN +C +C IF CONTOUR ALREADY DRAWN RETURN +C + ILOC = IOR(ISHIFT(JX,ISHFCT),JY) + IF (NP.EQ.0) GO TO 20 +C +C TEST IF CONTOUR FOUND +C + DO 10 I=1,NP + IF (ILOC.NE.ICOORD(I)) GO TO 10 + RETURN + 10 CONTINUE +C +C GET CORRECT OLD CASE +C + 20 IC = IOC + IF (ICASE.EQ.IOC) IC = NC +C +C SET UP STRUCTURE TO START IN OTHER DIRECTION FROM HERE IF CONTOUR +C UNEXPECTLY ENDS IN THIS DIRECTION +C + IFCASE = IC + IFOCSE = ICASE + FXO = XO + FYO = YO + LOOP = 1 +C +C SET UP IC TO SIMULATE EXIT FROM A PREVIOUS CELL +C + IC = MOD(IC+2,4) +C +C IF EXTRAPOLATING PASS ON +C + IF (EXTRAP) GO TO 60 +C +C TEST IF CONTOUR EXCEEDED BORDER LIMITS +C NOTE THAT ICASER CANNOT EQUAL 3 AT THIS POINT +C + GO TO ( 30, 40, 30, 50),ICASE +C +C EXIT FROM BOTTOM +C + 30 IF (JX.GE.IXMAX) RETURN + GO TO 60 +C +C EXIT FROM LEFT +C + 40 IF (JY.LE.ITLOC(JX*2 - 1)) RETURN + GO TO 60 +C +C EXIT FROM RIGHT +C + 50 IF (JY.GE.ITLOC(JX*2 - 1)) RETURN +C +C SAVE CELL INFO IF COMMING BACK +C + 60 TRT = TR + BRT = BR + TLT = TL + BLT = BL + IX = JX + IY = JY +C +C VALID CONTOUR START FOUND +C + XX = FX(XO,YO) + CALL FRSTD (XX,FY(XO,YO)) +C +C DRAW CONTOUR IN THIS CELL +C + 70 XX = FX(XN,YN) + CALL VECTD (XX,FY(XN,YN)) + XCSTOR = XC + YCSTOR = YC + IXSTOR = IX + IYSTOR = IY + IOLDC = IC + IC = ICASE +C +C ENTER COORDINATE PAIR OF CONTOUR IN LIST +C + NP = NP+1 + IF (NP.GT.MXXY) GO TO 180 + ICOORD(NP) = ILOC +C +C BRANCH TO APPROPIATE CODE DEPENDING ON CONTOUR EXIT FROM THE CELL +C + 80 GO TO ( 90, 110, 130, 150),IC +C +C EXIT FORM BOTTOM +C END CONTOUR IF ON CONVEX HULL +C + 90 IF (EXTRAP) GO TO 100 + IF (IY.LT.ITLOC(IX*2 - 1) .OR. IY-1.GT.ITLOC(IX*2)) GO TO 360 + 100 TR = BR + TL = BL + XC = XC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IX = IX+1 + IF (IX.GT.IXMAX) GO TO 360 + BR = SCRTCH(IX,IY) + BL = SCRTCH(IX,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM LEFT SIDE +C TEST IF IN CONVEX HULL +C + 110 IF (EXTRAP) GO TO 120 + IF (IY-1.LT.ITLOC( (IX-1)*2 - 1 ) .AND. IY-1.LT.ITLOC(IX*2 - 1)) + 1 GO TO 360 + 120 TR = TL + BR = BL + YC = YC-STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY-1 + IF (IY.LT.2) GO TO 360 + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM TOP +C END CONTOUR IF OUT OF CONVEX HULL +C + 130 IF (EXTRAP) GO TO 140 + IF (IY.LT.ITLOC( (IX-1)*2 - 1 ) .OR. IY-1.GT.ITLOC( (IX-1)*2 )) + 1 GO TO 360 + 140 BR = TR + BL = TL + XC = XC-STPSZ +C +C END CONTOUR IF OUTSIDE OF BORDER +C + IX = IX-1 + IF (IX.LT.2) GO TO 360 + TR = SCRTCH(IX-1,IY) + TL = SCRTCH(IX-1,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM RIGHT SIDE +C TEST IF ON CONVEX HULL +C + 150 IF (EXTRAP) GO TO 160 + IF (IY.GT.ITLOC( (IX-1)*2 ) .AND. IY.GT.ITLOC(IX*2)) GO TO 360 + 160 TL = TR + BL = BR + YC = YC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY+1 + IF (IY.GT.IYMAX) GO TO 360 + TR = SCRTCH(IX-1,IY) + BR = SCRTCH(IX,IY) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C END THE CONTOUR +C + 170 CALL LASTD + TR = TRT + BR = BRT + TL = TLT + BL = BLT + RETURN +C +C CONTOUR STORAGE EXCEEDED TRY PACKING +C + 180 IF (IPACK.EQ.0) GO TO 200 + NP = 0 + ITEST = IOR(ISHIFT(JX,ISHFCT),JY) + DO 190 K=1,MXXY + IF (ICOORD(K).LE.ITEST) GO TO 190 + NP = NP+1 + ICOORD(NP) = ICOORD(K) + 190 CONTINUE + IF (NP.LT.MXXY) GO TO 80 +C +C FAILURE NO MORE SPACE ABORT THIS CONTOUR LEVEL +C + 200 IHOLD(1:39) = ' CONDRW-CONTOUR STORAGE EXAUSTED LEVEL=' +C +C BLANK FILL THE ENCODE ARRAY +C + IVOUT = ' ' +C +NOAO - FTN internal write rewritten as encode for IRAF. +C +C WRITE(IVOUT,'(G13.5)')CONV + call encode (13, '(g13.5)', ivout, conv) +C +C -NOAO + IHOLD(40:62) = IVOUT + CALL SETER (IHOLD,10,IREC) + RETURN +C +C BAD TIME THE CONTOUR EXITED A CORNER OF THE CELL MUST SEARCH FOR +C NEW CELL +C + 230 IXSTP = IXSTOR + IYSTP = IYSTOR + GO TO ( 240, 250, 260, 270),IOLDC +C +C PREVIOUS CELL BOTTOM EXIT +C + 240 IXSTP = IXSTP-1 + GO TO 280 +C +C PREVIOUS CELL LEFT EXIT +C + 250 IYSTP = IYSTP+1 + GO TO 280 +C +C PREVIOUS CELL TOP EXIT +C + 260 IXSTP = IXSTP+1 + GO TO 280 +C +C PREVIOUS CELL RIGHT EXIT +C + 270 IYSTP = IYSTP-1 +C +C BRANCH TO CURRENT CELL CASE +C + 280 GO TO ( 290, 300, 310, 320),IC +C +C APPARENT BOTTOM EXIT +C + 290 IXMOV(1) = 0 + IXMOV(2) = 1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT LEFT EXIT +C + 300 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = -1 + GO TO 330 +C +C APPARENT TOP EXIT +C + 310 IXMOV(1) = 0 + IXMOV(2) = -1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT RIGHT EXIT +C + 320 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = 1 +C +C SEARCH THE POSSIBLE CELLS +C + 330 DO 350 K=1,2 + DO 340 L=1,2 + XC = XCSTOR + STPSZ*FLOAT( IXMOV(K) ) + YC = YCSTOR + STPSZ*FLOAT( IYMOV(L) ) + IX = IXSTOR+IXMOV(K) + IY = IYSTOR+IYMOV(L) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C IF BACK TO START END CONTOUR +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 +C +C IF AT PREVIOUS CELL SKIP PROCESSING +C + IF (IX.EQ.IXSTP .AND. IY.EQ.IYSTP) GO TO 340 +C +C COMPUTE CELL VALUES +C + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) + TR = SCRTCH(IX-1,IY) + BL = SCRTCH(IX,IY) + ICASE = IC + CALL CONCLD (ICASE,NOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 +C +C FAILURE TRY AGAIN +C + 340 CONTINUE + 350 CONTINUE +C +C NO MORE CONTOUR TRY OTHER END OF LINE +C + 360 IF (LOOP.EQ.0) GO TO 170 + LOOP = 0 + IX = JX + IY = JY + TR = TRT + TL = TLT + BR = BRT + BL = BLT + IC = IFCASE + ICASE = IC + IOLDC = IFOCSE + XC = XI + YC = YI + IXSTOR = IX + IYSTOR = IY + YCSTOR = YI + XCSTOR = XI + XX = FX(FXO,FYO) + CALL LASTD + CALL FRSTD (XX,FY(FXO,FYO)) + GO TO ( 90, 110, 130, 150),IC + END diff --git a/sys/gio/ncarutil/conlib/conint.f b/sys/gio/ncarutil/conlib/conint.f new file mode 100644 index 00000000..84a1be82 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conint.f @@ -0,0 +1,147 @@ + SUBROUTINE CONINT (NDP,XD,YD,ZD,NCP,IPC,PD) +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 THIS SUBROUTINE ESTIMATES PARTIAL DERIVATIVES OF THE FIRST AND +C SECOND ORDER AT THE DATA POINTS. +C THE INPUT PARAMETERS ARE +C +C NDP = NUMBER OF DATA POINTS, +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z COORDI- +C NATES OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS TO BE USED FOR ESTIMATION +C OF PARTIAL DERIVATIVES AT EACH DATA POINT, +C IPC = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C NCP DATA POINTS CLOSEST TO EACH OF THE NDP DATA +C POINT. +C THE OUTPUT PARAMETER IS +C +C PD = ARRAY OF DIMENSION 5*NDP, WHERE THE ESTIMATED +C +C ZX, ZY, ZXX, ZXY, AND ZYY VALUES AT THE DATA +C POINTS ARE TO BE STORED. +C DECLARATION STATEMENTS +C +C + DIMENSION XD(NDP) ,YD(NDP) ,ZD(NDP) ,IPC(1) , + 1 PD(1) + REAL NMX ,NMY ,NMZ ,NMXX , + 1 NMXY ,NMYX ,NMYY +C + SAVE +C +C PRELIMINARY PROCESSING +C +C + NCPM1 = NCP-1 +C +C ESTIMATION OF ZX AND ZY +C +C + DO 130 IP0=1,NDP + X0 = XD(IP0) + Y0 = YD(IP0) + Z0 = ZD(IP0) + NMX = 0.0 + NMY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 120 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + DZ1 = ZD(IPI)-Z0 + IC2MN = IC1+1 + DO 110 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 110 + DZ2 = ZD(IPI)-Z0 + DNMX = DY1*DZ2-DZ1*DY2 + DNMY = DZ1*DX2-DX1*DZ2 + IF (DNMZ .GE. 0.0) GO TO 100 + DNMX = -DNMX + DNMY = -DNMY + DNMZ = -DNMZ + 100 NMX = NMX+DNMX + NMY = NMY+DNMY + NMZ = NMZ+DNMZ + 110 CONTINUE + 120 CONTINUE + JPD0 = 5*IP0 + PD(JPD0-4) = -NMX/NMZ + PD(JPD0-3) = -NMY/NMZ + 130 CONTINUE +C +C ESTIMATION OF ZXX, ZXY, AND ZYY +C +C + DO 170 IP0=1,NDP + JPD0 = JPD0+5 + X0 = XD(IP0) + JPD0 = 5*IP0 + Y0 = YD(IP0) + ZX0 = PD(JPD0-4) + ZY0 = PD(JPD0-3) + NMXX = 0.0 + NMXY = 0.0 + NMYX = 0.0 + NMYY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 160 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + JPD = 5*IPI + DZX1 = PD(JPD-4)-ZX0 + DZY1 = PD(JPD-3)-ZY0 + IC2MN = IC1+1 + DO 150 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 150 + JPD = 5*IPI + DZX2 = PD(JPD-4)-ZX0 + DZY2 = PD(JPD-3)-ZY0 + DNMXX = DY1*DZX2-DZX1*DY2 + DNMXY = DZX1*DX2-DX1*DZX2 + DNMYX = DY1*DZY2-DZY1*DY2 + DNMYY = DZY1*DX2-DX1*DZY2 + IF (DNMZ .GE. 0.0) GO TO 140 + DNMXX = -DNMXX + DNMXY = -DNMXY + DNMYX = -DNMYX + DNMYY = -DNMYY + DNMZ = -DNMZ + 140 NMXX = NMXX+DNMXX + NMXY = NMXY+DNMXY + NMYX = NMYX+DNMYX + NMYY = NMYY+DNMYY + NMZ = NMZ+DNMZ + 150 CONTINUE + 160 CONTINUE + PD(JPD0-2) = -NMXX/NMZ + PD(JPD0-1) = -(NMXY+NMYX)/(2.0*NMZ) + PD(JPD0) = -NMYY/NMZ + 170 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlcm.f b/sys/gio/ncarutil/conlib/conlcm.f new file mode 100644 index 00000000..80791d49 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlcm.f @@ -0,0 +1,65 @@ + FUNCTION CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,LOC) +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 COMPUTE A Z VALUE FOR A GIVEN X,Y VALUE +C NOTE THAT X,Y MUST BE INSIDE THE CONVEX HULL OF THE INPUT DATA +C INORDER FOR THIS FUNCTION TO WORK. +C +C INPUT +C X-X COORDINATE OF REQUESTED POINT +C Y-Y COORDINATE OF REQUESTED POINT +C WK-LIST OF COEFICENTS FOR LINEAR INTERPOLATION FUNCTIONS +C LOCATED BY A = WK((TRI-1)*3+1) +C B = WK((TRI-2)*3+1) +C C = WK((TRI-3)*3+1) +C +C OUTPUT +C LOC-TRIANGLE NUMBER OF REQUESTED POINT +C Z VALUE AS FUNCTION RESULT +C + DIMENSION WK(1),IWK(1),XD(1),YD(1),ZD(1) +C + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV +C + SAVE +C +C LOCATE THE TRIANGLE +C + CALL CONLOC(NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),X,Y,LOC, + 1 IWK(JWIWL),WK) +C +C IF OUTSIDE CONVEX HULL THEN DON'T COMPUTE A VALUE +C + IF (LOC.GT.NT) RETURN +C +C GET THE VECTOR 1 VALUES FOR THE TRIANGLE +C + IVEC = (LOC-1)*3 + JWIPT + IV = IWK(IVEC) + X1 = X - XD(IV) + Y1 = Y - YD(IV) + Z1 = ZD(IV) +C +C COMPUT THE Z VALUE +C + IPOINT = (LOC-1)*3 + IPR +C + Z = (WK(IPOINT)*X1+WK(IPOINT+1)*Y1)/WK(IPOINT+2) + Z1 +C + CONLCM = Z +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlin.f b/sys/gio/ncarutil/conlib/conlin.f new file mode 100644 index 00000000..f940d48c --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlin.f @@ -0,0 +1,68 @@ + SUBROUTINE CONLIN(XD,YD,ZD,NT,IWK,WK) +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 THIS ROUTINE GENERATES THE COORDINATES USED IN A LINEAR INTERPOLATION +C OF THE TRIANGLES CREATED FROM IRREGULARLY DISTRIBUTED DATA. +C +C INPUT +C XD-X INPUT COORDINATES] +C YD-Y INPUT COORDINATES +C ZD-Z VALUE AT INPUT X,Y +C NT-NUMBER OF TRIANGLES GENERATED +C IWK-LIST OF TRIANGLE POINTS, RELATIVE TO XD,YD +C GROUPED 3 PER TRIANGLE I.E. TRIANGLE 1 IWK(1,2,3), +C TRIANGLE 2 IWK(4,5,6) ETC. +C +C OUTPUT +C WK ARRAY OF COEFICENTS FOR LINEATION FORMUALS +C GROUPED 3 PER TRIANGLE +C POINTS ARE (TRI-1)*3 + 1,2,3 +C + DIMENSION IWK(1),WK(1),XD(1),YD(1),ZD(1) +C + SAVE +C +C LOOP FOR ALL TRIANGLES +C + DO 1000 ITRI = 1,NT +C +C GET THE POINTS OF THE TRIANGLE +C + IPOINT = (ITRI-1)*3 + IP1 = IWK(IPOINT+1) + IP2 = IWK(IPOINT+2) + IP3 = IWK(IPOINT+3) +C +C GET THE VALUES AT THE TRIANBGLE POINTS +C + X1 = XD(IP1) + Y1 = YD(IP1) + Z1 = ZD(IP1) + X2 = XD(IP2) + Y2 = YD(IP2) + Z2 = ZD(IP2) + X3 = XD(IP3) + Y3 = YD(IP3) + Z3 = ZD(IP3) +C +C COMPUTE THE INTERPLOATING COEFICIENTS +C + WK(IPOINT+1) = (Y2-Y1)*(Z3-Z1)-(Y3-Y1)*(Z2-Z1) + WK(IPOINT+2) = (X3-X1)*(Z2-Z1)-(X2-X1)*(Z3-Z1) + WK(IPOINT+3) = (X3-X1)*(Y2-Y1)-(X2-X1)*(Y3-Y1) +C + 1000 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conloc.f b/sys/gio/ncarutil/conlib/conloc.f new file mode 100644 index 00000000..5907c9df --- /dev/null +++ b/sys/gio/ncarutil/conlib/conloc.f @@ -0,0 +1,256 @@ + SUBROUTINE CONLOC (NDP,XD,YD,NT,IPT,NL,IPL,XII,YII,ITI,IWK,WK) +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 THIS SUBROUTINE LOCATES A POINT, I.E., DETERMINES TO WHAT TRI- +C ANGLE A GIVEN POINT (XII,YII) BELONGS. WHEN THE GIVEN POINT +C DOES NOT LIE INSIDE THE DATA AREA, THIS SUBROUTINE DETERMINES +C THE BORDER LINE SEGMENT WHEN THE POINT LIES IN AN OUTSIDE +C RECTANGULAR AREA, AND TWO BORDER LINE SEGMENTS WHEN THE POINT +C LIES IN AN OUTSIDE TRIANGULAR AREA. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y +C COORDINATES OF THE DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE +C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE +C POINT NUMBERS OF THE END POINTS OF THE BORDER +C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE +C NUMBERS, +C XII,YII = X AND Y COORDINATES OF THE POINT TO BE +C LOCATED. +C THE OUTPUT PARAMETER IS +C ITI = TRIANGLE NUMBER, WHEN THE POINT IS INSIDE THE +C DATA AREA, OR +C TWO BORDER LINE SEGMENT NUMBERS, IL1 AND IL2, +C CODED TO IL1*(NT+NL)+IL2, WHEN THE POINT IS +C OUTSIDE THE DATA AREA. +C THE OTHER PARAMETERS ARE +C IWK = INTEGER ARRAY OF DIMENSION 18*NDP USED INTER- +C NALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + DIMENSION XD(1) ,YD(1) ,IPT(1) ,IPL(1) , + 1 IWK(1) ,WK(1) +C +C +C + DIMENSION NTSC(9) ,IDSC(9) + COMMON /CONRA5/ NIT ,ITIPV +C + SAVE +C +C STATEMENT FUNCTIONS +C + SIDE(U1,V1,U2,V2,U3,V3) = (U1-U3)*(V2-V3)-(V1-V3)*(U2-U3) + SPDT(U1,V1,U2,V2,U3,V3) = (U1-U2)*(U3-U2)+(V1-V2)*(V3-V2) +C +C PRELIMINARY PROCESSING +C + NT0 = NT + NL0 = NL + NTL = NT0+NL0 + X0 = XII + Y0 = YII +C +C PROCESSING FOR A NEW SET OF DATA POINTS +C + IF (NIT .NE. 0) GO TO 170 + NIT = 1 +C +C - DIVIDES THE X-Y PLANE INTO NINE RECTANGULAR SECTIONS. +C + XMN = XD(1) + XMX = XMN + YMN = YD(1) + YMX = YMN + DO 100 IDP=2,NDP + XI = XD(IDP) + YI = YD(IDP) + XMN = AMIN1(XI,XMN) + XMX = AMAX1(XI,XMX) + YMN = AMIN1(YI,YMN) + YMX = AMAX1(YI,YMX) + 100 CONTINUE + XS1 = (XMN+XMN+XMX)/3.0 + XS2 = (XMN+XMX+XMX)/3.0 + YS1 = (YMN+YMN+YMX)/3.0 + YS2 = (YMN+YMX+YMX)/3.0 +C +C - DETERMINES AND STORES IN THE IWK ARRAY TRIANGLE NUMBERS OF +C - THE TRIANGLES ASSOCIATED WITH EACH OF THE NINE SECTIONS. +C + DO 110 ISC=1,9 + NTSC(ISC) = 0 + IDSC(ISC) = 0 + 110 CONTINUE + IT0T3 = 0 + JWK = 0 + DO 160 IT0=1,NT0 + IT0T3 = IT0T3+3 + I1 = IPT(IT0T3-2) + I2 = IPT(IT0T3-1) + I3 = IPT(IT0T3) + XMN = AMIN1(XD(I1),XD(I2),XD(I3)) + XMX = AMAX1(XD(I1),XD(I2),XD(I3)) + YMN = AMIN1(YD(I1),YD(I2),YD(I3)) + YMX = AMAX1(YD(I1),YD(I2),YD(I3)) + IF (YMN .GT. YS1) GO TO 120 + IF (XMN .LE. XS1) IDSC(1) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(2) = 1 + IF (XMX .GE. XS2) IDSC(3) = 1 + 120 IF (YMX.LT.YS1 .OR. YMN.GT.YS2) GO TO 130 + IF (XMN .LE. XS1) IDSC(4) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(5) = 1 + IF (XMX .GE. XS2) IDSC(6) = 1 + 130 IF (YMX .LT. YS2) GO TO 140 + IF (XMN .LE. XS1) IDSC(7) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(8) = 1 + IF (XMX .GE. XS2) IDSC(9) = 1 + 140 DO 150 ISC=1,9 + IF (IDSC(ISC) .EQ. 0) GO TO 150 + JIWK = 9*NTSC(ISC)+ISC + IWK(JIWK) = IT0 + NTSC(ISC) = NTSC(ISC)+1 + IDSC(ISC) = 0 + 150 CONTINUE +C +C - STORES IN THE WK ARRAY THE MINIMUM AND MAXIMUM OF THE X AND +C - Y COORDINATE VALUES FOR EACH OF THE TRIANGLE. +C + JWK = JWK+4 + WK(JWK-3) = XMN + WK(JWK-2) = XMX + WK(JWK-1) = YMN + WK(JWK) = YMX + 160 CONTINUE + GO TO 200 +C +C CHECKS IF IN THE SAME TRIANGLE AS PREVIOUS. +C + 170 IT0 = ITIPV + IF (IT0 .GT. NT0) GO TO 180 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF ON THE SAME BORDER LINE SEGMENT. +C + 180 IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (IL2 .NE. IL1) GO TO 190 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF BETWEEN THE SAME TWO BORDER LINE SEGMENTS. +C + 190 IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 260 +C +C LOCATES INSIDE THE DATA AREA. +C - DETERMINES THE SECTION IN WHICH THE POINT IN QUESTION LIES. +C + 200 ISC = 1 + IF (X0 .GE. XS1) ISC = ISC+1 + IF (X0 .GE. XS2) ISC = ISC+1 + IF (Y0 .GE. YS1) ISC = ISC+3 + IF (Y0 .GE. YS2) ISC = ISC+3 +C +C - SEARCHES THROUGH THE TRIANGLES ASSOCIATED WITH THE SECTION. +C + NTSCI = NTSC(ISC) + IF (NTSCI .LE. 0) GO TO 220 + JIWK = -9+ISC + DO 210 ITSC=1,NTSCI + JIWK = JIWK+9 + IT0 = IWK(JIWK) + JWK = IT0*4 + IF (X0 .LT. WK(JWK-3)) GO TO 210 + IF (X0 .GT. WK(JWK-2)) GO TO 210 + IF (Y0 .LT. WK(JWK-1)) GO TO 210 + IF (Y0 .GT. WK(JWK)) GO TO 210 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 210 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 210 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 210 + GO TO 260 + 210 CONTINUE +C +C LOCATES OUTSIDE THE DATA AREA. +C + 220 DO 240 IL1=1,NL0 + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 240 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 230 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 240 + IL2 = IL1 + GO TO 250 + 230 IL2 = MOD(IL1,NL0)+1 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 250 + 240 CONTINUE + IT0 = 1 + GO TO 260 + 250 IT0 = IL1*NTL+IL2 +C +C NORMAL EXIT +C + 260 ITI = IT0 + ITIPV = IT0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlod.f b/sys/gio/ncarutil/conlib/conlod.f new file mode 100644 index 00000000..d7fc3804 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlod.f @@ -0,0 +1,194 @@ + SUBROUTINE CONLOD (XD,YD,ZD,NDP,WK,IWK,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****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +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 /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION SCRARR(1) +C + SAVE +C +C IFR - FLAG TO REGISTER FIRST PASS IN Y DIRECTION +C +C LOAD THE SCRATCH SPACE AND CONVEX HULL POINTERS +C ITLOC IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO THE SCARTCH +C SPACE. +C PV IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO USER COORDINATES +C +C INITALIZE THE SPECIAL VALUE FEATURE +C + X = (XED-XST)/2. + XST + Y = (YED-YST)/2. + YST + IF(LINEAR) GO TO 1 + SPVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 2 + 1 SPVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 2 CONTINUE +C +C INITIALIZE THE SEARCH +C + IYMAX = 0 + IFR = 1 + JX = 1 + X = XST + 10 JY = 1 + Y = YST +C +C SET HULL POINTERS FOR THIS COLUMN TO NULL +C + ITLOC(JX*2-1) = 0 + ITLOC(JX*2) = 0 +C +C FLAG START OF COLUMN +C + LOOP = 1 +C +C GET INTERPOLATED VALUE +C + 20 IF (LINEAR) GO TO 3 + RVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 4 + 3 RVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 4 CONTINUE + SCRARR(JY+(JX-1)*IYMAX) = RVAL + IF (RVAL.GT.SPVAL) SPVAL = RVAL +C +C IF OUTSIDE CONVEX HULL BRANCH +C + IF (IT.GT.NTNL) GO TO 30 +C +C IF OUTSIDE TRIANGLES AND USING LINEAR INTERPLOATION THEN BRANCH +C + IF(LINEAR.AND.IT.GT.NT) GO TO 30 +C +C IF FIRST OF COLUMN IN HULL CONTINUE THROUGH +C + IF (LOOP.NE.1) GO TO 40 +C +C SET HULL POINTERS +C + PV(JX*2-1) = Y + ITLOC(JX*2-1) = JY +C +C SET FLAG TO LOOK FOR END OF HULL IN COLUMN +C + LOOP = 2 +C +C GO FOR NEXT ENTRY +C + GO TO 40 +C +C TEST FOR END OF CONVEX HULL ON THIS ROW +C + 30 IF (LOOP.NE.2) GO TO 40 +C +C END OF HULL SET POINTERS FOR END OF HULL AND FLAG IT VIA LOOP +C + LOOP = 0 + ITLOC(JX*2) = JY-1 + PV(JX*2) = Y-STPSZ +C +C GET NEXT ELEMENT IN ROW IF NOT OUTSIDE ENCLOSING RECTANGULAR +C BOARDER +C + 40 Y = Y+STPSZ + JY = JY+1 + IF (Y.LE.YED) GO TO 20 +C +C TEST FOR FIRST COLUMN +C + IF (IFR.NE.1) GO TO 50 +C +C FIRST COLUMN OVER SET MAX Y VALUES +C + IYMAX = JY-1 + YMAX = Y-STPSZ + IFR = 0 +C +C IF HULL WENT TO EDGE OF RECTANGULAR BOARDER SET HULL POINTERS HERE +C + 50 IF (LOOP.NE.2) GO TO 60 + PV(JX*2) = Y-STPSZ + ITLOC(JX*2) = JY-1 +C +C END OF COLUMN GET NEXT ONE +C + 60 X = X+STPSZ + JX = JX+1 +C +C IF NOT END OF WORK CONTINUE WITH NEXT COLUMN +C + IF (X.LE.XED) GO TO 10 +C +C END OF WORK SET MAX X VALUES +C + IXMAX = JX-1 + XMAX = X-STPSZ + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop1.f b/sys/gio/ncarutil/conlib/conop1.f new file mode 100644 index 00000000..fc61872d --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop1.f @@ -0,0 +1,465 @@ + SUBROUTINE CONOP1 (IOPT) +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 SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C +C SET COMMON DATA EQUAL TO INPUT DATA +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 /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +c +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE OPTION AND ITS VALUE +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C REP FOUND CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'RE') THEN +C +C SWITCH = ON CONTOUR SAME DATA +C + IF (OPT .EQ. 'ON') THEN + REPEAT = .TRUE. + RETURN +C +C SWITCH = OFF CONTOUR NEW DATA +C + ELSEIF (OPT .EQ. 'OF') THEN + REPEAT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXTRAPOLATION FLAG +C + ELSEIF (TAG .EQ. 'EX') THEN +C +C SWITCH = ON EXTRAPOLATE WHEN CONTOURING +C + IF (OPT .EQ. 'ON') THEN + EXTRAP = .TRUE. + RETURN +C +C SWITCH = OFF INTERPOLATE ONLY +C + ELSEIF (OPT .EQ. 'OF') THEN + EXTRAP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PER FOUND SET PERIMETER +C + ELSEIF (TAG .EQ. 'PE') THEN +C +C SWITCH = ON DRAW PERIMETERS +C + IF (OPT .EQ. 'ON') THEN + PER = .TRUE. +C +C TURN GRID OFF, USER WANTS PERIMETER +C + GRD = .FALSE. + RETURN +C +C SWITCH = OFF DO NOT DRAW PERIMETERS +C + ELSEIF (OPT .EQ. 'OF') THEN + PER = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C DEF FOUND SET ALL OPTIONS TO DEFAULT (NO SWITCHES) +C + ELSEIF (TAG .EQ. 'DE') THEN + PER = .TRUE. + LISTOP = .FALSE. + PMIMX = .FALSE. + SCALE = 1. + TENSN = TENS + EXTRAP = .FALSE. + TITLE = .FALSE. + ITLSIZ = 16 + REPEAT = .FALSE. + MESS = .TRUE. + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. + IGRAD = IG + ISCALE = 0 + NCP = 4 + LOOK = .FALSE. + GRD = .FALSE. + PLDVLS = .FALSE. + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + BPSIZ = 0. + LABON = .TRUE. + ISIZEL = 9 + ISIZEP = 8 + ISIZEM = 15 + FRADV = .TRUE. + EXTRI = .FALSE. + MINGAP = 3 + LINEAR = .FALSE. + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. +C +C SET DEFAULT DASH PATTERN +C + IDASH = '$$$$$$$$$$' + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' +C +C SET DEFAULT FORMAT +C + FORM = '(G10.3)' + RETURN +C +C MES FOUND TEST VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'ME') THEN +C +C ACTIVATE CONRAN MESSAGE +C + IF (OPT .EQ. 'ON') THEN + MESS = .TRUE. + RETURN +C +C TURN OFF CONRAN MESSAGE +C + ELSEIF (OPT .EQ. 'OF') THEN + MESS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALING OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'SC') THEN +C +C SET VALUE OF SCALE FLAG +C + IF (OPT .EQ. 'ON') THEN + ISCALE = 0 + RETURN + ELSEIF (OPT .EQ. 'OF') THEN + ISCALE = 1 + RETURN + ELSEIF (OPT .EQ. 'PR') THEN + ISCALE = 2 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TRIANGLE FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'TR') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + LOOK = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + LOOK = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT DATA VALUES FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'PD') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + PLDVLS = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + PLDVLS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C GRID OPTION ACTIVATED GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'GR') THEN +C +C SWITCH ON SET GRID FLAG +C + IF (OPT .EQ. 'ON') THEN + GRD = .TRUE. +C +C TURN PER OFF USER WANTS GRID +C + PER = .FALSE. + RETURN +C +C SWITCH OFF CLEAR GRID FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + GRD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL PLOTTING FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LA') THEN +C +C SWITCH ON LABEL CONTOURS +C + IF (OPT .EQ. 'ON') THEN + LABON = .TRUE. + RETURN +C +C SWITCH OFF DON"T LABEL CONTOURS +C + ELSEIF (OPT .EQ. 'OF') THEN + LABON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT THE RELATIVE MIN"S AND MAX"S +C + ELSEIF (TAG .EQ. 'PM') THEN +C +C SWTICH ON PLOT THE INFO +C + IF (OPT .EQ. 'ON') THEN + PMIMX = .TRUE. + RETURN +C +C SWTICH OFF DO NOT PLOT THE INFO +C + ELSEIF (OPT .EQ. 'OF') THEN + PMIMX = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C ADVANCE FRAME BEFORE TRIANGULATION PLOT +C + ELSEIF (TAG .EQ. 'TF') THEN +C +C SWITCH ON ADVANCE FRAME +C + IF (OPT .EQ. 'ON') THEN + FRADV = .TRUE. + RETURN +C +C SWITCH OFF DO NOT ADVANCE FRAME +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXIT AFTER TRIANGULATION +C + ELSEIF (TAG .EQ. 'TO') THEN +C +C SWITCH ON EXIT AFTER TRIANGULATION +C + IF (OPT .EQ. 'ON') THEN + EXTRI = .TRUE. + LOOK = .TRUE. + FRADV = .FALSE. + RETURN +C +C SWITCH OFF DO NOT EXIT AFTER TRIANGULATION +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .TRUE. + LOOK = .FALSE. + EXTRI = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LIST OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LO') THEN +C +C ON SET LIST OPTIONS FLAG +C + IF (OPT .EQ. 'ON') THEN + LISTOP = .TRUE. + RETURN +C +C TURN OFF LIST OPTIONS FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + LISTOP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE INTERPOLATION SCHEME +C + ELSEIF (TAG .EQ. 'IT') THEN +C +C SET TO C1 SURFACE +C + IF (OPT .EQ. 'C1') THEN + LINEAR = .FALSE. + RETURN +C +C SET TO LINEAR INTERPOLATION +C + ELSEIF (OPT .EQ. 'LI') THEN + LINEAR = .TRUE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE SHIELD PLOT FLAG +C + ELSEIF (TAG .EQ. 'PS') THEN +C +C TURN ON SHIELD PLOT +C + IF (OPT .EQ. 'ON') THEN + SLDPLT = .TRUE. + RETURN +C +C TURN OFF SHIELD PLOT +C + ELSEIF (OPT .EQ. 'OF') THEN + SLDPLT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP1 -- UNDEFINED OPTION',1,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conop2.f b/sys/gio/ncarutil/conlib/conop2.f new file mode 100644 index 00000000..41dc27c3 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop2.f @@ -0,0 +1,316 @@ + SUBROUTINE CONOP2 (IOPT,ISIZE) +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 SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ISIZE- INTEGER INPUT +C +C SET COMMON DATA EQUAL TO INPUT DATA +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 /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C SET RESOLUTION OF VIRTUAL GRID +C + IF (TAG .EQ. 'SS') THEN +C +C SWITCH = ON SET RESOLUTION OF VIRTUAL GRID +C + IF (OPT .EQ. 'ON') THEN + IGRAD = ISIZE + RETURN +C +C SWITCH = OFF RESET RESOLUTION TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + IGRAD = IG + RETURN + ELSE + GOTO 120 + ENDIF +C +C NCP OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'NC') THEN +C +C SWITCH ON GET VALUE FOR NUMBER OF SURROUNDING DATA POINTS TO USE +C + IF (OPT .EQ. 'ON') THEN + NCP = ISIZE + RETURN +C +C SWITCH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + NCP = 4 + RETURN + ELSE + GOTO 120 + ENDIF +C +C INTENSITY OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'IN') THEN +C +C SWITCH OFF SET DEFAULT VALUES +C + IF (OPT .EQ. 'OF') THEN + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + RETURN +C +C SET PLOTTED DATA INTENSITY +C + ELSEIF (OPT .EQ. 'DA') THEN + INDAT = ISIZE + RETURN +C +C SET TITLE AND MESSAGE INTENSITY +C + ELSEIF (OPT .EQ. 'LA') THEN + INLAB = ISIZE + IRANTX = ISIZE + IRASTX = ISIZE + IRAQTX = ISIZE + RETURN +C +C SET ALL INTENSITIES TO THE SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IRANMJ = ISIZE + IRANMN = ISIZE + IRANTX = ISIZE + IRASMJ = ISIZE + IRASMN = ISIZE + IRASTX = ISIZE + IRAQMJ = ISIZE + IRAQMN = ISIZE + IRAQTX = ISIZE + INMAJ = ISIZE + INMIN = ISIZE + INLAB = ISIZE + INDAT = ISIZE + RETURN +C +C SET MAJOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MA') THEN + IRANMJ = ISIZE + IRASMJ = ISIZE + IRAQMJ = ISIZE + INMAJ = ISIZE + RETURN +C +C SET MINOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MI') THEN + IRANMN = ISIZE + IRASMN = ISIZE + IRAQMN = ISIZE + INMIN = ISIZE + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL SIZE OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LS') THEN +C +C SWITCH ON GET USER LABEL SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEL = ISIZE + RETURN +C +C SWITCH OFF SET LABEL SIZE TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEL = 9 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZES OF MINIMUM AND MAXIMUM LABELS +C + ELSEIF (TAG .EQ. 'SM') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEM = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEM = 15 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZE OF THE PLOTTED DATA +C + ELSEIF (TAG .EQ. 'SP') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEP = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEP = 8 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TITLE SIZE SWITCH +C + ELSEIF (TAG .EQ. 'ST') THEN +C +C SWITCH ON SET THE TITLE SIZE +C + IF (OPT .EQ. 'ON') THEN + ITLSIZ = ISIZE + RETURN +C +C SWITCH OFF SET TITLE SIZE TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ITLSIZ = 16 + RETURN + ELSE + GOTO 120 + ENDIF +C +C MINOR LINE COUNT OPTION +C + ELSEIF (TAG .EQ. 'MI') THEN +C +C SET MINOR LINE COUNT +C + IF (OPT .EQ. 'ON') THEN + MINGAP = ISIZE+1 + RETURN +C +C SET MINOR LINE COUNT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + MINGAP = 3 + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP2 - UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop3.f b/sys/gio/ncarutil/conlib/conop3.f new file mode 100644 index 00000000..e4632478 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop3.f @@ -0,0 +1,266 @@ + SUBROUTINE CONOP3 (IOPT,ARRAY,ISIZE) +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 SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ARRAY- REAL ARRAY OF DIMENSION ISIZE +C ISIZE- SIZE OF ARRAY +C +C SET COMMON DATA EQUAL TO INPUT DATA +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 /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + DIMENSION ARRAY(ISIZE) + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C CON CONTOUR LEVELS CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'CO') THEN +C +C SWITCH = ON SET CONTOUR LEVELS +C + IF (OPT .EQ. 'ON') THEN + IF (CHILO .OR. CINC) GOTO 140 +C +C TEST IF NUMBER OF CONTOURS IS ACCEPTABLE +C + IF (ISIZE .GT. 30) + 1 CALL SETER (' CONOP3-NUMBER OF CONTOUR LEVELS EXCEEDS 30', + 2 1,1) + DO 200 I=1,ISIZE + CL(I) = ARRAY(I) + 200 CONTINUE + CON = .TRUE. + NCL = ISIZE + RETURN +C +C SWITCH = OFF CLEAR CONTOUR LEVEL ARRAY (PROGRAM SELECTS) +C + ELSEIF (OPT .EQ. 'OF') THEN + CON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR HI LO OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CH') THEN +C +C SWITCH ON SET HI AND FLO +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + HI = ARRAY(1) + FLO = ARRAY(2) + CHILO = .TRUE. + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CHILO = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR INCREMENT OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CI') THEN +C +C SWITCH ON SET INCREMENT +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + CINC = .TRUE. + FINC = ARRAY(1) + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CINC = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALE THE DATA PLOTTED ON THE CONTOURS AND MIN MAX POINTS +C + ELSEIF (TAG .EQ. 'SD') THEN +C +C SWTICH ON GET SCALE FACTOR +C + IF (OPT .EQ. 'ON') THEN + SCALE = ARRAY(1) + RETURN +C +C SWTICH OFF SET FOR NO SCALING +C + ELSEIF (OPT .EQ. 'OF') THEN + SCALE = 1. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE TENSION VALUE FOR SMOOTHING +C + ELSEIF (TAG .EQ. 'TE') THEN +C +C SWTICH ON SET TENSION FACTOR +C + IF (OPT .EQ. 'ON') THEN + TENSN = ARRAY(1) + RETURN +C +C SWTICH OFF SET TO DEFAULT TENSION +C + ELSEIF (OPT .EQ. 'OF') THEN + TENSN = TENS + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN BREAK POINT SWITCH +C + ELSEIF (TAG .EQ. 'DB') THEN +C +C SWITCH ON GET USERS BREAKPOINT +C + IF (OPT .EQ. 'ON') THEN + BPSIZ = ARRAY(1) + RETURN +C +C SWITCH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + BPSIZ = 0. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SHIELD OPTION +C + ELSEIF (TAG .EQ. 'SL') THEN +C +C TURN SHIELDING ON AND SET THE SHIELD COORD POINTERS +C + IF (OPT .EQ. 'ON') THEN + NISIZE = ISIZE/2 + CALL CONSSD(ARRAY(1),ARRAY(NISIZE+1),NISIZE) + RETURN +C +C DEACTIVATE SHIELDING +C + ELSEIF (OPT .EQ. 'OF') THEN + ICOUNT = 0 + SHIELD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP3-UNDEFINED OPTION',1,1) + RETURN +C +C ILLEGAL USE OF CON WITH CIL OR CHL +C + 140 CALL SETER + 1('CONOP3-ILLEGAL USE OF CON OPTION WITH CIL OR CHL OPTION', + 2 1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop4.f b/sys/gio/ncarutil/conlib/conop4.f new file mode 100644 index 00000000..f963dcf9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop4.f @@ -0,0 +1,197 @@ + SUBROUTINE CONOP4 (IOPT,ARRAY,ISIZE,IFORT) +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 SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT -- CHARACTER STRING OF OPTION VALUE +C ARRAY -- CHARACTER INPUT DATA +C ISIZE -- INTEGER INPUT +C IFORT -- INTEGER. THIS VALUE IS USED ONLY WHEN IOPT IS +C "FMT=ON". IN THIS CASE, IFORT IS THE TOTAL NUMBER +C OF CHARACTERS TO BE PROCESSED BY THE FORMAT +C STATEMENT. FOR EXAMPLE, FOR THE FORMAT "F10.3", +C IFORT SHOULD BE SET TO 10. +C +C SET COMMON DATA EQUAL TO INPUT DATA +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 /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*(*) ARRAY + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C TITLE OPTION GET VALUE OF SWITCH +C + IF (TAG .EQ. 'TL') THEN +C +C SWITCH ON GET TITLE AND COUNT FROM INPUT +C + IF (OPT .EQ. 'ON') THEN + TITLE = .TRUE. + ISTRNG = ARRAY + ICNT = ISIZE + RETURN +C +C SWITCH OFF OPTION DEACTIVATED +C + ELSEIF (OPT .EQ. 'OF') THEN + TITLE = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CHANGE DATA VALUE FORMAT +C + ELSEIF (TAG .EQ. 'FM') THEN +C +C SWITCH ON GET USER FORMAT +C + IF (OPT .EQ. 'ON') THEN + FORM = ARRAY + LEN = ISIZE + IFMT = IFORT + RETURN +C +C SWITCH OFF SET FORMAT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'DA') THEN +C +C SWITCH OFF DEFAULT PATTERNS +C + IF (OPT .EQ. 'OF') THEN + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' + IDASH = '$$$$$$$$$$' + RETURN +C +C SWITCH ALL SET GTR,LSS,AND EQU TO SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IDASH = ARRAY + EDASH = ARRAY + NDASH = ARRAY + RETURN +C +C SWITCH SET TO POS CHANGE POS DASH PATTERN +C + ELSEIF (OPT .EQ. 'GT') THEN + IDASH = ARRAY + RETURN +C +C SWITCH SET TO NEG SET NEG DASH PATTERN +C + ELSEIF (OPT .EQ. 'LS') THEN + NDASH = ARRAY + RETURN +C +C SWITCH SET TO EQU SET EQUAL DASH PATTERN +C + ELSEIF (OPT .EQ. 'EQ') THEN + EDASH = ARRAY + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP4-UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conot2.f b/sys/gio/ncarutil/conlib/conot2.f new file mode 100644 index 00000000..f2bc6aed --- /dev/null +++ b/sys/gio/ncarutil/conlib/conot2.f @@ -0,0 +1,178 @@ + SUBROUTINE CONOT2 (IVER,IUNIT) +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 + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C OUTPUT THE OPTION VALUES TO THE LINE PRINTER +C +C CONTINUE FOR CONRAN AND CONRAS +C +C +C +C COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , +C 1 FINC ,HI ,FLO +C COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , +C 1 ISCALE ,LOOK ,PLDVLS ,GRD , +C 2 CINC ,CHILO ,CON ,LABON , +C 3 PMIMX ,SCALE ,FRADV ,EXTRI , +C 4 BPSIZ ,LISTOP +C COMMON /CONRA3/ IREC +C COMMON /CONRA4/ NCP ,NCPSZ +C COMMON /CONRA5/ NIT ,ITIPV +C COMMON /CONRA6/ XST ,YST ,XED ,YED , +C 1 STPSZ ,IGRAD ,IG ,XRG , +C 2 YRG ,BORD ,PXST ,PYST , +C 3 PXED ,PYED ,ITICK +C COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ +C COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , +C 1 LEN ,IFMT ,LEND , +C 2 IFMTD ,ISIZEP ,INMIN +C COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , +C 1 BR ,TL ,BL ,CONV , +C 2 XN ,YN ,ITLL ,IBLL , +C 3 ITRL ,IBRL ,XC ,YC , +C 4 ITLOC(210) ,JX ,JY ,ILOC , +C 5 ISHFCT ,XO ,YO ,IOC ,NC +C COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , +C 1 JWIWL ,JWIWP ,JWIPL ,IPR , +C 2 ITPV +C COMMON /CONR11/ NREP ,NCRT ,ISIZEL , +C 1 MINGAP ,ISIZEM , +C 2 TENS +C COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX +C LOGICAL REPEAT ,EXTRAP ,PER ,MESS , +C 1 LOOK ,PLDVLS ,GRD ,LABON , +C 2 PMIMX ,FRADV ,EXTRI ,CINC , +C 3 TITLE ,LISTOP ,CHILO ,CON +C COMMON /CONR15/ ISTRNG +C CHARACTER*64 ISTRNG +C COMMON /CONR16/ FORM +C CHARACTER*10 FORM +C COMMON /CONR17/ NDASH, IDASH, EDASH +C CHARACTER*10 NDASH, IDASH, EDASH +C +C +C SAVE +C +C LABEL THE CONTOURS +C +C WRITE (IUNIT,1001) +C IF (LABON) GO TO 100 +C WRITE (IUNIT,1002) +C GO TO 110 +C 100 WRITE (IUNIT,1003) +C +C LABEL SIZE +C +C 110 WRITE (IUNIT,1004) ISIZEL +C +C SCALE DATA ON CONTOURS +C +C WRITE (IUNIT,1005) +C IF (SCALE .NE. 1.) GO TO 120 +C WRITE (IUNIT,1006) +C GO TO 130 +C 120 WRITE (IUNIT,1007) SCALE +C +C TENSION FACTOR +C +C 130 WRITE (IUNIT,1008) TENS +C +C PLOT RELATIVE MINS AND MAXS +C +C WRITE (IUNIT,1009) +C IF (PMIMX) GO TO 140 +C WRITE (IUNIT,1010) +C GO TO 150 +C 140 WRITE (IUNIT,1011) +C +C SIZE OF MINIMUM AND MAXIMUM LABELS +C +C 150 WRITE (IUNIT,1012) ISIZEM +C +C DASH PATTERN +C +C WRITE (IUNIT,1013) +C IF (IDASH(1:1) .EQ. ' ') GO TO 170 +C WRITE (IUNIT,1014) IDASH +C GO TO 180 +C 170 WRITE (IUNIT,1015) +C 180 IF (EDASH(1:1) .EQ. ' ') GO TO 200 +C WRITE (IUNIT,1016) EDASH +C GO TO 210 +C 200 WRITE (IUNIT,1017) +C 210 IF (NDASH(1:1) .EQ. ' ') GO TO 230 +C WRITE (IUNIT,1018) NDASH +C GO TO 240 +C 230 WRITE (IUNIT,1019) +C +C DASH PATTERN BREAK POINT +C +C 240 WRITE (IUNIT,1020) BPSIZ +C +C PRINT MINOR LINE GAP +C +C ITT = MINGAP-1 +C WRITE (IUNIT,1021) ITT +C RETURN +C +C 1001 FORMAT (5X,'LABEL THE CONTOURS, LAB=') +C 1002 FORMAT ('+',28X,'OFF') +C 1003 FORMAT ('+',28X,'ON') +C 1004 FORMAT (5X,'CONTOUR LABEL SIZE IN PWRIT UNITS, LSZ=',I4) +C 1005 FORMAT (5X,'SCALE THE DATA ON CONTOUR LINES, SDC=') +C 1006 FORMAT ('+',41X,'OFF') +C 1007 FORMAT ('+','ON, SCALE FACTOR=',G10.3) +C 1008 FORMAT (5X,'TENSION FACTOR (USED FOR SMOOTH AND SUPER), TEN=', +C 1 F6.2) +C 1009 FORMAT (5X,'PLOT RELATIVE MINIMUMS AND MAXIMUMS, PMM=') +C 1010 FORMAT ('+',45X,'OFF') +C 1011 FORMAT ('+',45X,'ON') +C 1012 FORMAT (5X,'SIZE OF MIN AND MAX LABELS IN PWRIT UNITS SML=', +C 1 I4) +C 1013 FORMAT (5X,'DASH PATTERN GTR=GREATER, EQU=EQUAL, LSS=LESS') +C 1014 FORMAT (10X,'GTR=',A10) +C 1015 FORMAT (10X,'GTR=$$$$$$$$$$') +C 1016 FORMAT (10X,'EQU=',A10) +C 1017 FORMAT (10X,'EQU=$$$$$$$$$$') +C 1018 FORMAT (10X,'LSS=',A10) +C 1019 FORMAT (10X,'LSS=$$$$$$$$$$') +C 1020 FORMAT (5X,'DASH PATTERN BREAK POINT, DBP=',G10.3) +C 1021 FORMAT (5X,'MINOR LINE COUNT=',I3) +C +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONTERP TO ULIB * +C* AUGUST 1980 FIXED THE FOLLOWING PROBLEMS * +C* 1.PLOTTING OF INPUT DATA VALUES * +C* 2.SETTING OF MINIMUM INTENSITY IN ALL OPTION * +C* 3.SETTING OF EQU FLAG IN CONTOUR DASH PATTERN * +C* 4.TURNING OFF OF SIZE OF PLOTTED DATA OPTION * +C* DECEMBER 1980 FIXED CONTOUR SELECTION ALGORITHM AND MOVED IN * +C* DASH PACKAGE COMMON BLOCK INTPR +C* MARCH 1981 FIXED NON-PORTABLE STATEMENT ORDERING IN CONSET * +C* APRIL 1981 FIXED OPTION LISTING ROUTINE * +C* ADDED MINOR LINE COUNT OPTION * +C* JULY 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED LOC (MACHINE DEPENDENT FUNCTION), CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/conout.f b/sys/gio/ncarutil/conlib/conout.f new file mode 100644 index 00000000..c2684de9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conout.f @@ -0,0 +1,350 @@ + SUBROUTINE CONOUT (IVER) +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 + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C LIST OUT ALL THE CONRAN OPTION VALUES ON THE LINE PRINTER +C +C THE VALUE OF IVER DETERMINES WHICH ENTRY POINT CALLED THIS ROUTINE +C +C 1. CONRAQ +C 2. CONRAN +C 3. CONRAS +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 /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C +C GET THE STANDARD OUTPUT UNIT TO WRITE THE OPTION VALUE LIST +C + IUNIT = I1MACH(2) +C +C PRINT OUT HEADER AND ALL OPTIONS WHICH APPLY TO CALLING VERSION +C +C GO TO ( 100, 110, 120),IVER +C 100 WRITE (IUNIT,1001) +C GO TO 130 +C 110 WRITE (IUNIT,1002) +C GO TO 130 +C 120 WRITE (IUNIT,1003) +C 130 WRITE (IUNIT,1004) +C +C PERIMETER +C +C WRITE (IUNIT,1005) +C IF (PER) GO TO 140 +C WRITE (IUNIT,1006) +C GO TO 150 +C 140 WRITE (IUNIT,1007) +C +C GRID +C +C 150 WRITE (IUNIT,1008) +C IF (GRD) GO TO 160 +C WRITE (IUNIT,1009) +C GO TO 170 +C 160 WRITE (IUNIT,1010) +C +C SCALING OF DATA ON FRAME +C +C 170 WRITE (IUNIT,1011) +C GO TO ( 180, 190, 200),ISCALE+1 +C 180 WRITE (IUNIT,1012) +C GO TO 210 +C 190 WRITE (IUNIT,1013) +C GO TO 210 +C 200 WRITE (IUNIT,1014) +C +C SAME DATA ANOTHER PLOT +C +C 210 WRITE (IUNIT,1015) +C IF (REPEAT) GO TO 220 +C WRITE (IUNIT,1016) +C GO TO 230 +C 220 WRITE (IUNIT,1017) +C +C SHIELDING +C +C 230 WRITE(IUNIT,2000) +C IF (SHIELD) GO TO 231 +C WRITE(IUNIT,2001) +C GO TO 232 +C 231 WRITE(IUNIT,2002) +C +C INTERPOLATION +C +C 232 WRITE(IUNIT,2003) +C IF (LINEAR) GO TO 233 +C WRITE(IUNIT,2004) +C GO TO 234 +C 233 WRITE(IUNIT,2005) +C +C PLOT THE SHIELD +C +C 234 WRITE(IUNIT,2006) +C IF (SLDPLT) GO TO 235 +C WRITE(IUNIT,2007) +C GO TO 236 +C 235 WRITE(IUNIT,2008) +C +C EXTRAPOLATION +C +C 236 WRITE (IUNIT,1018) +C IF (EXTRAP) GO TO 240 +C WRITE (IUNIT,1019) +C GO TO 250 +C 240 WRITE (IUNIT,1020) +C +C STEP SIZE OR RESOLUTION OF THE GRID +C +C 250 WRITE (IUNIT,1021) IGRAD +C +C MESSAGE AT BOTTOM OF PLOT +C +C WRITE (IUNIT,1022) +C IF (MESS) GO TO 260 +C WRITE (IUNIT,1023) +C GO TO 270 +C 260 WRITE (IUNIT,1024) +C +C TITLE AT TOP OF PLOT +C +C 270 WRITE (IUNIT,1025) +C IF (TITLE) GO TO 280 +C WRITE (IUNIT,1026) +C GO TO 290 +C 280 WRITE (IUNIT,1027) +C +C SIZE OF TITLE +C +C 290 WRITE (IUNIT,1028) ITLSIZ +C +C PRINT TITLE +C +C IF (ICNT.EQ.0 .OR. .NOT.TITLE) GO TO 310 +C ICC = 100 +C IF (ICC .GT. ICNT) ICC = ICNT +C WRITE (IUNIT,1029) ISTRNG +C +C DATA POINTS USED FOR PARTIAL DERIVATIVE ESTIMATION +C +C 310 WRITE (IUNIT,1030) NCP +C +C LOOK AT TRIANGLES SWITCH +C +C WRITE (IUNIT,1031) +C IF (LOOK) GO TO 320 +C WRITE (IUNIT,1032) +C GO TO 330 +C 320 WRITE (IUNIT,1033) +C +C ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C +C 330 WRITE (IUNIT,1034) +C IF (FRADV) GO TO 340 +C WRITE (IUNIT,1035) +C GO TO 350 +C 340 WRITE (IUNIT,1036) +C +C TRIANGLES ONLY PLOT +C +C 350 WRITE (IUNIT,1037) +C IF (EXTRI) GO TO 360 +C WRITE (IUNIT,1038) +C GO TO 370 +C 360 WRITE (IUNIT,1039) +C +C PLOT THE INPUT DATA VALUES +C +C 370 WRITE (IUNIT,1040) +C IF (PLDVLS) GO TO 380 +C WRITE (IUNIT,1041) +C GO TO 390 +C 380 WRITE (IUNIT,1042) +C +C FORMAT OF THE PLOTTED INPUT DATA +C +C 390 WRITE (IUNIT,1043) +C IF (LEN .NE. 0) GO TO 400 +C WRITE (IUNIT,1044) +C GO TO 420 +C 400 WRITE (IUNIT,1045) FORM +C +C SIZE OF THE PLOTTED DATA VALUES +C +C 420 WRITE (IUNIT,1046) ISIZEP +C +C INTENSITY SETTINGS +C +C WRITE (IUNIT,1047) +C WRITE (IUNIT,1048) INMAJ,INMIN,INLAB,INDAT +C +C DISTLAY CONTOUR SETTING +C +C WRITE (IUNIT,1049) +C IF (CON) GO TO 430 +C WRITE (IUNIT,1050) +C GO TO 440 +C 430 WRITE (IUNIT,1051) NCL,(CL(I),I=1,NCL) +C +C CONTOUR INCREMENT +C +C 440 WRITE (IUNIT,1052) +C IF (CINC) GO TO 450 +C WRITE (IUNIT,1053) +C GO TO 460 +C 450 WRITE (IUNIT,1054) FINC +C +C CONTOUR HIGH AND LOW VALUES +C +C 460 WRITE (IUNIT,1055) +C IF (CHILO) GO TO 470 +C WRITE (IUNIT,1056) +C GO TO 480 +C 470 WRITE (IUNIT,1057) HI,FLO +C +C CALL CONOT2 IF NOT QUICK VERSION +C +C 480 IF (IVER .NE. 1) CALL CONOT2 (IVER,IUNIT) +C +C THE ROUTINE CONOT2 WAS GENERATED TO ELIMINATE COMPILER ERRORS +C RESULTING FROM TOO MANY FORMAT STATEMENTS IN ONE SUBROUTINE +C +C RETURN +C +C +C1001 FORMAT (1X,'CONRAQ') +C1002 FORMAT (1X,'CONRAN') +C1003 FORMAT (1X,'CONRAS') +C1004 FORMAT ('+',6X,'-OPTION VALUE SETTINGS',/ +C 1 ,7X,'ALL NON-PWRIT VALUES APPLY TO THE UNSCALED DATA') +C1005 FORMAT (5X,'PERIMETER, PER=') +C1006 FORMAT ('+',19X,'OFF') +C1007 FORMAT ('+',19X,'ON') +C1008 FORMAT (5X,'GRID, GRD=') +C1009 FORMAT ('+',14X,'OFF') +C1010 FORMAT ('+',14X,'ON') +C1011 FORMAT (5X,'SCALING OF PLOT ON FRAME, SCA=') +C1012 FORMAT ('+',34X,'ON') +C1013 FORMAT ('+',34X,'OFF') +C1014 FORMAT ('+',34X,'PRI') +C1015 FORMAT (5X,'SAME DATA FOR ANOTHER PLOT, REP=') +C1016 FORMAT ('+',36X,'OFF') +C1017 FORMAT ('+',36X,'ON') +C1018 FORMAT (5X,'EXTRAPOLATION, EXT=') +C1019 FORMAT ('+',23X,'OFF') +C1020 FORMAT ('+',23X,'ON') +C1021 FORMAT (5X,'RESOLUTION, SSZ=',I4) +C1022 FORMAT (5X,'MESSAGE, MES=') +C1023 FORMAT ('+',17X,'OFF') +C1024 FORMAT ('+',17X,'ON') +C1025 FORMAT (5X,'TITLE, TLE=') +C1026 FORMAT ('+',15X,'OFF') +C1027 FORMAT ('+',15X,'ON') +C1028 FORMAT (5X,'TITLE SIZE IN PWRIT UNITS, STL=',I4) +C1029 FORMAT (5X,'TITLE=',A64) +C1030 FORMAT (5X,'DATA POINTS USED FOR PARTIAL DERIVATIVE', +C 1' ESTIMATION, NCP=',I4) +C1031 FORMAT (5X,'LOOK AT TRIANGLES, TRI=') +C1032 FORMAT ('+',27X,'OFF') +C1033 FORMAT ('+',27X,'ON') +C1034 FORMAT (5X,'ADVANCE FRAME BEFORE PLOTTING TRIANGULATION,', +C 1' TFR=') +C1035 FORMAT ('+',53X,'OFF') +C1036 FORMAT ('+',53X,'ON') +C1037 FORMAT (5X,'TRIANGULATION ONLY PLOT, TOP=') +C1038 FORMAT ('+',33X,'OFF') +C1039 FORMAT ('+',33X,'ON') +C1040 FORMAT (5X,'PLOT THE INPUT DATA VALUES, PDV=') +C1041 FORMAT ('+',36X,'OFF') +C1042 FORMAT ('+',36X,'ON') +C1043 FORMAT (5X,'FORMAT OF THE PLOTTED INPUT DATA, FMT=') +C1044 FORMAT ('+',42X,'(G10.3)') +C1045 FORMAT ('+',42X,A10) +C1046 FORMAT (5X,'SIZE OF THE PLOTTED DATA VALUES IN PWRIT', +C 1' UNITS, SPD=',I4) +C1047 FORMAT (5X,'COLOR (INTENSITY) INDICES FOLLOW.', +C 1' FOR CONRAQ MAJOR CONTOURS ARE ONLY USED') +C1048 FORMAT (10X,'MAJOR CONTOUR LINES, MAJ=',I4,/ +C 1 ,10X,'MINOR CONTOUR LINES, MIN=',I4,/ +C 2 ,10X,'TITLE AND MESSAGE, LAB=',I4,/ +C 3 ,10X,'PLOTTED DATA VALUES, DAT=',I4) +C1049 FORMAT (5X,'CONTOUR LEVELS, CON=') +C1050 FORMAT ('+',25X,'OFF') +C1051 FORMAT ('+',25X,'ON, NCL=',I4,' ARRAY='/(10(2X,F10.3))) +C1052 FORMAT (5X,'CONTOUR INCREMENT, CIL=') +C1053 FORMAT ('+',27X,'OFF') +C 1054 FORMAT ('+',27X,'ON, INCREMENT=',G10.3) +C 1055 FORMAT (5X,'CONTOUR HIGH AND LOW VALUES, CHL=') +C 1056 FORMAT ('+',37X,'OFF') +C 1057 FORMAT ('+',37X,'ON, HI=',G10.3,' FLO=',G10.3) +C 2000 FORMAT (5X,'SHIELDING, SLD=') +C 2001 FORMAT ('+',19X,'OFF') +C 2002 FORMAT ('+',19X,'ON') +C 2003 FORMAT (5X,'INTERPOLATION, ITP=') +C 2004 FORMAT ('+',23X,'C1 SURFACE') +C 2005 FORMAT ('+',23X,'LINEAR') +C 2006 FORMAT (5X,'PLOT THE SHIELD, SPT=') +C 2007 FORMAT ('+',25X,'OFF') +C 2008 FORMAT ('+',25X,'ON') +C + END diff --git a/sys/gio/ncarutil/conlib/conpdv.f b/sys/gio/ncarutil/conlib/conpdv.f new file mode 100644 index 00000000..49c1f61f --- /dev/null +++ b/sys/gio/ncarutil/conlib/conpdv.f @@ -0,0 +1,118 @@ + SUBROUTINE CONPDV (XD,YD,ZD,NDP) +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 PLOT THE DATA VALUES ON THE CONTOUR MAP +C CURRENTLY UP TO 10 CHARACTERS FOR EACH VALUE ARE DISPLAYED +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C + CHARACTER*10 ISTR + DIMENSION XD(1) ,YD(1) ,ZD(1) +C + SAVE +C +C DATA TO CONVERT 0-32767 COORIDNATES TO 1-1024 VALUES +C + DATA TRANS/32./ +C +C SET INTENSITY +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C SET FORMAT IF NONE SPECIFIED +C + IF (LEN .NE. 0) GO TO 110 + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD +C +C LOOP AND PLOT ALL VALUES +C + 110 DO 120 K=1,NDP + CALL FL2INT (XD(K),YD(K),MX,MY) + MX = IFIX(FLOAT(MX)/TRANS)+1 + MY = IFIX(FLOAT(MY)/TRANS)+1 +C +C + NOAO - FTN internal write rewritten as call to encode for IRAF +C +C WRITE(ISTR,FORM)ZD(K) + call encode (len, form, istr, zd(k)) +C +C - NOAO +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) +C + CALL WTSTR(XC,YC,ISTR,ISIZEP,0,0) + CALL GSELNT(ICN) + 120 CONTINUE + IF (INDAT .NE. 1) THEN + CALL GSTXCI (IRANTX) + ENDIF + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conreo.f b/sys/gio/ncarutil/conlib/conreo.f new file mode 100644 index 00000000..c029c0bb --- /dev/null +++ b/sys/gio/ncarutil/conlib/conreo.f @@ -0,0 +1,129 @@ + SUBROUTINE CONREO (MAJLNS) +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 THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MAJLNS. PV IS USED AS A WORK SPACE. MINGAP IS +C THE NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS +C BETWEEN MAJOR LEVELS). +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 /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C + NL = NCL + IF (NL.LE.4 .OR. MINGAP.LE.1) GO TO 160 + NML = MINGAP-1 + IF (NL.LE.10) NML = 1 +C +C CHECK FOR BREAK POINT IN THE LIST OF CONTOURS FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 10 I=1,NL + ISAVE = I + IF (CL(I).EQ.BPSIZ) GO TO 40 + 10 CONTINUE +C +C NO BREAKPOINT FOUND SO TRY FOR A NICE NUMBER +C + L = NL/2 + L = ALOG10( ABS( CL(L) ) )+1. + Q = 10.**L + DO 30 J=1,3 + Q = Q/10. + DO 20 I=1,NL + ISAVE = I + IF (AMOD( ABS( CL(I) + 1.E-9*CL(I) )/Q,FLOAT(NMLP1) ).LE. + 1 .0001) GO TO 40 + 20 CONTINUE + 30 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN PV +C + 40 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART.EQ.0) ISTART = NMLP1 + NMAJL = 0 + DO 50 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + PV(NMAJL) = CL(I) + 50 CONTINUE + MAJLNS = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN PV +C + IC = NML/2 + 1 + L = MAJLNS+1 + DO 100 LOOP=1,NML + IC1 = IC + DO 90 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 60 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + IF (IC1.GE.NMLP1) GO TO 90 + IF (IC1.LE.0) GO TO 90 + 60 DO 70 K=ISTART,NL,NMLP1 + IND = K+IC1 + IF (IND.GT.NL) GO TO 80 + PV(L) = CL(IND) + L = L+1 + 70 CONTINUE + 80 IF (LOOP.EQ.1) GO TO 100 + 90 CONTINUE + 100 CONTINUE +C +C IF MAJOR LINES DID NOT START ON THE FIRST ENTRY PICK UP THE MISSING +C LEVELS +C + IF (ISTART.EQ.1) GO TO 140 + DO 130 LOOP=1,NML + IC1 = IC + DO 120 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 110 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + 110 IF (IC1.GE.ISTART) GO TO 120 + IF (IC1.LE.0) GO TO 120 + PV(L) = CL(IC1) + L = L+1 + IF (LOOP.EQ.1) GO TO 130 + 120 CONTINUE + 130 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 140 DO 150 I=1,NL + CL(I) = PV(I) + 150 CONTINUE + RETURN + 160 MAJLNS = NL + RETURN + END diff --git a/sys/gio/ncarutil/conlib/consld.f b/sys/gio/ncarutil/conlib/consld.f new file mode 100644 index 00000000..fd40e10d --- /dev/null +++ b/sys/gio/ncarutil/conlib/consld.f @@ -0,0 +1,165 @@ + SUBROUTINE CONSLD (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 THIS ROUTINE IS USED TO GENERATE A SHIELD WHERE CONTOUR +C DRAWING IS ALLOWED. +C +C THE ROUTINE TAKES THE SILHOUETTE INFORMATION FROM COMMON BLOCK +C CONR13 AND TRANSFORMS THIS INTO A SHIELD TO BE USED IN THE +C SCRATCH ARRAY PASSED IN BY THE USER (THE SCRATCH ARRAY HOLDS THE +C GRIDED DATA FROM THE INTERPOLATION). +C +C INPUT +C SCRARR-THE SCRATCH ARRAY HOLDING THE INTERPOLATED DATA +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + 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 /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C +C INCREASE THE RESOLUTION OF THE SHIELD PROFILE +C + DIMENSION SCRARR(1) +C + SAVE + DATA RESINC/8.0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C +C +NOAO +C These statement functions are never called. +C SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C IARVL(IXX,IYY) = IYY+(IXX-1)*IYMAX +C -NOAO + IGADDR(XXX,YYY) = + 1 IFIX((YYY-YST)/STPSZ+.5)+(IFIX((XXX-XST)/STPSZ+.5))*IYMAX +C +C SET THE SPECIAL VALUE +C + SPVAL = SPVAL * 2. +C +C SET THE USER ARRAY LOCATIONS TO TEMPORARY POINTERS +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 1,ICOUNT +C +C ASSIGN LINE SEGMENT END POINTS +C + X1 = XVS(IC) + Y1 = YVS(IC) + IF (IC .EQ. ICOUNT) GO TO 10 + X2 = XVS(IC+1) + Y2 = YVS(IC+1) + GO TO 15 + 10 CONTINUE + X2 = XVS(1) + Y2 = YVS(1) + 15 CONTINUE +C +C INSURE THAT ALL POINTS ARE IN THE CONVEX HULL +C + IF (X1.GT.XED) X1 = XED + IF (X1.LT.XST) X1 = XST + IF (X2.GT.XED) X2 = XED + IF (X2.LT.XST) X2 = XST + IF (Y1.GT.YED) Y1 = YED + IF (Y1.LT.YST) Y1 = YST + IF (Y2.GT.YED) Y2 = YED + IF (Y2.LT.YST) Y2 = YST +C +C SET THE START OF THE LINE SEGMENT SCRATCH LOCATION TO +C THE SPECIAL VALUE +C + II = IGADDR(X1,Y1) + SCRARR(II) = SPVAL +C +C FIND THE LENGTH OF THE LINE SEGMENT +C + DIST = SQRT(((X2-X1)**2)+((Y2-Y1)**2)) +C +C IF LENGTH SHORTER THAN STEP SIZE THEN THERE IS NOTHING TO DO +C + IF (DIST .LE. STPSZ) GO TO 100 +C +C SET UP LOOP TO SET ALL CELLS ON THE LINE SEGMENT +C + NSTPS = (DIST/STPSZ)*RESINC + XSTP = (X2-X1)/FLOAT(NSTPS) + YSTP = (Y2-Y1)/FLOAT(NSTPS) + X = X1 + Y = Y1 + DO 20 K = 1,NSTPS + X = X + XSTP + Y = Y + YSTP + II = IGADDR(X,Y) + SCRARR(II) = SPVAL + 20 CONTINUE +C + 100 CONTINUE +C +C FILL THE SHIELDED AREAS +C FOR EACH COLUMN THE ELEMENTS ARE SET TO SPVAL IF FILL IS TRUE. +C THE VALUE OF FILL IS NEGATED EVERY TIME A SPVAL IS ENCOUNTERED, +C AND THAT CELL REMAINS UNCHANGED. +C +C LOOP THROUGH THE GRID +C + DO 39 I = 1,IXMAX +C +C GET THE START AND END FOR THE COLUMN +C + IYS = (I-1)*IYMAX+1 + IYE = I*IYMAX +C +C ADVANCE IN THE FORWARD DIRECTION +C + DO 32 J = IYS,IYE +C +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(J).EQ.SPVAL) GO TO 33 + SCRARR(J) = SPVAL + 32 CONTINUE + GO TO 39 +C +C ADVANCE IN THE BACKWARD DIRECTION +C + 33 CONTINUE + DO 34 J = 1,IYMAX + NJ =IYE+1-J +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(NJ).EQ.SPVAL) GO TO 39 + SCRARR(NJ) = SPVAL + 34 CONTINUE + 39 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conssd.f b/sys/gio/ncarutil/conlib/conssd.f new file mode 100644 index 00000000..26ac20d1 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conssd.f @@ -0,0 +1,61 @@ + SUBROUTINE CONSSD(X,Y,IC) +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 THIS SUBROUTINE SETS THE SHIELDING FLAG AND CONNECTS THE +C USERS SHIELD ARRAYS TO SOME INTERNAL POINTERS +C +C INPUT +C X-X COORDINATE STRING +C Y-Y COORDINATE STRING +C IC-NUMBER OF COORDINATES +C +C NOTE THE USERS ARRAYS CANNOT BE MUCKED WITH DURING EXECUTION +C THOSE ARRAYS ARE USED DURING CONRAN EXECUTION +C + DIMENSION X(1),Y(1) + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C SET COUNTER +C + ICOUNT = IC +C +C CHECK THE DIMENSION OF SHIELD ARRAYS +C + IERUNT = I1MACH(4) + IF (ICOUNT .GT. 50) THEN + CALL SETER (' CONSSD -- NUMBER OF SHIELD POINTS .GT. 50',1,1) +C +C + NOAO - FTN write and format statement commented out; SETER is enough. +C WRITE(IERUNT,1001) + ICOUNT = 50 + ENDIF +C1001 FORMAT(' ERROR 1 IN CONSSD -- NUMBER OF SHIELD POINTS .GT. 50') +C - NOAO +C +C SET THE SHIELDING FLAG TO TRUE +C + SHIELD = .TRUE. +C +C COMPUTE POINTERS FOR THE USERS SHIELDING ARRAYS +C + DO 300 I = 1,ICOUNT + XVS(I) = X(I) + 300 YVS(I) = Y(I) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/constp.f b/sys/gio/ncarutil/conlib/constp.f new file mode 100644 index 00000000..8df0e23b --- /dev/null +++ b/sys/gio/ncarutil/conlib/constp.f @@ -0,0 +1,135 @@ + SUBROUTINE CONSTP (XD,YD,NDP) +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 COMPUTE STEP SIZE IN X AND Y DIRECTION +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) +C + SAVE +C +C FIND SMALLEST AND LARGST X AND Y +C + XST = XD(1) + XED = XD(1) + YST = YD(1) + YED = YD(1) + DO 130 I=2,NDP + IF (XST .LE. XD(I)) GO TO 100 + XST = XD(I) + GO TO 110 + 100 IF (XED .GE. XD(I)) GO TO 110 + XED = XD(I) + 110 IF (YST .LE. YD(I)) GO TO 120 + YST = YD(I) + GO TO 130 + 120 IF (YED .GE. YD(I)) GO TO 130 + YED = YD(I) + 130 CONTINUE +C +C COMPUTE STEP SIZE +C + XRG = (ABS(XED-XST)) + YRG = (ABS(YED-YST)) + SQRG = XRG + IF (SQRG .LT. YRG) SQRG = YRG + STPSZ = SQRG/FLOAT(IGRAD-1) +C +C COMPUTE PARAMETERS FOR SET CALL +C + DIFX = XRG/SQRG + DIFY = YRG/SQRG + PXST = .5-(BORD*DIFX)/2. + PXED = .5+(BORD*DIFX)/2. + PYST = .5-(BORD*DIFY)/2. + PYED = .5+(BORD*DIFY)/2. + XRG = XRG/FLOAT(ITICK) + YRG = YRG/FLOAT(ITICK) +C +C TEST IF THE ASPECT RATIO FOR THE COORDINATES IS REASONABLE. +C REASONABLE IS CURRENTLY DEFINED AS 5 TO 1. +C IF IT IS NOT REASONABLE THEN A POOR PLOT MAY BE GENERATED +C SO IT IS NICE THE WARN THE USER WHEN THIS HAPPENS. +C + TEST = XRG/YRG + IF (TEST.LE.5. .AND. TEST.GE.0.2) RETURN +C +C WARN THE USER ON THE STANDARD OUTPUT UNIT THAT THE PLOT MAY +C NOT BE TOO GOOD. +C +C SET RECOVERY MODE +C + CALL ENTSR(IROLD,IREC) +C +C FLAG THE ERROR +C + CALL SETER(' ASPECT RATIO OF X AND Y GREATER THAN 5 TO 1', + 1 1,1) +C + CALL EPRIN +C +C CLEAR THE ERROR +C + CALL ERROF +C +C RESET USER ERROR MODE +C + CALL ENTSR(IDUM,IROLD) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contlk.f b/sys/gio/ncarutil/conlib/contlk.f new file mode 100644 index 00000000..201b4d07 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contlk.f @@ -0,0 +1,98 @@ + SUBROUTINE CONTLK (XD,YD,NDP,IPT) +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 THE TRIANGLES CREATED BY CONTNG +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 /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,IPT(1) +C + SAVE +C +C STATEMENT FUNCTIONS TO SCALE DATA FOR OVERLAYS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C ADVANCE PICTURE IF DESIRED +C + IF (FRADV) CALL FRAME +C +C DRAW TRIANGLES +C + DO 100 K=1,NT + I = K*3 + I1 = IPT(I) + I2 = IPT(I-1) + I3 = IPT(I-2) + XX = FX(XD(I1),YD(I1)) + CALL FL2INT (XX,FY(XD(I1),YD(I1)),MX1,MY1) + CALL PLOTIT (MX1,MY1,0) + XX = FX(XD(I2),YD(I2)) + CALL FL2INT (XX,FY(XD(I2),YD(I2)),MX,MY) + CALL PLOTIT (MX,MY,1) + XX = FX(XD(I3),YD(I3)) + CALL FL2INT (XX,FY(XD(I3),YD(I3)),MX,MY) + CALL PLOTIT (MX,MY,1) + CALL PLOTIT (MX1,MY1,1) + 100 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contng.f b/sys/gio/ncarutil/conlib/contng.f new file mode 100644 index 00000000..7ebad596 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contng.f @@ -0,0 +1,432 @@ + SUBROUTINE CONTNG (NDP,XD,YD,NT,IPT,NL,IPL,IWL,IWP,WK) +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 THIS SUBROUTINE PERFORMS TRIANGULATION. IT DIVIDES THE X-Y +C PLANE INTO A NUMBER OF TRIANGLES ACCORDING TO GIVEN DATA +C POINTS IN THE PLANE, DETERMINES LINE SEGMENTS THAT FORM THE +C BORDER OF DATA AREA, AND DETERMINES THE TRIANGLE NUMBERS +C CORRESPONDING TO THE BORDER LINE SEGMENTS. +C AT COMPLETION, POINT NUMBERS OF THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. POINT NUMBERS OF THE END POINTS +C OF EACH BORDER LINE SEGMENT ARE LISTED COUNTER-CLOCKWISE, +C LISTING ORDER OF THE LINE SEGMENTS BEING COUNTER-CLOCKWISE. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD = ARRAY OF DIMENSION NDP CONTAINING THE +C X COORDINATES OF THE DATA POINTS, +C YD = ARRAY OF DIMENSION NDP CONTAINING THE +C Y COORDINATES OF THE DATA POINTS. +C THE OUTPUT PARAMETERS ARE +C NT = NUMBER OF TRIANGLES, +C IPT = ARRAY OF DIMENSION 6*NDP-15, WHERE THE POINT +C NUMBERS OF THE VERTEXES OF THE (IT)TH TRIANGLE +C ARE TO BE STORED AS THE (3*IT-2)ND, (3*IT-1)ST, +C AND (3*IT)TH ELEMENTS, IT=1,2,...,NT, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = ARRAY OF DIMENSION 6*NDP, WHERE THE POINT +C NUMBERS OF THE END POINTS OF THE (IL)TH BORDER +C LINE SEGMENT AND ITS RESPECTIVE TRIANGLE NUMBER +C ARE TO BE STORED AS THE (3*IL-2)ND, (3*IL-1)ST, +C AND (3*IL)TH ELEMENTS, IL=1,2,..., NL. +C THE OTHER PARAMETERS ARE +C IWL = INTEGER ARRAY OF DIMENSION 18*NDP USED +C INTERNALLY AS A WORK AREA, +C IWP = INTEGER ARRAY OF DIMENSION NDP USED +C INTERNALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + SAVE +C + INTEGER CONXCH + COMMON /CONRA3/ IREC + DIMENSION XD(*) ,YD(*) ,IPT(*) ,IPL(*) , + 1 IWL(*) ,IWP(*) ,WK(*) + DIMENSION ITF(2) + CHARACTER*4 IP1C, IP2C + CHARACTER*64 ITEMP + DATA RATIO/1.0E-6/, NREP/100/ +C +C STATEMENT FUNCTIONS +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 + SIDE(U1,V1,U2,V2,U3,V3) = (V3-V1)*(U2-U1)-(U3-U1)*(V2-V1) +C +C PRELIMINARY PROCESSING +C + NDPM1 = NDP-1 +C +C DETERMINES THE CLOSEST PAIR OF DATA POINTS AND THEIR MIDPOINT. +C + DSQMN = DSQF(XD(1),YD(1),XD(2),YD(2)) + IPMN1 = 1 + IPMN2 = 2 + DO 140 IP1=1,NDPM1 + X1 = XD(IP1) + Y1 = YD(IP1) + IP1P1 = IP1+1 + DO 130 IP2=IP1P1,NDP + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .NE. 0.) GO TO 120 +C +C ERROR, IDENTICAL INPUT DATA POINTS +C + ITEMP = ' CONTNG-IDENTICAL INPUT DATA POINTS FOUND + 1 AT AND ' +C +C + NOAO - FTN internal writes rewritten as calls to encode for IRAF +C +C WRITE(IP1C,'(I4)')IP1 +C WRITE(IP2C,'(I4)')IP2 + call encode (4, '(I4)', ip1c, ip1) + call encode (4, '(I4)', ip2c, ip2) +C - NOAO +C + CALL SETER (ITEMP,1,1) + ITEMP(46:49) = IP1C + ITEMP(55:58) = IP2C + RETURN + 120 IF (DSQI .GE. DSQMN) GO TO 130 + DSQMN = DSQI + IPMN1 = IP1 + IPMN2 = IP2 + 130 CONTINUE + 140 CONTINUE + DSQ12 = DSQMN + XDMP = (XD(IPMN1)+XD(IPMN2))/2.0 + YDMP = (YD(IPMN1)+YD(IPMN2))/2.0 +C +C SORTS THE OTHER (NDP-2) DATA POINTS IN ASCENDING ORDER OF +C DISTANCE FROM THE MIDPOINT AND STORES THE SORTED DATA POINT +C NUMBERS IN THE IWP ARRAY. +C + JP1 = 2 + DO 150 IP1=1,NDP + IF (IP1.EQ.IPMN1 .OR. IP1.EQ.IPMN2) GO TO 150 + JP1 = JP1+1 + IWP(JP1) = IP1 + WK(JP1) = DSQF(XDMP,YDMP,XD(IP1),YD(IP1)) + 150 CONTINUE + DO 170 JP1=3,NDPM1 + DSQMN = WK(JP1) + JPMN = JP1 + DO 160 JP2=JP1,NDP + IF (WK(JP2) .GE. DSQMN) GO TO 160 + DSQMN = WK(JP2) + JPMN = JP2 + 160 CONTINUE + ITS = IWP(JP1) + IWP(JP1) = IWP(JPMN) + IWP(JPMN) = ITS + WK(JPMN) = WK(JP1) + 170 CONTINUE +C +C IF NECESSARY, MODIFIES THE ORDERING IN SUCH A WAY THAT THE +C FIRST THREE DATA POINTS ARE NOT COLLINEAR. +C + AR = DSQ12*RATIO + X1 = XD(IPMN1) + Y1 = YD(IPMN1) + DX21 = XD(IPMN2)-X1 + DY21 = YD(IPMN2)-Y1 + DO 180 JP=3,NDP + IP = IWP(JP) + IF (ABS((YD(IP)-Y1)*DX21-(XD(IP)-X1)*DY21) .GT. AR) GO TO 190 + 180 CONTINUE + CALL SETER (' CONTNG - ALL COLLINEAR DATA POINTS',1,1) + 190 IF (JP .EQ. 3) GO TO 210 + JPMX = JP + JP = JPMX+1 + DO 200 JPC=4,JPMX + JP = JP-1 + IWP(JP) = IWP(JP-1) + 200 CONTINUE + IWP(3) = IP +C +C FORMS THE FIRST TRIANGLE. STORES POINT NUMBERS OF THE VER- +C TEXES OF THE TRIANGLE IN THE IPT ARRAY, AND STORES POINT NUM- +C BERS OF THE BORDER LINE SEGMENTS AND THE TRIANGLE NUMBER IN +C THE IPL ARRAY. +C + 210 IP1 = IPMN1 + IP2 = IPMN2 + IP3 = IWP(3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 220 + IP1 = IPMN2 + IP2 = IPMN1 + 220 NT0 = 1 + NTT3 = 3 + IPT(1) = IP1 + IPT(2) = IP2 + IPT(3) = IP3 + NL0 = 3 + NLT3 = 9 + IPL(1) = IP1 + IPL(2) = IP2 + IPL(3) = 1 + IPL(4) = IP2 + IPL(5) = IP3 + IPL(6) = 1 + IPL(7) = IP3 + IPL(8) = IP1 + IPL(9) = 1 +C +C ADDS THE REMAINING (NDP-3) DATA POINTS, ONE BY ONE. +C + DO 400 JP1=4,NDP + IP1 = IWP(JP1) + X1 = XD(IP1) + Y1 = YD(IP1) +C +C - DETERMINES THE VISIBLE BORDER LINE SEGMENTS. +C + IP2 = IPL(1) + JPMN = 1 + DXMN = XD(IP2)-X1 + DYMN = YD(IP2)-Y1 + DSQMN = DXMN**2+DYMN**2 + ARMN = DSQMN*RATIO + JPMX = 1 + DXMX = DXMN + DYMX = DYMN + DSQMX = DSQMN + ARMX = ARMN + DO 240 JP2=2,NL0 + IP2 = IPL(3*JP2-2) + DX = XD(IP2)-X1 + DY = YD(IP2)-Y1 + AR = DY*DXMN-DX*DYMN + IF (AR .GT. ARMN) GO TO 230 + DSQI = DX**2+DY**2 + IF (AR.GE.(-ARMN) .AND. DSQI.GE.DSQMN) GO TO 230 + JPMN = JP2 + DXMN = DX + DYMN = DY + DSQMN = DSQI + ARMN = DSQMN*RATIO + 230 AR = DY*DXMX-DX*DYMX + IF (AR .LT. (-ARMX)) GO TO 240 + DSQI = DX**2+DY**2 + IF (AR.LE.ARMX .AND. DSQI.GE.DSQMX) GO TO 240 + JPMX = JP2 + DXMX = DX + DYMX = DY + DSQMX = DSQI + ARMX = DSQMX*RATIO + 240 CONTINUE + IF (JPMX .LT. JPMN) JPMX = JPMX+NL0 + NSH = JPMN-1 + IF (NSH .LE. 0) GO TO 270 +C +C - SHIFTS (ROTATES) THE IPL ARRAY TO HAVE THE INVISIBLE BORDER +C - LINE SEGMENTS CONTAINED IN THE FIRST PART OF THE IPL ARRAY. +C + NSHT3 = NSH*3 + DO 250 JP2T3=3,NSHT3,3 + JP3T3 = JP2T3+NLT3 + IPL(JP3T3-2) = IPL(JP2T3-2) + IPL(JP3T3-1) = IPL(JP2T3-1) + IPL(JP3T3) = IPL(JP2T3) + 250 CONTINUE + DO 260 JP2T3=3,NLT3,3 + JP3T3 = JP2T3+NSHT3 + IPL(JP2T3-2) = IPL(JP3T3-2) + IPL(JP2T3-1) = IPL(JP3T3-1) + IPL(JP2T3) = IPL(JP3T3) + 260 CONTINUE + JPMX = JPMX-NSH +C +C - ADDS TRIANGLES TO THE IPT ARRAY, UPDATES BORDER LINE +C - SEGMENTS IN THE IPL ARRAY, AND SETS FLAGS FOR THE BORDER +C - LINE SEGMENTS TO BE REEXAMINED IN THE IWL ARRAY. +C + 270 JWL = 0 + DO 310 JP2=JPMX,NL0 + JP2T3 = JP2*3 + IPL1 = IPL(JP2T3-2) + IPL2 = IPL(JP2T3-1) + IT = IPL(JP2T3) +C +C - - ADDS A TRIANGLE TO THE IPT ARRAY. +C + NT0 = NT0+1 + NTT3 = NTT3+3 + IPT(NTT3-2) = IPL2 + IPT(NTT3-1) = IPL1 + IPT(NTT3) = IP1 +C +C - - UPDATES BORDER LINE SEGMENTS IN THE IPL ARRAY. +C + IF (JP2 .NE. JPMX) GO TO 280 + IPL(JP2T3-1) = IP1 + IPL(JP2T3) = NT0 + 280 IF (JP2 .NE. NL0) GO TO 290 + NLN = JPMX+1 + NLNT3 = NLN*3 + IPL(NLNT3-2) = IP1 + IPL(NLNT3-1) = IPL(1) + IPL(NLNT3) = NT0 +C +C - - DETERMINES THE VERTEX THAT DOES NOT LIE ON THE BORDER +C - - LINE SEGMENTS. +C + 290 ITT3 = IT*3 + IPTI = IPT(ITT3-2) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3-1) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 300 IF (CONXCH(XD,YD,IP1,IPTI,IPL1,IPL2) .EQ. 0) GO TO 310 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(ITT3-2) = IPTI + IPT(ITT3-1) = IPL1 + IPT(ITT3) = IP1 + IPT(NTT3-1) = IPTI + IF (JP2 .EQ. JPMX) IPL(JP2T3) = IT + IF (JP2.EQ.NL0 .AND. IPL(3).EQ.IT) IPL(3) = NT0 +C +C - - SETS FLAGS IN THE IWL ARRAY. +C + JWL = JWL+4 + IWL(JWL-3) = IPL1 + IWL(JWL-2) = IPTI + IWL(JWL-1) = IPTI + IWL(JWL) = IPL2 + 310 CONTINUE + NL0 = NLN + NLT3 = NLNT3 + NLF = JWL/2 + IF (NLF .EQ. 0) GO TO 400 +C +C - IMPROVES TRIANGULATION. +C + NTT3P3 = NTT3+3 + DO 390 IREP=1,NREP + DO 370 ILF=1,NLF + ILFT2 = ILF*2 + IPL1 = IWL(ILFT2-1) + IPL2 = IWL(ILFT2) +C +C - - LOCATES IN THE IPT ARRAY TWO TRIANGLES ON BOTH SIDES OF +C - - THE FLAGGED LINE SEGMENT. +C + NTF = 0 + DO 320 ITT3R=3,NTT3,3 + ITT3 = NTT3P3-ITT3R + IPT1 = IPT(ITT3-2) + IPT2 = IPT(ITT3-1) + IPT3 = IPT(ITT3) + IF (IPL1.NE.IPT1 .AND. IPL1.NE.IPT2 .AND. + 1 IPL1.NE.IPT3) GO TO 320 + IF (IPL2.NE.IPT1 .AND. IPL2.NE.IPT2 .AND. + 1 IPL2.NE.IPT3) GO TO 320 + NTF = NTF+1 + ITF(NTF) = ITT3/3 + IF (NTF .EQ. 2) GO TO 330 + 320 CONTINUE + IF (NTF .LT. 2) GO TO 370 +C +C - - DETERMINES THE VERTEXES OF THE TRIANGLES THAT DO NOT LIE +C - - ON THE LINE SEGMENT. +C + 330 IT1T3 = ITF(1)*3 + IPTI1 = IPT(IT1T3-2) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3-1) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3) + 340 IT2T3 = ITF(2)*3 + IPTI2 = IPT(IT2T3-2) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3-1) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 350 IF (CONXCH(XD,YD,IPTI1,IPTI2,IPL1,IPL2) .EQ. 0) + 1 GO TO 370 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(IT1T3-2) = IPTI1 + IPT(IT1T3-1) = IPTI2 + IPT(IT1T3) = IPL1 + IPT(IT2T3-2) = IPTI2 + IPT(IT2T3-1) = IPTI1 + IPT(IT2T3) = IPL2 +C +C - - SETS NEW FLAGS. +C + JWL = JWL+8 + IWL(JWL-7) = IPL1 + IWL(JWL-6) = IPTI1 + IWL(JWL-5) = IPTI1 + IWL(JWL-4) = IPL2 + IWL(JWL-3) = IPL2 + IWL(JWL-2) = IPTI2 + IWL(JWL-1) = IPTI2 + IWL(JWL) = IPL1 + DO 360 JLT3=3,NLT3,3 + IPLJ1 = IPL(JLT3-2) + IPLJ2 = IPL(JLT3-1) + IF ((IPLJ1.EQ.IPL1 .AND. IPLJ2.EQ.IPTI2) .OR. + 1 (IPLJ2.EQ.IPL1 .AND. IPLJ1.EQ.IPTI2)) + 2 IPL(JLT3) = ITF(1) + IF ((IPLJ1.EQ.IPL2 .AND. IPLJ2.EQ.IPTI1) .OR. + 1 (IPLJ2.EQ.IPL2 .AND. IPLJ1.EQ.IPTI1)) + 2 IPL(JLT3) = ITF(2) + 360 CONTINUE + 370 CONTINUE + NLFC = NLF + NLF = JWL/2 + IF (NLF .EQ. NLFC) GO TO 400 +C +C - - RESETS THE IWL ARRAY FOR THE NEXT ROUND. +C + JWL = 0 + JWL1MN = (NLFC+1)*2 + NLFT2 = NLF*2 + DO 380 JWL1=JWL1MN,NLFT2,2 + JWL = JWL+2 + IWL(JWL-1) = IWL(JWL1-1) + IWL(JWL) = IWL(JWL1) + 380 CONTINUE + NLF = JWL/2 + 390 CONTINUE + 400 CONTINUE +C +C REARRANGE THE IPT ARRAY SO THAT THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. +C + DO 410 ITT3=3,NTT3,3 + IP1 = IPT(ITT3-2) + IP2 = IPT(ITT3-1) + IP3 = IPT(ITT3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 410 + IPT(ITT3-2) = IP2 + IPT(ITT3-1) = IP1 + 410 CONTINUE + NT = NT0 + NL = NL0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conxch.f b/sys/gio/ncarutil/conlib/conxch.f new file mode 100644 index 00000000..6309f360 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conxch.f @@ -0,0 +1,67 @@ + INTEGER FUNCTION CONXCH (X,Y,I1,I2,I3,I4) +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 THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO +C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION +C BY C. L. LAWSON. +C THE INPUT PARAMETERS ARE +C X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA +C POINTS, +C I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2, +C P3, AND P4 THAT FORM A QUADRILATERAL +C WITH P3 AND P4 CONNECTED DIADONALLY. +C THIS FUNCTION RETURNS A VALUE 1 (ONE) WHEN AN EXCHANGE IS +C NEEDED, AND 0 (ZERO) OTHERWISE. +C DECLARATION STATEMENTS +C + DIMENSION X(1) ,Y(1) + DIMENSION X0(4) ,Y0(4) + EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ),(A4SQ,B1SQ), + 1 (B4SQ,A2SQ),(C4SQ,C3SQ) +C + SAVE +C +C STATEMENT FUNCTIONS +C +C CALCULATION +C + X0(1) = X(I1) + Y0(1) = Y(I1) + X0(2) = X(I2) + Y0(2) = Y(I2) + X0(3) = X(I3) + Y0(3) = Y(I3) + X0(4) = X(I4) + Y0(4) = Y(I4) + IDX = 0 + U3 = (Y0(2)-Y0(3))*(X0(1)-X0(3))-(X0(2)-X0(3))*(Y0(1)-Y0(3)) + U4 = (Y0(1)-Y0(4))*(X0(2)-X0(4))-(X0(1)-X0(4))*(Y0(2)-Y0(4)) + IF (U3*U4 .LE. 0.0) GO TO 100 + U1 = (Y0(3)-Y0(1))*(X0(4)-X0(1))-(X0(3)-X0(1))*(Y0(4)-Y0(1)) + U2 = (Y0(4)-Y0(2))*(X0(3)-X0(2))-(X0(4)-X0(2))*(Y0(3)-Y0(2)) + A1SQ = (X0(1)-X0(3))**2+(Y0(1)-Y0(3))**2 + B1SQ = (X0(4)-X0(1))**2+(Y0(4)-Y0(1))**2 + C1SQ = (X0(3)-X0(4))**2+(Y0(3)-Y0(4))**2 + A2SQ = (X0(2)-X0(4))**2+(Y0(2)-Y0(4))**2 + B2SQ = (X0(3)-X0(2))**2+(Y0(3)-Y0(2))**2 + C3SQ = (X0(2)-X0(1))**2+(Y0(2)-Y0(1))**2 + S1SQ = U1*U1/(C1SQ*AMAX1(A1SQ,B1SQ)) + S2SQ = U2*U2/(C2SQ*AMAX1(A2SQ,B2SQ)) + S3SQ = U3*U3/(C3SQ*AMAX1(A3SQ,B3SQ)) + S4SQ = U4*U4/(C4SQ*AMAX1(A4SQ,B4SQ)) + IF (AMIN1(S1SQ,S2SQ) .LT. AMIN1(S3SQ,S4SQ)) IDX = 1 + 100 CONXCH = IDX + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/mkpkg b/sys/gio/ncarutil/conlib/mkpkg new file mode 100644 index 00000000..5ebdc2cb --- /dev/null +++ b/sys/gio/ncarutil/conlib/mkpkg @@ -0,0 +1,37 @@ +# Update the CONCOM and CONTERP contributions to LIBNCAR. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + concal.f + concld.f + concls.f + concom.f + condet.f + condrw.f + condsd.f + conecd.f + congen.f + conint.f + conlcm.f + conlin.f + conloc.f + conlod.f + conop1.f + conop2.f + conop3.f + conop4.f + conot2.f + conout.f + conpdv.f + conreo.f + consld.f + conssd.f + constp.f + contlk.f + contng.f + conxch.f + ; |