CONTENT: C Interpolation of Irregularly Spaced Data C############################################################################### C Package: akima C Version: 0.3-4 C Title: Interpolation of irregularly spaced data C Author: Fortran code by H. Akima C R port by Albrecht Gebhardt <albrecht.gebhardt@uni-klu.ac.at> C Maintainer: Albrecht Gebhardt <albrecht.gebhardt@uni-klu.ac.at> C Description: Linear or cubic spline interpolation for irregular gridded data C License: Fortran code: ACM, free for non-commercial use, R functions GPL C DW: C Added - No Debian Package available C SUBROUTINE SDBI3P(MD,NDP,XD,YD,ZD,NIP,XI,YI, ZI,IER, WK,IWK, + EXTRPI,NEAR,NEXT,DIST) * * Scattered-data bivariate interpolation * (a master subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine performs bivariate interpolation when the data * points are scattered in the x-y plane. It is based on the * revised Akima method that has the accuracy of a cubic (third- * degree) polynomial. * * The input arguments are * MD = mode of computation * = 1 for new XD-YD (default) * = 2 for old XD-YD, new ZD * = 3 for old XD-YD, old ZD, * NDP = number of data points (must be 10 or greater), * XD = array of dimension NDP containing the x coordinates * of the data points, * YD = array of dimension NDP containing the y coordinates * of the data points, * ZD = array of dimension NDP containing the z values at * the data points, * NIP = number of output points at which interpolation is * to be performed (must be 1 or greater), * XI = array of dimension NIP containing the x coordinates * of the output points, * YI = array of dimension NIP containing the y coordinates * of the output points. * * The output arguments are * ZI = array of dimension NIP, where interpolated z values * are to be stored, * IER = error flag * = 0 for no errors * = 1 for NDP = 9 or less * = 2 for NDP not equal to NDPPV * = 3 for NIP = 0 or less * = 9 for errors in SDTRAN called by this subroutine. * * The other arguments are * WK = two-dimensional array of dimension NDP*17 used * internally as a work area, * IWK = two-dimensional integer array of dimension NDP*25 * used internally as a work area. * * agebhard@uni-klu.ac.at: added from new TRIPACK: * NEAR, NEXT, DIST work arrays from TRMESH, size NDP * * The very first call to this subroutine and the call with a new * NDP value or new XD and YD arrays must be made with MD=1. The * call with MD=2 must be preceded by another call with the same * NDP value and same XD and YD arrays. The call with MD=3 must * be preceded by another call with the same NDP value and same * XD, YD, and ZD arrays. Between the call with MD=2 and its * preceding call, the IWK array must not be disturbed. Between * the call with MD=3 and its preceding call, the WK and IWK * arrays must not be disturbed. * * The user of this subroutine can save the storage, by NDP*6 * numerical storage units, by placing the statement * EQUIVALENCE (WK(1,1),IWK(1,20)) * in the program that calls this subroutine. * * The constant in the PARAMETER statement below is * NIPIMX = maximum number of output points to be processed * at a time. * The constant value has been selected empirically. * * This subroutine calls the SDTRAN, SDPD3P, SDLCTN, and SDPLNL * subroutines. * * * Specification statements * .. Parameters .. INTEGER NIPIMX PARAMETER (NIPIMX=51) * .. * .. Scalar Arguments .. INTEGER IER,MD,NDP,NIP,NEAR(NDP),NEXT(NDP) * .. * .. Array Arguments .. DOUBLE PRECISION WK(NDP,17),XD(NDP),XI(NIP),YD(NDP), + YI(NIP),ZD(NDP),ZI(NIP),DIST(NDP) INTEGER IWK(NDP,25) LOGICAL EXTRPI(NIP) * .. * .. Local Scalars .. INTEGER IERT,IIP,NDPPV,NIPI,NL,NT * .. * .. Local Arrays .. INTEGER ITLI(NIPIMX),KTLI(NIPIMX) * .. * .. External Subroutines .. EXTERNAL SDLCTN,SDPD3P,SDPLNL,SDTRAN * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Save statement .. SAVE NDPPV,NT,NL * .. * Error check IF (NDP.LE.9) GO TO 20 IF (MD.NE.2 .AND. MD.NE.3) THEN NDPPV = NDP ELSE IF (NDP.NE.NDPPV) GO TO 30 END IF IF (NIP.LE.0) GO TO 40 * Triangulates the x-y plane. (for MD=1) IF (MD.NE.2 .AND. MD.NE.3) THEN CALL SDTRAN(NDP,XD,YD, NT,IWK(1,1),NL,IWK(1,7),IERT, + IWK(1,1),IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9), + NEAR,NEXT,DIST) * CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, * + LIST,LPTR,LEND,LTRI,ITL) IF (IERT.GT.0) GO TO 50 END IF * Estimates partial derivatives at all data points. (for MD=1,2) IF (MD.NE.3) THEN CALL SDPD3P(NDP,XD,YD,ZD, WK(1,1), WK(1,6),WK(1,15),WK(1,17), + IWK(1,9),IWK(1,10),IWK(1,19)) * CALL SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP) END IF * Locates all points at which interpolation is to be performed * and interpolates the ZI values. (for MD=1,2,3) DO 10 IIP = 1,NIP,NIPIMX NIPI = MIN(NIP-IIP+1,NIPIMX) CALL SDLCTN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),NIPI,XI(IIP), + YI(IIP), KTLI,ITLI) * CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI) CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1),NIPI, + XI(IIP),YI(IIP),KTLI,ITLI, ZI(IIP), EXTRPI(IIP)) * CALL SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD, * + NIP,XI,YI,KTLI,ITLI, ZI) 10 CONTINUE * Normal return IER = 0 RETURN * Error exit 20 WRITE (*,FMT=9000) MD,NDP IER = 1 RETURN 30 WRITE (*,FMT=9010) MD,NDP,NDPPV IER = 2 RETURN 40 WRITE (*,FMT=9020) MD,NDP,NIP IER = 3 RETURN 50 WRITE (*,FMT=9030) IER = 9 RETURN * Format statement for error message 9000 FORMAT (' ',/,'*** SDBI3P Error 1: NDP = 9 or less',/,' MD =', + I5,', NDP =',I5,/) 9010 FORMAT (' ',/,'*** SDBI3P Error 2: NDP not equal to NDPPV',/, + ' MD =',I5,', NDP =',I5,', NDPPV =',I5,/) 9020 FORMAT (' ',/,'*** SDBI3P Error 3: NIP = 0 or less',/,' MD =', + I5,', NDP =',I5,', NIP =',I5,/) 9030 FORMAT (' Error detected in SDTRAN called by SDBI3P',/) END SUBROUTINE SDSF3P(MD,NDP,XD,YD,ZD,NXI,XI,NYI,YI, ZI,IER, WK,IWK, + EXTRPI,NEAR,NEXT,DIST) * * Scattered-data smooth surface fitting * (a master subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine performs smooth surface fitting when the data * points are scattered in the x-y plane. It is based on the * revised Akima method that has the accuracy of a cubic (third- * degree) polynomial. * * The input arguments are * MD = mode of computation * = 1 for new XD-YD (default) * = 2 for old XD-YD, new ZD * = 3 for old XD-YD, old ZD, * NDP = number of data points (must be 10 or greater), * XD = array of dimension NDP containing the x coordinates * of the data points, * YD = array of dimension NDP containing the y coordinates * of the data points, * ZD = array of dimension NDP containing the z values at * the data points, * NXI = number of output grid points in the x coordinate * (must be 1 or greater), * XI = array of dimension NXI containing the x coordinates * of the output grid points, * NYI = number of output grid points in the y coordinate * (must be 1 or greater), * YI = array of dimension NYI containing the y coordinates * of the output grid points. * * The output arguments are * ZI = two-dimensional array of dimension NXI*NYI, where * the interpolated z values at the output grid points * are to be stored, * IER = error flag * = 0 for no errors * = 1 for NDP = 9 or less * = 2 for NDP not equal to NDPPV * = 3 for NXI = 0 or less * = 4 for NYI = 0 or less * = 9 for errors in SDTRAN called by this subroutine. * * The other arguments are * WK = two-dimensional array of dimension NDP*36 used * internally as a work area, * IWK = two-dimensional integer array of dimension NDP*25 * used internally as a work area. * * agebhard@uni-klu.ac.at: added from new TRIPACK: * NEAR, NEXT, DIST work arrays from TRMESH, size NDP * * The very first call to this subroutine and the call with a new * NDP value or new XD and YD arrays must be made with MD=1. The * call with MD=2 must be preceded by another call with the same * NDP value and same XD and YD arrays. The call with MD=3 must * be preceded by another call with the same NDP value and same * XD, YD, and ZD arrays. Between the call with MD=2 and its * preceding call, the IWK array must not be disturbed. Between * the call with MD=3 and its preceding call, the WK and IWK * arrays must not be disturbed. * * The user of this subroutine can save the storage, by NDP*6 * numeric storage units, by placing the statement * EQUIVALENCE (WK(1,1),IWK(1,20)) * in the program that calls this subroutine. * * The constant in the PARAMETER statement below is * NIPIMX = maximum number of output points to be processed * at a time. * The constant value has been selected empirically. * * This subroutine calls the SDTRAN, SDPD3P, SDLCTN, and SDPLNL * subroutines. * * * Specification statements * .. Parameters .. INTEGER NIPIMX PARAMETER (NIPIMX=51) * .. * .. Scalar Arguments .. INTEGER IER,MD,NDP,NXI,NYI,NEAR(NDP),NEXT(NDP) * .. * .. Array Arguments .. DOUBLE PRECISION WK(NDP,17),XD(NDP),XI(NXI),YD(NDP), + YI(NYI),ZD(NDP),ZI(NXI,NYI),DIST(NDP) INTEGER IWK(NDP,25) LOGICAL EXTRPI(NXI,NYI) * .. * .. Local Scalars .. INTEGER IERT,IIP,IXI,IYI,NDPPV,NIPI,NL,NT * .. * .. Local Arrays .. DOUBLE PRECISION YII(NIPIMX) INTEGER ITLI(NIPIMX),KTLI(NIPIMX) * .. * .. External Subroutines .. EXTERNAL SDLCTN,SDPD3P,SDPLNL,SDTRAN * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Save statement .. SAVE NDPPV,NT,NL * .. * Error check IF (NDP.LE.9) GO TO 40 IF (MD.NE.2 .AND. MD.NE.3) THEN NDPPV = NDP ELSE IF (NDP.NE.NDPPV) GO TO 50 END IF IF (NXI.LE.0) GO TO 60 IF (NYI.LE.0) GO TO 70 * Triangulates the x-y plane. (for MD=1) IF (MD.NE.2 .AND. MD.NE.3) THEN CALL SDTRAN(NDP,XD,YD, NT,IWK(1,1),NL,IWK(1,7),IERT, + IWK(1,1),IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9), + NEAR,NEXT,DIST) * CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, * + LIST,LPTR,LEND,LTRI,ITL) IF (IERT.GT.0) GO TO 80 END IF * Estimates partial derivatives at all data points. (for MD=1,2) IF (MD.NE.3) THEN CALL SDPD3P(NDP,XD,YD,ZD, WK(1,1), WK(1,6),WK(1,15),WK(1,17), + IWK(1,9),IWK(1,10),IWK(1,19)) * CALL SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP) END IF * Locates all grid points at which interpolation is to be * performed and interpolates the ZI values. (for MD=1,2,3) DO 30 IYI = 1,NYI DO 10 IIP = 1,NIPIMX YII(IIP) = YI(IYI) 10 CONTINUE DO 20 IXI = 1,NXI,NIPIMX NIPI = MIN(NXI-IXI+1,NIPIMX) CALL SDLCTN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),NIPI, + XI(IXI),YII, KTLI,ITLI) * CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI) CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1), + NIPI,XI(IXI),YII,KTLI,ITLI, ZI(IXI,IYI), + EXTRPI(IXI,IYI)) * CALL SDPLNL(NDP,XD,YD,ZD,NT,ITP,NL,IPL,PDD, * + NIP,XI,YI,KTLI,ITLI, ZI) 20 CONTINUE 30 CONTINUE * Normal return IER = 0 RETURN * Error exit 40 WRITE (*,FMT=9000) MD,NDP IER = 1 RETURN 50 WRITE (*,FMT=9010) MD,NDP,NDPPV IER = 2 RETURN 60 WRITE (*,FMT=9020) MD,NDP,NXI,NYI IER = 3 RETURN 70 WRITE (*,FMT=9030) MD,NDP,NXI,NYI IER = 4 RETURN 80 WRITE (*,FMT=9040) IER = 9 RETURN * Format statement for error message 9000 FORMAT (' ',/,'*** SDSF3P Error 1: NDP = 9 or less',/,' MD =', + I5,', NDP =',I5,/) 9010 FORMAT (' ',/,'*** SDSF3P Error 2: NDP not equal to NDPPV',/, + ' MD =',I5,', NDP =',I5,' NDPPV =',I5,/) 9020 FORMAT (' ',/,'*** SDSF3P Error 3: NXI = 0 or less',/,' MD =', + I5,', NDP =',I5,' NXI =',I5,', NYI =',I5,/) 9030 FORMAT (' ',/,'*** SDSF3P Error 4: NYI = 0 or less',/,' MD =', + I5,', NDP =',I5,' NXI =',I5,', NYI =',I5,/) 9040 FORMAT (' Error detected in SDTRAN called by SDSF3P',/) END SUBROUTINE SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, LIST,LPTR,LEND, + LTRI,ITL,NEAR,NEXT,DIST) * * Triangulation of the data area in a plane with a scattered data * point set * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine triangulates the data area in the x-y plane with * a scattered data point set. It divides the data area into a * number of triangles and determines line segments that form the * border of the data area. * * This subroutine consists of the following two steps, i.e., * (1) basic triangulation in the convex hull of the data points, * and (2) removal of thin triangles along the border line of the * data area. It calls the SDTRCH and SDTRTT subroutines, that * correspond to Steps (1) and (2), respectively. * * The input arguments are * NDP = number of data points (must be greater than 3), * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points. * * The output arguments are * NT = number of triangles (its maximum is 2*NDP-5), * IPT = two-dimensional integer array of dimension * (3,NT), where the point numbers of the vertexes * of the ITth triangle are to be stored counter- * clockwise in the ITth column, where IT = 1, 2, * ..., NT, * NL = number of border line segments (its maximum is * NDP), * IPL = two-dimensional integer array of dimension * (2,NL), where the point numbers of the end * points of the (IL)th border line segment are to * be stored counterclockwise in the ILth column, * where IL = 1, 2, ..., NL, with the line segments * stored counterclockwise, * IERT = error flag * = 0 for no errors * = 1 for NDP = 3 or less * = 2 for identical data points * = 3 for all collinear data points. * * The other arguments are * LIST = integer array of dimension 6*NDP USED internally * as a work area, * LPTR = integer array of dimension 6*NDP USED internally * as a work area, * LEND = integer array of dimension NDP USED internally as * a work area, * LTRI = two-dimensional integer array of dimension 12*NDP * used internally as a work area. * ITL = integer array of dimension NDP used internally as * a work area. * * agebhard@uni-klu.ac.at: added from new TRIPACK: * NEAR, NEXT, DIST work arrays from TRMESH, size NDP * * * Specification statements * .. Scalar Arguments .. INTEGER IERT,NDP,NL,NT,NEAR(NDP),NEXT(NDP) * .. * .. Array Arguments .. DOUBLE PRECISION XD(NDP),YD(NDP),DIST(NDP) INTEGER IPL(2,*),IPT(3,*),ITL(NDP),LEND(NDP),LIST(6,NDP), + LPTR(6,NDP),LTRI(12,NDP) * .. * .. Local Scalars .. INTEGER IERTL,IERTM,IP1 * .. * .. External Subroutines .. EXTERNAL SDTRCH,SDTRTT * .. * Basic triangulation CALL SDTRCH(NDP,XD,YD, NT,IPT,NL,IPL,IERTM,IERTL, LIST,LPTR,LEND, + LTRI,NEAR,NEXT,DIST) IF (IERTM.NE.0) GO TO 10 IF (IERTL.NE.0) GO TO 20 IERT = 0 * Removal of thin triangles that share border line segments CALL SDTRTT(NDP,XD,YD, NT,IPT,NL,IPL, ITL) RETURN * Error exit 10 IF (IERTM.EQ.-1) THEN IERT = 1 WRITE (*,FMT=9000) NDP ELSE IF (IERTM.EQ.-2) THEN IERT = 2 WRITE (*,FMT=9010) ELSE IERT = 3 IP1 = IERTM WRITE (*,FMT=9020) NDP,IP1,XD(IP1),YD(IP1) END IF RETURN 20 IF (IERTL.EQ.1) THEN IERT = 4 WRITE (*,FMT=9030) NDP ELSE IF (IERTL.EQ.2) THEN IERT = 5 WRITE (*,FMT=9040) END IF RETURN * Format statements 9000 FORMAT (' ',/,'*** SDTRAN Error 1: NDP = 3 or less',/,' NDP =', + I5) 9010 FORMAT (' ',/,'*** SDTRAN Error 2: ', + 'The first three data points are collinear.',/) 9020 FORMAT (' ',/,'*** SDTRAN Error 3: Identical data points',/, + ' NDP =',I5,', IP1 =',I5,', XD =',E11.3,', YD =', + E11.3) 9030 FORMAT (' ',/,'*** SDTRAN Error 4: NDP outside its valid', + ' range',/,' NDP =',I5) 9040 FORMAT (' ',/,'*** SDTRAN Error 5: ', + 'Invalid data structure (LIST,LPTR,LEND)',/) END SUBROUTINE SDTRCH(NDP,XD,YD, NT,IPT,NL,IPL,IERTM,IERTL, + LIST,LPTR,LEND,LTRI,NEAR,NEXT,DIST) * * Basic triangulation in the convex hull of a scattered data point * set in a plane * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine triangulates the data area that is a convex hull * of the scattered data points in the x-y plane. It divides the * data area into a number of triangles and determines line segments * that form the border of the data area. * * This subroutine depends on the TRIPACK package of ACM Algorithm * 751 by R. J. Renka. It calls the TRMESH and TRLIST subroutines * included in the package. The TRMESH subroutine in turn calls * either directly or indirectly 12 other subprograms included in * the package. * * The input arguments are * NDP = number of data points (must be greater than 3), * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points. * * The output arguments are * NT = number of triangles (its maximum is 2*NDP-5), * IPT = two-dimensional integer array of dimension * (3,NT), where the point numbers of the vertexes * of the ITth triangle are to be stored counter- * clockwise in the ITth column, where IT = 1, 2, * ..., NT, * NL = number of border line segments (its maximum is * NDP), * IPL = two-dimensional integer array of dimension * (2,NL), where the point numbers of the end * points of the (IL)th border line segment are to * be stored counterclockwise in the ILth column, * where IL = 1, 2, ..., NL, with the line segments * stored counterclockwise, * IERTM = error flag from the TRMESH subroutine, * = 0 for no errors * = -1 for NDP = 3 or less * = -2 for the first three collinear data points, * = L for the Lth data point identical to some * Mth data point, M > L. * IERTL = error flag from the TRLIST subroutine, * = 0 for no errors * = 1 for invalid NCC, NDP, or NROW value. * = 2 for invalid data structure (LIST,LPTR,LEND). * * The other arguments are * LIST = integer array of dimension 6*NDP USED internally * as a work area, * LPTR = integer array of dimension 6*NDP USED internally * as a work area, * LEND = integer array of dimension NDP USED internally as * a work area, * LTRI = two-dimensional integer array of dimension 12*NDP * used internally as a work area. * * agebhard@uni-klu.ac.at: added from new TRIPACK: * NEAR, NEXT, DIST work arrays from TRMESH, size NDP * * Specification statements * .. Parameters .. INTEGER NCC,NROW PARAMETER (NCC=0,NROW=6) * .. * .. Scalar Arguments .. INTEGER IERTL,IERTM,NDP,NL,NT,NEAR(NDP),NEXT(NDP) * .. * .. Array Arguments .. DOUBLE PRECISION XD(NDP),YD(NDP),DIST(NDP) INTEGER IPL(2,*),IPT(3,*),LEND(NDP),LIST(*),LPTR(*), + LTRI(NROW,*) * .. * .. Local Scalars .. INTEGER I,I1,I2,IL,IL1,IL2,IPL11,IPL21,J,LNEW * .. * .. Local Arrays .. INTEGER LCC(1),LCT(1) * .. * .. External Subroutines .. EXTERNAL TRLIST,TRMESH * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * Performs basic triangulation. CALL TRMESH(NDP,XD,YD, LIST,LPTR,LEND,LNEW,NEAR,NEXT,DIST,IERTM) IF (IERTM.NE.0) RETURN CALL TRLIST(NCC,LCC,NDP,LIST,LPTR,LEND,NROW, NT,LTRI,LCT,IERTL) IF (IERTL.NE.0) RETURN * Extracts the triangle data from the LTRI array and set the IPT * array. DO 20 J = 1,NT DO 10 I = 1,3 IPT(I,J) = LTRI(I,J) 10 CONTINUE 20 CONTINUE * Extracts the border-line-segment data from the LTRI array and * set the IPL array. IL = 0 DO 50 J = 1,NT DO 30 I = 1,3 IF (LTRI(I+3,J).LE.0) GO TO 40 30 CONTINUE GO TO 50 40 IL = IL + 1 I1 = MOD(I,3) + 1 I2 = MOD(I+1,3) + 1 IPL(1,IL) = LTRI(I1,J) IPL(2,IL) = LTRI(I2,J) 50 CONTINUE NL = IL * Sorts the IPL array. DO 80 IL1 = 1,NL - 1 DO 60 IL2 = IL1 + 1,NL IF (IPL(1,IL2).EQ.IPL(2,IL1)) GO TO 70 60 CONTINUE 70 IPL11 = IPL(1,IL1+1) IPL21 = IPL(2,IL1+1) IPL(1,IL1+1) = IPL(1,IL2) IPL(2,IL1+1) = IPL(2,IL2) IPL(1,IL2) = IPL11 IPL(2,IL2) = IPL21 80 CONTINUE RETURN END SUBROUTINE SDTRTT(NDP,XD,YD, NT,IPT,NL,IPL, ITL) * * Removal of thin triangles along the border line of triangulation * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine removes thin triangles along the border line of * triangulation. * * The input arguments are * NDP = number of data points (must be greater than 3), * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points. * * The input and output arguments are * NT = number of triangles (its maximum is 2*NDP-5), * IPT = two-dimensional integer array of dimension * (3,NT), where the point numbers of the vertexes * of the ITth triangle are to be stored counter- * clockwise in the ITth column, where IT = 1, 2, * ..., NT, * NL = number of border line segments (its maximum is * NDP), * IPL = two-dimensional integer array of dimension * (2,NL), where the point numbers of the end * points of the (IL)th border line segment are to * be stored counterclockwise in the ILth column, * where IL = 1, 2, ..., NL, with the line segments * stored counterclockwise. * * The other argument is * ITL = integer array of dimension NDP used internally as * a work area. * * The constants in the PARAMETER statement below are * HBRMN = minimum value of the height-to-bottom ratio of a * triangle along the border line of the data area, * NRRTT = number of repetitions in thin triangle removal. * The constant values have been selected empirically. * * Specification statements * .. Parameters .. DOUBLE PRECISION HBRMN INTEGER NRRTT PARAMETER (HBRMN=0.10,NRRTT=5) * .. * .. Scalar Arguments .. INTEGER NDP,NL,NT * .. * .. Array Arguments .. DOUBLE PRECISION XD(NDP),YD(NDP) INTEGER IPL(2,*),IPT(3,*),ITL(NDP) * .. * .. Local Scalars .. DOUBLE PRECISION HBR,U1,U2,U3,V1,V2,V3 INTEGER IL,IL0,IL00,IL1,ILP1,ILR1,IP1,IP2,IP3,IPL1,IPL2, + IREP,IT,IT0,ITP1,IV,IVP1,MODIF,NL0 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Statement Functions .. DOUBLE PRECISION DSQF,VPDT * .. * Statement Function definitions DSQF(U1,V1,U2,V2) = (U2-U1)**2 + (V2-V1)**2 VPDT(U1,V1,U2,V2,U3,V3) = (V3-V1)* (U2-U1) - (U3-U1)* (V2-V1) * .. * Triangle numbers of triangles that share line segments with the * border line. DO 20 IL = 1,NL IPL1 = IPL(1,IL) IPL2 = IPL(2,IL) DO 10 IT = 1,NT IF (IPL1.EQ.IPT(1,IT) .OR. IPL1.EQ.IPT(2,IT) .OR. + IPL1.EQ.IPT(3,IT)) THEN IF (IPL2.EQ.IPT(1,IT) .OR. IPL2.EQ.IPT(2,IT) .OR. + IPL2.EQ.IPT(3,IT)) THEN ITL(IL) = IT GO TO 20 END IF END IF 10 CONTINUE 20 CONTINUE * Removes thin triangles that share line segments with the border * line. DO 130 IREP = 1,NRRTT MODIF = 0 NL0 = NL IL = 0 DO 120 IL0 = 1,NL0 IL = IL + 1 IP1 = IPL(1,IL) IP2 = IPL(2,IL) IT = ITL(IL) * Calculates the height-to-bottom ratio of the triangle. IF (IPT(1,IT).NE.IP1 .AND. IPT(1,IT).NE.IP2) THEN IP3 = IPT(1,IT) ELSE IF (IPT(2,IT).NE.IP1 .AND. IPT(2,IT).NE.IP2) THEN IP3 = IPT(2,IT) ELSE IP3 = IPT(3,IT) END IF HBR = VPDT(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3), + YD(IP3))/DSQF(XD(IP1),YD(IP1),XD(IP2),YD(IP2)) IF (HBR.LT.HBRMN) THEN MODIF = 1 * Removes this triangle when applicable. ITP1 = IT + 1 DO 30 IT0 = ITP1,NT IPT(1,IT0-1) = IPT(1,IT0) IPT(2,IT0-1) = IPT(2,IT0) IPT(3,IT0-1) = IPT(3,IT0) 30 CONTINUE NT = NT - 1 DO 40 IL00 = 1,NL IF (ITL(IL00).GT.IT) ITL(IL00) = ITL(IL00) - 1 40 CONTINUE * Replaces the border line segment with two new line segments. IF (IL.LT.NL) THEN ILP1 = IL + 1 DO 50 ILR1 = ILP1,NL IL1 = NL + ILP1 - ILR1 IPL(1,IL1+1) = IPL(1,IL1) IPL(2,IL1+1) = IPL(2,IL1) ITL(IL1+1) = ITL(IL1) 50 CONTINUE END IF * - Adds the first new line segment. IPL(1,IL) = IP1 IPL(2,IL) = IP3 DO 70 IT0 = 1,NT DO 60 IV = 1,3 IF (IPT(IV,IT0).EQ.IP1 .OR. + IPT(IV,IT0).EQ.IP3) THEN IVP1 = MOD(IV,3) + 1 IF (IPT(IVP1,IT0).EQ.IP1 .OR. + IPT(IVP1,IT0).EQ.IP3) GO TO 80 END IF 60 CONTINUE 70 CONTINUE 80 ITL(IL) = IT0 * - Adds the second new line segment. IL = IL + 1 IPL(1,IL) = IP3 IPL(2,IL) = IP2 DO 100 IT0 = 1,NT DO 90 IV = 1,3 IF (IPT(IV,IT0).EQ.IP3 .OR. + IPT(IV,IT0).EQ.IP2) THEN IVP1 = MOD(IV,3) + 1 IF (IPT(IVP1,IT0).EQ.IP3 .OR. + IPT(IVP1,IT0).EQ.IP2) GO TO 110 END IF 90 CONTINUE 100 CONTINUE 110 ITL(IL) = IT0 NL = NL + 1 END IF 120 CONTINUE IF (MODIF.EQ.0) RETURN 130 CONTINUE RETURN END SUBROUTINE SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP) * * Partial derivatives for bivariate interpolation and surface * fitting for scattered data * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine estimates partial derivatives of the first and * second orders at the data points for bivariate interpolation * and surface fitting for scattered data. In most cases, this * subroutine has the accuracy of a cubic (third-degree) * polynomial. * * The input arguments are * NDP = number of data points, * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points, * ZD = array of dimension NDP containing the z values * at the data points. * * The output argument is * PDD = two-dimensional array of dimension 5*NDP, where * the estimated zx, zy, zxx, zxy, and zyy values * at the IDPth data point are to be stored in the * IDPth row, where IDP = 1, 2, ..., NDP. * * The other arguments are * CF3 = two-dimensional array of dimension 9*NDP used * internally as a work area, * CFL1 = two-dimensional array of dimension 2*NDP used * internally as a work area, * DSQ = array of dimension NDP used internally as a work * area, * IDSQ = integer array of dimension NDP used internally * as a work area, * IPC = two-dimensional integer array of dimension 9*NDP * used internally as a work area, * NCP = integer array of dimension NDP used internally * as a work area. * * The constant in the first PARAMETER statement below is * NPEMX = maximum number of primary estimates. * The constant value has been selected empirically. * * The constants in the second PARAMETER statement below are * NPEAMN = minimum number of primary estimates, * NPEAMX = maximum number of primary estimates when * additional primary estimates are added. * The constant values have been selected empirically. * * This subroutine calls the SDCLDP, SDCF3P, and SDLS1P * subroutines. * * * Specification statements * .. Parameters .. INTEGER NPEMX PARAMETER (NPEMX=25) INTEGER NPEAMN,NPEAMX PARAMETER (NPEAMN=3,NPEAMX=6) * .. * .. Scalar Arguments .. INTEGER NDP * .. * .. Array Arguments .. DOUBLE PRECISION CF3(9,NDP),CFL1(2,NDP),DSQ(NDP), + PDD(5,NDP),XD(NDP),YD(NDP),ZD(NDP) INTEGER IDSQ(NDP),IPC(9,NDP),NCP(NDP) * .. * .. Local Scalars .. DOUBLE PRECISION A01,A02,A03,A10,A11,A12,A20,A21,A30, + ALPWT,ANPE,ANPEM1,SMWTF,SMWTI,WTF,WTI,X,Y,ZX,ZY INTEGER IDP1,IDP2,IDPI,IDPPE1,IMN,IPE,IPE1,J,J1,J2,JJ, + JMN,K,NCP2,NCP2P1,NPE * .. * .. Local Arrays .. DOUBLE PRECISION AMPDPE(5),PDDIF(5),PDDII(5), + PDPE(5,NPEMX),PWT(NPEMX),RVWT(NPEMX),SSPDPE(5) INTEGER IDPPE(NPEMX),IPCPE(10,NPEMX) * .. * .. External Subroutines .. EXTERNAL SDCF3P,SDCLDP,SDLS1P * .. * .. Intrinsic Functions .. INTRINSIC EXP,DBLE * .. * Calculation * Selects, at each of the data points, nine data points closest * to the data point in question. CALL SDCLDP(NDP,XD,YD, IPC, DSQ,IDSQ) * Fits, at each of the data points, a cubic (third-degree) * polynomial to z values at the 10 data points that consist of * the data point in question and 9 data points closest to it. CALL SDCF3P(NDP,XD,YD,ZD,IPC, CF3,NCP) * Performs, at each of the data points, the least-squares fit of * a plane to z values at the 10 data points. CALL SDLS1P(NDP,XD,YD,ZD,IPC,NCP, CFL1) * Outermost DO-loop with respect to the data point DO 310 IDP1 = 1,NDP * Selects data point sets for sets of primary estimates of partial * derivatives. * - Selects a candidate. NPE = 0 DO 80 IDP2 = 1,NDP NCP2 = NCP(IDP2) NCP2P1 = NCP2 + 1 IF (IDP2.EQ.IDP1) GO TO 20 DO 10 J = 1,NCP2 IF (IPC(J,IDP2).EQ.IDP1) GO TO 20 10 CONTINUE GO TO 80 20 IPCPE(1,NPE+1) = IDP2 DO 30 J = 1,NCP2 IPCPE(J+1,NPE+1) = IPC(J,IDP2) 30 CONTINUE DO 50 J1 = 1,NCP2 JMN = J1 IMN = IPCPE(JMN,NPE+1) DO 40 J2 = J1,NCP2P1 IF (IPCPE(J2,NPE+1).LT.IMN) THEN JMN = J2 IMN = IPCPE(JMN,NPE+1) END IF 40 CONTINUE IPCPE(JMN,NPE+1) = IPCPE(J1,NPE+1) IPCPE(J1,NPE+1) = IMN 50 CONTINUE * - Checks whether or not the candidate has already been included. IF (NPE.GT.0) THEN DO 70 IPE1 = 1,NPE IDPPE1 = IDPPE(IPE1) IF (NCP2.NE.NCP(IDPPE1)) GO TO 70 DO 60 J = 1,NCP2P1 IF (IPCPE(J,NPE+1).NE. + IPCPE(J,IPE1)) GO TO 70 60 CONTINUE GO TO 80 70 CONTINUE END IF NPE = NPE + 1 IDPPE(NPE) = IDP2 IF (NPE.GE.NPEMX) GO TO 90 80 CONTINUE 90 CONTINUE * Adds additional closest data points when necessary. IF (NPE.LT.NPEAMN) THEN DO 150 JJ = 1,9 IDP2 = IPC(JJ,IDP1) NCP2 = NCP(IDP2) NCP2P1 = NCP2 + 1 IPCPE(1,NPE+1) = IDP2 DO 100 J = 1,NCP2 IPCPE(J+1,NPE+1) = IPC(J,IDP2) 100 CONTINUE DO 120 J1 = 1,NCP2 JMN = J1 IMN = IPCPE(JMN,NPE+1) DO 110 J2 = J1,NCP2P1 IF (IPCPE(J2,NPE+1).LT.IMN) THEN JMN = J2 IMN = IPCPE(JMN,NPE+1) END IF 110 CONTINUE IPCPE(JMN,NPE+1) = IPCPE(J1,NPE+1) IPCPE(J1,NPE+1) = IMN 120 CONTINUE IF (NPE.GT.0) THEN DO 140 IPE1 = 1,NPE IDPPE1 = IDPPE(IPE1) IF (NCP2.NE.NCP(IDPPE1)) GO TO 140 DO 130 J = 1,NCP2P1 IF (IPCPE(J,NPE+1).NE. + IPCPE(J,IPE1)) GO TO 140 130 CONTINUE GO TO 150 140 CONTINUE END IF NPE = NPE + 1 IDPPE(NPE) = IDP2 IF (NPE.GE.NPEAMX) GO TO 160 150 CONTINUE END IF 160 CONTINUE * Calculates the primary estimates of partial derivatives. X = XD(IDP1) Y = YD(IDP1) DO 170 IPE = 1,NPE IDPI = IDPPE(IPE) A10 = CF3(1,IDPI) A20 = CF3(2,IDPI) A30 = CF3(3,IDPI) A01 = CF3(4,IDPI) A11 = CF3(5,IDPI) A21 = CF3(6,IDPI) A02 = CF3(7,IDPI) A12 = CF3(8,IDPI) A03 = CF3(9,IDPI) PDPE(1,IPE) = A10 + X* (2.0*A20+X*3.0*A30) + + Y* (A11+2.0*A21*X+A12*Y) PDPE(2,IPE) = A01 + Y* (2.0*A02+Y*3.0*A03) + + X* (A11+2.0*A12*Y+A21*X) PDPE(3,IPE) = 2.0*A20 + 6.0*A30*X + 2.0*A21*Y PDPE(4,IPE) = A11 + 2.0*A21*X + 2.0*A12*Y PDPE(5,IPE) = 2.0*A02 + 6.0*A03*Y + 2.0*A12*X 170 CONTINUE IF (NPE.EQ.1) GO TO 290 * Weighted values of partial derivatives (through the statement * labeled 280 + 1) * Calculates the probability weight. ANPE = DBLE(NPE) ANPEM1 = DBLE(NPE-1) DO 190 K = 1,5 AMPDPE(K) = 0.0 SSPDPE(K) = 0.0 DO 180 IPE = 1,NPE AMPDPE(K) = AMPDPE(K) + PDPE(K,IPE) SSPDPE(K) = SSPDPE(K) + PDPE(K,IPE)**2 180 CONTINUE AMPDPE(K) = AMPDPE(K)/ANPE SSPDPE(K) = (SSPDPE(K)-ANPE*AMPDPE(K)**2)/ANPEM1 190 CONTINUE DO 210 IPE = 1,NPE ALPWT = 0.0 DO 200 K = 1,5 IF (SSPDPE(K).NE.0.0) ALPWT = ALPWT + + ((PDPE(K,IPE)-AMPDPE(K))**2)/SSPDPE(K) 200 CONTINUE PWT(IPE) = EXP(-ALPWT/2.0) 210 CONTINUE * Calculates the reciprocal of the volatility weight. DO 220 IPE = 1,NPE IDPI = IDPPE(IPE) ZX = CFL1(1,IDPI) ZY = CFL1(2,IDPI) RVWT(IPE) = ((PDPE(1,IPE)-ZX)**2+ (PDPE(2,IPE)-ZY)**2)* + (PDPE(3,IPE)**2+2.0*PDPE(4,IPE)**2+ + PDPE(5,IPE)**2) * ZXX=0.0 * ZXY=0.0 * ZYY=0.0 * RVWT(IPE)=((PDPE(1,IPE)-ZX)**2+(PDPE(2,IPE)-ZY)**2) * + *((PDPE(3,IPE)-ZXX)**2+2.0*(PDPE(4,IPE)-ZXY)**2 * + +(PDPE(5,IPE)-ZYY)**2) 220 CONTINUE * Calculates the weighted values of partial derivatives. DO 230 K = 1,5 PDDIF(K) = 0.0 PDDII(K) = 0.0 230 CONTINUE SMWTF = 0.0 SMWTI = 0.0 DO 260 IPE = 1,NPE IF (RVWT(IPE).GT.0.0) THEN WTF = PWT(IPE)/RVWT(IPE) DO 240 K = 1,5 PDDIF(K) = PDDIF(K) + PDPE(K,IPE)*WTF 240 CONTINUE SMWTF = SMWTF + WTF ELSE WTI = PWT(IPE) DO 250 K = 1,5 PDDII(K) = PDDII(K) + PDPE(K,IPE)*WTI 250 CONTINUE SMWTI = SMWTI + WTI END IF 260 CONTINUE IF (SMWTI.LE.0.0) THEN DO 270 K = 1,5 PDD(K,IDP1) = PDDIF(K)/SMWTF 270 CONTINUE ELSE DO 280 K = 1,5 PDD(K,IDP1) = PDDII(K)/SMWTI 280 CONTINUE END IF GO TO 310 * Only one qualified point set 290 DO 300 K = 1,5 PDD(K,IDP1) = PDPE(K,1) 300 CONTINUE 310 CONTINUE RETURN END SUBROUTINE SDCLDP(NDP,XD,YD, IPC, DSQ,IDSQ) * * Closest data points * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine selects, at each of the data points, nine data * points closest to it. * * The input arguments are * NDP = number of data points, * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points. * * The output argument is * IPC = two-dimensional integer array of dimension 9*NDP, * where the point numbers of nine data points closest * to the IDPth data point, in an ascending order of * the distance from the IDPth point, are to be * stored in the IDPth column, where IDP = 1, 2, * ..., NDP. * * The other arguments are * DSQ = array of dimension NDP used as a work area, * IDSQ = integer array of dimension NDP used as a work * area. * * * Specification statements * .. Scalar Arguments .. INTEGER NDP * .. * .. Array Arguments .. DOUBLE PRECISION DSQ(NDP),XD(NDP),YD(NDP) INTEGER IDSQ(NDP),IPC(9,NDP) * .. * .. Local Scalars .. DOUBLE PRECISION DSQMN INTEGER IDP,IDSQMN,JDP,JDPMN,JDSQMN,JIPC,JIPCMX * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * DO-loop with respect to the data point number DO 50 IDP = 1,NDP * Calculates the distance squared for all data points from the * IDPth data point and stores the data point number and the * calculated results in the IDSQ and DSQ arrays, respectively. DO 10 JDP = 1,NDP IDSQ(JDP) = JDP DSQ(JDP) = (XD(JDP)-XD(IDP))**2 + (YD(JDP)-YD(IDP))**2 10 CONTINUE * Sorts the IDSQ and DSQ arrays in such a way that the IDPth * point is in the first element in each array. IDSQ(IDP) = 1 DSQ(IDP) = DSQ(1) IDSQ(1) = IDP DSQ(1) = 0.0 * Selects nine data points closest to the IDPth data point and * stores the data point numbers in the IPC array. JIPCMX = MIN(NDP-1,10) DO 30 JIPC = 2,JIPCMX JDSQMN = JIPC DSQMN = DSQ(JIPC) JDPMN = JIPC + 1 DO 20 JDP = JDPMN,NDP IF (DSQ(JDP).LT.DSQMN) THEN JDSQMN = JDP DSQMN = DSQ(JDP) END IF 20 CONTINUE IDSQMN = IDSQ(JDSQMN) IDSQ(JDSQMN) = IDSQ(JIPC) DSQ(JDSQMN) = DSQ(JIPC) IDSQ(JIPC) = IDSQMN 30 CONTINUE DO 40 JIPC = 1,9 IPC(JIPC,IDP) = IDSQ(JIPC+1) 40 CONTINUE 50 CONTINUE RETURN END SUBROUTINE SDCF3P(NDP,XD,YD,ZD,IPC, CF,NCP) * * Coefficients of the third-degree polynomial for z(x,y) * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine calculates, for each data point, coefficients * of the third-degree polynomial for z(x,y) fitted to the set of * 10 data points consisting of the data point in question and * nine data points closest to it. When the condition number of * the matrix associated with the 10 data point set is too large, * this subroutine calculates coefficients of the second-degree * polynomial fitted to the set of six data points consisting of * the data point in question and five data points closest to it. * When the condition number of the matrix associated with the six * data point set is too large, this subroutine calculates * coefficients of the first-degree polynomial fitted to the set of * three data points closest to the data point in question. When * the condition number of the matrix associated with the three data * point set is too large, this subroutine calculates coefficients * of the first-degree polynomial fitted to the set of two data * points consisting of the data point in question and one data * point closest to it, assuming that the plane represented by the * polynomial is horizontal in the direction which is at right * angles to the line connecting the two data points. * * The input arguments are * NDP = number of data points, * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points, * ZD = array of dimension NDP containing the z values * at the data points, * IPC = two-dimensional integer array of dimension * 9*NDP containing the point numbers of 9 data * points closest to the IDPth data point in the * IDPth column, where IDP = 1, 2, ..., NDP. * * The output arguments are * CF = two-dimensional array of dimension 9*NDP, * where the coefficients of the polynomial * (a10, a20, a30, a01, a11, a21, a02, a12, a03) * calculated at the IDPth data point are to be * stored in the IDPth column, where IDP = 1, 2, * ..., NDP, * NCP = integer array of dimension NDP, where the numbers * of the closest points used are to be stored. * * The constant in the first PARAMETER statement below is * CNRMX = maximum value of the ratio of the condition * number of the matrix associated with the point * set to the number of points. * The constant value has been selected empirically. * * The N1, N2, and N3 constants in the second PARAMETER statement * are the numbers of the data points used to determine the first-, * second-, and third-degree polynomials, respectively. * * This subroutine calls the SDLEQN subroutine. * * * Specification statements * .. Parameters .. DOUBLE PRECISION CNRMX PARAMETER (CNRMX=1.5E+04) INTEGER N1,N2,N3 PARAMETER (N1=3,N2=6,N3=10) * .. * .. Scalar Arguments .. INTEGER NDP * .. * .. Array Arguments .. DOUBLE PRECISION CF(9,NDP),XD(NDP),YD(NDP),ZD(NDP) INTEGER IPC(9,NDP),NCP(NDP) * .. * .. Local Scalars .. DOUBLE PRECISION CN,DET,X,X1,X2,Y,Y1,Y2,Z1,Z2 INTEGER I,IDP,IDPI,J * .. * .. Local Arrays .. DOUBLE PRECISION AA1(N1,N1),AA2(N2,N2),AA3(N3,N3), + B(N3),CFI(N3),EE(N3,N3),ZZ(N3,N3) INTEGER K(N3) * .. * .. External Subroutines .. EXTERNAL SDLEQN * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. * Main DO-loop with respect to the data point DO 60 IDP = 1,NDP DO 10 J = 1,9 CF(J,IDP) = 0.0 10 CONTINUE * Calculates the coefficients of the set of linear equations * with the 10-point data point set. DO 20 I = 1,N3 IF (I.EQ.1) THEN IDPI = IDP ELSE IDPI = IPC(I-1,IDP) END IF X = XD(IDPI) Y = YD(IDPI) AA3(I,1) = 1.0 AA3(I,2) = X AA3(I,3) = X*X AA3(I,4) = X*X*X AA3(I,5) = Y AA3(I,6) = X*Y AA3(I,7) = X*X*Y AA3(I,8) = Y*Y AA3(I,9) = X*Y*Y AA3(I,10) = Y*Y*Y B(I) = ZD(IDPI) 20 CONTINUE * Solves the set of linear equations. CALL SDLEQN(N3,AA3,B, CFI,DET,CN, K,EE,ZZ) * Stores the calculated results as the coefficients of the * third-degree polynomial when applicable. IF (DET.NE.0.0) THEN IF (CN.LE.CNRMX*DBLE(N3)) THEN DO 30 J = 2,N3 CF(J-1,IDP) = CFI(J) 30 CONTINUE NCP(IDP) = N3 - 1 GO TO 60 END IF END IF * Calculates the coefficients of the set of linear equations * with the 6-point data point set. DO 40 I = 1,N2 IF (I.EQ.1) THEN IDPI = IDP ELSE IDPI = IPC(I-1,IDP) END IF X = XD(IDPI) Y = YD(IDPI) AA2(I,1) = 1.0 AA2(I,2) = X AA2(I,3) = X*X AA2(I,4) = Y AA2(I,5) = X*Y AA2(I,6) = Y*Y B(I) = ZD(IDPI) 40 CONTINUE * Solves the set of linear equations. CALL SDLEQN(N2,AA2,B, CFI,DET,CN, K,EE,ZZ) * Stores the calculated results as the coefficients of the * second-degree polynomial when applicable. IF (DET.NE.0.0) THEN IF (CN.LE.CNRMX*DBLE(N2)) THEN CF(1,IDP) = CFI(2) CF(2,IDP) = CFI(3) CF(4,IDP) = CFI(4) CF(5,IDP) = CFI(5) CF(7,IDP) = CFI(6) NCP(IDP) = N2 - 1 GO TO 60 END IF END IF * Calculates the coefficients of the set of linear equations * with the 3-point data point set. DO 50 I = 1,N1 IDPI = IPC(I,IDP) X = XD(IDPI) Y = YD(IDPI) AA1(I,1) = 1.0 AA1(I,2) = X AA1(I,3) = Y B(I) = ZD(IDPI) 50 CONTINUE * Solves the set of linear equations. CALL SDLEQN(N1,AA1,B, CFI,DET,CN, K,EE,ZZ) * Stores the calculated results as the coefficients of the * first-degree polynomial when applicable. IF (DET.NE.0.0) THEN IF (CN.LE.CNRMX*DBLE(N1)) THEN CF(1,IDP) = CFI(2) CF(4,IDP) = CFI(3) NCP(IDP) = N1 GO TO 60 END IF END IF * Calculates the coefficients of the set of linear equations * with the 2-point data point set when applicable. IDPI = IDP X1 = XD(IDPI) Y1 = YD(IDPI) Z1 = ZD(IDPI) IDPI = IPC(1,IDP) X2 = XD(IDPI) Y2 = YD(IDPI) Z2 = ZD(IDPI) CF(1,IDP) = (X2-X1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2) CF(4,IDP) = (Y2-Y1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2) NCP(IDP) = 1 60 CONTINUE RETURN END SUBROUTINE SDLEQN(N,AA,B, X,DET,CN, K,EE,ZZ) * * Solution of a set of linear equations * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine solves a set of linear equations. * * The input arguments are * N = number of linear equations, * AA = two-dimensional array of dimension N*N * containing the coefficients of the equations, * B = array of dimension N containing the constant * values in the right-hand side of the equations. * * The output arguments are * X = array of dimension N, where the solution is * to be stored, * DET = determinant of the AA array, * CN = condition number of the AA matrix. * * The other arguments are * K = integer array of dimension N used internally * as the work area, * EE = two-dimensional array of dimension N*N used * internally as the work area, * ZZ = two-dimensional array of dimension N*N used * internally as the work area. * * * Specification statements * .. Scalar Arguments .. DOUBLE PRECISION CN,DET INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION AA(N,N),B(N),EE(N,N),X(N),ZZ(N,N) INTEGER K(N) * .. * .. Local Scalars .. DOUBLE PRECISION AAIIJ,AAIJIJ,AAIJMX,AAMX,SA,SZ INTEGER I,IJ,IJP1,IJR,J,JJ,JMX,KJMX * .. * .. Intrinsic Functions .. INTRINSIC ABS,SQRT * .. * Calculation * Initial setting DO 10 J = 1,N K(J) = J 10 CONTINUE DO 30 I = 1,N DO 20 J = 1,N EE(I,J) = 0.0 20 CONTINUE EE(I,I) = 1.0 30 CONTINUE * Calculation of inverse matrix of AA DO 110 IJ = 1,N * Finds out the element having the maximum absolute value in the * IJ th row. AAMX = ABS(AA(IJ,IJ)) JMX = IJ DO 40 J = IJ,N IF (ABS(AA(IJ,J)).GT.AAMX) THEN AAMX = ABS(AA(IJ,J)) JMX = J END IF 40 CONTINUE * Switches two columns in such a way that the element with the * maximum value is on the diagonal. DO 50 I = 1,N AAIJMX = AA(I,IJ) AA(I,IJ) = AA(I,JMX) AA(I,JMX) = AAIJMX 50 CONTINUE KJMX = K(IJ) K(IJ) = K(JMX) K(JMX) = KJMX * Makes the diagonal element to be unity. AAIJIJ = AA(IJ,IJ) IF (AAIJIJ.EQ.0.0) GO TO 210 DO 60 J = IJ,N AA(IJ,J) = AA(IJ,J)/AAIJIJ 60 CONTINUE DO 70 JJ = 1,N EE(IJ,JJ) = EE(IJ,JJ)/AAIJIJ 70 CONTINUE * Eliminates the lower left elements. IF (IJ.LT.N) THEN IJP1 = IJ + 1 DO 100 I = IJP1,N AAIIJ = AA(I,IJ) DO 80 J = IJP1,N AA(I,J) = AA(I,J) - AA(IJ,J)*AAIIJ 80 CONTINUE DO 90 JJ = 1,N EE(I,JJ) = EE(I,JJ) - EE(IJ,JJ)*AAIIJ 90 CONTINUE 100 CONTINUE END IF * Calculates the determinant. IF (IJ.EQ.1) THEN DET = 1.0 END IF DET = DET*AAIJIJ* ((-1)** (IJ+JMX)) 110 CONTINUE * Calculates the elements of the inverse matrix. DO 140 IJR = 1,N IJ = N + 1 - IJR IF (IJ.LT.N) THEN IJP1 = IJ + 1 DO 130 J = IJP1,N DO 120 JJ = 1,N EE(IJ,JJ) = EE(IJ,JJ) - AA(IJ,J)*EE(J,JJ) 120 CONTINUE 130 CONTINUE END IF 140 CONTINUE DO 160 J = 1,N I = K(J) DO 150 JJ = 1,N ZZ(I,JJ) = EE(J,JJ) 150 CONTINUE 160 CONTINUE * Calculation of the condition number of AA SA = 0.0 SZ = 0.0 DO 180 I = 1,N DO 170 J = 1,N SA = SA + AA(I,J)*AA(J,I) SZ = SZ + ZZ(I,J)*ZZ(J,I) 170 CONTINUE 180 CONTINUE CN = SQRT(ABS(SA*SZ)) * Calculation of X vector DO 200 I = 1,N X(I) = 0.0 DO 190 J = 1,N X(I) = X(I) + ZZ(I,J)*B(J) 190 CONTINUE 200 CONTINUE RETURN * Special case where the determinant is zero 210 DO 220 I = 1,N X(I) = 0.0 220 CONTINUE DET = 0.0 RETURN END SUBROUTINE SDLS1P(NDP,XD,YD,ZD,IPC,NCP, CFL1) * * Least squares fit of a linear surface (plane) to z(x,y) values * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine performs the least squares fit of a linear * surface (plane) to a data point set consisting of the data * point in question and several data points closest to it used * in the SDCF3P subroutine. * * The input arguments are * NDP = number of data points, * XD = array of dimension NDP containing the x coordinates * of the data points, * YD = array of dimension NDP containing the y coordinates * of the data points, * ZD = array of dimension NDP containing the z values at * the data points, * IPC = two-dimensional integer array of dimension 9*NDP * containing, in the IDPth column, point numbers of * nine data points closest to the IDPth data point, * where IDP = 1, 2, ..., NDP, * NCP = integer array of dimension NDP containing the * numbers of the closest points used in the SDCF3P * subroutine. * * The output argument is * CFL1 = two-dimensional array of dimension 2*NDP, where * the coefficients (a10, a01) of the least squares * fit, first-degree polynomial calculated at the * IDPth data point are to be stored in the IDPth * column, where IDP = 1, 2, ..., NDP. * * Before this subroutine is called, the SDCF3P subroutine must * have been called. * * * Specification statements * .. Scalar Arguments .. INTEGER NDP * .. * .. Array Arguments .. DOUBLE PRECISION CFL1(2,NDP),XD(NDP),YD(NDP),ZD(NDP) INTEGER IPC(9,NDP),NCP(NDP) * .. * .. Local Scalars .. DOUBLE PRECISION A11,A12,A22,AN,B1,B2,DLT,SX,SXX,SXY, + SXZ,SY,SYY,SYZ,SZ,X,X1,X2,Y,Y1,Y2,Z,Z1,Z2 INTEGER I,IDP,IDPI,NPLS * .. * DO-loop with respect to the data point DO 30 IDP = 1,NDP NPLS = NCP(IDP) + 1 IF (NPLS.EQ.2) GO TO 20 * Performs the least squares fit of a plane. SX = 0.0 SY = 0.0 SXX = 0.0 SXY = 0.0 SYY = 0.0 SZ = 0.0 SXZ = 0.0 SYZ = 0.0 DO 10 I = 1,NPLS IF (I.EQ.1) THEN IDPI = IDP ELSE IDPI = IPC(I-1,IDP) END IF X = XD(IDPI) Y = YD(IDPI) Z = ZD(IDPI) SX = SX + X SY = SY + Y SXX = SXX + X*X SXY = SXY + X*Y SYY = SYY + Y*Y SZ = SZ + Z SXZ = SXZ + X*Z SYZ = SYZ + Y*Z 10 CONTINUE AN = NPLS A11 = AN*SXX - SX*SX A12 = AN*SXY - SX*SY A22 = AN*SYY - SY*SY B1 = AN*SXZ - SX*SZ B2 = AN*SYZ - SY*SZ DLT = A11*A22 - A12*A12 CFL1(1,IDP) = (B1*A22-B2*A12)/DLT CFL1(2,IDP) = (B2*A11-B1*A12)/DLT GO TO 30 20 IDPI = IDP X1 = XD(IDPI) Y1 = YD(IDPI) Z1 = ZD(IDPI) IDPI = IPC(1,IDP) X2 = XD(IDPI) Y2 = YD(IDPI) Z2 = ZD(IDPI) CFL1(1,IDP) = (X2-X1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2) CFL1(2,IDP) = (Y2-Y1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2) 30 CONTINUE RETURN END SUBROUTINE SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI) * * Locating points in a scattered data point set * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine locates points in a scattered data point set in * the x-y plane, i.e., determines to which triangle each of the * points to be located belongs. When a point to be located does * not lie inside the data area, this subroutine determines the * border line segment when the point lies in an outside rectangle, * in an outside triangle, or in the overlap of two outside * rectangles. * * The input arguments are * NDP = number of data points, * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points, * NT = number of triangles, * IPT = two-dimensional integer array of dimension 3*NT * containing the point numbers of the vertexes of * the triangles, * NL = number of border line segments, * IPL = two-dimensional integer array of dimension 2*NL * containing the point numbers of the end points of * the border line segments, * NIP = number of points to be located, * XI = array of dimension NIP containing the x * coordinates of the points to be located, * YI = array of dimension NIP containing the y * coordinates of the points to be located. * * The output arguments are * KTLI = integer array of dimension NIP, where the code * for the type of the piece of plane in which each * interpolated point lies is to be stored * = 1 for a triangle inside the data area * = 2 for a rectangle on the right-hand side of a * border line segment * = 3 for a triangle between two rectangles on the * right-hand side of two consecutive border line * segments * = 4 for a triangle which is an overlap of two * rectangles on the right-hand side of two * consecutive border line segments, * ITLI = integer array of dimension NIP, where the * triangle numbers or the (second) border line * segment numbers corresponding to the points to * be located are to be stored. * * * Specification statements * .. Scalar Arguments .. INTEGER NDP,NIP,NL,NT * .. * .. Array Arguments .. DOUBLE PRECISION XD(NDP),XI(NIP),YD(NDP),YI(NIP) INTEGER IPL(2,NL),IPT(3,NT),ITLI(NIP),KTLI(NIP) * .. * .. Local Scalars .. DOUBLE PRECISION U1,U2,U3,V1,V2,V3,X0,X1,X2,X3,Y0,Y1, + Y2,Y3 INTEGER IIP,IL1,IL2,ILII,IP1,IP2,IP3,ITII,ITLIPV,KTLIPV * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Statement Functions .. DOUBLE PRECISION SPDT,VPDT * .. * Statement Function definitions SPDT(U1,V1,U2,V2,U3,V3) = (U1-U3)* (U2-U3) + (V1-V3)* (V2-V3) VPDT(U1,V1,U2,V2,U3,V3) = (U1-U3)* (V2-V3) - (V1-V3)* (U2-U3) * .. * Outermost DO-loop with respect to the points to be located DO 40 IIP = 1,NIP X0 = XI(IIP) Y0 = YI(IIP) IF (IIP.EQ.1) THEN KTLIPV = 0 ITLIPV = 0 ELSE KTLIPV = KTLI(IIP-1) ITLIPV = ITLI(IIP-1) END IF * Checks if in the same inside triangle as previous. IF (KTLIPV.EQ.1) THEN ITII = ITLIPV IP1 = IPT(1,ITII) IP2 = IPT(2,ITII) IP3 = IPT(3,ITII) X1 = XD(IP1) Y1 = YD(IP1) X2 = XD(IP2) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0) .AND. + (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0) .AND. + (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0)) THEN KTLI(IIP) = 1 ITLI(IIP) = ITII GO TO 40 END IF END IF * Locates inside the data area. DO 10 ITII = 1,NT IP1 = IPT(1,ITII) IP2 = IPT(2,ITII) IP3 = IPT(3,ITII) X1 = XD(IP1) Y1 = YD(IP1) X2 = XD(IP2) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0) .AND. + (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0) .AND. + (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0)) THEN KTLI(IIP) = 1 ITLI(IIP) = ITII GO TO 40 END IF 10 CONTINUE * Locates outside the data area. DO 20 ILII = 1,NL IL1 = ILII IL2 = MOD(IL1,NL) + 1 IP1 = IPL(1,IL1) IP2 = IPL(1,IL2) IP3 = IPL(2,IL2) X1 = XD(IP1) Y1 = YD(IP1) X2 = XD(IP2) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) IF (VPDT(X1,Y1,X3,Y3,X0,Y0).LE.0.0) THEN IF (VPDT(X1,Y1,X3,Y3,X2,Y2).LE.0.0) THEN IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).LE.0.0) .AND. + (SPDT(X3,Y3,X0,Y0,X2,Y2).LE.0.0)) THEN KTLI(IIP) = 3 ITLI(IIP) = IL2 GO TO 40 END IF END IF IF (VPDT(X1,Y1,X3,Y3,X2,Y2).GE.0.0) THEN IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).GE.0.0) .AND. + (SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0)) THEN KTLI(IIP) = 4 ITLI(IIP) = IL2 GO TO 40 END IF END IF END IF 20 CONTINUE DO 30 ILII = 1,NL IL2 = ILII IP2 = IPL(1,IL2) IP3 = IPL(2,IL2) X2 = XD(IP2) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) IF (VPDT(X2,Y2,X3,Y3,X0,Y0).LE.0.0) THEN IF ((SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0) .AND. + (SPDT(X2,Y2,X0,Y0,X3,Y3).GE.0.0)) THEN KTLI(IIP) = 2 ITLI(IIP) = IL2 GO TO 40 END IF END IF 30 CONTINUE 40 CONTINUE END SUBROUTINE SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD,NIP,XI,YI,KTLI, + ITLI, ZI, EXTRPI) * * Polynomials * (a supporting subroutine of the SDBI3P/SDSF3P subroutine package) * * Hiroshi Akima * U.S. Department of Commerce, NTIA/ITS * Version of 1995/05 * * This subroutine determines a polynomial in x and y for each * triangle or rectangle in the x-y plane and calculates the z * value by evaluating the polynomial for the desired points, * for bivariate interpolation and surface fitting for scattered * data. * * The input arguments are * NDP = number of data points, * XD = array of dimension NDP containing the x * coordinates of the data points, * YD = array of dimension NDP containing the y * coordinates of the data points, * ZD = array of dimension NDP containing the z * values at the data points, * NT = number of triangles, * IPT = two-dimensional integer array of dimension 3*NT * containing the point numbers of the vertexes of * the triangles, * NL = number of border line segments, * IPL = two-dimensional integer array of dimension 2*NL * containing the point numbers of the end points of * the border line segments, * PDD = two-dimensional array of dimension 5*NDP * containing the partial derivatives at the data * points, * NIP = number of output points at which interpolation is * to be performed, * XI = array of dimension NIP containing the x * coordinates of the output points, * YI = array of dimension NIP containing the y * coordinates of the output points, * KTLI = integer array of dimension NIP, each element * containing the code for the type of the piece of * the plane in which each output point lies * = 1 for a triangle inside the data area * = 2 for a rectangle on the right-hand side of a * border line segment * = 3 for a triangle between two rectangles on the * right-hand side of two consecutive border * line segments * = 4 for the triangle which is an overlap of two * rectangles on the right-hand side of two * consecutive border line segments, * ITLI = integer array of dimension NIP containing the * triangle numbers or the (second) border line * segment numbers corresponding to the output * points. * * The output argument is * ZI = array of dimension NIP, where the calculated z * values are to be stored. * EXTRPI = logical array of dimension NIP, indicating * if a point resides outside the convex hull (and its Z value * has been extrapolated) * * Specification statements * .. Scalar Arguments .. INTEGER NDP,NIP,NL,NT * .. * .. Array Arguments .. DOUBLE PRECISION PDD(5,NDP),XD(NDP),XI(NIP),YD(NDP), + YI(NIP),ZD(NDP),ZI(NIP) INTEGER IPL(2,NL),IPT(3,NT),ITLI(NIP),KTLI(NIP) LOGICAL EXTRPI(NIP) * .. * .. Local Scalars .. DOUBLE PRECISION A,AA,AB,ACT2,AD,ADBC,AP,B,BB,BC,BDT2, + BP,C,CC,CD, + CP,D,DD,DLT,DP,DX,DY,E1,E2,G1,G2,H1,H2,H3,LUSQ, + LVSQ,P0,P00,P01,P02,P03,P04,P05,P1,P10,P11,P12, + P13,P14,P2,P20,P21,P22,P23,P3,P30,P31,P32,P4,P40, + P41,P5,P50,SPUV,U,V,WT1,WT2,X0,XII,Y0,YII,Z0,ZII, + ZII1,ZII2 INTEGER I,IDP,IIP,ILI,IR,ITLII,ITLIPV,K,KTLII,KTLIPV * .. * .. Local Arrays .. DOUBLE PRECISION PD(5,3),X(3),Y(3),Z(3),ZU(3),ZUU(3), + ZUV(3),ZV(3),ZVV(3) * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * Outermost DO-loop with respect to the output point DO 120 IIP = 1,NIP XII = XI(IIP) YII = YI(IIP) KTLII = KTLI(IIP) ITLII = ITLI(IIP) IF (IIP.EQ.1) THEN KTLIPV = 0 ITLIPV = 0 ELSE KTLIPV = KTLI(IIP-1) ITLIPV = ITLI(IIP-1) END IF * Part 1. Calculation of ZII by interpolation IF (KTLII.EQ.1) THEN * Calculates the coefficients when necessary. IF (KTLII.NE.KTLIPV .OR. ITLII.NE.ITLIPV) THEN * Loads coordinate and partial derivative values at the * vertexes. DO 20 I = 1,3 IDP = IPT(I,ITLII) X(I) = XD(IDP) Y(I) = YD(IDP) Z(I) = ZD(IDP) DO 10 K = 1,5 PD(K,I) = PDD(K,IDP) 10 CONTINUE 20 CONTINUE * Determines the coefficients for the coordinate system * transformation from the x-y system to the u-v system * and vice versa. 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 * Converts the partial derivatives at the vertexes of the * triangle for the u-v coordinate system. 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 30 I = 1,3 ZU(I) = A*PD(1,I) + C*PD(2,I) ZV(I) = B*PD(1,I) + D*PD(2,I) ZUU(I) = AA*PD(3,I) + ACT2*PD(4,I) + CC*PD(5,I) ZUV(I) = AB*PD(3,I) + ADBC*PD(4,I) + CD*PD(5,I) ZVV(I) = BB*PD(3,I) + BDT2*PD(4,I) + DD*PD(5,I) 30 CONTINUE * Calculates the coefficients of the polynomial. 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 LUSQ = AA + CC LVSQ = BB + DD SPUV = AB + CD P41 = 5.0*SPUV/LUSQ*P50 P14 = 5.0*SPUV/LVSQ*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 E1 = (LVSQ-SPUV)/ ((LVSQ-SPUV)+ (LUSQ-SPUV)) E2 = 1.0 - E1 G1 = 5.0*E1 - 2.0 G2 = 1.0 - G1 H1 = 5.0* (E1* (P50-P41)+E2* (P05-P14)) + (P41+P14) H2 = 0.5*ZVV(2) - P02 - P12 H3 = 0.5*ZUU(3) - P20 - P21 P22 = H1 + G1*H2 + G2*H3 P32 = H2 - P22 P23 = H3 - P22 END IF * Converts XII and YII to u-v system. DX = XII - X0 DY = YII - Y0 U = AP*DX + BP*DY V = CP*DX + DP*DY * Evaluates the polynomial. 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 P5 = P50 ZI(IIP) = P0 + U* (P1+U* (P2+U* (P3+U* (P4+U*P5)))) EXTRPI(IIP) = .FALSE. END IF * Part 2. Calculation of ZII by extrapolation in the rectangle IF (KTLII.EQ.2) THEN * Calculates the coefficients when necessary. IF (KTLII.NE.KTLIPV .OR. ITLII.NE.ITLIPV) THEN * Loads coordinate and partial derivative values at the end * points of the border line segment. DO 50 I = 1,2 IDP = IPL(I,ITLII) X(I) = XD(IDP) Y(I) = YD(IDP) Z(I) = ZD(IDP) DO 40 K = 1,5 PD(K,I) = PDD(K,IDP) 40 CONTINUE 50 CONTINUE * Determines the coefficients for the coordinate system * transformation from the x-y system to the u-v system * and vice versa. 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 * Converts the partial derivatives at the end points of the * border line segment for the u-v coordinate system. 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 60 I = 1,2 ZU(I) = A*PD(1,I) + C*PD(2,I) ZV(I) = B*PD(1,I) + D*PD(2,I) ZUU(I) = AA*PD(3,I) + ACT2*PD(4,I) + CC*PD(5,I) ZUV(I) = AB*PD(3,I) + ADBC*PD(4,I) + CD*PD(5,I) ZVV(I) = BB*PD(3,I) + BDT2*PD(4,I) + DD*PD(5,I) 60 CONTINUE * Calculates the coefficients of the polynomial. 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.5* (ZUU(2)-ZUU(1)) END IF * Converts XII and YII to u-v system. DX = XII - X0 DY = YII - Y0 U = AP*DX + BP*DY V = CP*DX + DP*DY * Evaluates the polynomial. P0 = P00 + V* (P01+V* (P02+V* (P03+V* (P04+V*P05)))) P1 = P10 + V* (P11+V* (P12+V*P13)) P2 = P20 + V*P21 ZI(IIP) = P0 + U* (P1+U*P2) EXTRPI(IIP) = .TRUE. END IF * Part 3. Calculation of ZII by extrapolation in the triangle IF (KTLII.EQ.3) THEN * Calculates the coefficients when necessary. IF (KTLII.NE.KTLIPV .OR. ITLII.NE.ITLIPV) THEN * Loads coordinate and partial derivative values at the vertex * of the triangle. IDP = IPL(1,ITLII) X0 = XD(IDP) Y0 = YD(IDP) Z0 = ZD(IDP) DO 70 K = 1,5 PD(K,1) = PDD(K,IDP) 70 CONTINUE * Calculates the coefficients of the polynomial. P00 = Z0 P10 = PD(1,1) P01 = PD(2,1) P20 = 0.5*PD(3,1) P11 = PD(4,1) P02 = 0.5*PD(5,1) END IF * Converts XII and YII to U-V system. U = XII - X0 V = YII - Y0 * Evaluates the polynomial. P0 = P00 + V* (P01+V*P02) P1 = P10 + V*P11 ZI(IIP) = P0 + U* (P1+U*P20) EXTRPI(IIP) = .TRUE. END IF * Part 4. Calculation of ZII by extrapolation in the triangle * which is an overlap of two rectangles. IF (KTLII.EQ.4) THEN * Calculates the coefficients. DO 110 IR = 1,2 IF (IR.EQ.1) THEN ILI = MOD(ITLII+NL-2,NL) + 1 ELSE ILI = ITLII END IF * Loads coordinate and partial derivative values at the end * points of the border line segment. DO 90 I = 1,2 IDP = IPL(I,ILI) X(I) = XD(IDP) Y(I) = YD(IDP) Z(I) = ZD(IDP) DO 80 K = 1,5 PD(K,I) = PDD(K,IDP) 80 CONTINUE 90 CONTINUE * Determines the coefficients for the coordinate system * transformation from the x-y system to the u-v system * and vice versa. 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 * Converts the partial derivatives at the end points of the * border line segment for the u-v coordinate system. 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 100 I = 1,2 ZU(I) = A*PD(1,I) + C*PD(2,I) ZV(I) = B*PD(1,I) + D*PD(2,I) ZUU(I) = AA*PD(3,I) + ACT2*PD(4,I) + CC*PD(5,I) ZUV(I) = AB*PD(3,I) + ADBC*PD(4,I) + CD*PD(5,I) ZVV(I) = BB*PD(3,I) + BDT2*PD(4,I) + DD*PD(5,I) 100 CONTINUE * Calculates the coefficients of the polynomial. 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.5* (ZUU(2)-ZUU(1)) * Converts XII and YII to u-v system. DX = XII - X0 DY = YII - Y0 U = AP*DX + BP*DY V = CP*DX + DP*DY * Evaluates the polynomial. P0 = P00 + V* (P01+V* (P02+V* (P03+V* (P04+V*P05)))) P1 = P10 + V* (P11+V* (P12+V*P13)) P2 = P20 + V*P21 ZII = P0 + U* (P1+U*P2) IF (IR.EQ.1) THEN ZII1 = ZII WT2 = ((X(1)-X(2))* (XII-X(2))+ + (Y(1)-Y(2))* (YII-Y(2)))**2 ELSE ZII2 = ZII WT1 = ((X(2)-X(1))* (XII-X(1))+ + (Y(2)-Y(1))* (YII-Y(1)))**2 END IF 110 CONTINUE ZI(IIP) = (WT1*ZII1+WT2*ZII2)/ (WT1+WT2) EXTRPI(IIP) = .TRUE. END IF 120 CONTINUE END SUBROUTINE IDBVIP(MD,NCP,NDP,XD,YD,ZD,NIP,XI,YI,ZI, ID001340 1 IWK,WK,MISSI) C THIS SUBROUTINE PERFORMS BIVARIATE INTERPOLATION WHEN THE PRO- C JECTIONS OF THE DATA POINTS IN THE X-Y PLANE ARE IRREGULARLY C DISTRIBUTED IN THE PLANE. C THE INPUT PARAMETERS ARE C MD = MODE OF COMPUTATION (MUST BE 1, 2, OR 3), C = 1 FOR NEW NCP AND/OR NEW XD-YD, C = 2 FOR OLD NCP, OLD XD-YD, NEW XI-YI, C = 3 FOR OLD NCP, OLD XD-YD, OLD XI-YI, C NCP = NUMBER OF ADDITIONAL DATA POINTS USED FOR ESTI- C MATING PARTIAL DERIVATIVES AT EACH DATA POINT C (MUST BE 2 OR GREATER, BUT SMALLER THAN NDP), C NDP = NUMBER OF DATA POINTS (MUST BE 4 OR GREATER), C XD = ARRAY OF DIMENSION NDP CONTAINING THE X C COORDINATES OF THE DATA POINTS, C YD = ARRAY OF DIMENSION NDP CONTAINING THE Y C COORDINATES OF THE DATA POINTS, C ZD = ARRAY OF DIMENSION NDP CONTAINING THE Z C COORDINATES OF THE DATA POINTS, C NIP = NUMBER OF OUTPUT POINTS AT WHICH INTERPOLATION C IS TO BE PERFORMED (MUST BE 1 OR GREATER), C XI = ARRAY OF DIMENSION NIP CONTAINING THE X C COORDINATES OF THE OUTPUT POINTS, C YI = ARRAY OF DIMENSION NIP CONTAINING THE Y C COORDINATES OF THE OUTPUT POINTS. C THE OUTPUT PARAMETER IS C ZI = ARRAY OF DIMENSION NIP WHERE INTERPOLATED Z C VALUES ARE TO BE STORED. C MISSI = LOCICAL ARRAY, INDICATING IF EXTRAPOLATION OR MISSING VALUES C OUTSIDE CONVEX HULL WANTED C THE OTHER PARAMETERS ARE C IWK = INTEGER ARRAY OF DIMENSION C MAX0(31,27+NCP)*NDP+NIP C USED INTERNALLY AS A WORK AREA, C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A C WORK AREA. C THE VERY FIRST CALL TO THIS SUBROUTINE AND THE CALL WITH A NEW C NCP VALUE, A NEW NDP VALUE, AND/OR NEW CONTENTS OF THE XD AND C YD ARRAYS MUST BE MADE WITH MD=1. THE CALL WITH MD=2 MUST BE C PRECEDED BY ANOTHER CALL WITH THE SAME NCP AND NDP VALUES AND C WITH THE SAME CONTENTS OF THE XD AND YD ARRAYS. THE CALL WITH C MD=3 MUST BE PRECEDED BY ANOTHER CALL WITH THE SAME NCP, NDP, C AND NIP VALUES AND WITH THE SAME CONTENTS OF THE XD, YD, XI, C AND YI ARRAYS. BETWEEN THE CALL WITH MD=2 OR MD=3 AND ITS C PRECEDING CALL, THE IWK AND WK ARRAYS MUST NOT BE DISTURBED. C USE OF A VALUE BETWEEN 3 AND 5 (INCLUSIVE) FOR NCP IS RECOM- C MENDED UNLESS THERE ARE EVIDENCES THAT DICTATE OTHERWISE. C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, C THEREFORE, SYSTEM DEPENDENT. C THIS SUBROUTINE CALLS THE IDCLDP, IDLCTN, IDPDRV, IDPTIP, AND C IDTANG SUBROUTINES. C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) LOGICAL MISSI, LINEAR DIMENSION XD(NDP),YD(NDP),ZD(NDP),XI(NIP),YI(NIP), 1 ZI(NIP),MISSI(NIP),IWK((31+NCP)*NDP+NIP),WK(8*NDP) COMMON/IDLC/NIT, idummy COMMON/IDPI/ITPV DATA LUN/6/ C SETTING OF SOME INPUT PARAMETERS TO LOCAL VARIABLES. C (FOR MD=1,2,3) 10 MD0=MD NCP0=NCP NDP0=NDP NIP0=NIP C ERROR CHECK. (FOR MD=1,2,3) 20 IF(MD0.LT.1.OR.MD0.GT.3) GO TO 90 IF(NCP0.EQ.0) THEN LINEAR=.TRUE. DO 21 I=1,NIP MISSI(I)=.TRUE. 21 CONTINUE END IF IF(NCP0.EQ.1.OR.NCP0.GE.NDP0) GO TO 90 IF(NDP0.LT.4) GO TO 90 IF(NIP0.LT.1) GO TO 90 IF(MD0.GE.2) GO TO 22 IWK(1)=NCP0 IWK(2)=NDP0 GO TO 23 22 NCPPV=IWK(1) NDPPV=IWK(2) IF(NCP0.NE.NCPPV) GO TO 90 IF(NDP0.NE.NDPPV) GO TO 90 23 IF(MD0.GE.3) GO TO 24 IWK(3)=NIP GO TO 30 24 NIPPV=IWK(3) IF(NIP0.NE.NIPPV) GO TO 90 C ALLOCATION OF STORAGE AREAS IN THE IWK ARRAY. (FOR MD=1,2,3) 30 JWIPT=16 JWIWL=6*NDP0+1 JWIWK=JWIWL JWIPL=24*NDP0+1 JWIWP=30*NDP0+1 JWIPC=27*NDP0+1 JWIT0=MAX0(31,27+NCP0)*NDP0 C TRIANGULATES THE X-Y PLANE. (FOR MD=1) 40 IF(MD0.GT.1) GO TO 50 CALL IDTANG(NDP0,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL), 1 IWK(JWIWL),IWK(JWIWP),WK) IWK(5)=NT IWK(6)=NL IF(NT.EQ.0) RETURN C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. (FOR MD=1) 50 IF(MD0.GT.1 .OR. LINEAR) GO TO 60 CALL IDCLDP(NDP0,XD,YD,NCP0,IWK(JWIPC)) IF(IWK(JWIPC).EQ.0) RETURN C LOCATES ALL POINTS AT WHICH INTERPOLATION IS TO BE PERFORMED. C (FOR MD=1,2) 60 IF(MD0.EQ.3) GO TO 70 NIT=0 JWIT=JWIT0 DO 61 IIP=1,NIP0 JWIT=JWIT+1 CALL IDLCTN(NDP0,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL), 1 XI(IIP),YI(IIP),IWK(JWIT),IWK(JWIWK),WK) 61 CONTINUE C ESTIMATES PARTIAL DERIVATIVES AT ALL DATA POINTS. C (FOR MD=1,2,3) 70 IF (.NOT.LINEAR) CALL IDPDRV(NDP0,XD,YD,ZD,NCP0,IWK(JWIPC),WK) C INTERPOLATES THE ZI VALUES. (FOR MD=1,2,3) 80 ITPV=0 JWIT=JWIT0 DO 81 IIP=1,NIP0 JWIT=JWIT+1 IF (LINEAR) THEN CALL IDPTLI(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL), 1 IWK(JWIT),XI(IIP),YI(IIP),ZI(IIP),MISSI(IIP)) ELSE CALL IDPTIP(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),WK, 1 IWK(JWIT),XI(IIP),YI(IIP),ZI(IIP),MISSI(IIP)) END IF 81 CONTINUE RETURN C ERROR EXIT 90 WRITE (LUN,2090) MD0,NCP0,NDP0,NIP0 RETURN C FORMAT STATEMENT FOR ERROR MESSAGE 2090 FORMAT(1X/41H *** IMPROPER INPUT PARAMETER VALUE(S)./ 1 7H MD =,I4,10X,5HNCP =,I6,10X,5HNDP =,I6, 2 10X,5HNIP =,I6/ 3 35H ERROR DETECTED IN ROUTINE IDBVIP/) END SUBROUTINE IDCLDP(NDP,XD,YD,NCP,IPC) 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 OF DIMENSION NDP CONTAINING THE X AND Y C COORDINATES OF THE 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. C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, C THEREFORE, SYSTEM DEPENDENT. C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) DIMENSION XD(NDP),YD(NDP),IPC(NCP*NDP) DIMENSION DSQ0(25),IPC0(25) DATA NCPMX/25/, LUN/6/ C STATEMENT FUNCTION DSQF(U1,V1,U2,V2)=(U2-U1)**2+(V2-V1)**2 C PRELIMINARY PROCESSING 10 NDP0=NDP NCP0=NCP IF(NDP0.LT.2) GO TO 90 IF(NCP0.LT.1.OR.NCP0.GT.NCPMX.OR.NCP0.GE.NDP0) GO TO 90 C CALCULATION 20 DO 59 IP1=1,NDP0 C - SELECTS NCP POINTS. X1=XD(IP1) Y1=YD(IP1) J1=0 DSQMX=0.0 DO 22 IP2=1,NDP0 IF(IP2.EQ.IP1) GO TO 22 DSQI=DSQF(X1,Y1,XD(IP2),YD(IP2)) J1=J1+1 DSQ0(J1)=DSQI IPC0(J1)=IP2 IF(DSQI.LE.DSQMX) GO TO 21 DSQMX=DSQI JMX=J1 21 IF(J1.GE.NCP0) GO TO 23 22 CONTINUE 23 IP2MN=IP2+1 IF(IP2MN.GT.NDP0) GO TO 30 DO 25 IP2=IP2MN,NDP0 IF(IP2.EQ.IP1) GO TO 25 DSQI=DSQF(X1,Y1,XD(IP2),YD(IP2)) IF(DSQI.GE.DSQMX) GO TO 25 DSQ0(JMX)=DSQI IPC0(JMX)=IP2 DSQMX=0.0 DO 24 J1=1,NCP0 IF(DSQ0(J1).LE.DSQMX) GO TO 24 DSQMX=DSQ0(J1) JMX=J1 24 CONTINUE 25 CONTINUE C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR. 30 IP2=IPC0(1) DX12=XD(IP2)-X1 DY12=YD(IP2)-Y1 DO 31 J3=2,NCP0 IP3=IPC0(J3) DX13=XD(IP3)-X1 DY13=YD(IP3)-Y1 IF((DY13*DX12-DX13*DY12).NE.0.0) GO TO 50 31 CONTINUE C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT. 40 NCLPT=0 DO 43 IP3=1,NDP0 IF(IP3.EQ.IP1) GO TO 43 DO 41 J4=1,NCP0 IF(IP3.EQ.IPC0(J4)) GO TO 43 41 CONTINUE DX13=XD(IP3)-X1 DY13=YD(IP3)-Y1 IF((DY13*DX12-DX13*DY12).EQ.0.0) GO TO 43 DSQI=DSQF(X1,Y1,XD(IP3),YD(IP3)) IF(NCLPT.EQ.0) GO TO 42 IF(DSQI.GE.DSQMN) GO TO 43 42 NCLPT=1 DSQMN=DSQI IP3MN=IP3 43 CONTINUE IF(NCLPT.EQ.0) GO TO 91 DSQMX=DSQMN IPC0(JMX)=IP3MN C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY. 50 J1=(IP1-1)*NCP0 DO 51 J2=1,NCP0 J1=J1+1 IPC(J1)=IPC0(J2) 51 CONTINUE 59 CONTINUE RETURN C ERROR EXIT 90 WRITE (LUN,2090) GO TO 92 91 WRITE (LUN,2091) 92 WRITE (LUN,2092) NDP0,NCP0 IPC(1)=0 RETURN C FORMAT STATEMENTS FOR ERROR MESSAGES 2090 FORMAT(1X/41H *** IMPROPER INPUT PARAMETER VALUE(S).) 2091 FORMAT(1X/33H *** ALL COLLINEAR DATA POINTS.) 2092 FORMAT(8H NDP =,I5,5X,5HNCP =,I5/ 1 35H ERROR DETECTED IN ROUTINE IDCLDP/) END SUBROUTINE IDGRID(XD, YD, NDP, NT, IPT, NL, IPL, NXI, NYI, XI, YI, IDG 10 * NGP, IGP) C THIS SUBROUTINE ORGANIZES GRID POINTS FOR SURFACE FITTING BY C SORTING THEM IN ASCENDING ORDER OF TRIANGLE NUMBERS AND OF THE C BORDER LINE SEGMENT NUMBER. C THE INPUT PARAMETERS ARE C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y C COORDINATES OF THE DATA POINTS, WHERE NDP IS THE C NUMBER 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 NXI = NUMBER OF GRID POINTS IN THE X COORDINATE, C NYI = NUMBER OF GRID POINTS IN THE Y COORDINATE, C XI,YI = ARRAYS OF DIMENSION NXI AND NYI CONTAINING C THE X AND Y COORDINATES OF THE GRID POINTS, C RESPECTIVELY. C THE OUTPUT PARAMETERS ARE C NGP = INTEGER ARRAY OF DIMENSION 2*(NT+2*NL) WHERE THE C NUMBER OF GRID POINTS THAT BELONG TO EACH OF THE C TRIANGLES OR OF THE BORDER LINE SEGMENTS ARE TO C BE STORED, C IGP = INTEGER ARRAY OF DIMENSION NXI*NYI WHERE THE C GRID POINT NUMBERS ARE TO BE STORED IN ASCENDING C ORDER OF THE TRIANGLE NUMBER AND THE BORDER LINE C SEGMENT NUMBER. C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) DIMENSION XD(NDP), YD(NDP), IPT(3*NT), IPL(3*NL), XI(NXI), * YI(NYI), NGP(2*(NT+2*NL)), IGP(NXI*NYI) C STATEMENT FUNCTIONS 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 PRELIMINARY PROCESSING NT0 = NT NL0 = NL NXI0 = NXI NYI0 = NYI NXINYI = NXI0*NYI0 XIMN = DMIN1(XI(1),XI(NXI0)) XIMX = DMAX1(XI(1),XI(NXI0)) YIMN = DMIN1(YI(1),YI(NYI0)) YIMX = DMAX1(YI(1),YI(NYI0)) C DETERMINES GRID POINTS INSIDE THE DATA AREA. JNGP0 = 0 JNGP1 = 2*(NT0+2*NL0) + 1 JIGP0 = 0 JIGP1 = NXINYI + 1 DO 160 IT0=1,NT0 NGP0 = 0 NGP1 = 0 IT0T3 = IT0*3 IP1 = IPT(IT0T3-2) IP2 = IPT(IT0T3-1) IP3 = IPT(IT0T3) X1 = XD(IP1) Y1 = YD(IP1) X2 = XD(IP2) Y2 = YD(IP2) X3 = XD(IP3) Y3 = YD(IP3) XMN = DMIN1(X1,X2,X3) XMX = DMAX1(X1,X2,X3) YMN = DMIN1(Y1,Y2,Y3) YMX = DMAX1(Y1,Y2,Y3) INSD = 0 DO 20 IXI=1,NXI0 IF (XI(IXI).GE.XMN .AND. XI(IXI).LE.XMX) GO TO 10 IF (INSD.EQ.0) GO TO 20 IXIMX = IXI - 1 GO TO 30 10 IF (INSD.EQ.1) GO TO 20 INSD = 1 IXIMN = IXI 20 CONTINUE IF (INSD.EQ.0) GO TO 150 IXIMX = NXI0 30 DO 140 IYI=1,NYI0 YII = YI(IYI) IF (YII.LT.YMN .OR. YII.GT.YMX) GO TO 140 DO 130 IXI=IXIMN,IXIMX XII = XI(IXI) L = 0 IF (SIDE(X1,Y1,X2,Y2,XII,YII)) 130, 40, 50 40 L = 1 50 IF (SIDE(X2,Y2,X3,Y3,XII,YII)) 130, 60, 70 60 L = 1 70 IF (SIDE(X3,Y3,X1,Y1,XII,YII)) 130, 80, 90 80 L = 1 90 IZI = NXI0*(IYI-1) + IXI IF (L.EQ.1) GO TO 100 NGP0 = NGP0 + 1 JIGP0 = JIGP0 + 1 IGP(JIGP0) = IZI GO TO 130 100 IF (JIGP1.GT.NXINYI) GO TO 120 DO 110 JIGP1I=JIGP1,NXINYI IF (IZI.EQ.IGP(JIGP1I)) GO TO 130 110 CONTINUE 120 NGP1 = NGP1 + 1 JIGP1 = JIGP1 - 1 IGP(JIGP1) = IZI 130 CONTINUE 140 CONTINUE 150 JNGP0 = JNGP0 + 1 NGP(JNGP0) = NGP0 JNGP1 = JNGP1 - 1 NGP(JNGP1) = NGP1 160 CONTINUE C DETERMINES GRID POINTS OUTSIDE THE DATA AREA. C - IN SEMI-INFINITE RECTANGULAR AREA. DO 450 IL0=1,NL0 NGP0 = 0 NGP1 = 0 IL0T3 = IL0*3 IP1 = IPL(IL0T3-2) IP2 = IPL(IL0T3-1) X1 = XD(IP1) Y1 = YD(IP1) X2 = XD(IP2) Y2 = YD(IP2) XMN = XIMN XMX = XIMX YMN = YIMN YMX = YIMX IF (Y2.GE.Y1) XMN = DMIN1(X1,X2) IF (Y2.LE.Y1) XMX = DMAX1(X1,X2) IF (X2.LE.X1) YMN = DMIN1(Y1,Y2) IF (X2.GE.X1) YMX = DMAX1(Y1,Y2) INSD = 0 DO 180 IXI=1,NXI0 IF (XI(IXI).GE.XMN .AND. XI(IXI).LE.XMX) GO TO 170 IF (INSD.EQ.0) GO TO 180 IXIMX = IXI - 1 GO TO 190 170 IF (INSD.EQ.1) GO TO 180 INSD = 1 IXIMN = IXI 180 CONTINUE IF (INSD.EQ.0) GO TO 310 IXIMX = NXI0 190 DO 300 IYI=1,NYI0 YII = YI(IYI) IF (YII.LT.YMN .OR. YII.GT.YMX) GO TO 300 DO 290 IXI=IXIMN,IXIMX XII = XI(IXI) L = 0 IF (SIDE(X1,Y1,X2,Y2,XII,YII)) 210, 200, 290 200 L = 1 210 IF (SPDT(X2,Y2,X1,Y1,XII,YII)) 290, 220, 230 220 L = 1 230 IF (SPDT(X1,Y1,X2,Y2,XII,YII)) 290, 240, 250 240 L = 1 250 IZI = NXI0*(IYI-1) + IXI IF (L.EQ.1) GO TO 260 NGP0 = NGP0 + 1 JIGP0 = JIGP0 + 1 IGP(JIGP0) = IZI GO TO 290 260 IF (JIGP1.GT.NXINYI) GO TO 280 DO 270 JIGP1I=JIGP1,NXINYI IF (IZI.EQ.IGP(JIGP1I)) GO TO 290 270 CONTINUE 280 NGP1 = NGP1 + 1 JIGP1 = JIGP1 - 1 IGP(JIGP1) = IZI 290 CONTINUE 300 CONTINUE 310 JNGP0 = JNGP0 + 1 NGP(JNGP0) = NGP0 JNGP1 = JNGP1 - 1 NGP(JNGP1) = NGP1 C - IN SEMI-INFINITE TRIANGULAR AREA. NGP0 = 0 NGP1 = 0 ILP1 = MOD(IL0,NL0) + 1 ILP1T3 = ILP1*3 IP3 = IPL(ILP1T3-1) X3 = XD(IP3) Y3 = YD(IP3) XMN = XIMN XMX = XIMX YMN = YIMN YMX = YIMX IF (Y3.GE.Y2 .AND. Y2.GE.Y1) XMN = X2 IF (Y3.LE.Y2 .AND. Y2.LE.Y1) XMX = X2 IF (X3.LE.X2 .AND. X2.LE.X1) YMN = Y2 IF (X3.GE.X2 .AND. X2.GE.X1) YMX = Y2 INSD = 0 DO 330 IXI=1,NXI0 IF (XI(IXI).GE.XMN .AND. XI(IXI).LE.XMX) GO TO 320 IF (INSD.EQ.0) GO TO 330 IXIMX = IXI - 1 GO TO 340 320 IF (INSD.EQ.1) GO TO 330 INSD = 1 IXIMN = IXI 330 CONTINUE IF (INSD.EQ.0) GO TO 440 IXIMX = NXI0 340 DO 430 IYI=1,NYI0 YII = YI(IYI) IF (YII.LT.YMN .OR. YII.GT.YMX) GO TO 430 DO 420 IXI=IXIMN,IXIMX XII = XI(IXI) L = 0 IF (SPDT(X1,Y1,X2,Y2,XII,YII)) 360, 350, 420 350 L = 1 360 IF (SPDT(X3,Y3,X2,Y2,XII,YII)) 380, 370, 420 370 L = 1 380 IZI = NXI0*(IYI-1) + IXI IF (L.EQ.1) GO TO 390 NGP0 = NGP0 + 1 JIGP0 = JIGP0 + 1 IGP(JIGP0) = IZI GO TO 420 390 IF (JIGP1.GT.NXINYI) GO TO 410 DO 400 JIGP1I=JIGP1,NXINYI IF (IZI.EQ.IGP(JIGP1I)) GO TO 420 400 CONTINUE 410 NGP1 = NGP1 + 1 JIGP1 = JIGP1 - 1 IGP(JIGP1) = IZI 420 CONTINUE 430 CONTINUE 440 JNGP0 = JNGP0 + 1 NGP(JNGP0) = NGP0 JNGP1 = JNGP1 - 1 NGP(JNGP1) = NGP1 450 CONTINUE RETURN END SUBROUTINE IDLCTN(NDP, XD, YD, NT, IPT, NL, IPL, XII, YII, ITI, IDL 10 * IWK, WK) 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 IMPLICIT DOUBLE PRECISION (A-D,P-Z) DIMENSION XD(NDP), YD(NDP), IPT(3*NT), IPL(3*NL), IWK(18*NDP), * WK(8*NDP) DIMENSION NTSC(9), IDSC(9) COMMON /IDLC/ NIT, ITIPV C STATEMENT FUNCTIONS 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 PRELIMINARY PROCESSING NDP0 = NDP NT0 = NT NL0 = NL NTL = NT0 + NL0 X0 = XII Y0 = YII C PROCESSING FOR A NEW SET OF DATA POINTS IF (NIT.NE.0) GO TO 80 NIT = 1 C - DIVIDES THE X-Y PLANE INTO NINE RECTANGULAR SECTIONS. XMN = XD(1) XMX = XMN YMN = YD(1) YMX = YMN DO 10 IDP=2,NDP0 XI = XD(IDP) YI = YD(IDP) XMN = DMIN1(XI,XMN) XMX = DMAX1(XI,XMX) YMN = DMIN1(YI,YMN) YMX = DMAX1(YI,YMX) 10 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 - DETERMINES AND STORES IN THE IWK ARRAY TRIANGLE NUMBERS OF C - THE TRIANGLES ASSOCIATED WITH EACH OF THE NINE SECTIONS. DO 20 ISC=1,9 NTSC(ISC) = 0 IDSC(ISC) = 0 20 CONTINUE IT0T3 = 0 JWK = 0 DO 70 IT0=1,NT0 IT0T3 = IT0T3 + 3 I1 = IPT(IT0T3-2) I2 = IPT(IT0T3-1) I3 = IPT(IT0T3) XMN = DMIN1(XD(I1),XD(I2),XD(I3)) XMX = DMAX1(XD(I1),XD(I2),XD(I3)) YMN = DMIN1(YD(I1),YD(I2),YD(I3)) YMX = DMAX1(YD(I1),YD(I2),YD(I3)) IF (YMN.GT.YS1) GO TO 30 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 30 IF (YMX.LT.YS1 .OR. YMN.GT.YS2) GO TO 40 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 40 IF (YMX.LT.YS2) GO TO 50 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 50 DO 60 ISC=1,9 IF (IDSC(ISC).EQ.0) GO TO 60 JIWK = 9*NTSC(ISC) + ISC IWK(JIWK) = IT0 NTSC(ISC) = NTSC(ISC) + 1 IDSC(ISC) = 0 60 CONTINUE C - STORES IN THE WK ARRAY THE MINIMUM AND MAXIMUM OF THE X AND C - Y COORDINATE VALUES FOR EACH OF THE TRIANGLE. JWK = JWK + 4 WK(JWK-3) = XMN WK(JWK-2) = XMX WK(JWK-1) = YMN WK(JWK) = YMX 70 CONTINUE GO TO 110 C CHECKS IF IN THE SAME TRIANGLE AS PREVIOUS. 80 IT0 = ITIPV IF (IT0.GT.NT0) GO TO 90 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 110 IP3 = IPT(IT0T3) X3 = XD(IP3) Y3 = YD(IP3) IF (SIDE(X2,Y2,X3,Y3,X0,Y0).LT.0.0) GO TO 110 IF (SIDE(X3,Y3,X1,Y1,X0,Y0).LT.0.0) GO TO 110 GO TO 170 C CHECKS IF ON THE SAME BORDER LINE SEGMENT. 90 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 100 IF (SPDT(X1,Y1,X2,Y2,X0,Y0).LT.0.0) GO TO 110 IF (SPDT(X2,Y2,X1,Y1,X0,Y0).LT.0.0) GO TO 110 IF (SIDE(X1,Y1,X2,Y2,X0,Y0).GT.0.0) GO TO 110 GO TO 170 C CHECKS IF BETWEEN THE SAME TWO BORDER LINE SEGMENTS. 100 IF (SPDT(X1,Y1,X2,Y2,X0,Y0).GT.0.0) GO TO 110 IP3 = IPL(3*IL2-1) X3 = XD(IP3) Y3 = YD(IP3) IF (SPDT(X3,Y3,X2,Y2,X0,Y0).LE.0.0) GO TO 170 C LOCATES INSIDE THE DATA AREA. C - DETERMINES THE SECTION IN WHICH THE POINT IN QUESTION LIES. 110 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 - SEARCHES THROUGH THE TRIANGLES ASSOCIATED WITH THE SECTION. NTSCI = NTSC(ISC) IF (NTSCI.LE.0) GO TO 130 JIWK = -9 + ISC DO 120 ITSC=1,NTSCI JIWK = JIWK + 9 IT0 = IWK(JIWK) JWK = IT0*4 IF (X0.LT.WK(JWK-3)) GO TO 120 IF (X0.GT.WK(JWK-2)) GO TO 120 IF (Y0.LT.WK(JWK-1)) GO TO 120 IF (Y0.GT.WK(JWK)) GO TO 120 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 120 IP3 = IPT(IT0T3) X3 = XD(IP3) Y3 = YD(IP3) IF (SIDE(X2,Y2,X3,Y3,X0,Y0).LT.0.0) GO TO 120 IF (SIDE(X3,Y3,X1,Y1,X0,Y0).LT.0.0) GO TO 120 GO TO 170 120 CONTINUE C LOCATES OUTSIDE THE DATA AREA. 130 DO 150 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 150 IF (SPDT(X1,Y1,X2,Y2,X0,Y0).LT.0.0) GO TO 140 IF (SIDE(X1,Y1,X2,Y2,X0,Y0).GT.0.0) GO TO 150 IL2 = IL1 GO TO 160 140 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 160 150 CONTINUE IT0 = 1 GO TO 170 160 IT0 = IL1*NTL + IL2 C NORMAL EXIT 170 ITI = IT0 ITIPV = IT0 RETURN END SUBROUTINE IDPDRV(NDP,XD,YD,ZD,NCP,IPC,PD) ID008940 C THIS SUBROUTINE ESTIMATES PARTIAL DERIVATIVES OF THE FIRST AND C SECOND ORDER AT THE DATA POINTS. C THE INPUT PARAMETERS ARE C NDP = NUMBER OF DATA POINTS, C XD,YD,ZD = ARRAYS OF DIMENSION NDP CONTAINING THE X, C Y, AND Z COORDINATES OF THE DATA POINTS, C NCP = NUMBER OF ADDITIONAL DATA POINTS USED FOR ESTI- C MATING PARTIAL DERIVATIVES AT EACH DATA POINT, C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP CONTAINING C THE POINT NUMBERS OF NCP DATA POINTS CLOSEST TO C EACH OF THE NDP DATA POINTS. C THE OUTPUT PARAMETER IS C PD = ARRAY OF DIMENSION 5*NDP, WHERE THE ESTIMATED C ZX, ZY, ZXX, ZXY, AND ZYY VALUES AT THE DATA C POINTS ARE TO BE STORED. C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) DIMENSION XD(NDP),YD(NDP),ZD(NDP),IPC(NCP*NDP),PD(5*NDP) DOUBLE PRECISION NMX,NMY,NMZ,NMXX,NMXY,NMYX,NMYY C PRELIMINARY PROCESSING 10 NDP0=NDP NCP0=NCP NCPM1=NCP0-1 C ESTIMATION OF ZX AND ZY 20 DO 24 IP0=1,NDP0 X0=XD(IP0) Y0=YD(IP0) Z0=ZD(IP0) NMX=0.0 NMY=0.0 NMZ=0.0 JIPC0=NCP0*(IP0-1) DO 23 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 22 IC2=IC2MN,NCP0 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 22 DZ2=ZD(IPI)-Z0 DNMX=DY1*DZ2-DZ1*DY2 DNMY=DZ1*DX2-DX1*DZ2 IF(DNMZ.GE.0.0) GO TO 21 DNMX=-DNMX DNMY=-DNMY DNMZ=-DNMZ 21 NMX=NMX+DNMX NMY=NMY+DNMY NMZ=NMZ+DNMZ 22 CONTINUE 23 CONTINUE JPD0=5*IP0 PD(JPD0-4)=-NMX/NMZ PD(JPD0-3)=-NMY/NMZ 24 CONTINUE C ESTIMATION OF ZXX, ZXY, AND ZYY 30 DO 34 IP0=1,NDP0 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=NCP0*(IP0-1) DO 33 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 32 IC2=IC2MN,NCP0 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 32 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 31 DNMXX=-DNMXX DNMXY=-DNMXY DNMYX=-DNMYX DNMYY=-DNMYY DNMZ =-DNMZ 31 NMXX=NMXX+DNMXX NMXY=NMXY+DNMXY NMYX=NMYX+DNMYX NMYY=NMYY+DNMYY NMZ =NMZ +DNMZ 32 CONTINUE 33 CONTINUE PD(JPD0-2)=-NMXX/NMZ PD(JPD0-1)=-(NMXY+NMYX)/(2.0*NMZ) PD(JPD0) =-NMYY/NMZ 34 CONTINUE RETURN END SUBROUTINE IDPTIP(XD,YD,ZD,NDP,NT,IPT,NL,IPL,PDD,ITI,XII,YII, ID010190 1 ZII,MISSII) C THIS SUBROUTINE PERFORMS PUNCTUAL INTERPOLATION OR EXTRAPOLA- C TION, I.E., DETERMINES THE Z VALUE AT A POINT. C THE INPUT PARAMETERS ARE C XD,YD,ZD = ARRAYS OF DIMENSION NDP CONTAINING THE X, C Y, AND Z COORDINATES OF THE DATA POINTS, WHERE C NDP IS THE NUMBER 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 PDD = ARRAY OF DIMENSION 5*NDP CONTAINING THE PARTIAL C DERIVATIVES AT 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 ZII = INTERPOLATED Z VALUE. C MISSII = LOCIGAL INDICATING MISSING VALUE C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) LOGICAL MISSII DIMENSION XD(NDP),YD(NDP),ZD(NDP),IPT(3*NT),IPL(3*NL), 1 PDD(5*NDP) COMMON/IDPI/ITPV DIMENSION X(3),Y(3),Z(3),PD(15), 1 ZU(3),ZV(3),ZUU(3),ZUV(3),ZVV(3) DOUBLE PRECISION LU,LV EQUIVALENCE (P5,P50) C PRELIMINARY PROCESSING 10 IT0=ITI NTL=NT+NL IF(IT0.LE.NTL) GO TO 20 C EXTRAPOLATION OR MISSING VALUE WANTED? IF (MISSII) THEN ZII=0 RETURN END IF IL1=IT0/NTL IL2=IT0-IL1*NTL IF(IL1.EQ.IL2) GO TO 40 GO TO 60 C CALCULATION OF ZII BY INTERPOLATION. C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. 20 IF(IT0.EQ.ITPV) GO TO 30 C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE C VERTEXES. 21 JIPT=3*(IT0-1) JPD=0 DO 23 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 22 KPD=1,5 JPD=JPD+1 JPDD=JPDD+1 PD(JPD)=PDD(JPDD) 22 CONTINUE 23 CONTINUE C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM C AND VICE VERSA. 24 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 CONVERTS THE PARTIAL DERIVATIVES AT THE VERTEXES OF THE C TRIANGLE FOR THE U-V COORDINATE SYSTEM. 25 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 26 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) 26 CONTINUE C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. 27 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 CONVERTS XII AND YII TO U-V SYSTEM. 30 DX=XII-X0 DY=YII-Y0 U=AP*DX+BP*DY V=CP*DX+DP*DY C EVALUATES THE POLYNOMIAL. 31 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)))) MISSII=.FALSE. RETURN C CALCULATION OF ZII BY EXTRAPOLATION IN THE RECTANGLE. C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. 40 IF(IT0.EQ.ITPV) GO TO 50 C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE END C POINTS OF THE BORDER LINE SEGMENT. 41 JIPL=3*(IL1-1) JPD=0 DO 43 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 42 KPD=1,5 JPD=JPD+1 JPDD=JPDD+1 PD(JPD)=PDD(JPDD) 42 CONTINUE 43 CONTINUE C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM C AND VICE VERSA. 44 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 CONVERTS THE PARTIAL DERIVATIVES AT THE END POINTS OF THE C BORDER LINE SEGMENT FOR THE U-V COORDINATE SYSTEM. 45 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 46 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) 46 CONTINUE C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. 47 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 CONVERTS XII AND YII TO U-V SYSTEM. 50 DX=XII-X0 DY=YII-Y0 U=AP*DX+BP*DY V=CP*DX+DP*DY C EVALUATES THE POLYNOMIAL. 51 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 CALCULATION OF ZII BY EXTRAPOLATION IN THE TRIANGLE. C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. 60 IF(IT0.EQ.ITPV) GO TO 70 C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE VERTEX C OF THE TRIANGLE. 61 JIPL=3*IL2-2 IDP=IPL(JIPL) X(1)=XD(IDP) Y(1)=YD(IDP) Z(1)=ZD(IDP) JPDD=5*(IDP-1) DO 62 KPD=1,5 JPDD=JPDD+1 PD(KPD)=PDD(JPDD) 62 CONTINUE C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. 67 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 CONVERTS XII AND YII TO U-V SYSTEM. 70 U=XII-X(1) V=YII-Y(1) C EVALUATES THE POLYNOMIAL. 71 P0=P00+V*(P01+V*P02) P1=P10+V*P11 ZII=P0+U*(P1+U*P20) RETURN END SUBROUTINE IDPTLI(XD,YD,ZD,NDP,NT,IPT,NL,IPL,ITI,XII,YII,ZII, 1 MISSII) ID010191 C THIS SUBROUTINE PERFORMS LINEAR PUNCTUAL INTERPOLATION, C I.E., DETERMINES THE Z VALUE AT A POINT. C THE INPUT PARAMETERS ARE C XD,YD,ZD = ARRAYS OF DIMENSION NDP CONTAINING THE X, C Y, AND Z COORDINATES OF THE DATA POINTS, WHERE C NDP IS THE NUMBER 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 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 PARAMETERS ARE C ZII = INTERPOLATED Z VALUE. C MISSII = LOCIGAL INDICATING MISSING VALUE C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) LOGICAL MISSII DIMENSION XD(NDP),YD(NDP),ZD(NDP),IPT(3*NT),IPL(3*NL) COMMON/IDPI/ITPV DIMENSION X(3),Y(3),Z(3) EQUIVALENCE (P5,P50) C PRELIMINARY PROCESSING 10 IT0=ITI NTL=NT+NL IF(IT0.LE.NTL) GO TO 20 GO TO 40 C CALCULATION OF ZII BY INTERPOLATION. C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. 20 IF(IT0.EQ.ITPV) GO TO 30 C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE C VERTEXES. 21 JIPT=3*(IT0-1) JPD=0 DO 23 I=1,3 JIPT=JIPT+1 IDP=IPT(JIPT) X(I)=XD(IDP) Y(I)=YD(IDP) Z(I)=ZD(IDP) 23 CONTINUE C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM C AND VICE VERSA. 24 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 CONVERTS XII AND YII TO U-V SYSTEM. 30 DX=XII-X0 DY=YII-Y0 U=AP*DX+BP*DY V=CP*DX+DP*DY C EVALUATES THE INTERPOLATED PLANE C ACCORDING TO C | U V ZII-Z1 | C | 1 0 Z2-Z1 | = 0 C | 0 1 Z3-Z1 | C ZII=Z(1)+U*(Z(2)-Z(1))+V*(Z(3)-Z(1)) MISSII=.FALSE. RETURN C NO EXTRAPOLATION! 40 ZII=0 MISSII=.TRUE. RETURN END SUBROUTINE IDSFFT(MD,NCP,NDP,XD,YD,ZD,NXI,NYI,XI,YI,ZI, ID013070 1 IWK,WK,MISSI) C THIS SUBROUTINE PERFORMS SMOOTH SURFACE FITTING WHEN THE PRO- C JECTIONS OF THE DATA POINTS IN THE X-Y PLANE ARE IRREGULARLY C DISTRIBUTED IN THE PLANE. C THE INPUT PARAMETERS ARE C MD = MODE OF COMPUTATION (MUST BE 1, 2, OR 3), C = 1 FOR NEW NCP AND/OR NEW XD-YD, C = 2 FOR OLD NCP, OLD XD-YD, NEW XI-YI, C = 3 FOR OLD NCP, OLD XD-YD, OLD XI-YI, C NCP = NUMBER OF ADDITIONAL DATA POINTS USED FOR ESTI- C MATING PARTIAL DERIVATIVES AT EACH DATA POINT C (MUST BE 2 OR GREATER, BUT SMALLER THAN NDP), C NDP = NUMBER OF DATA POINTS (MUST BE 4 OR GREATER), C XD = ARRAY OF DIMENSION NDP CONTAINING THE X C COORDINATES OF THE DATA POINTS, C YD = ARRAY OF DIMENSION NDP CONTAINING THE Y C COORDINATES OF THE DATA POINTS, C ZD = ARRAY OF DIMENSION NDP CONTAINING THE Z C COORDINATES OF THE DATA POINTS, C NXI = NUMBER OF OUTPUT GRID POINTS IN THE X COORDINATE C (MUST BE 1 OR GREATER), C NYI = NUMBER OF OUTPUT GRID POINTS IN THE Y COORDINATE C (MUST BE 1 OR GREATER), C XI = ARRAY OF DIMENSION NXI CONTAINING THE X C COORDINATES OF THE OUTPUT GRID POINTS, C YI = ARRAY OF DIMENSION NYI CONTAINING THE Y C COORDINATES OF THE OUTPUT GRID POINTS. C THE OUTPUT PARAMETER IS C ZI = DOUBLY-DIMENSIONED ARRAY OF DIMENSION (NXI,NYI), C WHERE THE INTERPOLATED Z VALUES AT THE OUTPUT C GRID POINTS ARE TO BE STORED. C THE OTHER PARAMETERS ARE C IWK = INTEGER ARRAY OF DIMENSION C MAX0(31,27+NCP)*NDP+NXI*NYI C USED INTERNALLY AS A WORK AREA, C WK = ARRAY OF DIMENSION 5*NDP USED INTERNALLY AS A C WORK AREA. C MISSI = LOCICAL ARRAY, INDICATING IF EXTRAPOLATION OR MISSING VALUES C OUTSIDE CONVEX HULL WANTED C THE VERY FIRST CALL TO THIS SUBROUTINE AND THE CALL WITH A NEW C NCP VALUE, A NEW NDP VALUE, AND/OR NEW CONTENTS OF THE XD AND C YD ARRAYS MUST BE MADE WITH MD=1. THE CALL WITH MD=2 MUST BE C PRECEDED BY ANOTHER CALL WITH THE SAME NCP AND NDP VALUES AND C WITH THE SAME CONTENTS OF THE XD AND YD ARRAYS. THE CALL WITH C MD=3 MUST BE PRECEDED BY ANOTHER CALL WITH THE SAME NCP, NDP, C NXI, AND NYI VALUES AND WITH THE SAME CONTENTS OF THE XD, YD, C XI, AND YI ARRAYS. BETWEEN THE CALL WITH MD=2 OR MD=3 AND ITS C PRECEDING CALL, THE IWK AND WK ARRAYS MUST NOT BE DISTURBED. C USE OF A VALUE BETWEEN 3 AND 5 (INCLUSIVE) FOR NCP IS RECOM- C MENDED UNLESS THERE ARE EVIDENCES THAT DICTATE OTHERWISE. C THE LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, C THEREFORE, SYSTEM DEPENDENT. C THIS SUBROUTINE CALLS THE IDCLDP, IDGRID, IDPDRV, IDPTIP, AND C IDTANG SUBROUTINES. C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) LOGICAL MISSI, LINEAR DIMENSION XD(NDP),YD(NDP),ZD(NDP),XI(NXI),YI(NYI), 1 ZI(NXI*NYI),MISSI(NXI*NYI),IWK((31+NCP)*NDP+NXI*NYI), 2 WK(5*NDP) COMMON/IDPI/ITPV DATA LUN/6/ LINEAR=.FALSE. C SETTING OF SOME INPUT PARAMETERS TO LOCAL VARIABLES. C (FOR MD=1,2,3) 10 MD0=MD NCP0=NCP NDP0=NDP NXI0=NXI NYI0=NYI C ERROR CHECK. (FOR MD=1,2,3) 20 IF(MD0.LT.1.OR.MD0.GT.3) GO TO 90 IF(NCP0.EQ.0) THEN LINEAR=.TRUE. DO 21 I=1,NXI*NYI MISSI(I)=.TRUE. 21 CONTINUE END IF IF(NCP0.EQ.1.OR.NCP0.GE.NDP0) GO TO 90 IF(NDP0.LT.4) GO TO 90 IF(NXI0.LT.1.OR.NYI0.LT.1) GO TO 90 IF(MD0.GE.2) GO TO 23 IWK(1)=NCP0 IWK(2)=NDP0 GO TO 24 23 NCPPV=IWK(1) NDPPV=IWK(2) IF(NCP0.NE.NCPPV) GO TO 90 IF(NDP0.NE.NDPPV) GO TO 90 24 IF(MD0.GE.3) GO TO 25 IWK(3)=NXI0 IWK(4)=NYI0 GO TO 30 25 NXIPV=IWK(3) NYIPV=IWK(4) IF(NXI0.NE.NXIPV) GO TO 90 IF(NYI0.NE.NYIPV) GO TO 90 C ALLOCATION OF STORAGE AREAS IN THE IWK ARRAY. (FOR MD=1,2,3) 30 JWIPT=16 JWIWL=6*NDP0+1 JWNGP0=JWIWL-1 JWIPL=24*NDP0+1 JWIWP=30*NDP0+1 JWIPC=27*NDP0+1 JWIGP0=MAX0(31,27+NCP0)*NDP0 C TRIANGULATES THE X-Y PLANE. (FOR MD=1) 40 IF(MD0.GT.1) GO TO 50 CALL IDTANG(NDP0,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL), 1 IWK(JWIWL),IWK(JWIWP),WK) IWK(5)=NT IWK(6)=NL IF(NT.EQ.0) RETURN C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. (FOR MD=1) 50 IF(MD0.GT.1 .OR. LINEAR) GO TO 60 CALL IDCLDP(NDP0,XD,YD,NCP0,IWK(JWIPC)) IF(IWK(JWIPC).EQ.0) RETURN C SORTS OUTPUT GRID POINTS IN ASCENDING ORDER OF THE TRIANGLE C NUMBER AND THE BORDER LINE SEGMENT NUMBER. (FOR MD=1,2) 60 IF(MD0.EQ.3) GO TO 70 CALL IDGRID(XD,YD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),NXI0,NYI0, 1 XI,YI,IWK(JWNGP0+1),IWK(JWIGP0+1)) C ESTIMATES PARTIAL DERIVATIVES AT ALL DATA POINTS. C (FOR MD=1,2,3) 70 IF (.NOT.LINEAR) CALL IDPDRV(NDP0,XD,YD,ZD,NCP0,IWK(JWIPC),WK) C INTERPOLATES THE ZI VALUES. (FOR MD=1,2,3) 80 ITPV=0 JIG0MX=0 JIG1MN=NXI0*NYI0+1 NNGP=NT+2*NL DO 89 JNGP=1,NNGP ITI=JNGP IF(JNGP.LE.NT) GO TO 81 IL1=(JNGP-NT+1)/2 IL2=(JNGP-NT+2)/2 IF(IL2.GT.NL) IL2=1 ITI=IL1*(NT+NL)+IL2 81 JWNGP=JWNGP0+JNGP NGP0=IWK(JWNGP) IF(NGP0.EQ.0) GO TO 86 JIG0MN=JIG0MX+1 JIG0MX=JIG0MX+NGP0 DO 82 JIGP=JIG0MN,JIG0MX JWIGP=JWIGP0+JIGP IZI=IWK(JWIGP) IYI=(IZI-1)/NXI0+1 IXI=IZI-NXI0*(IYI-1) IF (LINEAR) THEN CALL IDPTLI(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL), 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) ELSE CALL IDPTIP(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),WK, 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) END IF 82 CONTINUE 86 JWNGP=JWNGP0+2*NNGP+1-JNGP NGP1=IWK(JWNGP) IF(NGP1.EQ.0) GO TO 89 JIG1MX=JIG1MN-1 JIG1MN=JIG1MN-NGP1 DO 87 JIGP=JIG1MN,JIG1MX JWIGP=JWIGP0+JIGP IZI=IWK(JWIGP) IYI=(IZI-1)/NXI0+1 IXI=IZI-NXI0*(IYI-1) IF (LINEAR) THEN CALL IDPTLI(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL), 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) ELSE CALL IDPTIP(XD,YD,ZD,NDP,NT,IWK(JWIPT),NL,IWK(JWIPL),WK, 1 ITI,XI(IXI),YI(IYI),ZI(IZI),MISSI(IZI)) END IF 87 CONTINUE 89 CONTINUE RETURN C ERROR EXIT 90 WRITE (LUN,2090) MD0,NCP0,NDP0,NXI0,NYI0 RETURN C FORMAT STATEMENT FOR ERROR MESSAGE 2090 FORMAT(1X/41H *** IMPROPER INPUT PARAMETER VALUE(S)./ 1 7H MD =,I4,10X,5HNCP =,I6,10X,5HNDP =,I6, 2 10X,5HNXI =,I6,10X,5HNYI =,I6/ 3 35H ERROR DETECTED IN ROUTINE IDSFFT/) END SUBROUTINE IDTANG(NDP,XD,YD,NT,IPT,NL,IPL,IWL,IWP,WK) ID014770 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 LUN CONSTANT IN THE DATA INITIALIZATION STATEMENT IS THE C LOGICAL UNIT NUMBER OF THE STANDARD OUTPUT UNIT AND IS, C THEREFORE, SYSTEM DEPENDENT. C THIS SUBROUTINE CALLS THE IDXCHG FUNCTION. 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 = INTEGER ARRAY OF DIMENSION 6*NDP-15, WHERE THE C POINT NUMBERS OF THE VERTEXES OF THE (IT)TH C TRIANGLE ARE TO BE STORED AS THE (3*IT-2)ND, C (3*IT-1)ST, AND (3*IT)TH ELEMENTS, C IT=1,2,...,NT, C NL = NUMBER OF BORDER LINE SEGMENTS, C IPL = INTEGER ARRAY OF DIMENSION 6*NDP, WHERE THE C POINT NUMBERS OF THE END POINTS OF THE (IL)TH C BORDER LINE SEGMENT AND ITS RESPECTIVE TRIANGLE C NUMBER ARE TO BE STORED AS THE (3*IL-2)ND, C (3*IL-1)ST, AND (3*IL)TH ELEMENTS, C 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 IMPLICIT DOUBLE PRECISION (A-D,P-Z) DIMENSION XD(NDP),YD(NDP),IPT(6*NDP-15),IPL(6*NDP), 1 IWL(18*NDP),IWP(NDP),WK(NDP) DIMENSION ITF(2) DATA RATIO/1.0E-6/, NREP/100/, LUN/6/ C STATEMENT FUNCTIONS 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 PRELIMINARY PROCESSING 10 NDP0=NDP NDPM1=NDP0-1 IF(NDP0.LT.4) GO TO 90 C DETERMINES THE CLOSEST PAIR OF DATA POINTS AND THEIR MIDPOINT. 20 DSQMN=DSQF(XD(1),YD(1),XD(2),YD(2)) IPMN1=1 IPMN2=2 DO 22 IP1=1,NDPM1 X1=XD(IP1) Y1=YD(IP1) IP1P1=IP1+1 DO 21 IP2=IP1P1,NDP0 DSQI=DSQF(X1,Y1,XD(IP2),YD(IP2)) IF(DSQI.EQ.0.0) GO TO 91 IF(DSQI.GE.DSQMN) GO TO 21 DSQMN=DSQI IPMN1=IP1 IPMN2=IP2 21 CONTINUE 22 CONTINUE DSQ12=DSQMN XDMP=(XD(IPMN1)+XD(IPMN2))/2.0 YDMP=(YD(IPMN1)+YD(IPMN2))/2.0 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. 30 JP1=2 DO 31 IP1=1,NDP0 IF(IP1.EQ.IPMN1.OR.IP1.EQ.IPMN2) GO TO 31 JP1=JP1+1 IWP(JP1)=IP1 WK(JP1)=DSQF(XDMP,YDMP,XD(IP1),YD(IP1)) 31 CONTINUE DO 33 JP1=3,NDPM1 DSQMN=WK(JP1) JPMN=JP1 DO 32 JP2=JP1,NDP0 IF(WK(JP2).GE.DSQMN) GO TO 32 DSQMN=WK(JP2) JPMN=JP2 32 CONTINUE ITS=IWP(JP1) IWP(JP1)=IWP(JPMN) IWP(JPMN)=ITS WK(JPMN)=WK(JP1) 33 CONTINUE C IF NECESSARY, MODIFIES THE ORDERING IN SUCH A WAY THAT THE C FIRST THREE DATA POINTS ARE NOT COLLINEAR. 35 AR=DSQ12*RATIO X1=XD(IPMN1) Y1=YD(IPMN1) DX21=XD(IPMN2)-X1 DY21=YD(IPMN2)-Y1 DO 36 JP=3,NDP0 IP=IWP(JP) IF(ABS((YD(IP)-Y1)*DX21-(XD(IP)-X1)*DY21).GT.AR) 1 GO TO 37 36 CONTINUE GO TO 92 37 IF(JP.EQ.3) GO TO 40 JPMX=JP JP=JPMX+1 DO 38 JPC=4,JPMX JP=JP-1 IWP(JP)=IWP(JP-1) 38 CONTINUE IWP(3)=IP 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. 40 IP1=IPMN1 IP2=IPMN2 IP3=IWP(3) IF(SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) 1 .GE.0.0) GO TO 41 IP1=IPMN2 IP2=IPMN1 41 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 ADDS THE REMAINING (NDP-3) DATA POINTS, ONE BY ONE. 50 DO 79 JP1=4,NDP0 IP1=IWP(JP1) X1=XD(IP1) Y1=YD(IP1) C - DETERMINES THE VISIBLE BORDER LINE SEGMENTS. 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 52 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 51 DSQI=DX**2+DY**2 IF(AR.GE.(-ARMN).AND.DSQI.GE.DSQMN) GO TO 51 JPMN=JP2 DXMN=DX DYMN=DY DSQMN=DSQI ARMN=DSQMN*RATIO 51 AR=DY*DXMX-DX*DYMX IF(AR.LT.(-ARMX)) GO TO 52 DSQI=DX**2+DY**2 IF(AR.LE.ARMX.AND.DSQI.GE.DSQMX) GO TO 52 JPMX=JP2 DXMX=DX DYMX=DY DSQMX=DSQI ARMX=DSQMX*RATIO 52 CONTINUE IF(JPMX.LT.JPMN) JPMX=JPMX+NL0 NSH=JPMN-1 IF(NSH.LE.0) GO TO 60 C - SHIFTS (ROTATES) THE IPL ARRAY TO HAVE THE INVISIBLE BORDER C - LINE SEGMENTS CONTAINED IN THE FIRST PART OF THE IPL ARRAY. NSHT3=NSH*3 DO 53 JP2T3=3,NSHT3,3 JP3T3=JP2T3+NLT3 IPL(JP3T3-2)=IPL(JP2T3-2) IPL(JP3T3-1)=IPL(JP2T3-1) IPL(JP3T3) =IPL(JP2T3) 53 CONTINUE DO 54 JP2T3=3,NLT3,3 JP3T3=JP2T3+NSHT3 IPL(JP2T3-2)=IPL(JP3T3-2) IPL(JP2T3-1)=IPL(JP3T3-1) IPL(JP2T3) =IPL(JP3T3) 54 CONTINUE JPMX=JPMX-NSH 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. 60 JWL=0 DO 64 JP2=JPMX,NL0 JP2T3=JP2*3 IPL1=IPL(JP2T3-2) IPL2=IPL(JP2T3-1) IT =IPL(JP2T3) C - - ADDS A TRIANGLE TO THE IPT ARRAY. NT0=NT0+1 NTT3=NTT3+3 IPT(NTT3-2)=IPL2 IPT(NTT3-1)=IPL1 IPT(NTT3) =IP1 C - - UPDATES BORDER LINE SEGMENTS IN THE IPL ARRAY. IF(JP2.NE.JPMX) GO TO 61 IPL(JP2T3-1)=IP1 IPL(JP2T3) =NT0 61 IF(JP2.NE.NL0) GO TO 62 NLN=JPMX+1 NLNT3=NLN*3 IPL(NLNT3-2)=IP1 IPL(NLNT3-1)=IPL(1) IPL(NLNT3) =NT0 C - - DETERMINES THE VERTEX THAT DOES NOT LIE ON THE BORDER C - - LINE SEGMENTS. 62 ITT3=IT*3 IPTI=IPT(ITT3-2) IF(IPTI.NE.IPL1.AND.IPTI.NE.IPL2) GO TO 63 IPTI=IPT(ITT3-1) IF(IPTI.NE.IPL1.AND.IPTI.NE.IPL2) GO TO 63 IPTI=IPT(ITT3) C - - CHECKS IF THE EXCHANGE IS NECESSARY. 63 IF(IDXCHG(XD,YD,NDP,IP1,IPTI,IPL1,IPL2).EQ.0) GO TO 64 C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. 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 - - SETS FLAGS IN THE IWL ARRAY. JWL=JWL+4 IWL(JWL-3)=IPL1 IWL(JWL-2)=IPTI IWL(JWL-1)=IPTI IWL(JWL) =IPL2 64 CONTINUE NL0=NLN NLT3=NLNT3 NLF=JWL/2 IF(NLF.EQ.0) GO TO 79 C - IMPROVES TRIANGULATION. 70 NTT3P3=NTT3+3 DO 78 IREP=1,NREP DO 76 ILF=1,NLF ILFT2=ILF*2 IPL1=IWL(ILFT2-1) IPL2=IWL(ILFT2) C - - LOCATES IN THE IPT ARRAY TWO TRIANGLES ON BOTH SIDES OF C - - THE FLAGGED LINE SEGMENT. NTF=0 DO 71 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 71 IF(IPL2.NE.IPT1.AND.IPL2.NE.IPT2.AND. 1 IPL2.NE.IPT3) GO TO 71 NTF=NTF+1 ITF(NTF)=ITT3/3 IF(NTF.EQ.2) GO TO 72 71 CONTINUE IF(NTF.LT.2) GO TO 76 C - - DETERMINES THE VERTEXES OF THE TRIANGLES THAT DO NOT LIE C - - ON THE LINE SEGMENT. 72 IT1T3=ITF(1)*3 IPTI1=IPT(IT1T3-2) IF(IPTI1.NE.IPL1.AND.IPTI1.NE.IPL2) GO TO 73 IPTI1=IPT(IT1T3-1) IF(IPTI1.NE.IPL1.AND.IPTI1.NE.IPL2) GO TO 73 IPTI1=IPT(IT1T3) 73 IT2T3=ITF(2)*3 IPTI2=IPT(IT2T3-2) IF(IPTI2.NE.IPL1.AND.IPTI2.NE.IPL2) GO TO 74 IPTI2=IPT(IT2T3-1) IF(IPTI2.NE.IPL1.AND.IPTI2.NE.IPL2) GO TO 74 IPTI2=IPT(IT2T3) C - - CHECKS IF THE EXCHANGE IS NECESSARY. 74 IF(IDXCHG(XD,YD,NDP,IPTI1,IPTI2,IPL1,IPL2).EQ.0) 1 GO TO 76 C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. IPT(IT1T3-2)=IPTI1 IPT(IT1T3-1)=IPTI2 IPT(IT1T3) =IPL1 IPT(IT2T3-2)=IPTI2 IPT(IT2T3-1)=IPTI1 IPT(IT2T3) =IPL2 C - - SETS NEW FLAGS. 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 75 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) 75 CONTINUE 76 CONTINUE NLFC=NLF NLF=JWL/2 IF(NLF.EQ.NLFC) GO TO 79 C - - RESETS THE IWL ARRAY FOR THE NEXT ROUND. JWL=0 JWL1MN=(NLFC+1)*2 NLFT2=NLF*2 DO 77 JWL1=JWL1MN,NLFT2,2 JWL=JWL+2 IWL(JWL-1)=IWL(JWL1-1) IWL(JWL) =IWL(JWL1) 77 CONTINUE NLF=JWL/2 78 CONTINUE 79 CONTINUE C REARRANGES THE IPT ARRAY SO THAT THE VERTEXES OF EACH TRIANGLE C ARE LISTED COUNTER-CLOCKWISE. 80 DO 81 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)) 1 .GE.0.0) GO TO 81 IPT(ITT3-2)=IP2 IPT(ITT3-1)=IP1 81 CONTINUE NT=NT0 NL=NL0 RETURN C ERROR EXIT 90 WRITE (LUN,2090) NDP0 GO TO 93 91 WRITE (LUN,2091) NDP0,IP1,IP2,X1,Y1 GO TO 93 92 WRITE (LUN,2092) NDP0 93 WRITE (LUN,2093) NT=0 RETURN C FORMAT STATEMENTS 2090 FORMAT(1X/23H *** NDP LESS THAN 4./8H NDP =,I5) 2091 FORMAT(1X/29H *** IDENTICAL DATA POINTS./ 1 8H NDP =,I5,5X,5HIP1 =,I5,5X,5HIP2 =,I5, 2 5X,4HXD =,E12.4,5X,4HYD =,E12.4) 2092 FORMAT(1X/33H *** ALL COLLINEAR DATA POINTS./ 1 8H NDP =,I5) 2093 FORMAT(35H ERROR DETECTED IN ROUTINE IDTANG/) END FUNCTION IDXCHG(X,Y,NDP,I1,I2,I3,I4) ID018560 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 WITH P3 C AND P4 CONNECTED DIAGONALLY. C THIS FUNCTION RETURNS AN INTEGER VALUE 1 (ONE) WHEN AN EX- C CHANGE IS NECESSARY, AND 0 (ZERO) OTHERWISE. C DECLARATION STATEMENTS IMPLICIT DOUBLE PRECISION (A-D,P-Z) DIMENSION X(NDP),Y(NDP) EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ), 1 (A4SQ,B1SQ),(B4SQ,A2SQ),(C4SQ,C3SQ) C PRELIMINARY PROCESSING 10 X1=X(I1) Y1=Y(I1) X2=X(I2) Y2=Y(I2) X3=X(I3) Y3=Y(I3) X4=X(I4) Y4=Y(I4) C CALCULATION 20 IDX=0 U3=(Y2-Y3)*(X1-X3)-(X2-X3)*(Y1-Y3) U4=(Y1-Y4)*(X2-X4)-(X1-X4)*(Y2-Y4) IF(U3*U4.LE.0.0) GO TO 30 U1=(Y3-Y1)*(X4-X1)-(X3-X1)*(Y4-Y1) U2=(Y4-Y2)*(X3-X2)-(X4-X2)*(Y3-Y2) A1SQ=(X1-X3)**2+(Y1-Y3)**2 B1SQ=(X4-X1)**2+(Y4-Y1)**2 C1SQ=(X3-X4)**2+(Y3-Y4)**2 A2SQ=(X2-X4)**2+(Y2-Y4)**2 B2SQ=(X3-X2)**2+(Y3-Y2)**2 C3SQ=(X2-X1)**2+(Y2-Y1)**2 S1SQ=U1*U1/(C1SQ*DMAX1(A1SQ,B1SQ)) S2SQ=U2*U2/(C2SQ*DMAX1(A2SQ,B2SQ)) S3SQ=U3*U3/(C3SQ*DMAX1(A3SQ,B3SQ)) S4SQ=U4*U4/(C4SQ*DMAX1(A4SQ,B4SQ)) IF(DMIN1(S1SQ,S2SQ).LT.DMIN1(S3SQ,S4SQ)) IDX=1 30 IDXCHG=IDX RETURN END C ALGORITHM 751, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 22, NO. 1, March, 1996, P. 1--8. C ####### With remark from renka (to appear) 4/dec/1998 C C modifications for R: C REAL -> DOUBLE PRECISION albrecht.gebhardt@uni-klu.ac.at C SUBROUTINE ADDCST (NCC,LCC,N,X,Y, LWK,IWK,LIST,LPTR, . LEND, IER) INTEGER NCC, LCC(*), N, LWK, IWK(LWK), LIST(*), . LPTR(*), LEND(N), IER DOUBLE PRECISION X(N), Y(N) C C*********************************************************** C C From TRIPACK C Robert J. Renka C Dept. of Computer Science C Univ. of North Texas C renka@cs.unt.edu C 11/12/94 C C This subroutine provides for creation of a constrained C Delaunay triangulation which, in some sense, covers an C arbitrary connected region R rather than the convex hull C of the nodes. This is achieved simply by forcing the C presence of certain adjacencies (triangulation arcs) cor- C responding to constraint curves. The union of triangles C coincides with the convex hull of the nodes, but triangles C in R can be distinguished from those outside of R. The C only modification required to generalize the definition of C the Delaunay triangulation is replacement of property 5 C (refer to TRMESH) by the following: C C 5 ') If a node is contained in the interior of the cir-C cumcircle of a triangle, then every interior pointC of the triangle is separated from the node by aC constraint arc.CC In order to be explicit, we make the following defini-C tions. A constraint region is the open interior of aC simple closed positively oriented polygonal curve definedC by an ordered sequence of three or more distinct nodesC (constraint nodes) P(1),P(2),...,P(K), such that P(I) isC adjacent to P(I+1) for I = 1,...,K with P(K+1) = P(1).C Thus, the constraint region is on the left (and may haveC nonfinite area) as the sequence of constraint nodes isC traversed in the specified order. The constraint regionsC must not contain nodes and must not overlap. The regionC R is the convex hull of the nodes with constraint regionsC excluded.CC Note that the terms boundary node and boundary arc areC reserved for nodes and arcs on the boundary of the convexC hull of the nodes.CC The algorithm is as follows: given a triangulationC which includes one or more sets of constraint nodes, theC corresponding adjacencies (constraint arcs) are forced toC be present (Subroutine EDGE). Any additional new arcsC required are chosen to be locally optimal (satisfy theC modified circumcircle property).CCC On input:CC NCC = Number of constraint curves (constraint re-C gions). NCC .GE. 0.CC LCC = Array of length NCC (or dummy array of lengthC 1 if NCC = 0) containing the index (for X, Y,C and LEND) of the first node of constraint I inC LCC(I) for I = 1 to NCC. Thus, constraint IC contains K = LCC(I+1) - LCC(I) nodes, K .GE.C 3, stored in (X,Y) locations LCC(I), ...,C LCC(I+1)-1, where LCC(NCC+1) = N+1.CC N = Number of nodes in the triangulation, includingC constraint nodes. N .GE. 3.CC X,Y = Arrays of length N containing the coordinatesC of the nodes with non-constraint nodes in theC first LCC(1)-1 locations, followed by NCC se-C quences of constraint nodes. Only one ofC these sequences may be specified in clockwiseC order to represent an exterior constraintC curve (a constraint region with nonfiniteC area).CC The above parameters are not altered by this routine.CC LWK = Length of IWK. This must be at least 2*NIC where NI is the maximum number of arcs whichC intersect a constraint arc to be added. NIC is bounded by N-3.CC IWK = Integer work array of length LWK (used byC Subroutine EDGE to add constraint arcs).CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC On output:CC LWK = Required length of IWK unless IER = 1 or IER =C 3. In the case of IER = 1, LWK is not alteredC from its input value.CC IWK = Array containing the endpoint indexes of theC new arcs which were swapped in by the lastC call to Subroutine EDGE.CC LIST,LPTR,LEND = Triangulation data structure withC all constraint arcs present unlessC IER .NE. 0. These arrays are notC altered if IER = 1.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = 1 if NCC, N, or an LCC entry is outsideC its valid range, or LWK .LT. 0 onC input.C IER = 2 if more space is required in IWK.C IER = 3 if the triangulation data structure isC invalid, or failure (in EDGE or OPTIM)C was caused by collinear nodes on theC convex hull boundary. An error mes-C sage is written to logical unit 6 inC this case.C IER = 4 if intersecting constraint arcs wereC encountered.C IER = 5 if a constraint region contains aC node.CC Modules required by ADDCST: EDGE, LEFT, LSTPTR, OPTIM,C SWAP, SWPTSTCC Intrinsic functions called by ADDCST: ABS, MAXCC***********************************************************C INTEGER I, IFRST, ILAST, K, KBAK, KFOR, KN, LCCIP1, . LP, LPB, LPF, LPL, LW, LWD2, N1, N2 LWD2 = LWK/2CC Test for errors in input parameters.C IER = 1 IF (NCC .LT. 0 .OR. LWK .LT. 0) RETURN IF (NCC .EQ. 0) THEN IF (N .LT. 3) RETURN LWK = 0 GO TO 9 ELSE LCCIP1 = N+1 DO 1 I = NCC,1,-1 IF (LCCIP1 - LCC(I) .LT. 3) RETURN LCCIP1 = LCC(I) 1 CONTINUE IF (LCCIP1 .LT. 1) RETURN ENDIFCC Force the presence of constraint arcs. The outer loop isC on constraints in reverse order. IFRST and ILAST areC the first and last nodes of constraint I.C LWK = 0 IFRST = N+1 DO 3 I = NCC,1,-1 ILAST = IFRST - 1 IFRST = LCC(I)CC Inner loop on constraint arcs N1-N2 in constraint I.C N1 = ILAST DO 2 N2 = IFRST,ILAST LW = LWD2 CALL EDGE (N1,N2,X,Y, LW,IWK,LIST,LPTR,LEND, IER) LWK = MAX(LWK,2*LW) IF (IER .EQ. 4) IER = 3 IF (IER .NE. 0) RETURN N1 = N2 2 CONTINUE 3 CONTINUECC Test for errors. The outer loop is on constraint I withC first and last nodes IFRST and ILAST, and the inner loopC is on constraint nodes K with (KBAK,K,KFOR) a subse-C quence of constraint I.C IER = 4 IFRST = N+1 DO 8 I = NCC,1,-1 ILAST = IFRST - 1 IFRST = LCC(I) KBAK = ILAST DO 7 K = IFRST,ILAST KFOR = K + 1 IF (K .EQ. ILAST) KFOR = IFRSTCC Find the LIST pointers LPF and LPB of KFOR and KBAK asC neighbors of K.C LPF = 0 LPB = 0 LPL = LEND(K) LP = LPLC 4 LP = LPTR(LP) KN = ABS(LIST(LP)) IF (KN .EQ. KFOR) LPF = LP IF (KN .EQ. KBAK) LPB = LP IF (LP .NE. LPL) GO TO 4CC A pair of intersecting constraint arcs was encounteredC if and only if a constraint arc is missing (introduc-C tion of the second caused the first to be swapped out).C IF (LPF .EQ. 0 .OR. LPB .EQ. 0) RETURNCC Loop on neighbors KN of node K which follow KFOR andC precede KBAK. The constraint region contains no nodesC if and only if all such nodes KN are in constraint I.C LP = LPF 5 LP = LPTR(LP) IF (LP .EQ. LPB) GO TO 6 KN = ABS(LIST(LP)) IF (KN .LT. IFRST .OR. KN .GT. ILAST) GO TO 10 GO TO 5CC Bottom of loop.C 6 KBAK = K 7 CONTINUE 8 CONTINUECC No errors encountered.C 9 IER = 0 RETURNCC A constraint region contains a node.C 10 IER = 5 RETURN END SUBROUTINE ADDNOD (K,XK,YK,IST,NCC, LCC,N,X,Y,LIST, . LPTR,LEND,LNEW, IER) INTEGER K, IST, NCC, LCC(*), N, LIST(*), LPTR(*), . LEND(*), LNEW, IER DOUBLE PRECISION XK, YK, X(*), Y(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/27/98CC Given a triangulation of N nodes in the plane created byC Subroutine TRMESH or TRMSHR, this subroutine updates theC data structure with the addition of a new node in positionC K. If node K is inserted into X and Y (K .LE. N) ratherC than appended (K = N+1), then a corresponding insertionC must be performed in any additional arrays associatedC with the nodes. For example, an array of data values ZC must be shifted down to open up position K for the newC value: set Z(I+1) to Z(I) for I = N,N-1,...,K. ForC optimal efficiency, new nodes should be appended wheneverC possible. Insertion is necessary, however, to add a non-C constraint node when constraints are present (refer toC Subroutine ADDCST).CC Note that a constraint node cannot be added by thisC routine. In order to insert a constraint node, it isC necessary to add the node with no constraints presentC (call this routine with NCC = 0), update LCC by increment-C ing the appropriate entries, and then create (or restore)C the constraints by a call to ADDCST.CC The algorithm consists of the following steps: node KC is located relative to the triangulation (TRFIND), itsC index is added to the data structure (INTADD or BDYADD),C and a sequence of swaps (SWPTST and SWAP) are applied toC the arcs opposite K so that all arcs incident on node KC and opposite node K (excluding constraint arcs) are local-C ly optimal (satisfy the circumcircle test). Thus, if aC (constrained) Delaunay triangulation is input, a (con-C strained) Delaunay triangulation will result. All indexesC are incremented as necessary for an insertion.CCC On input:CC K = Nodal index (index for X, Y, and LEND) of theC new node to be added. 1 .LE. K .LE. LCC(1).C (K .LE. N+1 if NCC=0).CC XK,YK = Cartesian coordinates of the new node (to beC stored in X(K) and Y(K)). The node must notC lie in a constraint region.CC IST = Index of a node at which TRFIND begins theC search. Search time depends on the proximityC of this node to node K. 1 .LE. IST .LE. N.CC NCC = Number of constraint curves. NCC .GE. 0.CC The above parameters are not altered by this routine.CC LCC = List of constraint curve starting indexes (orC dummy array of length 1 if NCC = 0). Refer toC Subroutine ADDCST.CC N = Number of nodes in the triangulation before K isC added. N .GE. 3. Note that N will be incre-C mented following the addition of node K.CC X,Y = Arrays of length at least N+1 containing theC Cartesian coordinates of the nodes in theC first N positions with non-constraint nodesC in the first LCC(1)-1 locations if NCC > 0.CC LIST,LPTR,LEND,LNEW = Data structure associated withC the triangulation of nodes 1C to N. The arrays must haveC sufficient length for N+1C nodes. Refer to TRMESH.CC On output:CC LCC = List of constraint curve starting indexes in-C cremented by 1 to reflect the insertion of KC unless NCC = 0 or (IER .NE. 0 and IER .NE.C -4).CC N = Number of nodes in the triangulation including KC unless IER .NE. 0 and IER .NE. -4. Note thatC all comments refer to the input value of N.CC X,Y = Arrays updated with the insertion of XK and YKC in the K-th positions (node I+1 was node I be-C fore the insertion for I = K to N if K .LE. N)C unless IER .NE. 0 and IER .NE. -4.CC LIST,LPTR,LEND,LNEW = Data structure updated withC the addition of node K unlessC IER .NE. 0 and IER .NE. -4.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = -1 if K, IST, NCC, N, or an LCC entry isC outside its valid range on input.C IER = -2 if all nodes (including K) are col-C linear.C IER = L if nodes L and K coincide for some L.C IER = -3 if K lies in a constraint region.C IER = -4 if an error flag is returned by SWAPC implying that the triangulationC (geometry) was bad on input.CC The errors conditions are tested in the orderC specified.CC Modules required by ADDNOD: BDYADD, CRTRI, INDXCC,C INSERT, INTADD, JRAND,C LEFT, LSTPTR, SWAP,C SWPTST, TRFINDCC Intrinsic function called by ADDNOD: ABSCC***********************************************************C INTEGER INDXCC, LSTPTR INTEGER I, I1, I2, I3, IBK, IO1, IO2, IN1, KK, L, . LCCIP1, LP, LPF, LPO1, NM1 LOGICAL CRTRI, SWPTST KK = KCC Test for an invalid input parameter.C IF (KK .LT. 1 .OR. IST .LT. 1 .OR. IST .GT. N . .OR. NCC .LT. 0 .OR. N .LT. 3) GO TO 7 LCCIP1 = N+1 DO 1 I = NCC,1,-1 IF (LCCIP1-LCC(I) .LT. 3) GO TO 7 LCCIP1 = LCC(I) 1 CONTINUE IF (KK .GT. LCCIP1) GO TO 7CC Find a triangle (I1,I2,I3) containing K or the rightmostC (I1) and leftmost (I2) visible boundary nodes as viewedC from node K.C CALL TRFIND (IST,XK,YK,N,X,Y,LIST,LPTR,LEND, I1,I2,I3)CC Test for collinear nodes, duplicate nodes, and K lying inC a constraint region.C IF (I1 .EQ. 0) GO TO 8 IF (I3 .NE. 0) THEN L = I1 IF (XK .EQ. X(L) .AND. YK .EQ. Y(L)) GO TO 9 L = I2 IF (XK .EQ. X(L) .AND. YK .EQ. Y(L)) GO TO 9 L = I3 IF (XK .EQ. X(L) .AND. YK .EQ. Y(L)) GO TO 9 IF (NCC .GT. 0 .AND. CRTRI(NCC,LCC,I1,I2,I3) ) . GO TO 10 ELSECC K is outside the convex hull of the nodes and lies in aC constraint region iff an exterior constraint curve isC present.C IF (NCC .GT. 0 .AND. INDXCC(NCC,LCC,N,LIST,LEND) . .NE. 0) GO TO 10 ENDIFCC No errors encountered.C IER = 0 NM1 = N N = N + 1 IF (KK .LT. N) THENCC Open a slot for K in X, Y, and LEND, and increment allC nodal indexes which are greater than or equal to K.C Note that LIST, LPTR, and LNEW are not yet updated withC either the neighbors of K or the edges terminating on K.C DO 2 IBK = NM1,KK,-1 X(IBK+1) = X(IBK) Y(IBK+1) = Y(IBK) LEND(IBK+1) = LEND(IBK) 2 CONTINUE DO 3 I = 1,NCC LCC(I) = LCC(I) + 1 3 CONTINUE L = LNEW - 1 DO 4 I = 1,L IF (LIST(I) .GE. KK) LIST(I) = LIST(I) + 1 IF (LIST(I) .LE. -KK) LIST(I) = LIST(I) - 1 4 CONTINUE IF (I1 .GE. KK) I1 = I1 + 1 IF (I2 .GE. KK) I2 = I2 + 1 IF (I3 .GE. KK) I3 = I3 + 1 ENDIFCC Insert K into X and Y, and update LIST, LPTR, LEND, andC LNEW with the arcs containing node K.C X(KK) = XK Y(KK) = YK IF (I3 .EQ. 0) THEN CALL BDYADD (KK,I1,I2, LIST,LPTR,LEND,LNEW ) ELSE CALL INTADD (KK,I1,I2,I3, LIST,LPTR,LEND,LNEW ) ENDIFCC Initialize variables for optimization of the triangula-C tion.C LP = LEND(KK) LPF = LPTR(LP) IO2 = LIST(LPF) LPO1 = LPTR(LPF) IO1 = ABS(LIST(LPO1))CC Begin loop: find the node opposite K.C 5 LP = LSTPTR(LEND(IO1),IO2,LIST,LPTR) IF (LIST(LP) .LT. 0) GO TO 6 LP = LPTR(LP) IN1 = ABS(LIST(LP)) IF ( CRTRI(NCC,LCC,IO1,IO2,IN1) ) GO TO 6CC Swap test: if a swap occurs, two new arcs areC opposite K and must be tested.C IF ( .NOT. SWPTST(IN1,KK,IO1,IO2,X,Y) ) GO TO 6 CALL SWAP (IN1,KK,IO1,IO2, LIST,LPTR,LEND, LPO1) IF (LPO1 .EQ. 0) GO TO 11 IO1 = IN1 GO TO 5CC No swap occurred. Test for termination and resetC IO2 and IO1.C 6 IF (LPO1 .EQ. LPF .OR. LIST(LPO1) .LT. 0) RETURN IO2 = IO1 LPO1 = LPTR(LPO1) IO1 = ABS(LIST(LPO1)) GO TO 5CC A parameter is outside its valid range on input.C 7 IER = -1 RETURNCC All nodes are collinear.C 8 IER = -2 RETURNCC Nodes L and K coincide.C 9 IER = L RETURNCC Node K lies in a constraint region.C 10 IER = -3 RETURNCC Zero pointer returned by SWAP.C 11 IER = -4 RETURN END DOUBLE PRECISION FUNCTION AREAP (X,Y,NB,NODES) INTEGER NB, NODES(NB) DOUBLE PRECISION X(*), Y(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/21/90CC Given a sequence of NB points in the plane, this func-C tion computes the signed area bounded by the closed poly-C gonal curve which passes through the points in theC specified order. Each simple closed curve is positivelyC oriented (bounds positive area) if and only if the pointsC are specified in counterclockwise order. The last pointC of the curve is taken to be the first point specified, andC this point should therefore not be specified twice.CC The area of a triangulation may be computed by callingC AREAP with values of NB and NODES determined by SubroutineC BNODES.CCC On input:CC X,Y = Arrays of length N containing the CartesianC coordinates of a set of points in the planeC for some N .GE. NB.CC NB = Length of NODES.CC NODES = Array of length NB containing the orderedC sequence of nodal indexes (in the rangeC 1 to N) which define the polygonal curve.CC Input parameters are not altered by this function.CC On output:CC AREAP = Signed area bounded by the polygonal curve,C or zero if NB < 3.CC Modules required by AREAP: NoneCC***********************************************************C INTEGER I, ND1, ND2, NNB DOUBLE PRECISION ACC Local parameters:CC A = Partial sum of signed (and doubled) trapezoidC areasC I = DO-loop and NODES indexC ND1,ND2 = Elements of NODESC NNB = Local copy of NBC NNB = NB A = 0. IF (NNB .LT. 3) GO TO 2 ND2 = NODES(NNB)CC Loop on line segments NODES(I-1) -> NODES(I), whereC NODES(0) = NODES(NB), adding twice the signed trapezoidC areas (integrals of the linear interpolants) to A.C DO 1 I = 1,NNB ND1 = ND2 ND2 = NODES(I) A = A + (X(ND2)-X(ND1))*(Y(ND1)+Y(ND2)) 1 CONTINUECC A contains twice the negative signed area of the region.C 2 AREAP = -A/2. RETURN END SUBROUTINE BDYADD (KK,I1,I2, LIST,LPTR,LEND,LNEW ) INTEGER KK, I1, I2, LIST(*), LPTR(*), LEND(*), LNEWCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 02/22/91CC This subroutine adds a boundary node to a triangulationC of a set of points in the plane. The data structure isC updated with the insertion of node KK, but no optimizationC is performed.CCC On input:CC KK = Index of a node to be connected to the sequenceC of all visible boundary nodes. KK .GE. 1 andC KK must not be equal to I1 or I2.CC I1 = First (rightmost as viewed from KK) boundaryC node in the triangulation which is visible fromC node KK (the line segment KK-I1 intersects noC arcs.CC I2 = Last (leftmost) boundary node which is visibleC from node KK. I1 and I2 may be determined byC Subroutine TRFIND.CC The above parameters are not altered by this routine.CC LIST,LPTR,LEND,LNEW = Triangulation data structureC created by TRMESH or TRMSHR.C Nodes I1 and I2 must be in-C cluded in the triangulation.CC On output:CC LIST,LPTR,LEND,LNEW = Data structure updated withC the addition of node KK. NodeC KK is connected to I1, I2, andC all boundary nodes in between.CC Module required by BDYADD: INSERTCC***********************************************************C INTEGER K, LP, LSAV, N1, N2, NEXT, NSAV K = KK N1 = I1 N2 = I2CC Add K as the last neighbor of N1.C LP = LEND(N1) LSAV = LPTR(LP) LPTR(LP) = LNEW LIST(LNEW) = -K LPTR(LNEW) = LSAV LEND(N1) = LNEW LNEW = LNEW + 1 NEXT = -LIST(LP) LIST(LP) = NEXT NSAV = NEXTCC Loop on the remaining boundary nodes between N1 and N2,C adding K as the first neighbor.C 1 LP = LEND(NEXT) CALL INSERT (K,LP,LIST,LPTR,LNEW) IF (NEXT .EQ. N2) GO TO 2 NEXT = -LIST(LP) LIST(LP) = NEXT GO TO 1CC Add the boundary nodes between N1 and N2 as neighborsC of node K.C 2 LSAV = LNEW LIST(LNEW) = N1 LPTR(LNEW) = LNEW + 1 LNEW = LNEW + 1 NEXT = NSAVC 3 IF (NEXT .EQ. N2) GO TO 4 LIST(LNEW) = NEXT LPTR(LNEW) = LNEW + 1 LNEW = LNEW + 1 LP = LEND(NEXT) NEXT = LIST(LP) GO TO 3C 4 LIST(LNEW) = -N2 LPTR(LNEW) = LSAV LEND(K) = LNEW LNEW = LNEW + 1 RETURN END SUBROUTINE BNODES (N,LIST,LPTR,LEND, NODES,NB,NA,NT) INTEGER N, LIST(*), LPTR(*), LEND(N), NODES(*), NB, . NA, NTCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC Given a triangulation of N points in the plane, thisC subroutine returns an array containing the indexes, inC counterclockwise order, of the nodes on the boundary ofC the convex hull of the set of points.CCC On input:CC N = Number of nodes in the triangulation. N .GE. 3.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC The above parameters are not altered by this routine.CC NODES = Integer array of length at least NBC (NB .LE. N).CC On output:CC NODES = Ordered sequence of boundary node indexesC in the range 1 to N.CC NB = Number of boundary nodes.CC NA,NT = Number of arcs and triangles, respectively,C in the triangulation.CC Modules required by BNODES: NoneCC***********************************************************C INTEGER K, LP, N0, NSTCC Set NST to the first boundary node encountered.C NST = 1 1 LP = LEND(NST) IF (LIST(LP) .LT. 0) GO TO 2 NST = NST + 1 GO TO 1CC Initialization.C 2 NODES(1) = NST K = 1 N0 = NSTCC Traverse the boundary in counterclockwise order.C 3 LP = LEND(N0) LP = LPTR(LP) N0 = LIST(LP) IF (N0 .EQ. NST) GO TO 4 K = K + 1 NODES(K) = N0 GO TO 3CC Termination.C 4 NB = K NT = 2*N - NB - 2 NA = NT + N - 1 RETURN END SUBROUTINE CIRCUM (X1,Y1,X2,Y2,X3,Y3,RATIO, XC,YC,CR, . SA,AR) LOGICAL RATIO DOUBLE PRECISION X1, Y1, X2, Y2, X3, Y3, XC, YC, CR, . SA, ARCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 12/10/96CC Given three vertices defining a triangle, this subrou-C tine returns the circumcenter, circumradius, signedC triangle area, and, optionally, the aspect ratio of theC triangle.CCC On input:CC X1,...,Y3 = Cartesian coordinates of the vertices.CC RATIO = Logical variable with value TRUE if and onlyC if the aspect ratio is to be computed.CC Input parameters are not altered by this routine.CC On output:CC XC,YC = Cartesian coordinates of the circumcenterC (center of the circle defined by the threeC points) unless SA = 0, in which XC and YCC are not altered.CC CR = Circumradius (radius of the circle defined byC the three points) unless SA = 0 (infiniteC radius), in which case CR is not altered.CC SA = Signed triangle area with positive value ifC and only if the vertices are specified inC counterclockwise order: (X3,Y3) is strictlyC to the left of the directed line from (X1,Y1)C toward (X2,Y2).CC AR = Aspect ratio r/CR, where r is the radius of theC inscribed circle, unless RATIO = FALSE, inC which case AR is not altered. AR is in theC range 0 to .5, with value 0 iff SA = 0 andC value .5 iff the vertices define an equilateralC triangle.CC Modules required by CIRCUM: NoneCC Intrinsic functions called by CIRCUM: ABS, SQRTCC***********************************************************C INTEGER I DOUBLE PRECISION DS(3), FX, FY, U(3), V(3)CC Set U(K) and V(K) to the x and y components, respectively,C of the directed edge opposite vertex K.C U(1) = X3 - X2 U(2) = X1 - X3 U(3) = X2 - X1 V(1) = Y3 - Y2 V(2) = Y1 - Y3 V(3) = Y2 - Y1CC Set SA to the signed triangle area.C SA = (U(1)*V(2) - U(2)*V(1))/2. IF (SA .EQ. 0.) THEN IF (RATIO) AR = 0. RETURN ENDIFCC Set DS(K) to the squared distance from the origin toC vertex K.C DS(1) = X1*X1 + Y1*Y1 DS(2) = X2*X2 + Y2*Y2 DS(3) = X3*X3 + Y3*Y3CC Compute factors of XC and YC.C FX = 0. FY = 0. DO 1 I = 1,3 FX = FX - DS(I)*V(I) FY = FY + DS(I)*U(I) 1 CONTINUE XC = FX/(4.*SA) YC = FY/(4.*SA) CR = SQRT( (XC-X1)**2 + (YC-Y1)**2 ) IF (.NOT. RATIO) RETURNCC Compute the squared edge lengths and aspect ratio.C DO 2 I = 1,3 DS(I) = U(I)*U(I) + V(I)*V(I) 2 CONTINUE AR = 2.*ABS(SA)/ . ( (SQRT(DS(1)) + SQRT(DS(2)) + SQRT(DS(3)))*CR ) RETURN END LOGICAL FUNCTION CRTRI (NCC,LCC,I1,I2,I3) INTEGER NCC, LCC(*), I1, I2, I3CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 08/14/91CC This function returns TRUE if and only if triangle (I1,C I2,I3) lies in a constraint region.CCC On input:CC NCC,LCC = Constraint data structure. Refer to Sub-C routine ADDCST.CC I1,I2,I3 = Nodal indexes of the counterclockwise-C ordered vertices of a triangle.CC Input parameters are altered by this function.CC CRTRI = TRUE iff (I1,I2,I3) is a constraint regionC triangle.CC Note that input parameters are not tested for validity.CC Modules required by CRTRI: NoneCC Intrinsic functions called by CRTRI: MAX, MINCC***********************************************************C INTEGER I, IMAX, IMIN IMAX = MAX(I1,I2,I3)CC Find the index I of the constraint containing IMAX.C I = NCC + 1 1 I = I - 1 IF (I .LE. 0) GO TO 2 IF (IMAX .LT. LCC(I)) GO TO 1 IMIN = MIN(I1,I2,I3)CC P lies in a constraint region iff I1, I2, and I3 are nodesC of the same constraint (IMIN >= LCC(I)), and (IMIN,IMAX)C is (I1,I3), (I2,I1), or (I3,I2).C CRTRI = IMIN .GE. LCC(I) .AND. ((IMIN .EQ. I1 .AND. . IMAX .EQ. I3) .OR. (IMIN .EQ. I2 .AND. . IMAX .EQ. I1) .OR. (IMIN .EQ. I3 .AND. . IMAX .EQ. I2)) RETURNCC NCC .LE. 0 or all vertices are non-constraint nodes.C 2 CRTRI = .FALSE. RETURN END SUBROUTINE DELARC (N,IO1,IO2, LIST,LPTR,LEND, . LNEW, IER) INTEGER N, IO1, IO2, LIST(*), LPTR(*), LEND(N), LNEW, . IERCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 11/12/94CC This subroutine deletes a boundary arc from a triangula-C tion. It may be used to remove a null triangle from theC convex hull boundary. Note, however, that if the union ofC triangles is rendered nonconvex, Subroutines DELNOD, EDGE,C and TRFIND may fail. Thus, Subroutines ADDCST, ADDNOD,C DELNOD, EDGE, and NEARND should not be called followingC an arc deletion.CCC On input:CC N = Number of nodes in the triangulation. N .GE. 4.CC IO1,IO2 = Indexes (in the range 1 to N) of a pair ofC adjacent boundary nodes defining the arcC to be removed.CC The above parameters are not altered by this routine.CC LIST,LPTR,LEND,LNEW = Triangulation data structureC created by TRMESH or TRMSHR.CC On output:CC LIST,LPTR,LEND,LNEW = Data structure updated withC the removal of arc IO1-IO2C unless IER > 0.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = 1 if N, IO1, or IO2 is outside its validC range, or IO1 = IO2.C IER = 2 if IO1-IO2 is not a boundary arc.C IER = 3 if the node opposite IO1-IO2 is al-C ready a boundary node, and thus IO1C or IO2 has only two neighbors or aC deletion would result in two triangu-C lations sharing a single node.C IER = 4 if one of the nodes is a neighbor ofC the other, but not vice versa, imply-C ing an invalid triangulation dataC structure.CC Modules required by DELARC: DELNB, LSTPTRCC Intrinsic function called by DELARC: ABSCC***********************************************************C INTEGER LSTPTR INTEGER LP, LPH, LPL, N1, N2, N3 N1 = IO1 N2 = IO2CC Test for errors, and set N1->N2 to the directed boundaryC edge associated with IO1-IO2: (N1,N2,N3) is a triangleC for some N3.C IF (N .LT. 4 .OR. N1 .LT. 1 .OR. N1 .GT. N .OR. . N2 .LT. 1 .OR. N2 .GT. N .OR. N1 .EQ. N2) THEN IER = 1 RETURN ENDIFC LPL = LEND(N2) IF (-LIST(LPL) .NE. N1) THEN N1 = N2 N2 = IO1 LPL = LEND(N2) IF (-LIST(LPL) .NE. N1) THEN IER = 2 RETURN ENDIF ENDIFCC Set N3 to the node opposite N1->N2 (the second neighborC of N1), and test for error 3 (N3 already a boundaryC node).C LPL = LEND(N1) LP = LPTR(LPL) LP = LPTR(LP) N3 = ABS(LIST(LP)) LPL = LEND(N3) IF (LIST(LPL) .LE. 0) THEN IER = 3 RETURN ENDIFCC Delete N2 as a neighbor of N1, making N3 the firstC neighbor, and test for error 4 (N2 not a neighborC of N1). Note that previously computed pointers mayC no longer be valid following the call to DELNB.C CALL DELNB (N1,N2,N, LIST,LPTR,LEND,LNEW, LPH) IF (LPH .LT. 0) THEN IER = 4 RETURN ENDIFCC Delete N1 as a neighbor of N2, making N3 the new lastC neighbor.C CALL DELNB (N2,N1,N, LIST,LPTR,LEND,LNEW, LPH)CC Make N3 a boundary node with first neighbor N2 and lastC neighbor N1.C LP = LSTPTR(LEND(N3),N1,LIST,LPTR) LEND(N3) = LP LIST(LP) = -N1CC No errors encountered.C IER = 0 RETURN END SUBROUTINE DELNB (N0,NB,N, LIST,LPTR,LEND,LNEW, LPH) INTEGER N0, NB, N, LIST(*), LPTR(*), LEND(N), LNEW, . LPHCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 07/30/98CC This subroutine deletes a neighbor NB from the adjacencyC list of node N0 (but N0 is not deleted from the adjacencyC list of NB) and, if NB is a boundary node, makes N0 aC boundary node. For pointer (LIST index) LPH to NB as aC neighbor of N0, the empty LIST,LPTR location LPH is filledC in with the values at LNEW-1, pointer LNEW-1 (in LPTR andC possibly in LEND) is changed to LPH, and LNEW is decremen-C ted. This requires a search of LEND and LPTR entailing anC expected operation count of O(N).CCC On input:CC N0,NB = Indexes, in the range 1 to N, of a pair ofC nodes such that NB is a neighbor of N0.C (N0 need not be a neighbor of NB.)CC N = Number of nodes in the triangulation. N .GE. 3.CC The above parameters are not altered by this routine.CC LIST,LPTR,LEND,LNEW = Data structure defining theC triangulation.CC On output:CC LIST,LPTR,LEND,LNEW = Data structure updated withC the removal of NB from the ad-C jacency list of N0 unlessC LPH < 0.CC LPH = List pointer to the hole (NB as a neighbor ofC N0) filled in by the values at LNEW-1 or errorC indicator:C LPH > 0 if no errors were encountered.C LPH = -1 if N0, NB, or N is outside its validC range.C LPH = -2 if NB is not a neighbor of N0.CC Modules required by DELNB: NoneCC Intrinsic function called by DELNB: ABSCC***********************************************************C INTEGER I, LNW, LP, LPB, LPL, LPP, NNCC Local parameters:CC I = DO-loop indexC LNW = LNEW-1 (output value of LNEW)C LP = LIST pointer of the last neighbor of NBC LPB = Pointer to NB as a neighbor of N0C LPL = Pointer to the last neighbor of N0C LPP = Pointer to the neighbor of N0 that precedes NBC NN = Local copy of NC NN = NCC Test for error 1.C IF (N0 .LT. 1 .OR. N0 .GT. NN .OR. NB .LT. 1 .OR. . NB .GT. NN .OR. NN .LT. 3) THEN LPH = -1 RETURN ENDIFCC Find pointers to neighbors of N0:CC LPL points to the last neighbor,C LPP points to the neighbor NP preceding NB, andC LPB points to NB.C LPL = LEND(N0) LPP = LPL LPB = LPTR(LPP) 1 IF (LIST(LPB) .EQ. NB) GO TO 2 LPP = LPB LPB = LPTR(LPP) IF (LPB .NE. LPL) GO TO 1CC Test for error 2 (NB not found).C IF (ABS(LIST(LPB)) .NE. NB) THEN LPH = -2 RETURN ENDIFCC NB is the last neighbor of N0. Make NP the new lastC neighbor and, if NB is a boundary node, then make N0C a boundary node.C LEND(N0) = LPP LP = LEND(NB) IF (LIST(LP) .LT. 0) LIST(LPP) = -LIST(LPP) GO TO 3CC NB is not the last neighbor of N0. If NB is a boundaryC node and N0 is not, then make N0 a boundary node withC last neighbor NP.C 2 LP = LEND(NB) IF (LIST(LP) .LT. 0 .AND. LIST(LPL) .GT. 0) THEN LEND(N0) = LPP LIST(LPP) = -LIST(LPP) ENDIFCC Update LPTR so that the neighbor following NB now fol-C lows NP, and fill in the hole at location LPB.C 3 LPTR(LPP) = LPTR(LPB) LNW = LNEW-1 LIST(LPB) = LIST(LNW) LPTR(LPB) = LPTR(LNW) DO 4 I = NN,1,-1 IF (LEND(I) .EQ. LNW) THEN LEND(I) = LPB GO TO 5 ENDIF 4 CONTINUEC 5 DO 6 I = 1,LNW-1 IF (LPTR(I) .EQ. LNW) THEN LPTR(I) = LPB ENDIF 6 CONTINUECC No errors encountered.C LNEW = LNW LPH = LPB RETURN END SUBROUTINE DELNOD (K,NCC, LCC,N,X,Y,LIST,LPTR,LEND, . LNEW,LWK,IWK, IER) INTEGER K, NCC, LCC(*), N, LIST(*), LPTR(*), . LEND(*), LNEW, LWK, IWK(2,*), IER DOUBLE PRECISION X(*), Y(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/28/98CC This subroutine deletes node K (along with all arcsC incident on node K) from a triangulation of N nodes in theC plane, and inserts arcs as necessary to produce a triangu-C lation of the remaining N-1 nodes. If a Delaunay triangu-C lation is input, a Delaunay triangulation will result, andC thus, DELNOD reverses the effect of a call to SubroutineC ADDNOD.CC Note that a constraint node cannot be deleted by thisC routine. In order to delete a constraint node, it isC necessary to call this routine with NCC = 0, decrement theC appropriate LCC entries (LCC(I) such that LCC(I) > K), andC then create (or restore) the constraints by a call to Sub-C routine ADDCST.CCC On input:CC K = Index (for X and Y) of the node to be deleted.C 1 .LE. K .LT. LCC(1). (K .LE. N if NCC=0).CC NCC = Number of constraint curves. NCC .GE. 0.CC The above parameters are not altered by this routine.CC LCC = List of constraint curve starting indexes (orC dummy array of length 1 if NCC = 0). Refer toC Subroutine ADDCST.CC N = Number of nodes in the triangulation on input.C N .GE. 4. Note that N will be decrementedC following the deletion.CC X,Y = Arrays of length N containing the coordinatesC of the nodes with non-constraint nodes in theC first LCC(1)-1 locations if NCC > 0.CC LIST,LPTR,LEND,LNEW = Data structure defining theC triangulation. Refer to Sub-C routine TRMESH.CC LWK = Number of columns reserved for IWK. LWK mustC be at least NNB-3, where NNB is the number ofC neighbors of node K, including an extraC pseudo-node if K is a boundary node.CC IWK = Integer work array dimensioned 2 by LWK (orC array of length .GE. 2*LWK).CC On output:CC LCC = List of constraint curve starting indexes de-C cremented by 1 to reflect the deletion of KC unless NCC = 0 or 1 .LE. IER .LE. 4.CC N = New number of nodes (input value minus one) un-C less 1 .LE. IER .LE. 4.CC X,Y = Updated arrays of length N-1 containing nodalC coordinates (with elements K+1,...,N shiftedC up a position and thus overwriting element K)C unless 1 .LE. IER .LE. 4. (N here denotes theC input value.)CC LIST,LPTR,LEND,LNEW = Updated triangulation dataC structure reflecting the dele-C tion unless IER .NE. 0. NoteC that the data structure mayC have been altered if IER .GE.C 3.CC LWK = Number of IWK columns required unless IER = 1C or IER = 3.CC IWK = Indexes of the endpoints of the new arcs addedC unless LWK = 0 or 1 .LE. IER .LE. 4. (ArcsC are associated with columns, or pairs ofC adjacent elements if IWK is declared as aC singly-subscripted array.)CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = 1 if K, NCC, N, or an LCC entry is out-C side its valid range or LWK < 0 onC input.C IER = 2 if more space is required in IWK.C Refer to LWK.C IER = 3 if the triangulation data structure isC invalid on input.C IER = 4 if K is an interior node with 4 orC more neighbors, and the number ofC neighbors could not be reduced to 3C by swaps. This could be caused byC floating point errors with collinearC nodes or by an invalid data structure.C IER = 5 if an error flag was returned byC OPTIM. An error message is writtenC to the standard output unit in thisC event.CC Note that the deletion may result in all remaining nodesC being collinear. This situation is not flagged.CC Modules required by DELNOD: DELNB, LEFT, LSTPTR, NBCNT,C OPTIM, SWAP, SWPTSTCC Intrinsic function called by DELNOD: ABSCC***********************************************************C INTEGER LSTPTR, NBCNT LOGICAL LEFT INTEGER I, IERR, IWL, J, LCCIP1, LNW, LP, LP21, LPF, . LPH, LPL, LPL2, LPN, LWKL, N1, N2, NFRST, NIT, . NL, NN, NNB, NR LOGICAL BDRY DOUBLE PRECISION X1, X2, XL, XR, Y1, Y2, YL, YRCC Set N1 to K and NNB to the number of neighbors of N1 (plusC one if N1 is a boundary node), and test for errors. LPFC and LPL are LIST indexes of the first and last neighborsC of N1, IWL is the number of IWK columns containing arcs,C and BDRY is TRUE iff N1 is a boundary node.C N1 = K NN = N IF (NCC .LT. 0 .OR. N1 .LT. 1 .OR. NN .LT. 4 .OR. . LWK .LT. 0) GO TO 21 LCCIP1 = NN+1 DO 1 I = NCC,1,-1 IF (LCCIP1-LCC(I) .LT. 3) GO TO 21 LCCIP1 = LCC(I) 1 CONTINUE IF (N1 .GE. LCCIP1) GO TO 21 LPL = LEND(N1) LPF = LPTR(LPL) NNB = NBCNT(LPL,LPTR) BDRY = LIST(LPL) .LT. 0 IF (BDRY) NNB = NNB + 1 IF (NNB .LT. 3) GO TO 23 LWKL = LWK LWK = NNB - 3 IF (LWKL .LT. LWK) GO TO 22 IWL = 0 IF (NNB .EQ. 3) GO TO 5CC Initialize for loop on arcs N1-N2 for neighbors N2 of N1,C beginning with the second neighbor. NR and NL are theC neighbors preceding and following N2, respectively, andC LP indexes NL. The loop is exited when all possibleC swaps have been applied to arcs incident on N1. If N1C is interior, the number of neighbors will be reducedC to 3.C X1 = X(N1) Y1 = Y(N1) NFRST = LIST(LPF) NR = NFRST XR = X(NR) YR = Y(NR) LP = LPTR(LPF) N2 = LIST(LP) X2 = X(N2) Y2 = Y(N2) LP = LPTR(LP)CC Top of loop: set NL to the neighbor following N2.C 2 NL = ABS(LIST(LP)) IF (NL .EQ. NFRST .AND. BDRY) GO TO 5 XL = X(NL) YL = Y(NL)CC Test for a convex quadrilateral. To avoid an incorrectC test caused by collinearity, use the fact that if N1C is a boundary node, then N1 LEFT NR->NL and if N2 isC a boundary node, then N2 LEFT NL->NR.C LPL2 = LEND(N2) IF ( (BDRY .OR. LEFT(XR,YR,XL,YL,X1,Y1)) .AND. . (LIST(LPL2) .LT. 0 .OR. . LEFT(XL,YL,XR,YR,X2,Y2)) ) GO TO 3CC Nonconvex quadrilateral -- no swap is possible.C NR = N2 XR = X2 YR = Y2 GO TO 4CC The quadrilateral defined by adjacent trianglesC (N1,N2,NL) and (N2,N1,NR) is convex. Swap inC NL-NR and store it in IWK. Indexes larger than N1C must be decremented since N1 will be deleted fromC X and Y.C 3 CALL SWAP (NL,NR,N1,N2, LIST,LPTR,LEND, LP21) IWL = IWL + 1 IF (NL .LE. N1) THEN IWK(1,IWL) = NL ELSE IWK(1,IWL) = NL - 1 ENDIF IF (NR .LE. N1) THEN IWK(2,IWL) = NR ELSE IWK(2,IWL) = NR - 1 ENDIFCC Recompute the LIST indexes LPL,LP and decrement NNB.C LPL = LEND(N1) NNB = NNB - 1 IF (NNB .EQ. 3) GO TO 5 LP = LSTPTR(LPL,NL,LIST,LPTR) IF (NR .EQ. NFRST) GO TO 4CC NR is not the first neighbor of N1.C Back up and test N1-NR for a swap again: Set N2 toC NR and NR to the previous neighbor of N1 -- theC neighbor of NR which follows N1. LP21 points to NLC as a neighbor of NR.C N2 = NR X2 = XR Y2 = YR LP21 = LPTR(LP21) LP21 = LPTR(LP21) NR = ABS(LIST(LP21)) XR = X(NR) YR = Y(NR) GO TO 2CC Bottom of loop -- test for invalid termination.C 4 IF (N2 .EQ. NFRST) GO TO 24 N2 = NL X2 = XL Y2 = YL LP = LPTR(LP) GO TO 2CC Delete N1 from the adjacency list of N2 for all neighborsC N2 of N1. LPL points to the last neighbor of N1.C LNEW is stored in local variable LNW.C 5 LP = LPL LNW = LNEWCC Loop on neighbors N2 of N1, beginning with the first.C 6 LP = LPTR(LP) N2 = ABS(LIST(LP)) CALL DELNB (N2,N1,N, LIST,LPTR,LEND,LNW, LPH) IF (LPH .LT. 0) GO TO 23CC LP and LPL may require alteration.C IF (LPL .EQ. LNW) LPL = LPH IF (LP .EQ. LNW) LP = LPH IF (LP .NE. LPL) GO TO 6CC Delete N1 from X, Y, and LEND, and remove its adjacencyC list from LIST and LPTR. LIST entries (nodal indexes)C which are larger than N1 must be decremented.C NN = NN - 1 IF (N1 .GT. NN) GO TO 9 DO 7 I = N1,NN X(I) = X(I+1) Y(I) = Y(I+1) LEND(I) = LEND(I+1) 7 CONTINUEC DO 8 I = 1,LNW-1 IF (LIST(I) .GT. N1) LIST(I) = LIST(I) - 1 IF (LIST(I) .LT. -N1) LIST(I) = LIST(I) + 1 8 CONTINUECC For LPN = first to last neighbors of N1, delete theC preceding neighbor (indexed by LP).CC Each empty LIST,LPTR location LP is filled in with theC values at LNW-1, and LNW is decremented. All pointersC (including those in LPTR and LEND) with value LNW-1C must be changed to LP.CC LPL points to the last neighbor of N1.C 9 IF (BDRY) NNB = NNB - 1 LPN = LPL DO 13 J = 1,NNB LNW = LNW - 1 LP = LPN LPN = LPTR(LP) LIST(LP) = LIST(LNW) LPTR(LP) = LPTR(LNW) IF (LPTR(LPN) .EQ. LNW) LPTR(LPN) = LP IF (LPN .EQ. LNW) LPN = LP DO 10 I = NN,1,-1 IF (LEND(I) .EQ. LNW) THEN LEND(I) = LP GO TO 11 ENDIF 10 CONTINUEC 11 DO 12 I = LNW-1,1,-1 IF (LPTR(I) .EQ. LNW) LPTR(I) = LP 12 CONTINUE 13 CONTINUECC Decrement LCC entries.C DO 14 I = 1,NCC LCC(I) = LCC(I) - 1 14 CONTINUECC Update N and LNEW, and optimize the patch of trianglesC containing K (on input) by applying swaps to the arcsC in IWK.C N = NN LNEW = LNW IF (IWL .GT. 0) THEN NIT = 4*IWL CALL OPTIM (X,Y,IWL, LIST,LPTR,LEND,NIT,IWK, IERR) IF (IERR .NE. 0) GO TO 25 ENDIFCC Successful termination.C IER = 0 RETURNCC Invalid input parameter.C 21 IER = 1 RETURNCC Insufficient space reserved for IWK.C 22 IER = 2 RETURNCC Invalid triangulation data structure. NNB < 3 on input orC N2 is a neighbor of N1 but N1 is not a neighbor of N2.C 23 IER = 3 RETURNCC K is an interior node with 4 or more neighbors, but theC number of neighbors could not be reduced.C 24 IER = 4 RETURNCC Error flag returned by OPTIM.C 25 IER = 5 WRITE (*,100) NIT, IERR RETURN 100 FORMAT (//5X,'*** Error in OPTIM: NIT = ',I4, . ', IER = ',I1,' *** '/) END SUBROUTINE EDGE (IN1,IN2,X,Y, LWK,IWK,LIST,LPTR, . LEND, IER) INTEGER IN1, IN2, LWK, IWK(2,*), LIST(*), LPTR(*), . LEND(*), IER DOUBLE PRECISION X(*), Y(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/23/98CC Given a triangulation of N nodes and a pair of nodalC indexes IN1 and IN2, this routine swaps arcs as necessaryC to force IN1 and IN2 to be adjacent. Only arcs whichC intersect IN1-IN2 are swapped out. If a Delaunay triangu-C lation is input, the resulting triangulation is as closeC as possible to a Delaunay triangulation in the sense thatC all arcs other than IN1-IN2 are locally optimal.CC A sequence of calls to EDGE may be used to force theC presence of a set of edges defining the boundary of a non-C convex and/or multiply connected region (refer to Subrou-C tine ADDCST), or to introduce barriers into the triangula-C tion. Note that Subroutine GETNP will not necessarilyC return closest nodes if the triangulation has been con-C strained by a call to EDGE. However, this is appropriateC in some applications, such as triangle-based interpolationC on a nonconvex domain.CCC On input:CC IN1,IN2 = Indexes (of X and Y) in the range 1 to NC defining a pair of nodes to be connectedC by an arc.CC X,Y = Arrays of length N containing the CartesianC coordinates of the nodes.CC The above parameters are not altered by this routine.CC LWK = Number of columns reserved for IWK. This mustC be at least NI -- the number of arcs whichC intersect IN1-IN2. (NI is bounded by N-3.)CC IWK = Integer work array of length at least 2*LWK.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC On output:CC LWK = Number of arcs which intersect IN1-IN2 (butC not more than the input value of LWK) unlessC IER = 1 or IER = 3. LWK = 0 if and only ifC IN1 and IN2 were adjacent (or LWK=0) on input.CC IWK = Array containing the indexes of the endpointsC of the new arcs other than IN1-IN2 unless IERC .GT. 0 or LWK = 0. New arcs to the left ofC IN2-IN1 are stored in the first K-1 columnsC (left portion of IWK), column K containsC zeros, and new arcs to the right of IN2-IN1C occupy columns K+1,...,LWK. (K can be deter-C mined by searching IWK for the zeros.)CC LIST,LPTR,LEND = Data structure updated if necessaryC to reflect the presence of an arcC connecting IN1 and IN2 unless IERC .NE. 0. The data structure hasC been altered if IER = 4.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = 1 if IN1 .LT. 1, IN2 .LT. 1, IN1 = IN2,C or LWK .LT. 0 on input.C IER = 2 if more space is required in IWK.C IER = 3 if IN1 and IN2 could not be connectedC due to either an invalid data struc-C ture or collinear nodes (and floatingC point error).C IER = 4 if an error flag was returned byC OPTIM.CC An error message is written to the standard output unitC in the case of IER = 3 or IER = 4.CC Modules required by EDGE: LEFT, LSTPTR, OPTIM, SWAP,C SWPTSTCC Intrinsic function called by EDGE: ABSCC***********************************************************C LOGICAL LEFT INTEGER I, IERR, IWC, IWCP1, IWEND, IWF, IWL, LFT, LP, . LPL, LP21, NEXT, NIT, NL, NR, N0, N1, N2, . N1FRST, N1LST DOUBLE PRECISION DX, DY, X0, Y0, X1, Y1, X2, Y2CC Local parameters:CC DX,DY = Components of arc N1-N2C I = DO-loop index and column index for IWKC IERR = Error flag returned by Subroutine OPTIMC IWC = IWK index between IWF and IWL -- NL->NR isC stored in IWK(1,IWC)->IWK(2,IWC)C IWCP1 = IWC + 1C IWEND = Input or output value of LWKC IWF = IWK (column) index of the first (leftmost) arcC which intersects IN1->IN2C IWL = IWK (column) index of the last (rightmost) areC which intersects IN1->IN2C LFT = Flag used to determine if a swap results in theC new arc intersecting IN1-IN2 -- LFT = 0 iffC N0 = IN1, LFT = -1 implies N0 LEFT IN1->IN2,C and LFT = 1 implies N0 LEFT IN2->IN1C LP21 = Unused parameter returned by SWAPC LP = List pointer (index) for LIST and LPTRC LPL = Pointer to the last neighbor of IN1 or NLC N0 = Neighbor of N1 or node opposite NR->NLC N1,N2 = Local copies of IN1 and IN2C N1FRST = First neighbor of IN1C N1LST = (Signed) last neighbor of IN1C NEXT = Node opposite NL->NRC NIT = Flag or number of iterations employed by OPTIMC NL,NR = Endpoints of an arc which intersects IN1-IN2C with NL LEFT IN1->IN2C X0,Y0 = Coordinates of N0C X1,Y1 = Coordinates of IN1C X2,Y2 = Coordinates of IN2CCC Store IN1, IN2, and LWK in local variables and test forC errors.C N1 = IN1 N2 = IN2 IWEND = LWK IF (N1 .LT. 1 .OR. N2 .LT. 1 .OR. N1 .EQ. N2 .OR. . IWEND .LT. 0) GO TO 31CC Test for N2 as a neighbor of N1. LPL points to the lastC neighbor of N1.C LPL = LEND(N1) N0 = ABS(LIST(LPL)) LP = LPL 1 IF (N0 .EQ. N2) GO TO 30 LP = LPTR(LP) N0 = LIST(LP) IF (LP .NE. LPL) GO TO 1CC Initialize parameters.C IWL = 0 NIT = 0CC Store the coordinates of N1 and N2.C 2 X1 = X(N1) Y1 = Y(N1) X2 = X(N2) Y2 = Y(N2)CC Set NR and NL to adjacent neighbors of N1 such thatC NR LEFT N2->N1 and NL LEFT N1->N2,C (NR Forward N1->N2 or NL Forward N1->N2), andC (NR Forward N2->N1 or NL Forward N2->N1).CC Initialization: Set N1FRST and N1LST to the first andC (signed) last neighbors of N1, respectively, andC initialize NL to N1FRST.C LPL = LEND(N1) N1LST = LIST(LPL) LP = LPTR(LPL) N1FRST = LIST(LP) NL = N1FRST IF (N1LST .LT. 0) GO TO 4CC N1 is an interior node. Set NL to the first candidateC for NR (NL LEFT N2->N1).C 3 IF ( LEFT(X2,Y2,X1,Y1,X(NL),Y(NL)) ) GO TO 4 LP = LPTR(LP) NL = LIST(LP) IF (NL .NE. N1FRST) GO TO 3CC All neighbors of N1 are strictly left of N1->N2.C GO TO 5CC NL = LIST(LP) LEFT N2->N1. Set NR to NL and NL to theC following neighbor of N1.C 4 NR = NL LP = LPTR(LP) NL = ABS(LIST(LP)) IF ( LEFT(X1,Y1,X2,Y2,X(NL),Y(NL)) ) THENCC NL LEFT N1->N2 and NR LEFT N2->N1. The Forward testsC are employed to avoid an error associated withC collinear nodes.C DX = X2-X1 DY = Y2-Y1 IF ((DX*(X(NL)-X1)+DY*(Y(NL)-Y1) .GE. 0. .OR. . DX*(X(NR)-X1)+DY*(Y(NR)-Y1) .GE. 0.) .AND. . (DX*(X(NL)-X2)+DY*(Y(NL)-Y2) .LE. 0. .OR. . DX*(X(NR)-X2)+DY*(Y(NR)-Y2) .LE. 0.)) GO TO 6CC NL-NR does not intersect N1-N2. However, there isC another candidate for the first arc if NL lies onC the line N1-N2.C IF ( .NOT. LEFT(X2,Y2,X1,Y1,X(NL),Y(NL)) ) GO TO 5 ENDIFCC Bottom of loop.C IF (NL .NE. N1FRST) GO TO 4CC Either the triangulation is invalid or N1-N2 lies on theC convex hull boundary and an edge NR->NL (opposite N1 andC intersecting N1-N2) was not found due to floating pointC error. Try interchanging N1 and N2 -- NIT > 0 iff thisC has already been done.C 5 IF (NIT .GT. 0) GO TO 33 NIT = 1 N1 = N2 N2 = IN1 GO TO 2CC Store the ordered sequence of intersecting edges NL->NR inC IWK(1,IWL)->IWK(2,IWL).C 6 IWL = IWL + 1 IF (IWL .GT. IWEND) GO TO 32 IWK(1,IWL) = NL IWK(2,IWL) = NRCC Set NEXT to the neighbor of NL which follows NR.C LPL = LEND(NL) LP = LPTR(LPL)CC Find NR as a neighbor of NL. The search begins withC the first neighbor.C 7 IF (LIST(LP) .EQ. NR) GO TO 8 LP = LPTR(LP) IF (LP .NE. LPL) GO TO 7CC NR must be the last neighbor, and NL->NR cannot be aC boundary edge.C IF (LIST(LP) .NE. NR) GO TO 33CC Set NEXT to the neighbor following NR, and test forC termination of the store loop.C 8 LP = LPTR(LP) NEXT = ABS(LIST(LP)) IF (NEXT .EQ. N2) GO TO 9CC Set NL or NR to NEXT.C IF ( LEFT(X1,Y1,X2,Y2,X(NEXT),Y(NEXT)) ) THEN NL = NEXT ELSE NR = NEXT ENDIF GO TO 6CC IWL is the number of arcs which intersect N1-N2.C Store LWK.C 9 LWK = IWL IWEND = IWLCC Initialize for edge swapping loop -- all possible swapsC are applied (even if the new arc again intersectsC N1-N2), arcs to the left of N1->N2 are stored in theC left portion of IWK, and arcs to the right are stored inC the right portion. IWF and IWL index the first and lastC intersecting arcs.C IWF = 1CC Top of loop -- set N0 to N1 and NL->NR to the first edge.C IWC points to the arc currently being processed. LFTC .LE. 0 iff N0 LEFT N1->N2.C 10 LFT = 0 N0 = N1 X0 = X1 Y0 = Y1 NL = IWK(1,IWF) NR = IWK(2,IWF) IWC = IWFCC Set NEXT to the node opposite NL->NR unless IWC is theC last arc.C 11 IF (IWC .EQ. IWL) GO TO 21 IWCP1 = IWC + 1 NEXT = IWK(1,IWCP1) IF (NEXT .NE. NL) GO TO 16 NEXT = IWK(2,IWCP1)CC NEXT RIGHT N1->N2 and IWC .LT. IWL. Test for a possibleC swap.C IF ( .NOT. LEFT(X0,Y0,X(NR),Y(NR),X(NEXT),Y(NEXT)) ) . GO TO 14 IF (LFT .GE. 0) GO TO 12 IF ( .NOT. LEFT(X(NL),Y(NL),X0,Y0,X(NEXT),Y(NEXT)) ) . GO TO 14CC Replace NL->NR with N0->NEXT.C CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21) IWK(1,IWC) = N0 IWK(2,IWC) = NEXT GO TO 15CC Swap NL-NR for N0-NEXT, shift columns IWC+1,...,IWL toC the left, and store N0-NEXT in the right portion ofC IWK.C 12 CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21) DO 13 I = IWCP1,IWL IWK(1,I-1) = IWK(1,I) IWK(2,I-1) = IWK(2,I) 13 CONTINUE IWK(1,IWL) = N0 IWK(2,IWL) = NEXT IWL = IWL - 1 NR = NEXT GO TO 11CC A swap is not possible. Set N0 to NR.C 14 N0 = NR X0 = X(N0) Y0 = Y(N0) LFT = 1CC Advance to the next arc.C 15 NR = NEXT IWC = IWC + 1 GO TO 11CC NEXT LEFT N1->N2, NEXT .NE. N2, and IWC .LT. IWL.C Test for a possible swap.C 16 IF ( .NOT. LEFT(X(NL),Y(NL),X0,Y0,X(NEXT),Y(NEXT)) ) . GO TO 19 IF (LFT .LE. 0) GO TO 17 IF ( .NOT. LEFT(X0,Y0,X(NR),Y(NR),X(NEXT),Y(NEXT)) ) . GO TO 19CC Replace NL->NR with NEXT->N0.C CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21) IWK(1,IWC) = NEXT IWK(2,IWC) = N0 GO TO 20CC Swap NL-NR for N0-NEXT, shift columns IWF,...,IWC-1 toC the right, and store N0-NEXT in the left portion ofC IWK.C 17 CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21) DO 18 I = IWC-1,IWF,-1 IWK(1,I+1) = IWK(1,I) IWK(2,I+1) = IWK(2,I) 18 CONTINUE IWK(1,IWF) = N0 IWK(2,IWF) = NEXT IWF = IWF + 1 GO TO 20CC A swap is not possible. Set N0 to NL.C 19 N0 = NL X0 = X(N0) Y0 = Y(N0) LFT = -1CC Advance to the next arc.C 20 NL = NEXT IWC = IWC + 1 GO TO 11CC N2 is opposite NL->NR (IWC = IWL).C 21 IF (N0 .EQ. N1) GO TO 24 IF (LFT .LT. 0) GO TO 22CC N0 RIGHT N1->N2. Test for a possible swap.C IF ( .NOT. LEFT(X0,Y0,X(NR),Y(NR),X2,Y2) ) GO TO 10CC Swap NL-NR for N0-N2 and store N0-N2 in the rightC portion of IWK.C CALL SWAP (N2,N0,NL,NR, LIST,LPTR,LEND, LP21) IWK(1,IWL) = N0 IWK(2,IWL) = N2 IWL = IWL - 1 GO TO 10CC N0 LEFT N1->N2. Test for a possible swap.C 22 IF ( .NOT. LEFT(X(NL),Y(NL),X0,Y0,X2,Y2) ) GO TO 10CC Swap NL-NR for N0-N2, shift columns IWF,...,IWL-1 to theC right, and store N0-N2 in the left portion of IWK.C CALL SWAP (N2,N0,NL,NR, LIST,LPTR,LEND, LP21) I = IWL 23 IWK(1,I) = IWK(1,I-1) IWK(2,I) = IWK(2,I-1) I = I - 1 IF (I .GT. IWF) GO TO 23 IWK(1,IWF) = N0 IWK(2,IWF) = N2 IWF = IWF + 1 GO TO 10CC IWF = IWC = IWL. Swap out the last arc for N1-N2 andC store zeros in IWK.C 24 CALL SWAP (N2,N1,NL,NR, LIST,LPTR,LEND, LP21) IWK(1,IWC) = 0 IWK(2,IWC) = 0CC Optimization procedure --C IF (IWC .GT. 1) THENCC Optimize the set of new arcs to the left of IN1->IN2.C NIT = 3*(IWC-1) CALL OPTIM (X,Y,IWC-1, LIST,LPTR,LEND,NIT,IWK, IERR) IF (IERR .NE. 0) GO TO 34 ENDIF IF (IWC .LT. IWEND) THENCC Optimize the set of new arcs to the right of IN1->IN2.C NIT = 3*(IWEND-IWC) CALL OPTIM (X,Y,IWEND-IWC, LIST,LPTR,LEND,NIT, . IWK(1,IWC+1), IERR) IF (IERR .NE. 0) GO TO 34 ENDIFCC Successful termination.C IER = 0 RETURNCC IN1 and IN2 were adjacent on input.C 30 IER = 0 RETURNCC Invalid input parameter.C 31 IER = 1 RETURNCC Insufficient space reserved for IWK.C 32 IER = 2 RETURNCC Invalid triangulation data structure or collinear nodesC on convex hull boundary.C 33 IER = 3 WRITE (*,130) IN1, IN2 130 FORMAT (//5X,'*** Error in EDGE: Invalid triangula ', . 'tion or null triangles on boundary '/ . 9X,'IN1 =',I4,', IN2= ',I4/) RETURNCC Error flag returned by OPTIM.C 34 IER = 4 WRITE (*,140) NIT, IERR 140 FORMAT (//5X,'*** Error in OPTIM: NIT = ',I4, . ', IER = ',I1,' *** '/) RETURN END SUBROUTINE GETNP (NCC,LCC,N,X,Y,LIST,LPTR,LEND, . L, NPTS,DS, IER) INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N), . L, NPTS(L), IER DOUBLE PRECISION X(N), Y(N), DS(L)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 11/12/94CC Given a triangulation of N nodes and an array NPTS con-C taining the indexes of L-1 nodes ordered by distance fromC NPTS(1), this subroutine sets NPTS(L) to the index of theC next node in the sequence -- the node, other than NPTS(1),C ...,NPTS(L-1), which is closest to NPTS(1). Thus, theC ordered sequence of K closest nodes to N1 (including N1)C may be determined by K-1 calls to GETNP with NPTS(1) = N1C and L = 2,3,...,K for K .GE. 2. Note that NPTS must in-C clude constraint nodes as well as non-constraint nodes.C Thus, a sequence of K1 closest non-constraint nodes to N1C must be obtained as a subset of the closest K2 nodes to N1C for some K2 .GE. K1.CC The terms closest and distance have special definitionsC when constraint nodes are present in the triangulation.C Nodes N1 and N2 are said to be visible from each other ifC and only if the line segment N1-N2 intersects no con-C straint arc (except possibly itself) and is not an interi-C or constraint arc (arc whose interior lies in a constraintC region). A path from N1 to N2 is an ordered sequence ofC nodes, with N1 first and N2 last, such that adjacent pathC elements are visible from each other. The path length isC the sum of the Euclidean distances between adjacent pathC nodes. Finally, the distance from N1 to N2 is defined toC be the length of the shortest path from N1 to N2.CC The algorithm uses the property of a Delaunay triangula-C tion that the K-th closest node to N1 is a neighbor of oneC of the K-1 closest nodes to N1. With the definition ofC distance used here, this property holds when constraintsC are present as long as non-constraint arcs are locallyC optimal.CCC On input:CC NCC = Number of constraints. NCC .GE. 0.CC LCC = List of constraint curve starting indexes (orC dummy array of length 1 if NCC = 0). Refer toC Subroutine ADDCST.CC N = Number of nodes in the triangulation. N .GE. 3.CC X,Y = Arrays of length N containing the coordinatesC of the nodes with non-constraint nodes in theC first LCC(1)-1 locations if NCC > 0.CC LIST,LPTR,LEND = Triangulation data structure. Re-C fer to Subroutine TRMESH.CC L = Number of nodes in the sequence on output. 2C .LE. L .LE. N.CC NPTS = Array of length .GE. L containing the indexesC of the L-1 closest nodes to NPTS(1) in theC first L-1 locations.CC DS = Array of length .GE. L containing the distanceC (defined above) between NPTS(1) and NPTS(I) inC the I-th position for I = 1,...,L-1. Thus,C DS(1) = 0.CC Input parameters other than NPTS(L) and DS(L) are notC altered by this routine.CC On output:CC NPTS = Array updated with the index of the L-thC closest node to NPTS(1) in position L unlessC IER .NE. 0.CC DS = Array updated with the distance between NPTS(1)C and NPTS(L) in position L unless IER .NE. 0.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = -1 if NCC, N, L, or an LCC entry isC outside its valid range on input.C IER = K if NPTS(K) is not a valid index inC the range 1 to N.CC Module required by GETNP: INTSECCC Intrinsic functions called by GETNP: ABS, MIN, SQRTCC***********************************************************C LOGICAL INTSEC INTEGER I, IFRST, ILAST, J, K, KM1, LCC1, LM1, LP, . LPCL, LPK, LPKL, N1, NC, NF1, NF2, NJ, NK, . NKBAK, NKFOR, NL, NN LOGICAL ISW, VIS, NCF, NJF, SKIP, SKSAV, LFT1, LFT2, . LFT12 DOUBLE PRECISION DC, DL, X1, XC, XJ, XK, Y1, YC, YJ, . YKCC Store parameters in local variables and test for errors.C LCC1 indexes the first constraint node.C IER = -1 NN = N LCC1 = NN+1 LM1 = L-1 IF (NCC .LT. 0 .OR. LM1 .LT. 1 .OR. LM1 .GE. NN) . RETURN IF (NCC .EQ. 0) THEN IF (NN .LT. 3) RETURN ELSE DO 1 I = NCC,1,-1 IF (LCC1 - LCC(I) .LT. 3) RETURN LCC1 = LCC(I) 1 CONTINUE IF (LCC1 .LT. 1) RETURN ENDIFCC Test for an invalid index in NPTS.C DO 2 K = 1,LM1 NK = NPTS(K) IF (NK .LT. 1 .OR. NK .GT. NN) THEN IER = K RETURN ENDIF 2 CONTINUECC Store N1 = NPTS(1) and mark the elements of NPTS.C N1 = NPTS(1) X1 = X(N1) Y1 = Y(N1) DO 3 K = 1,LM1 NK = NPTS(K) LEND(NK) = -LEND(NK) 3 CONTINUECC Candidates NC for NL = NPTS(L) are the unmarked visibleC neighbors of nodes NK in NPTS. ISW is an initializationC switch set to .TRUE. when NL and its distance DL from N1C have been initialized with the first candidate encount-C ered.C ISW = .FALSE. DL = 0.CC Loop on marked nodes NK = NPTS(K). LPKL indexes the lastC neighbor of NK in LIST.C DO 16 K = 1,LM1 KM1 = K - 1 NK = NPTS(K) XK = X(NK) YK = Y(NK) LPKL = -LEND(NK) NKFOR = 0 NKBAK = 0 VIS = .TRUE. IF (NK .GE. LCC1) THENCC NK is a constraint node. Set NKFOR and NKBAK to theC constraint nodes which follow and precede NK. IFRSTC and ILAST are set to the first and last nodes in theC constraint containing NK.C IFRST = NN + 1 DO 4 I = NCC,1,-1 ILAST = IFRST - 1 IFRST = LCC(I) IF (NK .GE. IFRST) GO TO 5 4 CONTINUEC 5 IF (NK .LT. ILAST) THEN NKFOR = NK + 1 ELSE NKFOR = IFRST ENDIF IF (NK .GT. IFRST) THEN NKBAK = NK - 1 ELSE NKBAK = ILAST ENDIFCC Initialize VIS to TRUE iff NKFOR precedes NKBAK in theC adjacency list for NK -- the first neighbor is visi-C ble and is not NKBAK.C LPK = LPKL 6 LPK = LPTR(LPK) NC = ABS(LIST(LPK)) IF (NC .NE. NKFOR .AND. NC .NE. NKBAK) GO TO 6 VIS = NC .EQ. NKFOR ENDIFCC Loop on neighbors NC of NK, bypassing marked and nonvis-C ible neighbors.C LPK = LPKL 7 LPK = LPTR(LPK) NC = ABS(LIST(LPK)) IF (NC .EQ. NKBAK) VIS = .TRUE.CC VIS = .FALSE. iff NK-NC is an interior constraint arcC (NK is a constraint node and NC lies strictly betweenC NKFOR and NKBAK).C IF (.NOT. VIS) GO TO 15 IF (NC .EQ. NKFOR) VIS = .FALSE. IF (LEND(NC) .LT. 0) GO TO 15CC Initialize distance DC between N1 and NC to EuclideanC distance.C XC = X(NC) YC = Y(NC) DC = SQRT((XC-X1)*(XC-X1) + (YC-Y1)*(YC-Y1)) IF (ISW .AND. DC .GE. DL) GO TO 15 IF (K .EQ. 1) GO TO 14CC K .GE. 2. Store the pointer LPCL to the last neighborC of NC.C LPCL = LEND(NC)CC Set DC to the length of the shortest path from N1 to NCC which has not previously been encountered and which isC a viable candidate for the shortest path from N1 to NL.C This is Euclidean distance iff NC is visible from N1.C Since the shortest path from N1 to NL contains only ele-C ments of NPTS which are constraint nodes (in addition toC N1 and NL), only these need be considered for the pathC from N1 to NC. Thus, for distance function D(A,B) andC J = 1,...,K, DC = min(D(N1,NJ) + D(NJ,NC)) over con-C straint nodes NJ = NPTS(J) which are visible from NC.C DO 13 J = 1,KM1 NJ = NPTS(J) IF (J .GT. 1 .AND. NJ .LT. LCC1) GO TO 13CC If NC is a visible neighbor of NJ, a path from N1 to NCC containing NJ has already been considered. Thus, NJ mayC be bypassed if it is adjacent to NC.C LP = LPCL 8 LP = LPTR(LP) IF ( NJ .EQ. ABS(LIST(LP)) ) GO TO 12 IF (LP .NE. LPCL) GO TO 8CC NJ is a constraint node (unless J=1) not adjacent to NC,C and is visible from NC iff NJ-NC is not intersected byC a constraint arc. Loop on constraints I in reverseC order --C XJ = X(NJ) YJ = Y(NJ) IFRST = NN+1 DO 11 I = NCC,1,-1 ILAST = IFRST - 1 IFRST = LCC(I) NF1 = ILAST NCF = NF1 .EQ. NC NJF = NF1 .EQ. NJ SKIP = NCF .OR. NJFCC Loop on boundary constraint arcs NF1-NF2 which containC neither NC nor NJ. NCF and NJF are TRUE iff NC (or NJ)C has been encountered in the constraint, and SKIP =C .TRUE. iff NF1 = NC or NF1 = NJ.C DO 10 NF2 = IFRST,ILAST IF (NF2 .EQ. NC) NCF = .TRUE. IF (NF2 .EQ. NJ) NJF = .TRUE. SKSAV = SKIP SKIP = NF2 .EQ. NC .OR. NF2 .EQ. NJCC The last constraint arc in the constraint need not beC tested if none of the arcs have been skipped.C IF ( SKSAV .OR. SKIP .OR. . (NF2 .EQ. ILAST .AND. . .NOT. NCF .AND. .NOT. NJF) ) GO TO 9 IF ( INTSEC(X(NF1),Y(NF1),X(NF2),Y(NF2), . XC,YC,XJ,YJ) ) GO TO 12 9 NF1 = NF2 10 CONTINUE IF (.NOT. NCF .OR. .NOT. NJF) GO TO 11CC NC and NJ are constraint nodes in the same constraint.C NC-NJ is intersected by an interior constraint arc iffC 1) NC LEFT NF2->NF1 and (NJ LEFT NF1->NC and NJ LEFTC NC->NF2) orC 2) NC .NOT. LEFT NF2->NF1 and (NJ LEFT NF1->NC orC NJ LEFT NC->NF2),C where NF1, NC, NF2 are consecutive constraint nodes.C IF (NC .NE. IFRST) THEN NF1 = NC - 1 ELSE NF1 = ILAST ENDIF IF (NC .NE. ILAST) THEN NF2 = NC + 1 ELSE NF2 = IFRST ENDIF LFT1 = (XC-X(NF1))*(YJ-Y(NF1)) .GE. . (XJ-X(NF1))*(YC-Y(NF1)) LFT2 = (X(NF2)-XC)*(YJ-YC) .GE. . (XJ-XC)*(Y(NF2)-YC) LFT12 = (X(NF1)-X(NF2))*(YC-Y(NF2)) .GE. . (XC-X(NF2))*(Y(NF1)-Y(NF2)) IF ( (LFT1 .AND. LFT2) .OR. (.NOT. LFT12 . .AND. (LFT1 .OR. LFT2)) ) GO TO 12 11 CONTINUECC NJ is visible from NC. Exit the loop with DC = EuclideanC distance if J = 1.C IF (J .EQ. 1) GO TO 14 DC = MIN(DC,DS(J) + SQRT((XC-XJ)*(XC-XJ) + . (YC-YJ)*(YC-YJ))) GO TO 13CC NJ is not visible from NC or is adjacent to NC. Initial-C ize DC with D(N1,NK) + D(NK,NC) if J = 1.C 12 IF (J .EQ. 1) DC = DS(K) + SQRT((XC-XK)*(XC-XK) . + (YC-YK)*(YC-YK)) 13 CONTINUECC Compare DC with DL.C IF (ISW .AND. DC .GE. DL) GO TO 15CC The first (or a closer) candidate for NL has beenC encountered.C 14 NL = NC DL = DC ISW = .TRUE. 15 IF (LPK .NE. LPKL) GO TO 7 16 CONTINUECC Unmark the elements of NPTS and store NL and DL.C DO 17 K = 1,LM1 NK = NPTS(K) LEND(NK) = -LEND(NK) 17 CONTINUE NPTS(L) = NL DS(L) = DL IER = 0 RETURN END INTEGER FUNCTION INDXCC (NCC,LCC,N,LIST,LEND) INTEGER NCC, LCC(*), N, LIST(*), LEND(N)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 08/25/91CC Given a constrained Delaunay triangulation, this func-C tion returns the index, if any, of an exterior constraintC curve (an unbounded constraint region). An exterior con-C straint curve is assumed to be present if and only if theC clockwise-ordered sequence of boundary nodes is a subse-C quence of a constraint node sequence. The triangulationC adjacencies corresponding to constraint edges may or mayC not have been forced by a call to ADDCST, and the con-C straint region may or may not be valid (contain no nodes).CCC On input:CC NCC = Number of constraints. NCC .GE. 0.CC LCC = List of constraint curve starting indexes (orC dummy array of length 1 if NCC = 0). Refer toC Subroutine ADDCST.CC N = Number of nodes in the triangulation. N .GE. 3.CC LIST,LEND = Data structure defining the triangula-C tion. Refer to Subroutine TRMESH.CC Input parameters are not altered by this function. NoteC that the parameters are not tested for validity.CC On output:CC INDXCC = Index of the exterior constraint curve, ifC present, or 0 otherwise.CC Modules required by INDXCC: NoneCC***********************************************************C INTEGER I, IFRST, ILAST, LP, N0, NST, NXT INDXCC = 0 IF (NCC .LT. 1) RETURNCC Set N0 to the boundary node with smallest index.C N0 = 0 1 N0 = N0 + 1 LP = LEND(N0) IF (LIST(LP) .GT. 0) GO TO 1CC Search in reverse order for the constraint I, if any, thatC contains N0. IFRST and ILAST index the first and lastC nodes in constraint I.C I = NCC ILAST = N 2 IFRST = LCC(I) IF (N0 .GE. IFRST) GO TO 3 IF (I .EQ. 1) RETURN I = I - 1 ILAST = IFRST - 1 GO TO 2CC N0 is in constraint I which indexes an exterior constraintC curve iff the clockwise-ordered sequence of boundaryC node indexes beginning with N0 is increasing and boundedC above by ILAST.C 3 NST = N0C 4 NXT = -LIST(LP) IF (NXT .EQ. NST) GO TO 5 IF (NXT .LE. N0 .OR. NXT .GT. ILAST) RETURN N0 = NXT LP = LEND(N0) GO TO 4CC Constraint I contains the boundary node sequence as aC subset.C 5 INDXCC = I RETURN END SUBROUTINE INSERT (K,LP, LIST,LPTR,LNEW ) INTEGER K, LP, LIST(*), LPTR(*), LNEWCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC This subroutine inserts K as a neighbor of N1 followingC N2, where LP is the LIST pointer of N2 as a neighbor ofC N1. Note that, if N2 is the last neighbor of N1, K willC become the first neighbor (even if N1 is a boundary node).CCC On input:CC K = Index of the node to be inserted.CC LP = LIST pointer of N2 as a neighbor of N1.CC The above parameters are not altered by this routine.CC LIST,LPTR,LNEW = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC On output:CC LIST,LPTR,LNEW = Data structure updated with theC addition of node K.CC Modules required by INSERT: NoneCC***********************************************************C INTEGER LSAVC LSAV = LPTR(LP) LPTR(LP) = LNEW LIST(LNEW) = K LPTR(LNEW) = LSAV LNEW = LNEW + 1 RETURN END SUBROUTINE INTADD (KK,I1,I2,I3, LIST,LPTR,LEND,LNEW ) INTEGER KK, I1, I2, I3, LIST(*), LPTR(*), LEND(*), . LNEWCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 02/22/91CC This subroutine adds an interior node to a triangulationC of a set of points in the plane. The data structure isC updated with the insertion of node KK into the triangleC whose vertices are I1, I2, and I3. No optimization of theC triangulation is performed.CCC On input:CC KK = Index of the node to be inserted. KK .GE. 1C and KK must not be equal to I1, I2, or I3.CC I1,I2,I3 = Indexes of the counterclockwise-orderedC sequence of vertices of a triangle whichC contains node KK.CC The above parameters are not altered by this routine.CC LIST,LPTR,LEND,LNEW = Data structure defining theC triangulation. Refer to Sub-C routine TRMESH. TriangleC (I1,I2,I3) must be includedC in the triangulation.CC On output:CC LIST,LPTR,LEND,LNEW = Data structure updated withC the addition of node KK. KKC will be connected to nodes I1,C I2, and I3.CC Modules required by INTADD: INSERT, LSTPTRCC***********************************************************C INTEGER LSTPTR INTEGER K, LP, N1, N2, N3 K = KKCC Initialization.C N1 = I1 N2 = I2 N3 = I3CC Add K as a neighbor of I1, I2, and I3.C LP = LSTPTR(LEND(N1),N2,LIST,LPTR) CALL INSERT (K,LP,LIST,LPTR,LNEW) LP = LSTPTR(LEND(N2),N3,LIST,LPTR) CALL INSERT (K,LP,LIST,LPTR,LNEW) LP = LSTPTR(LEND(N3),N1,LIST,LPTR) CALL INSERT (K,LP,LIST,LPTR,LNEW)CC Add I1, I2, and I3 as neighbors of K.C LIST(LNEW) = N1 LIST(LNEW+1) = N2 LIST(LNEW+2) = N3 LPTR(LNEW) = LNEW + 1 LPTR(LNEW+1) = LNEW + 2 LPTR(LNEW+2) = LNEW LEND(K) = LNEW + 2 LNEW = LNEW + 3 RETURN END LOGICAL FUNCTION INTSEC (X1,Y1,X2,Y2,X3,Y3,X4,Y4) DOUBLE PRECISION X1, Y1, X2, Y2, X3, Y3, X4, Y4CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC Given a pair of line segments P1-P2 and P3-P4, thisC function returns the value .TRUE. if and only if P1-P2C shares one or more points with P3-P4. The line segmentsC include their endpoints, and the four points need not beC distinct. Thus, either line segment may consist of aC single point, and the segments may meet in a V (which isC treated as an intersection). Note that an incorrectC decision may result from floating point error if the fourC endpoints are nearly collinear.CCC On input:CC X1,Y1 = Coordinates of P1.CC X2,Y2 = Coordinates of P2.CC X3,Y3 = Coordinates of P3.CC X4,Y4 = Coordinates of P4.CC Input parameters are not altered by this function.CC On output:CC INTSEC = Logical value defined above.CC Modules required by INTSEC: NoneCC***********************************************************C DOUBLE PRECISION A, B, D, DX12, DX31, DX34, DY12, . DY31, DY34CC Test for overlap between the smallest rectangles thatC contain the line segments and have sides parallel toC the axes.C IF ((X1 .LT. X3 .AND. X1 .LT. X4 .AND. X2 .LT. X3 . .AND. X2 .LT. X4) .OR. . (X1 .GT. X3 .AND. X1 .GT. X4 .AND. X2 .GT. X3 . .AND. X2 .GT. X4) .OR. . (Y1 .LT. Y3 .AND. Y1 .LT. Y4 .AND. Y2 .LT. Y3 . .AND. Y2 .LT. Y4) .OR. . (Y1 .GT. Y3 .AND. Y1 .GT. Y4 .AND. Y2 .GT. Y3 . .AND. Y2 .GT. Y4)) THEN INTSEC = .FALSE. RETURN ENDIFCC Compute A = P4-P3 X P1-P3, B = P2-P1 X P1-P3, andC D = P2-P1 X P4-P3 (Z components).C DX12 = X2 - X1 DY12 = Y2 - Y1 DX34 = X4 - X3 DY34 = Y4 - Y3 DX31 = X1 - X3 DY31 = Y1 - Y3 A = DX34*DY31 - DX31*DY34 B = DX12*DY31 - DX31*DY12 D = DX12*DY34 - DX34*DY12 IF (D .EQ. 0.) GO TO 1CC D .NE. 0 and the point of intersection of the lines de-C fined by the line segments is P = P1 + (A/D)*(P2-P1) =C P3 + (B/D)*(P4-P3).C INTSEC = A/D .GE. 0. .AND. A/D .LE. 1. .AND. . B/D .GE. 0. .AND. B/D .LE. 1. RETURNCC D .EQ. 0 and thus either the line segments are parallel,C or one (or both) of them is a single point.C 1 INTSEC = A .EQ. 0. .AND. B .EQ. 0. RETURN END INTEGER FUNCTION JRAND (N, IX,IY,IZ ) INTEGER N, IX, IY, IZCC***********************************************************CC From STRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 07/28/98CC This function returns a uniformly distributed pseudo-C random integer in the range 1 to N.CCC On input:CC N = Maximum value to be returned.CC N is not altered by this function.CC IX,IY,IZ = Integer seeds initialized to values inC the range 1 to 30,000 before the firstC call to JRAND, and not altered betweenC subsequent calls (unless a sequence ofC random numbers is to be repeated byC reinitializing the seeds).CC On output:CC IX,IY,IZ = Updated integer seeds.CC JRAND = Random integer in the range 1 to N.CC Reference: B. A. Wichmann and I. D. Hill, "An EfficientC and Portable Pseudo-random Number Generator",C Applied Statistics, Vol. 31, No. 2, 1982,C pp. 188-190.CC Modules required by JRAND: NoneCC Intrinsic functions called by JRAND: INT, MOD, DBLECC***********************************************************C DOUBLE PRECISION U, XCC Local parameters:CC U = Pseudo-random number uniformly distributed in theC interval (0,1).C X = Pseudo-random number in the range 0 to 3 whose frac-C tional part is U.C IX = MOD(171*IX,30269) IY = MOD(172*IY,30307) IZ = MOD(170*IZ,30323) X = (DBLE(IX)/30269.) + (DBLE(IY)/30307.) + . (DBLE(IZ)/30323.) U = X - INT(X) JRAND = DBLE(N)*U + 1. RETURN END LOGICAL FUNCTION LEFT (X1,Y1,X2,Y2,X0,Y0) DOUBLE PRECISION X1, Y1, X2, Y2, X0, Y0CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC This function determines whether node N0 is to the leftC or to the right of the line through N1-N2 as viewed by anC observer at N1 facing N2.CCC On input:CC X1,Y1 = Coordinates of N1.CC X2,Y2 = Coordinates of N2.CC X0,Y0 = Coordinates of N0.CC Input parameters are not altered by this function.CC On output:CC LEFT = .TRUE. if and only if (X0,Y0) is on or to theC left of the directed line N1->N2.CC Modules required by LEFT: NoneCC***********************************************************C DOUBLE PRECISION DX1, DY1, DX2, DY2CC Local parameters:CC DX1,DY1 = X,Y components of the vector N1->N2C DX2,DY2 = X,Y components of the vector N1->N0C DX1 = X2-X1 DY1 = Y2-Y1 DX2 = X0-X1 DY2 = Y0-Y1CC If the sign of the vector cross product of N1->N2 andC N1->N0 is positive, then sin(A) > 0, where A is theC angle between the vectors, and thus A is in the rangeC (0,180) degrees.C LEFT = DX1*DY2 .GE. DX2*DY1 RETURN END INTEGER FUNCTION LSTPTR (LPL,NB,LIST,LPTR) INTEGER LPL, NB, LIST(*), LPTR(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC This function returns the index (LIST pointer) of NB inC the adjacency list for N0, where LPL = LEND(N0).CCC On input:CC LPL = LEND(N0)CC NB = Index of the node whose pointer is to be re-C turned. NB must be connected to N0.CC LIST,LPTR = Data structure defining the triangula-C tion. Refer to Subroutine TRMESH.CC Input parameters are not altered by this function.CC On output:CC LSTPTR = Pointer such that LIST(LSTPTR) = NB orC LIST(LSTPTR) = -NB, unless NB is not aC neighbor of N0, in which case LSTPTR = LPL.CC Modules required by LSTPTR: NoneCC***********************************************************C INTEGER LP, NDC LP = LPTR(LPL) 1 ND = LIST(LP) IF (ND .EQ. NB) GO TO 2 LP = LPTR(LP) IF (LP .NE. LPL) GO TO 1C 2 LSTPTR = LP RETURN END INTEGER FUNCTION NBCNT (LPL,LPTR) INTEGER LPL, LPTR(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC This function returns the number of neighbors of a nodeC N0 in a triangulation created by Subroutine TRMESH (orC TRMSHR).CCC On input:CC LPL = LIST pointer to the last neighbor of N0 --C LPL = LEND(N0).CC LPTR = Array of pointers associated with LIST.CC Input parameters are not altered by this function.CC On output:CC NBCNT = Number of neighbors of N0.CC Modules required by NBCNT: NoneCC***********************************************************C INTEGER K, LPC LP = LPL K = 1C 1 LP = LPTR(LP) IF (LP .EQ. LPL) GO TO 2 K = K + 1 GO TO 1C 2 NBCNT = K RETURN END INTEGER FUNCTION NEARND (XP,YP,IST,N,X,Y,LIST,LPTR, . LEND, DSQ) INTEGER IST, N, LIST(*), LPTR(*), LEND(N) DOUBLE PRECISION XP, YP, X(N), Y(N), DSQCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/27/98CC Given a point P in the plane and a Delaunay triangula-C tion created by Subroutine TRMESH or TRMSHR, this functionC returns the index of the nearest triangulation node to P.CC The algorithm consists of implicitly adding P to theC triangulation, finding the nearest neighbor to P, andC implicitly deleting P from the triangulation. Thus, itC is based on the fact that, if P is a node in a DelaunayC triangulation, the nearest node to P is a neighbor of P.CCC On input:CC XP,YP = Cartesian coordinates of the point P to beC located relative to the triangulation.CC IST = Index of a node at which TRFIND begins theC search. Search time depends on the proximityC of this node to P.CC N = Number of nodes in the triangulation. N .GE. 3.CC X,Y = Arrays of length N containing the CartesianC coordinates of the nodes.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to TRMESH.CC Input parameters are not altered by this function.CC On output:CC NEARND = Nodal index of the nearest node to P, or 0C if N < 3 or the triangulation data struc-C ture is invalid.CC DSQ = Squared distance between P and NEARND unlessC NEARND = 0.CC Note that the number of candidates for NEARNDC (neighbors of P) is limited to LMAX defined inC the PARAMETER statement below.CC Modules required by NEARND: JRAND, LEFT, LSTPTR, TRFINDCC Intrinsic function called by NEARND: ABSCC***********************************************************C INTEGER LSTPTR INTEGER LMAX PARAMETER (LMAX=25) INTEGER I1, I2, I3, L, LISTP(LMAX), LP, LP1, LP2, . LPL, LPTRP(LMAX), N1, N2, N3, NR, NST DOUBLE PRECISION COS1, COS2, DS1, DSR, DX11, DX12, . DX21, DX22, DY11, DY12, DY21, DY22, SIN1, . SIN2CC Store local parameters and test for N invalid.C IF (N .LT. 3) GO TO 7 NST = IST IF (NST .LT. 1 .OR. NST .GT. N) NST = 1CC Find a triangle (I1,I2,I3) containing P, or the rightmostC (I1) and leftmost (I2) visible boundary nodes as viewedC from P.C CALL TRFIND (NST,XP,YP,N,X,Y,LIST,LPTR,LEND, I1,I2,I3)CC Test for collinear nodes.C IF (I1 .EQ. 0) GO TO 7CC Store the linked list of 'neighbors ' of P in LISTP andC LPTRP. I1 is the first neighbor, and 0 is stored asC the last neighbor if P is not contained in a triangle.C L is the length of LISTP and LPTRP, and is limited toC LMAX.C IF (I3 .NE. 0) THEN LISTP(1) = I1 LPTRP(1) = 2 LISTP(2) = I2 LPTRP(2) = 3 LISTP(3) = I3 LPTRP(3) = 1 L = 3 ELSE N1 = I1 L = 1 LP1 = 2 LISTP(L) = N1 LPTRP(L) = LP1CC Loop on the ordered sequence of visible boundary nodesC N1 from I1 to I2.C 1 LPL = LEND(N1) N1 = -LIST(LPL) L = LP1 LP1 = L+1 LISTP(L) = N1 LPTRP(L) = LP1 IF (N1 .NE. I2 .AND. LP1 .LT. LMAX) GO TO 1 L = LP1 LISTP(L) = 0 LPTRP(L) = 1 ENDIFCC Initialize variables for a loop on arcs N1-N2 opposite PC in which new 'neighbors' are 'swapped ' in. N1 followsC N2 as a neighbor of P, and LP1 and LP2 are the LISTPC indexes of N1 and N2.C LP2 = 1 N2 = I1 LP1 = LPTRP(1) N1 = LISTP(LP1)CC Begin loop: find the node N3 opposite N1->N2.C 2 LP = LSTPTR(LEND(N1),N2,LIST,LPTR) IF (LIST(LP) .LT. 0) GO TO 4 LP = LPTR(LP) N3 = ABS(LIST(LP))CC Swap test: Exit the loop if L = LMAX.C IF (L .EQ. LMAX) GO TO 5 DX11 = X(N1) - X(N3) DX12 = X(N2) - X(N3) DX22 = X(N2) - XP DX21 = X(N1) - XPC DY11 = Y(N1) - Y(N3) DY12 = Y(N2) - Y(N3) DY22 = Y(N2) - YP DY21 = Y(N1) - YPC COS1 = DX11*DX12 + DY11*DY12 COS2 = DX22*DX21 + DY22*DY21 IF (COS1 .GE. 0. .AND. COS2 .GE. 0.) GO TO 4 IF (COS1 .LT. 0. .AND. COS2 .LT. 0.) GO TO 3C SIN1 = DX11*DY12 - DX12*DY11 SIN2 = DX22*DY21 - DX21*DY22 IF (SIN1*COS2 + COS1*SIN2 .GE. 0.) GO TO 4CC Swap: Insert N3 following N2 in the adjacency list for P.C The two new arcs opposite P must be tested.C 3 L = L+1 LPTRP(LP2) = L LISTP(L) = N3 LPTRP(L) = LP1 LP1 = L N1 = N3 GO TO 2CC No swap: Advance to the next arc and test for terminationC on N1 = I1 (LP1 = 1) or N1 followed by 0.C 4 IF (LP1 .EQ. 1) GO TO 5 LP2 = LP1 N2 = N1 LP1 = LPTRP(LP1) N1 = LISTP(LP1) IF (N1 .EQ. 0) GO TO 5 GO TO 2CC Set NR and DSR to the index of the nearest node to P andC its squared distance from P, respectively.C 5 NR = I1 DSR = (X(NR)-XP)**2 + (Y(NR)-YP)**2 DO 6 LP = 2,L N1 = LISTP(LP) IF (N1 .EQ. 0) GO TO 6 DS1 = (X(N1)-XP)**2 + (Y(N1)-YP)**2 IF (DS1 .LT. DSR) THEN NR = N1 DSR = DS1 ENDIF 6 CONTINUE DSQ = DSR NEARND = NR RETURNCC Invalid input.C 7 NEARND = 0 RETURN END SUBROUTINE OPTIM (X,Y,NA, LIST,LPTR,LEND,NIT,IWK, IER) INTEGER NA, LIST(*), LPTR(*), LEND(*), NIT, IWK(2,NA), . IER DOUBLE PRECISION X(*), Y(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/27/98CC Given a set of NA triangulation arcs, this subroutineC optimizes the portion of the triangulation consisting ofC the quadrilaterals (pairs of adjacent triangles) whichC have the arcs as diagonals by applying the circumcircleC test and appropriate swaps to the arcs.CC An iteration consists of applying the swap test andC swaps to all NA arcs in the order in which they areC stored. The iteration is repeated until no swap occursC or NIT iterations have been performed. The bound on theC number of iterations may be necessary to prevent anC infinite loop caused by cycling (reversing the effect of aC previous swap) due to floating point inaccuracy when fourC or more nodes are nearly cocircular.CCC On input:CC X,Y = Arrays containing the nodal coordinates.CC NA = Number of arcs in the set. NA .GE. 0.CC The above parameters are not altered by this routine.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC NIT = Maximum number of iterations to be performed.C A reasonable value is 3*NA. NIT .GE. 1.CC IWK = Integer array dimensioned 2 by NA containingC the nodal indexes of the arc endpoints (pairsC of endpoints are stored in columns).CC On output:CC LIST,LPTR,LEND = Updated triangulation data struc-C ture reflecting the swaps.CC NIT = Number of iterations performed.CC IWK = Endpoint indexes of the new set of arcsC reflecting the swaps.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = 1 if a swap occurred on the last ofC MAXIT iterations, where MAXIT is theC value of NIT on input. The new setC of arcs in not necessarily optimalC in this case.C IER = 2 if NA < 0 or NIT < 1 on input.C IER = 3 if IWK(2,I) is not a neighbor ofC IWK(1,I) for some I in the range 1C to NA. A swap may have occurred inC this case.C IER = 4 if a zero pointer was returned byC Subroutine SWAP.CC Modules required by OPTIM: LSTPTR, SWAP, SWPTSTCC Intrinsic function called by OPTIM: ABSCC***********************************************************C LOGICAL SWPTST INTEGER I, IO1, IO2, ITER, LP, LP21, LPL, LPP, MAXIT, . N1, N2, NNA LOGICAL SWPCC Local parameters:CC I = Column index for IWKC IO1,IO2 = Nodal indexes of the endpoints of an arc in IWKC ITER = Iteration countC LP = LIST pointerC LP21 = Parameter returned by SWAP (not used)C LPL = Pointer to the last neighbor of IO1C LPP = Pointer to the node preceding IO2 as a neighborC of IO1C MAXIT = Input value of NITC N1,N2 = Nodes opposite IO1->IO2 and IO2->IO1,C respectivelyC NNA = Local copy of NAC SWP = Flag set to TRUE iff a swap occurs in theC optimization loopC NNA = NA MAXIT = NIT IF (NNA .LT. 0 .OR. MAXIT .LT. 1) GO TO 7CC Initialize iteration count ITER and test for NA = 0.C ITER = 0 IF (NNA .EQ. 0) GO TO 5CC Top of loop --C SWP = TRUE iff a swap occurred in the current iteration.C 1 IF (ITER .EQ. MAXIT) GO TO 6 ITER = ITER + 1 SWP = .FALSE.CC Inner loop on arcs IO1-IO2 --C DO 4 I = 1,NNA IO1 = IWK(1,I) IO2 = IWK(2,I)CC Set N1 and N2 to the nodes opposite IO1->IO2 andC IO2->IO1, respectively. Determine the following:CC LPL = pointer to the last neighbor of IO1,C LP = pointer to IO2 as a neighbor of IO1, andC LPP = pointer to the node N2 preceding IO2.C LPL = LEND(IO1) LPP = LPL LP = LPTR(LPP) 2 IF (LIST(LP) .EQ. IO2) GO TO 3 LPP = LP LP = LPTR(LPP) IF (LP .NE. LPL) GO TO 2CC IO2 should be the last neighbor of IO1. Test for noC arc and bypass the swap test if IO1 is a boundaryC node.C IF (ABS(LIST(LP)) .NE. IO2) GO TO 8 IF (LIST(LP) .LT. 0) GO TO 4CC Store N1 and N2, or bypass the swap test if IO1 is aC boundary node and IO2 is its first neighbor.C 3 N2 = LIST(LPP) IF (N2 .LT. 0) GO TO 4 LP = LPTR(LP) N1 = ABS(LIST(LP))CC Test IO1-IO2 for a swap, and update IWK if necessary.C IF ( .NOT. SWPTST(N1,N2,IO1,IO2,X,Y) ) GO TO 4 CALL SWAP (N1,N2,IO1,IO2, LIST,LPTR,LEND, LP21) IF (LP21 .EQ. 0) GO TO 9 SWP = .TRUE. IWK(1,I) = N1 IWK(2,I) = N2 4 CONTINUE IF (SWP) GO TO 1CC Successful termination.C 5 NIT = ITER IER = 0 RETURNCC MAXIT iterations performed without convergence.C 6 NIT = MAXIT IER = 1 RETURNCC Invalid input parameter.C 7 NIT = 0 IER = 2 RETURNCC IO2 is not a neighbor of IO1.C 8 NIT = ITER IER = 3 RETURNCC Zero pointer returned by SWAP.C 9 NIT = ITER IER = 4 RETURN END DOUBLE PRECISION FUNCTION STORE (X) DOUBLE PRECISION XCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 03/18/90CC This function forces its argument X to be stored in aC memory location, thus providing a means of determiningC floating point number characteristics (such as the machineC precision) when it is necessary to avoid computation inC high precision registers.CCC On input:CC X = Value to be stored.CC X is not altered by this function.CC On output:CC STORE = Value of X after it has been stored andC possibly truncated or rounded to the singleC precision word length.CC Modules required by STORE: NoneCC***********************************************************C DOUBLE PRECISION Y COMMON/STCOM/YC Y = X STORE = Y RETURN END SUBROUTINE SWAP (IN1,IN2,IO1,IO2, LIST,LPTR, . LEND, LP21) INTEGER IN1, IN2, IO1, IO2, LIST(*), LPTR(*), LEND(*), . LP21CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/22/98CC Given a triangulation of a set of points on the unitC sphere, this subroutine replaces a diagonal arc in aC strictly convex quadrilateral (defined by a pair of adja-C cent triangles) with the other diagonal. Equivalently, aC pair of adjacent triangles is replaced by another pairC having the same union.CCC On input:CC IN1,IN2,IO1,IO2 = Nodal indexes of the vertices ofC the quadrilateral. IO1-IO2 is re-C placed by IN1-IN2. (IO1,IO2,IN1)C and (IO2,IO1,IN2) must be trian-C gles on input.CC The above parameters are not altered by this routine.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC On output:CC LIST,LPTR,LEND = Data structure updated with theC swap -- triangles (IO1,IO2,IN1) andC (IO2,IO1,IN2) are replaced byC (IN1,IN2,IO2) and (IN2,IN1,IO1)C unless LP21 = 0.CC LP21 = Index of IN1 as a neighbor of IN2 after theC swap is performed unless IN1 and IN2 areC adjacent on input, in which case LP21 = 0.CC Module required by SWAP: LSTPTRCC Intrinsic function called by SWAP: ABSCC***********************************************************C INTEGER LSTPTR INTEGER LP, LPH, LPSAVCC Local parameters:CC LP,LPH,LPSAV = LIST pointersCCC Test for IN1 and IN2 adjacent.C LP = LSTPTR(LEND(IN1),IN2,LIST,LPTR) IF (ABS(LIST(LP)) .EQ. IN2) THEN LP21 = 0 RETURN ENDIFCC Delete IO2 as a neighbor of IO1.C LP = LSTPTR(LEND(IO1),IN2,LIST,LPTR) LPH = LPTR(LP) LPTR(LP) = LPTR(LPH)CC If IO2 is the last neighbor of IO1, make IN2 theC last neighbor.C IF (LEND(IO1) .EQ. LPH) LEND(IO1) = LPCC Insert IN2 as a neighbor of IN1 following IO1C using the hole created above.C LP = LSTPTR(LEND(IN1),IO1,LIST,LPTR) LPSAV = LPTR(LP) LPTR(LP) = LPH LIST(LPH) = IN2 LPTR(LPH) = LPSAVCC Delete IO1 as a neighbor of IO2.C LP = LSTPTR(LEND(IO2),IN1,LIST,LPTR) LPH = LPTR(LP) LPTR(LP) = LPTR(LPH)CC If IO1 is the last neighbor of IO2, make IN1 theC last neighbor.C IF (LEND(IO2) .EQ. LPH) LEND(IO2) = LPCC Insert IN1 as a neighbor of IN2 following IO2.C LP = LSTPTR(LEND(IN2),IO2,LIST,LPTR) LPSAV = LPTR(LP) LPTR(LP) = LPH LIST(LPH) = IN1 LPTR(LPH) = LPSAV LP21 = LPH RETURN END LOGICAL FUNCTION SWPTST (IN1,IN2,IO1,IO2,X,Y) INTEGER IN1, IN2, IO1, IO2 DOUBLE PRECISION X(*), Y(*)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 09/01/88CC This function applies the circumcircle test to a quadri-C lateral defined by a pair of adjacent triangles. TheC diagonal arc (shared triangle side) should be swapped forC the other diagonl if and only if the fourth vertex isC strictly interior to the circumcircle of one of theC triangles (the decision is independent of the choice ofC triangle). Equivalently, the diagonal is chosen to maxi-C mize the smallest of the six interior angles over the twoC pairs of possible triangles (the decision is for no swapC if the quadrilateral is not strictly convex).CC When the four vertices are nearly cocircular (theC neutral case), the preferred decision is no swap -- inC order to avoid unnecessary swaps and, more important, toC avoid cycling in Subroutine OPTIM which is called byC DELNOD and EDGE. Thus, a tolerance SWTOL (stored inC SWPCOM by TRMESH or TRMSHR) is used to define 'nearness 'C to the neutral case.CCC On input:CC IN1,IN2,IO1,IO2 = Nodal indexes of the vertices ofC the quadrilateral. IO1-IO2 is theC triangulation arc (shared triangleC side) to be replaced by IN1-IN2 ifC the decision is to swap. TheC triples (IO1,IO2,IN1) and (IO2,C IO1,IN2) must define triangles (beC in counterclockwise order) on in-C put.CC X,Y = Arrays containing the nodal coordinates.CC Input parameters are not altered by this routine.CC On output:CC SWPTST = .TRUE. if and only if the arc connectingC IO1 and IO2 is to be replaced.CC Modules required by SWPTST: NoneCC***********************************************************C DOUBLE PRECISION DX11, DX12, DX22, DX21, DY11, DY12, DY22, DY21, . SIN1, SIN2, COS1, COS2, SIN12, SWTOLCC Tolerance stored by TRMESH or TRMSHR.C COMMON/SWPCOM/SWTOLCC Local parameters:CC DX11,DY11 = X,Y components of the vector IN1->IO1C DX12,DY12 = X,Y components of the vector IN1->IO2C DX22,DY22 = X,Y components of the vector IN2->IO2C DX21,DY21 = X,Y components of the vector IN2->IO1C SIN1 = Cross product of the vectors IN1->IO1 andC IN1->IO2 -- proportional to sin(T1), whereC T1 is the angle at IN1 formed by the vectorsC COS1 = Inner product of the vectors IN1->IO1 andC IN1->IO2 -- proportional to cos(T1)C SIN2 = Cross product of the vectors IN2->IO2 andC IN2->IO1 -- proportional to sin(T2), whereC T2 is the angle at IN2 formed by the vectorsC COS2 = Inner product of the vectors IN2->IO2 andC IN2->IO1 -- proportional to cos(T2)C SIN12 = SIN1*COS2 + COS1*SIN2 -- proportional toC sin(T1+T2)CCC Compute the vectors containing the angles T1 and T2.C DX11 = X(IO1) - X(IN1) DX12 = X(IO2) - X(IN1) DX22 = X(IO2) - X(IN2) DX21 = X(IO1) - X(IN2)C DY11 = Y(IO1) - Y(IN1) DY12 = Y(IO2) - Y(IN1) DY22 = Y(IO2) - Y(IN2) DY21 = Y(IO1) - Y(IN2)CC Compute inner products.C COS1 = DX11*DX12 + DY11*DY12 COS2 = DX22*DX21 + DY22*DY21CC The diagonals should be swapped iff (T1+T2) > 180C degrees. The following two tests ensure numericalC stability: the decision must be FALSE when bothC angles are close to 0, and TRUE when both anglesC are close to 180 degrees.C IF (COS1 .GE. 0. .AND. COS2 .GE. 0.) GO TO 2 IF (COS1 .LT. 0. .AND. COS2 .LT. 0.) GO TO 1CC Compute vector cross products (Z-components).C SIN1 = DX11*DY12 - DX12*DY11 SIN2 = DX22*DY21 - DX21*DY22 SIN12 = SIN1*COS2 + COS1*SIN2 IF (SIN12 .GE. -SWTOL) GO TO 2CC Swap.C 1 SWPTST = .TRUE. RETURNCC No swap.C 2 SWPTST = .FALSE. RETURN END SUBROUTINE TRFIND (NST,PX,PY,N,X,Y,LIST,LPTR,LEND, I1, . I2,I3) INTEGER NST, N, LIST(*), LPTR(*), LEND(N), I1, I2, I3 DOUBLE PRECISION PX, PY, X(N), Y(N)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 07/28/98CC This subroutine locates a point P relative to a triangu-C lation created by Subroutine TRMESH or TRMSHR. If P isC contained in a triangle, the three vertex indexes areC returned. Otherwise, the indexes of the rightmost andC leftmost visible boundary nodes are returned.CCC On input:CC NST = Index of a node at which TRFIND begins theC search. Search time depends on the proximityC of this node to P.CC PX,PY = X and y coordinates of the point P to beC located.CC N = Number of nodes in the triangulation. N .GE. 3.CC X,Y = Arrays of length N containing the coordinatesC of the nodes in the triangulation.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC Input parameters are not altered by this routine.CC On output:CC I1,I2,I3 = Nodal indexes, in counterclockwise order,C of the vertices of a triangle containingC P if P is contained in a triangle. If PC is not in the convex hull of the nodes,C I1 indexes the rightmost visible boundaryC node, I2 indexes the leftmost visibleC boundary node, and I3 = 0. Rightmost andC leftmost are defined from the perspectiveC of P, and a pair of points are visibleC from each other if and only if the lineC segment joining them intersects no trian-C gulation arc. If P and all of the nodesC lie on a common line, then I1 = I2 = I3 =C 0 on output.CC Modules required by TRFIND: JRAND, LEFT, LSTPTR, STORECC Intrinsic function called by TRFIND: ABSCC***********************************************************C INTEGER JRAND, LSTPTR LOGICAL LEFT DOUBLE PRECISION STORE INTEGER IX, IY, IZ, LP, N0, N1, N1S, N2, N2S, N3, N4, . NB, NF, NL, NP, NPP LOGICAL FRWRD DOUBLE PRECISION B1, B2, XA, XB, XC, XP, YA, YB, YC, . YPC SAVE IX, IY, IZ DATA IX/1/, IY/2/, IZ/3/CC Local parameters:CC B1,B2 = Unnormalized barycentric coordinates of P withC respect to (N1,N2,N3)C IX,IY,IZ = Integer seeds for JRANDC LP = LIST pointerC N0,N1,N2 = Nodes in counterclockwise order defining aC cone (with vertex N0) containing PC N1S,N2S = Saved values of N1 and N2C N3,N4 = Nodes opposite N1->N2 and N2->N1, respectivelyC NB = Index of a boundary node -- first neighbor ofC NF or last neighbor of NL in the boundaryC traversal loopsC NF,NL = First and last neighbors of N0, or firstC (rightmost) and last (leftmost) nodesC visible from P when P is exterior to theC triangulationC NP,NPP = Indexes of boundary nodes used in the boundaryC traversal loopsC XA,XB,XC = Dummy arguments for FRWRDC YA,YB,YC = Dummy arguments for FRWRDC XP,YP = Local variables containing the components of PCC Statement function:CC FRWRD = TRUE iff C is forward of A->BC iff <A->B,A->C> .GE. 0.C FRWRD(XA,YA,XB,YB,XC,YC) = (XB-XA)*(XC-XA) + . (YB-YA)*(YC-YA) .GE. 0.CC Initialize variables.C XP = PX YP = PY N0 = NST IF (N0 .LT. 1 .OR. N0 .GT. N) . N0 = JRAND(N, IX,IY,IZ )CC Set NF and NL to the first and last neighbors of N0, andC initialize N1 = NF.C 1 LP = LEND(N0) NL = LIST(LP) LP = LPTR(LP) NF = LIST(LP) N1 = NFCC Find a pair of adjacent neighbors N1,N2 of N0 that defineC a wedge containing P: P LEFT N0->N1 and P RIGHT N0->N2.C IF (NL .GT. 0) GO TO 2CC N0 is a boundary node. Test for P exterior.C NL = -NL IF ( .NOT. LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) ) THEN NL = N0 GO TO 9 ENDIF IF ( .NOT. LEFT(X(NL),Y(NL),X(N0),Y(N0),XP,YP) ) THEN NB = NF NF = N0 NP = NL NPP = N0 GO TO 11 ENDIF GO TO 3CC N0 is an interior node. Find N1.C 2 IF ( LEFT(X(N0),Y(N0),X(N1),Y(N1),XP,YP) ) GO TO 3 LP = LPTR(LP) N1 = LIST(LP) IF (N1 .EQ. NL) GO TO 6 GO TO 2CC P is to the left of edge N0->N1. Initialize N2 to theC next neighbor of N0.C 3 LP = LPTR(LP) N2 = ABS(LIST(LP)) IF ( .NOT. LEFT(X(N0),Y(N0),X(N2),Y(N2),XP,YP) ) . GO TO 7 N1 = N2 IF (N1 .NE. NL) GO TO 3 IF ( .NOT. LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) ) . GO TO 6 IF (XP .EQ. X(N0) .AND. YP .EQ. Y(N0)) GO TO 5CC P is left of or on edges N0->NB for all neighbors NBC of N0.C All points are collinear iff P is left of NB->N0 forC all neighbors NB of N0. Search the neighbors of N0.C NOTE -- N1 = NL and LP points to NL.C 4 IF ( .NOT. LEFT(X(N1),Y(N1),X(N0),Y(N0),XP,YP) ) . GO TO 5 LP = LPTR(LP) N1 = ABS(LIST(LP)) IF (N1 .EQ. NL) GO TO 17 GO TO 4CC P is to the right of N1->N0, or P=N0. Set N0 to N1 andC start over.C 5 N0 = N1 GO TO 1CC P is between edges N0->N1 and N0->NF.C 6 N2 = NFCC P is contained in the wedge defined by line segmentsC N0->N1 and N0->N2, where N1 is adjacent to N2. SetC N3 to the node opposite N1->N2, and save N1 and N2 toC test for cycling.C 7 N3 = N0 N1S = N1 N2S = N2CC Top of edge hopping loop. Test for termination.C 8 IF ( LEFT(X(N1),Y(N1),X(N2),Y(N2),XP,YP) ) THENCC P LEFT N1->N2 and hence P is in (N1,N2,N3) unless anC error resulted from floating point inaccuracy andC collinearity. Compute the unnormalized barycentricC coordinates of P with respect to (N1,N2,N3).C B1 = (X(N3)-X(N2))*(YP-Y(N2)) - . (XP-X(N2))*(Y(N3)-Y(N2)) B2 = (X(N1)-X(N3))*(YP-Y(N3)) - . (XP-X(N3))*(Y(N1)-Y(N3)) IF (STORE(B1+1.) .GE. 1. .AND. . STORE(B2+1.) .GE. 1.) GO TO 16CC Restart with N0 randomly selected.C N0 = JRAND(N, IX,IY,IZ ) GO TO 1 ENDIFCC Set N4 to the neighbor of N2 which follows N1 (nodeC opposite N2->N1) unless N1->N2 is a boundary edge.C LP = LSTPTR(LEND(N2),N1,LIST,LPTR) IF (LIST(LP) .LT. 0) THEN NF = N2 NL = N1 GO TO 9 ENDIF LP = LPTR(LP) N4 = ABS(LIST(LP))CC Select the new edge N1->N2 which intersects the lineC segment N0-P, and set N3 to the node opposite N1->N2.C IF ( LEFT(X(N0),Y(N0),X(N4),Y(N4),XP,YP) ) THEN N3 = N1 N1 = N4 N2S = N2 IF (N1 .NE. N1S .AND. N1 .NE. N0) GO TO 8 ELSE N3 = N2 N2 = N4 N1S = N1 IF (N2 .NE. N2S .AND. N2 .NE. N0) GO TO 8 ENDIFCC The starting node N0 or edge N1-N2 was encounteredC again, implying a cycle (infinite loop). RestartC with N0 randomly selected.C N0 = JRAND(N, IX,IY,IZ ) GO TO 1CC Boundary traversal loops. NL->NF is a boundary edge andC P RIGHT NL->NF. Save NL and NF. 9 NP = NL NPP = NFCC Find the first (rightmost) visible boundary node NF. NBC is set to the first neighbor of NF, and NP is the lastC neighbor.C 10 LP = LEND(NF) LP = LPTR(LP) NB = LIST(LP) IF ( .NOT. LEFT(X(NF),Y(NF),X(NB),Y(NB),XP,YP) ) . GO TO 12CC P LEFT NF->NB and thus NB is not visible unless an errorC resulted from floating point inaccuracy and collinear-C ity of the 4 points NP, NF, NB, and P.C 11 IF ( FRWRD(X(NF),Y(NF),X(NP),Y(NP),XP,YP) .OR. . FRWRD(X(NF),Y(NF),X(NP),Y(NP),X(NB),Y(NB)) ) THEN I1 = NF GO TO 13 ENDIFCC Bottom of loop.C 12 NP = NF NF = NB GO TO 10CC Find the last (leftmost) visible boundary node NL. NBC is set to the last neighbor of NL, and NPP is the firstC neighbor.C 13 LP = LEND(NL) NB = -LIST(LP) IF ( .NOT. LEFT(X(NB),Y(NB),X(NL),Y(NL),XP,YP) ) . GO TO 14CC P LEFT NB->NL and thus NB is not visible unless an errorC resulted from floating point inaccuracy and collinear-C ity of the 4 points P, NB, NL, and NPP.C IF ( FRWRD(X(NL),Y(NL),X(NPP),Y(NPP),XP,YP) .OR. . FRWRD(X(NL),Y(NL),X(NPP),Y(NPP),X(NB),Y(NB)) ) . GO TO 15CC Bottom of loop.C 14 NPP = NL NL = NB GO TO 13CC NL is the leftmost visible boundary node.C 15 I2 = NL I3 = 0 RETURNCC P is in the triangle (N1,N2,N3).C 16 I1 = N1 I2 = N2 I3 = N3 RETURNCC All points are collinear.C 17 I1 = 0 I2 = 0 I3 = 0 RETURN END SUBROUTINE TRLIST (NCC,LCC,N,LIST,LPTR,LEND,NROW, NT, . LTRI,LCT,IER) INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N), . NROW, NT, LTRI(NROW,*), LCT(*), IERCC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 03/22/97CC This subroutine converts a triangulation data structureC from the linked list created by Subroutine TRMESH orC TRMSHR to a triangle list.CC On input:CC NCC = Number of constraints. NCC .GE. 0.CC LCC = List of constraint curve starting indexes (orC dummy array of length 1 if NCC = 0). Refer toC Subroutine ADDCST.CC N = Number of nodes in the triangulation. N .GE. 3.CC LIST,LPTR,LEND = Linked list data structure defin-C ing the triangulation. Refer toC Subroutine TRMESH.CC NROW = Number of rows (entries per triangle) re-C served for the triangle list LTRI. The valueC must be 6 if only the vertex indexes andC neighboring triangle indexes are to beC stored, or 9 if arc indexes are also to beC assigned and stored. Refer to LTRI.CC The above parameters are not altered by this routine.CC LTRI = Integer array of length at least NROW*NT,C where NT is at most 2N-5. (A sufficientC length is 12N if NROW=6 or 18N if NROW=9.)CC LCT = Integer array of length NCC or dummy array ofC length 1 if NCC = 0.CC On output:CC NT = Number of triangles in the triangulation unlessC IER .NE. 0, in which case NT = 0. NT = 2N - NBC - 2, where NB is the number of boundary nodes.CC LTRI = NROW by NT array whose J-th column containsC the vertex nodal indexes (first three rows),C neighboring triangle indexes (second threeC rows), and, if NROW = 9, arc indexes (lastC three rows) associated with triangle J forC J = 1,...,NT. The vertices are orderedC counterclockwise with the first vertex takenC to be the one with smallest index. Thus,C LTRI(2,J) and LTRI(3,J) are larger thanC LTRI(1,J) and index adjacent neighbors ofC node LTRI(1,J). For I = 1,2,3, LTRI(I+3,J)C and LTRI(I+6,J) index the triangle and arc,C respectively, which are opposite (not sharedC by) node LTRI(I,J), with LTRI(I+3,J) = 0 ifC LTRI(I+6,J) indexes a boundary arc. VertexC indexes range from 1 to N, triangle indexesC from 0 to NT, and, if included, arc indexesC from 1 to NA = NT+N-1. The triangles are or-C dered on first (smallest) vertex indexes,C except that the sets of constraint trianglesC (triangles contained in the closure of a con-C straint region) follow the non-constraintC triangles.CC LCT = Array of length NCC containing the triangleC index of the first triangle of constraint J inC LCT(J). Thus, the number of non-constraintC triangles is LCT(1)-1, and constraint J con-C tains LCT(J+1)-LCT(J) triangles, whereC LCT(NCC+1) = NT+1.CC IER = Error indicator.C IER = 0 if no errors were encountered.C IER = 1 if NCC, N, NROW, or an LCC entry isC outside its valid range on input.C IER = 2 if the triangulation data structureC (LIST,LPTR,LEND) is invalid. Note,C however, that these arrays are notC completely tested for validity.CC Modules required by TRLIST: NoneCC Intrinsic function called by TRLIST: ABSCC***********************************************************C INTEGER I, I1, I2, I3, ISV, J, JLAST, KA, KN, KT, L, . LCC1, LP, LP2, LPL, LPLN1, N1, N1ST, N2, N3, . NM2, NN LOGICAL ARCS, CSTRI, PASS2CC Test for invalid input parameters and store the indexC LCC1 of the first constraint node (if any).C NN = N IF (NCC .LT. 0 .OR. (NROW .NE. 6 .AND. . NROW .NE. 9)) GO TO 12 LCC1 = NN+1 IF (NCC .EQ. 0) THEN IF (NN .LT. 3) GO TO 12 ELSE DO 1 I = NCC,1,-1 IF (LCC1-LCC(I) .LT. 3) GO TO 12 LCC1 = LCC(I) 1 CONTINUE IF (LCC1 .LT. 1) GO TO 12 ENDIFCC Initialize parameters for loop on triangles KT = (N1,N2,C N3), where N1 < N2 and N1 < N3. This requires twoC passes through the nodes with all non-constraintC triangles stored on the first pass, and the constraintC triangles stored on the second.CC ARCS = TRUE iff arc indexes are to be stored.C KA,KT = Numbers of currently stored arcs and triangles.C N1ST = Starting index for the loop on nodes (N1ST = 1 onC pass 1, and N1ST = LCC1 on pass 2).C NM2 = Upper bound on candidates for N1.C PASS2 = TRUE iff constraint triangles are to be stored.C ARCS = NROW .EQ. 9 KA = 0 KT = 0 N1ST = 1 NM2 = NN-2 PASS2 = .FALSE.CC Loop on nodes N1: J = constraint containing N1,C JLAST = last node in constraint J.C 2 J = 0 JLAST = LCC1 - 1 DO 11 N1 = N1ST,NM2 IF (N1 .GT. JLAST) THENCC N1 is the first node in constraint J+1. Update J andC JLAST, and store the first constraint triangle indexC if in pass 2.C J = J + 1 IF (J .LT. NCC) THEN JLAST = LCC(J+1) - 1 ELSE JLAST = NN ENDIF IF (PASS2) LCT(J) = KT + 1 ENDIFCC Loop on pairs of adjacent neighbors (N2,N3). LPLN1 pointsC to the last neighbor of N1, and LP2 points to N2.C LPLN1 = LEND(N1) LP2 = LPLN1 3 LP2 = LPTR(LP2) N2 = LIST(LP2) LP = LPTR(LP2) N3 = ABS(LIST(LP)) IF (N2 .LT. N1 .OR. N3 .LT. N1) GO TO 10CC (N1,N2,N3) is a constraint triangle iff the three nodesC are in the same constraint and N2 < N3. Bypass con-C straint triangles on pass 1 and non-constraint trianglesC on pass 2.C CSTRI = N1 .GE. LCC1 .AND. N2 .LT. N3 .AND. . N3 .LE. JLAST IF ((CSTRI .AND. .NOT. PASS2) .OR. . (.NOT. CSTRI .AND. PASS2)) GO TO 10CC Add a new triangle KT = (N1,N2,N3).C KT = KT + 1 LTRI(1,KT) = N1 LTRI(2,KT) = N2 LTRI(3,KT) = N3CC Loop on triangle sides (I1,I2) with neighboring trianglesC KN = (I1,I2,I3).C DO 9 I = 1,3 IF (I .EQ. 1) THEN I1 = N3 I2 = N2 ELSEIF (I .EQ. 2) THEN I1 = N1 I2 = N3 ELSE I1 = N2 I2 = N1 ENDIFCC Set I3 to the neighbor of I1 which follows I2 unlessC I2->I1 is a boundary arc.C LPL = LEND(I1) LP = LPTR(LPL) 4 IF (LIST(LP) .EQ. I2) GO TO 5 LP = LPTR(LP) IF (LP .NE. LPL) GO TO 4CC I2 is the last neighbor of I1 unless the data structureC is invalid. Bypass the search for a neighboringC triangle if I2->I1 is a boundary arc.C IF (ABS(LIST(LP)) .NE. I2) GO TO 13 KN = 0 IF (LIST(LP) .LT. 0) GO TO 8CC I2->I1 is not a boundary arc, and LP points to I2 asC a neighbor of I1.C 5 LP = LPTR(LP) I3 = ABS(LIST(LP))CC Find L such that LTRI(L,KN) = I3 (not used if KN > KT),C and permute the vertex indexes of KN so that I1 isC smallest.C IF (I1 .LT. I2 .AND. I1 .LT. I3) THEN L = 3 ELSEIF (I2 .LT. I3) THEN L = 2 ISV = I1 I1 = I2 I2 = I3 I3 = ISV ELSE L = 1 ISV = I1 I1 = I3 I3 = I2 I2 = ISV ENDIFCC Test for KN > KT (triangle index not yet assigned).C IF (I1 .GT. N1 .AND. .NOT. PASS2) GO TO 9CC Find KN, if it exists, by searching the triangle list inC reverse order.C DO 6 KN = KT-1,1,-1 IF (LTRI(1,KN) .EQ. I1 .AND. LTRI(2,KN) .EQ. . I2 .AND. LTRI(3,KN) .EQ. I3) GO TO 7 6 CONTINUE GO TO 9CC Store KT as a neighbor of KN.C 7 LTRI(L+3,KN) = KTCC Store KN as a neighbor of KT, and add a new arc KA.C 8 LTRI(I+3,KT) = KN IF (ARCS) THEN KA = KA + 1 LTRI(I+6,KT) = KA IF (KN .NE. 0) LTRI(L+6,KN) = KA ENDIF 9 CONTINUECC Bottom of loop on triangles.C 10 IF (LP2 .NE. LPLN1) GO TO 3 11 CONTINUECC Bottom of loop on nodes.C IF (.NOT. PASS2 .AND. NCC .GT. 0) THEN PASS2 = .TRUE. N1ST = LCC1 GO TO 2 ENDIFCC No errors encountered.C NT = KT IER = 0 RETURNCC Invalid input parameter.C 12 NT = 0 IER = 1 RETURNCC Invalid triangulation data structure: I1 is a neighbor ofC I2, but I2 is not a neighbor of I1.C 13 NT = 0 IER = 2 RETURN END SUBROUTINE TRLPRT (NCC,LCT,N,X,Y,NROW,NT,LTRI,LOUT, . PRNTX) INTEGER NCC, LCT(*), N, NROW, NT, LTRI(NROW,NT), . LOUT LOGICAL PRNTX DOUBLE PRECISION X(N), Y(N)CC***********************************************************CC From TRLPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 07/02/98CC Given a triangulation of a set of points in the plane,C this subroutine prints the triangle list created byC Subroutine TRLIST and, optionally, the nodal coordinatesC on logical unit LOUT. The numbers of boundary nodes,C triangles, and arcs, and the constraint region triangleC indexes, if any, are also printed.CC All parameters other than LOUT and PRNTX should beC unaltered from their values on output from TRLIST.CCC On input:CC NCC = Number of constraints.CC LCT = List of constraint triangle starting indexesC (or dummy array of length 1 if NCC = 0).CC N = Number of nodes in the triangulation.C 3 .LE. N .LE. 9999.CC X,Y = Arrays of length N containing the coordinatesC of the nodes in the triangulation -- not usedC unless PRNTX = TRUE.CC NROW = Number of rows (entries per triangle) re-C served for the triangle list LTRI. The valueC must be 6 if only the vertex indexes andC neighboring triangle indexes are stored, or 9C if arc indexes are also stored.CC NT = Number of triangles in the triangulation.C 1 .LE. NT .LE. 9999.CC LTRI = NROW by NT array whose J-th column containsC the vertex nodal indexes (first three rows),C neighboring triangle indexes (second threeC rows), and, if NROW = 9, arc indexes (lastC three rows) associated with triangle J forC J = 1,...,NT.CC LOUT = Logical unit number for output. 0 .LE. LOUTC .LE. 99. Output is printed on unit 6 if LOUTC is outside its valid range on input.CC PRNTX = Logical variable with value TRUE if and onlyC if X and Y are to be printed (to 6 decimalC places).CC None of the parameters are altered by this routine.CC Modules required by TRLPRT: NoneCC***********************************************************C INTEGER I, K, LUN, NA, NB, NL, NLMAX, NMAX DATA NMAX/9999/, NLMAX/60/CC Local parameters:CC I = DO-loop, nodal index, and row index for LTRIC K = DO-loop and triangle indexC LUN = Logical unit number for outputC NA = Number of triangulation arcsC NB = Number of boundary nodesC NL = Number of lines printed on the current pageC NLMAX = Maximum number of print lines per pageC NMAX = Maximum value of N and NT (4-digit format)C LUN = LOUT IF (LUN .LT. 0 .OR. LUN .GT. 99) LUN = 6CC Print a heading and test for invalid input.C WRITE (LUN,100) NL = 1 IF (N .LT. 3 .OR. N .GT. NMAX .OR. . (NROW .NE. 6 .AND. NROW .NE. 9) .OR. . NT .LT. 1 .OR. NT .GT. NMAX) THENCC Print an error message and bypass the loops.C WRITE (LUN,110) N, NROW, NT GO TO 3 ENDIF IF (PRNTX) THENCC Print X and Y.C WRITE (LUN,101) NL = 6 DO 1 I = 1,N IF (NL .GE. NLMAX) THEN WRITE (LUN,106) NL = 0 ENDIF WRITE (LUN,102) I, X(I), Y(I) NL = NL + 1 1 CONTINUE ENDIFCC Print the triangulation LTRI.C IF (NL .GT. NLMAX/2) THEN WRITE (LUN,106) NL = 0 ENDIF IF (NROW .EQ. 6) THEN WRITE (LUN,103) ELSE WRITE (LUN,104) ENDIF NL = NL + 5 DO 2 K = 1,NT IF (NL .GE. NLMAX) THEN WRITE (LUN,106) NL = 0 ENDIF WRITE (LUN,105) K, (LTRI(I,K), I = 1,NROW) NL = NL + 1 2 CONTINUECC Print NB, NA, and NT (boundary nodes, arcs, andC triangles).C NB = 2*N - NT - 2 NA = NT + N - 1 IF (NL .GT. NLMAX-6) WRITE (LUN,106) WRITE (LUN,107) NB, NA, NTCC Print NCC and LCT.C 3 WRITE (LUN,108) NCC IF (NCC .GT. 0) WRITE (LUN,109) (LCT(I), I = 1,NCC) RETURNCC Print formats:C 100 FORMAT (///,24X,'TRIPACK (TRLIST) Output ') 101 FORMAT (//16X,'Node',7X,'X(Node)',10X,'Y(Node) '//) 102 FORMAT (16X,I4,2E17.6) 103 FORMAT (//1X,'Triangle',8X,'Vertices',12X,'Neighbors '/ . 4X,'KT',7X,'N1',5X,'N2',5X,'N3',4X,'KT1 ',4X, . 'KT2',4X,'KT3 '/) 104 FORMAT (//1X,'Triangle',8X,'Vertices',12X,'Neighbors ', . 14X,'Arcs '/ . 4X,'KT',7X,'N1',5X,'N2',5X,'N3',4X,'KT1 ',4X, . 'KT2',4X,'KT3',4X,'KA1',4X,'KA2',4X,'KA3 '/) 105 FORMAT (2X,I4,2X,6(3X,I4),3(2X,I5)) 106 FORMAT (///) 107 FORMAT (/1X,'NB = ',I4,' Boundary Nodes ',5X, . 'NA = ',I5,' Arcs',5X,'NT = ',I5, . ' Triangles ') 108 FORMAT (/1X,'NCC =',I3,' Constraint Curves ') 109 FORMAT (1X,9X,14I5) 110 FORMAT (//1X,10X,'*** Invalid Parameter: N = ',I5, . ', NROW =',I5,', NT =',I5,' *** ') END SUBROUTINE TRMESH (N,X,Y, LIST,LPTR,LEND,LNEW,NEAR, . NEXT,DIST,IER) INTEGER N, LIST(*), LPTR(*), LEND(N), LNEW, NEAR(N), . NEXT(N), IER DOUBLE PRECISION X(N), Y(N), DIST(N)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/28/98CC This subroutine creates a Delaunay triangulation of aC set of N arbitrarily distributed points in the plane re-C ferred to as nodes. The Delaunay triangulation is definedC as a set of triangles with the following five properties:CC 1) The triangle vertices are nodes.C 2) No triangle contains a node other than its vertices.C 3) The interiors of the triangles are pairwise disjoint.C 4) The union of triangles is the convex hull of the setC of nodes (the smallest convex set which containsC the nodes).C 5) The interior of the circumcircle of each triangleC contains no node.CC The first four properties define a triangulation, and theC last property results in a triangulation which is as closeC as possible to equiangular in a certain sense and which isC uniquely defined unless four or more nodes lie on a commonC circle. This property makes the triangulation well-suitedC for solving closest point problems and for triangle-basedC interpolation.CC The triangulation can be generalized to a constrainedC Delaunay triangulation by a call to Subroutine ADDCST.C This allows for user-specified boundaries defining a non-C convex and/or multiply connected region.CC The algorithm for constructing the triangulation hasC expected time complexity O(N*log(N)) for most nodal dis-C tributions. Also, since the algorithm proceeds by addingC nodes incrementally, the triangulation may be updated withC the addition (or deletion) of a node very efficiently.C The adjacency information representing the triangulationC is stored as a linked list requiring approximately 13NC storage locations.CCC The following is a list of the software package modulesC which a user may wish to call directly:CC ADDCST - Generalizes the Delaunay triangulation to allowC for user-specified constraints.CC ADDNOD - Updates the triangulation by appending orC inserting a new node.CC AREAP - Computes the area bounded by a closed polygonalC curve such as the boundary of the triangula-C tion or of a constraint region.CC BNODES - Returns an array containing the indexes of theC boundary nodes in counterclockwise order.C Counts of boundary nodes, triangles, and arcsC are also returned.CC CIRCUM - Computes the area, circumcenter, circumradius,C and, optionally, the aspect ratio of a trian-C gle defined by user-specified vertices.CC DELARC - Deletes a boundary arc from the triangulation.CC DELNOD - Updates the triangulation with the deletion of aC node.CC EDGE - Forces a pair of nodes to be connected by an arcC in the triangulation.CC GETNP - Determines the ordered sequence of L closestC nodes to a given node, along with the associ-C ated distances. The distance between nodes isC taken to be the length of the shortest connec-C ting path which intersects no constraintC region.CC INTSEC - Determines whether or not an arbitrary pair ofC line segments share a common point.CC JRAND - Generates a uniformly distributed pseudo-randomC integer.CC LEFT - Locates a point relative to a line.CC NEARND - Returns the index of the nearest node to anC arbitrary point, along with its squaredC distance.CC STORE - Forces a value to be stored in main memory soC that the precision of floating point numbersC in memory locations rather than registers isC computed.CC TRLIST - Converts the triangulation data structure to aC triangle list more suitable for use in a fin-C ite element code.CC TRLPRT - Prints the triangle list created by SubroutineC TRLIST.CC TRMESH - Creates a Delaunay triangulation of a set ofC nodes.CC TRMSHR - Creates a Delaunay triangulation (more effici-C ently than TRMESH) of a set of nodes lying atC the vertices of a (possibly skewed) rectangu-C lar grid.CC TRPLOT - Creates a level-2 Encapsulated Postscript (EPS)C file containing a triangulation plot.CC TRPRNT - Prints the triangulation data structure and,C optionally, the nodal coordinates.CCC On input:CC N = Number of nodes in the triangulation. N .GE. 3.CC X,Y = Arrays of length N containing the CartesianC coordinates of the nodes. (X(K),Y(K)) is re-C ferred to as node K, and K is referred to asC a nodal index. The first three nodes must notC be collinear.CC The above parameters are not altered by this routine.CC LIST,LPTR = Arrays of length at least 6N-12.CC LEND = Array of length at least N.CC NEAR,NEXT,DIST = Work space arrays of length atC least N. The space is used toC efficiently determine the nearestC triangulation node to each un-C processed node for use by ADDNOD.CC On output:CC LIST = Set of nodal indexes which, along with LPTR,C LEND, and LNEW, define the triangulation as aC set of N adjacency lists -- counterclockwise-C ordered sequences of neighboring nodes suchC that the first and last neighbors of a bound-C ary node are boundary nodes (the first neigh-C bor of an interior node is arbitrary). InC order to distinguish between interior andC boundary nodes, the last neighbor of eachC boundary node is represented by the negativeC of its index.CC LPTR = Set of pointers (LIST indexes) in one-to-oneC correspondence with the elements of LIST.C LIST(LPTR(I)) indexes the node which followsC LIST(I) in cyclical counterclockwise orderC (the first neighbor follows the last neigh-C bor).CC LEND = Set of pointers to adjacency lists. LEND(K)C points to the last neighbor of node K forC K = 1,...,N. Thus, LIST(LEND(K)) < 0 if andC only if K is a boundary node.CC LNEW = Pointer to the first empty location in LISTC and LPTR (list length plus one). LIST, LPTR,C LEND, and LNEW are not altered if IER < 0,C and are incomplete if IER > 0.CC NEAR,NEXT,DIST = Garbage.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = -1 if N < 3 on input.C IER = -2 if the first three nodes areC collinear.C IER = -4 if an error flag was returned by aC call to SWAP in ADDNOD. This is anC internal error and should be reportedC to the programmer.C IER = L if nodes L and M coincide for someC M > L. The linked list representsC a triangulation of nodes 1 to M-1C in this case.CC Modules required by TRMESH: ADDNOD, BDYADD, INSERT,C INTADD, JRAND, LEFT,C LSTPTR, STORE, SWAP,C SWPTST, TRFINDCC Intrinsic function called by TRMESH: ABSCC***********************************************************C LOGICAL LEFT DOUBLE PRECISION STORE INTEGER I, I0, J, K, KM1, LCC(1), LP, LPL, NCC, NEXTI, . NN DOUBLE PRECISION D, D1, D2, D3, EPS, SWTOL COMMON/SWPCOM/SWTOLCC Local parameters:CC D = Squared distance from node K to node IC D1,D2,D3 = Squared distances from node K to nodes 1, 2,C and 3, respectivelyC EPS = Half the machine precisionC I,J = Nodal indexesC I0 = Index of the node preceding I in a sequence ofC unprocessed nodes: I = NEXT(I0)C K = Index of node to be added and DO-loop index:C K > 3C KM1 = K-1C LCC(1) = Dummy arrayC LP = LIST index (pointer) of a neighbor of KC LPL = Pointer to the last neighbor of KC NCC = Number of constraint curvesC NEXTI = NEXT(I)C NN = Local copy of NC SWTOL = Tolerance for function SWPTSTC NN = N IF (NN .LT. 3) THEN IER = -1 RETURN ENDIFCC Compute a tolerance for function SWPTST: SWTOL = 10*C (machine precision)C EPS = 1. 1 EPS = EPS/2. SWTOL = STORE(EPS + 1.) IF (SWTOL .GT. 1.) GO TO 1 SWTOL = EPS*20.CC Store the first triangle in the linked list.C IF ( .NOT. LEFT(X(1),Y(1),X(2),Y(2),X(3),Y(3)) ) THENCC The initial triangle is (3,2,1) = (2,1,3) = (1,3,2).C LIST(1) = 3 LPTR(1) = 2 LIST(2) = -2 LPTR(2) = 1 LEND(1) = 2C LIST(3) = 1 LPTR(3) = 4 LIST(4) = -3 LPTR(4) = 3 LEND(2) = 4C LIST(5) = 2 LPTR(5) = 6 LIST(6) = -1 LPTR(6) = 5 LEND(3) = 6C ELSEIF ( .NOT. LEFT(X(2),Y(2),X(1),Y(1),X(3),Y(3)) ) . THENCC The initial triangle is (1,2,3).C LIST(1) = 2 LPTR(1) = 2 LIST(2) = -3 LPTR(2) = 1 LEND(1) = 2C LIST(3) = 3 LPTR(3) = 4 LIST(4) = -1 LPTR(4) = 3 LEND(2) = 4C LIST(5) = 1 LPTR(5) = 6 LIST(6) = -2 LPTR(6) = 5 LEND(3) = 6C ELSECC The first three nodes are collinear.C IER = -2 RETURN ENDIFCC Initialize LNEW and test for N = 3.C LNEW = 7 IF (NN .EQ. 3) THEN IER = 0 RETURN ENDIFCC A nearest-node data structure (NEAR, NEXT, and DIST) isC used to obtain an expected-time (N*log(N)) incrementalC algorithm by enabling constant search time for locatingC each new node in the triangulation.CC For each unprocessed node K, NEAR(K) is the index of theC triangulation node closest to K (used as the startingC point for the search in Subroutine TRFIND) and DIST(K)C is an increasing function of the distance between nodesC K and NEAR(K).CC Since it is necessary to efficiently find the subset ofC unprocessed nodes associated with each triangulationC node J (those that have J as their NEAR entries), theC subsets are stored in NEAR and NEXT as follows: forC each node J in the triangulation, I = NEAR(J) is theC first unprocessed node in J's set (with I = 0 if the C set is empty), L = NEXT(I) (if I > 0) is the second, C NEXT(L) (if L > 0) is the third, etc. The nodes in each C set are initially ordered by increasing indexes (which C maximizes efficiency) but that ordering is not main- C tained as the data structure is updated. C C Initialize the data structure for the single triangle. C NEAR(1) = 0 NEAR(2) = 0 NEAR(3) = 0 DO 2 K = NN,4,-1 D1 = (X(K)-X(1))**2 + (Y(K)-Y(1))**2 D2 = (X(K)-X(2))**2 + (Y(K)-Y(2))**2 D3 = (X(K)-X(3))**2 + (Y(K)-Y(3))**2 IF (D1 .LE. D2 .AND. D1 .LE. D3) THEN NEAR(K) = 1 DIST(K) = D1 NEXT(K) = NEAR(1) NEAR(1) = K ELSEIF (D2 .LE. D1 .AND. D2 .LE. D3) THEN NEAR(K) = 2 DIST(K) = D2 NEXT(K) = NEAR(2) NEAR(2) = K ELSE NEAR(K) = 3 DIST(K) = D3 NEXT(K) = NEAR(3) NEAR(3) = K ENDIF 2 CONTINUE C C Add the remaining nodes. Parameters for ADDNOD are as C follows: C C K = Index of the node to be added. C NEAR(K) = Index of the starting node for the search in C TRFIND. C NCC = Number of constraint curves. C LCC = Dummy array (since NCC = 0). C KM1 = Number of nodes in the triangulation. C NCC = 0 DO 7 K = 4,NN KM1 = K-1 CALL ADDNOD (K,X(K),Y(K),NEAR(K),NCC, LCC,KM1,X,Y, . LIST,LPTR,LEND,LNEW, IER) IF (IER .NE. 0) RETURN C C Remove K from the set of unprocessed nodes associated C with NEAR(K). C I = NEAR(K) IF (NEAR(I) .EQ. K) THEN NEAR(I) = NEXT(K) ELSE I = NEAR(I) 3 I0 = I I = NEXT(I0) IF (I .NE. K) GO TO 3 NEXT(I0) = NEXT(K) ENDIF NEAR(K) = 0 C C Loop on neighbors J of node K. C LPL = LEND(K) LP = LPL 4 LP = LPTR(LP) J = ABS(LIST(LP)) C C Loop on elements I in the sequence of unprocessed nodes C associated with J: K is a candidate for replacing J C as the nearest triangulation node to I. The next value C of I in the sequence, NEXT(I), must be saved before I C is moved because it is altered by adding I to K 's set.C I = NEAR(J) 5 IF (I .EQ. 0) GO TO 6 NEXTI = NEXT(I)CC Test for the distance from I to K less than the distanceC from I to J.C D = (X(K)-X(I))**2 + (Y(K)-Y(I))**2 IF (D .LT. DIST(I)) THENCC Replace J by K as the nearest triangulation node to I:C update NEAR(I) and DIST(I), and remove I from J's set C of unprocessed nodes and add it to K 's set.C NEAR(I) = K DIST(I) = D IF (I .EQ. NEAR(J)) THEN NEAR(J) = NEXTI ELSE NEXT(I0) = NEXTI ENDIF NEXT(I) = NEAR(K) NEAR(K) = I ELSE I0 = I ENDIFCC Bottom of loop on I.C I = NEXTI GO TO 5CC Bottom of loop on neighbors J.C 6 IF (LP .NE. LPL) GO TO 4 7 CONTINUE RETURN END SUBROUTINE TRMSHR (N,NX,X,Y, NIT, LIST,LPTR,LEND,LNEW, . IER) INTEGER N, NX, NIT, LIST(*), LPTR(*), LEND(N), LNEW, . IER DOUBLE PRECISION X(N), Y(N)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 06/27/98CC This subroutine creates a Delaunay triangulation of aC set of N nodes in the plane, where the nodes are the vert-C ices of an NX by NY skewed rectangular grid with theC natural ordering. Thus, N = NX*NY, and the nodes areC ordered from left to right beginning at the top row soC that adjacent nodes have indexes which differ by 1 in theC x-direction and by NX in the y-direction. A skewed rec-C tangular grid is defined as one in which each grid cell isC a strictly convex quadrilateral (and is thus the convexC hull of its four vertices). Equivalently, any transfor-C mation from a rectangle to a grid cell which is bilinearC in both components has an invertible Jacobian.CC If the nodes are not distributed and ordered as definedC above, Subroutine TRMESH must be called in place of thisC routine. Refer to Subroutine ADDCST for the treatment ofC constraints.CC The first phase of the algorithm consists of construc-C ting a triangulation by choosing a diagonal arc in eachC grid cell. If NIT = 0, all diagonals connect lower leftC to upper right corners and no error checking or additionalC computation is performed. Otherwise, each diagonal arc isC chosen to be locally optimal, and boundary arcs are addedC where necessary in order to cover the convex hull of theC nodes. (This is the first iteration.) If NIT > 1 and noC error was detected, the triangulation is then optimized byC a sequence of up to NIT-1 iterations in which interiorC arcs of the triangulation are tested and swapped if appro-C priate. The algorithm terminates when an iterationC results in no swaps and/or when the allowable number ofC iterations has been performed. NIT = 0 is sufficient toC produce a Delaunay triangulation if the original grid isC actually rectangular, and NIT = 1 is sufficient if it isC close to rectangular. Note, however, that the orderingC and distribution of nodes is not checked for validity inC the case NIT = 0, and the triangulation will not be validC unless the rectangular grid covers the convex hull of theC nodes.CCC On input:CC N = Number of nodes in the grid. N = NX*NY for someC NY .GE. 2.CC NX = Number of grid points in the x-direction. NXC .GE. 2.CC X,Y = Arrays of length N containing coordinates ofC the nodes with the ordering and distributionC defined in the header comments above.C (X(K),Y(K)) is referred to as node K.CC The above parameters are not altered by this routine.CC NIT = Nonnegative integer specifying the maximumC number of iterations to be employed. ReferC to the header comments above.CC LIST,LPTR = Arrays of length at least 6N-12.CC LEND = Array of length at least N.CC On output:CC NIT = Number of iterations employed.CC LIST,LPTR,LEND,LNEW = Data structure defining theC triangulation. Refer to Sub-C routine TRMESH.CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = K if the grid element with upper leftC corner at node K is not a strictlyC convex quadrilateral. The algorithmC is terminated when the first suchC occurrence is detected. Note thatC this test is not performed if NIT = 0C on input.C IER = -1 if N, NX, or NIT is outside its validC range on input.C IER = -2 if NIT > 1 on input, and the optimi-C zation loop failed to converge withinC the allowable number of iterations.C The triangulation is valid but notC optimal in this case.CC Modules required by TRMSHR: INSERT, LEFT, LSTPTR, NBCNT,C STORE, SWAP, SWPTSTCC Intrinsic function called by TRMSHR: ABSCC***********************************************************C INTEGER LSTPTR, NBCNT LOGICAL LEFT, SWPTST DOUBLE PRECISION STORE INTEGER I, ITER, J, K, KP1, LP, LPF, LPK, LPL, LPP, . M1, M2, M3, M4, MAXIT, N0, N1, N2, N3, N4, NI, . NJ, NM1, NN, NNB LOGICAL TST DOUBLE PRECISION EPS, SWTOL COMMON/SWPCOM/SWTOLCC Store local variables and test for errors in inputC parameters.C NI = NX NJ = N/NI NN = NI*NJ MAXIT = NIT NIT = 0 IF (N .NE. NN .OR. NJ .LT. 2 .OR. NI .LT. 2 .OR. . MAXIT .LT. 0) THEN IER = -1 RETURN ENDIF IER = 0CC Compute a tolerance for function SWPTST: SWTOL = 10*C (machine precision)C EPS = 1. 1 EPS = EPS/2. SWTOL = STORE(EPS + 1.) IF (SWTOL .GT. 1.) GO TO 1 SWTOL = EPS*20.CC Loop on grid points (I,J) corresponding to nodes K =C (J-1)*NI + I. TST = TRUE iff diagonals are to beC chosen by the swap test. M1, M2, M3, and M4 are theC slopes (-1, 0, or 1) of the diagonals in quadrants 1C to 4 (counterclockwise beginning with the upper right)C for a coordinate system with origin at node K.C TST = MAXIT .GT. 0 M1 = 0 M4 = 0 LP = 0 KP1 = 1 DO 6 J = 1,NJ DO 5 I = 1,NI M2 = M1 M3 = M4 K = KP1 KP1 = K + 1 LPF = LP + 1 IF (J .EQ. NJ .AND. I .NE. NI) GO TO 2 IF (I .NE. 1) THEN IF (J .NE. 1) THENCC K is not in the top row, leftmost column, or bottom rowC (unless K is the lower right corner). Take the firstC neighbor to be the node above K.C LP = LP + 1 LIST(LP) = K - NI LPTR(LP) = LP + 1 IF (M2 .LE. 0) THEN LP = LP + 1 LIST(LP) = K - 1 - NI LPTR(LP) = LP + 1 ENDIF ENDIFCC K is not in the leftmost column. The next (or first)C neighbor is to the left of K.C LP = LP + 1 LIST(LP) = K - 1 LPTR(LP) = LP + 1 IF (J .EQ. NJ) GO TO 3 IF (M3 .GE. 0) THEN LP = LP + 1 LIST(LP) = K - 1 + NI LPTR(LP) = LP + 1 ENDIF ENDIFCC K is not in the bottom row. The next (or first)C neighbor is below K.C LP = LP + 1 LIST(LP) = K + NI LPTR(LP) = LP + 1CC Test for a negative diagonal in quadrant 4 unless K isC in the rightmost column. The quadrilateral associatedC with the quadrant is tested for strict convexity un-C less NIT = 0 on input.C IF (I .EQ. NI) GO TO 3 M4 = 1 IF (.NOT. TST) GO TO 2 IF ( LEFT(X(KP1),Y(KP1),X(K+NI),Y(K+NI),X(K),Y(K)) . .OR. LEFT(X(K),Y(K),X(KP1+NI),Y(KP1+NI), . X(K+NI),Y(K+NI)) . .OR. LEFT(X(K+NI),Y(K+NI),X(KP1),Y(KP1), . X(KP1+NI),Y(KP1+NI)) . .OR. LEFT(X(KP1+NI),Y(KP1+NI),X(K),Y(K), . X(KP1),Y(KP1)) ) GO TO 12 IF ( SWPTST(KP1,K+NI,K,KP1+NI,X,Y) ) GO TO 2 M4 = -1 LP = LP + 1 LIST(LP) = KP1 + NI LPTR(LP) = LP + 1CC The next (or first) neighbor is to the right of K.C 2 LP = LP + 1 LIST(LP) = KP1 LPTR(LP) = LP + 1CC Test for a positive diagonal in quadrant 1 (the neighborC of K-NI which follows K is not K+1) unless K is in theC top row.C IF (J .EQ. 1) GO TO 3 IF (TST) THEN M1 = -1 LPK = LSTPTR(LEND(K-NI),K,LIST,LPTR) LPK = LPTR(LPK) IF (LIST(LPK) .NE. KP1) THEN M1 = 1 LP = LP + 1 LIST(LP) = KP1 - NI LPTR(LP) = LP + 1 ENDIF ENDIFCC If K is in the leftmost column (and not the top row) orC in the bottom row (and not the rightmost column), thenC the next neighbor is the node above K.C IF (I .NE. 1 .AND. J .NE. NJ) GO TO 4 LP = LP + 1 LIST(LP) = K - NI LPTR(LP) = LP + 1 IF (I .EQ. 1) GO TO 3CC K is on the bottom row (and not the leftmost or right-C most column).C IF (M2 .LE. 0) THEN LP = LP + 1 LIST(LP) = K - 1 - NI LPTR(LP) = LP + 1 ENDIF LP = LP + 1 LIST(LP) = K - 1 LPTR(LP) = LP + 1CC K is a boundary node.C 3 LIST(LP) = -LIST(LP)CC Bottom of loop. Store LEND and correct LPTR(LP).C LPF and LP point to the first and last neighborsC of K.C 4 LEND(K) = LP LPTR(LP) = LPF 5 CONTINUE 6 CONTINUECC Store LNEW, and terminate the algorithm if NIT = 0 onC input.C LNEW = LP + 1 IF (MAXIT .EQ. 0) RETURNCC Add boundary arcs where necessary in order to cover theC convex hull of the nodes. N1, N2, and N3 are consecu-C tive boundary nodes in counterclockwise order, and N0C is the starting point for each loop around the boundary.C N0 = 1 N1 = N0 N2 = NI + 1CC TST is set to TRUE if an arc is added. The boundaryC loop is repeated until a traversal results in noC added arcs.C 7 TST = .FALSE.CC Top of boundary loop. Set N3 to the first neighbor ofC N2, and test for N3 LEFT N1 -> N2.C 8 LPL = LEND(N2) LP = LPTR(LPL) N3 = LIST(LP) IF ( LEFT(X(N1),Y(N1),X(N2),Y(N2),X(N3),Y(N3)) ) . N1 = N2 IF (N1 .NE. N2) THENCC Add the boundary arc N1-N3. If N0 = N2, the startingC point is changed to N3, since N2 will be removed fromC the boundary. N3 is inserted as the first neighbor ofC N1, N2 is changed to an interior node, and N1 isC inserted as the last neighbor of N3.C TST = .TRUE. IF (N2 .EQ. N0) N0 = N3 LP = LEND(N1) CALL INSERT (N3,LP, LIST,LPTR,LNEW ) LIST(LPL) = -LIST(LPL) LP = LEND(N3) LIST(LP) = N2 CALL INSERT (-N1,LP, LIST,LPTR,LNEW ) LEND(N3) = LNEW - 1 ENDIFCC Bottom of loops. Test for termination.C N2 = N3 IF (N1 .NE. N0) GO TO 8 IF (TST) GO TO 7CC Terminate the algorithm if NIT = 1 on input.C NIT = 1 IF (MAXIT .EQ. 1) RETURNCC Optimize the triangulation by applying the swap test andC appropriate swaps to the interior arcs. The loop isC repeated until no swaps are performed or MAXIT itera-C tions have been applied. ITER is the current iteration,C and TST is set to TRUE if a swap occurs.C ITER = 1 NM1 = NN - 1 9 ITER = ITER + 1 TST = .FALSE.CC Loop on interior arcs N1-N2, where N2 > N1 andC (N1,N2,N3) and (N2,N1,N4) are adjacent triangles.CC Top of loop on nodes N1.C DO 11 N1 = 1,NM1 LPL = LEND(N1) N4 = LIST(LPL) LPF = LPTR(LPL) N2 = LIST(LPF) LP = LPTR(LPF) N3 = LIST(LP) NNB = NBCNT(LPL,LPTR)CC Top of loop on neighbors N2 of N1. NNB is the number ofC neighbors of N1.C DO 10 I = 1,NNBCC Bypass the swap test if N1 is a boundary node and N2 isC the first neighbor (N4 < 0), N2 < N1, or N1-N2 is aC diagonal arc (already locally optimal) when ITER = 2.C IF ( N4 .GT. 0 .AND. N2 .GT. N1 .AND. . (ITER .NE. 2 .OR. ABS(N1+NI-N2) .NE. 1) ) . THEN IF (SWPTST(N3,N4,N1,N2,X,Y) ) THENCC Swap diagonal N1-N2 for N3-N4, set TST to TRUE, and setC N2 to N4 (the neighbor preceding N3).C CALL SWAP (N3,N4,N1,N2, LIST,LPTR,LEND, LPP) IF (LPP .NE. 0) THEN TST = .TRUE. N2 = N4 ENDIF ENDIF ENDIFCC Bottom of neighbor loop.C IF (LIST(LPL) .EQ. -N3) GO TO 11 N4 = N2 N2 = N3 LP = LSTPTR(LPL,N2,LIST,LPTR) LP = LPTR(LP) N3 = ABS(LIST(LP)) 10 CONTINUE 11 CONTINUECC Test for termination.C IF (TST .AND. ITER .LT. MAXIT) GO TO 9 NIT = ITER IF (TST) IER = -2 RETURNCC Invalid grid cell encountered.C 12 IER = K RETURN END SUBROUTINE TRPLOT (LUN,PLTSIZ,WX1,WX2,WY1,WY2,NCC,LCC, . N,X,Y,LIST,LPTR,LEND,TITLE, . NUMBR, IER) CHARACTER*(*) TITLE INTEGER LUN, NCC, LCC(*), N, LIST(*), LPTR(*), . LEND(N), IER LOGICAL NUMBR DOUBLE PRECISION PLTSIZ, WX1, WX2, WY1, WY2, X(N), . Y(N)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 07/15/98CC This subroutine creates a level-2 Encapsulated Post-C script (EPS) file containing a triangulation plot.CCC On input:CC LUN = Logical unit number in the range 0 to 99.C The unit should be opened with an appropriateC file name before the call to this routine.CC PLTSIZ = Plot size in inches. The window is mapped,C with aspect ratio preserved, to a rectangu-C lar viewport with maximum side-length equalC to .88*PLTSIZ (leaving room for labels out-C side the viewport). The viewport isC centered on the 8.5 by 11 inch page, andC its boundary is drawn. 1.0 .LE. PLTSIZC .LE. 8.5.CC WX1,WX2,WY1,WY2 = Parameters defining a rectangularC window against which the triangu-C lation is clipped. (Only theC portion of the triangulation thatC lies in the window is drawn.)C (WX1,WY1) and (WX2,WY2) are theC lower left and upper right cor-C ners, respectively. WX1 < WX2 andC WY1 < WY2.CC NCC = Number of constraint curves. Refer to Subrou-C tine ADDCST. NCC .GE. 0.CC LCC = Array of length NCC (or dummy parameter ifC NCC = 0) containing the index of the firstC node of constraint I in LCC(I). For I = 1 toC NCC, LCC(I+1)-LCC(I) .GE. 3, where LCC(NCC+1)C = N+1.CC N = Number of nodes in the triangulation. N .GE. 3.CC X,Y = Arrays of length N containing the coordinatesC of the nodes with non-constraint nodes in theC first LCC(1)-1 locations.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC TITLE = Type CHARACTER variable or constant contain-C ing a string to be centered above the plot.C The string must be enclosed in parentheses;C i.e., the first and last characters must beC '(' and ') ', respectively, but these are notC displayed. TITLE may have at most 80 char-C acters including the parentheses.CC NUMBR = Option indicator: If NUMBR = TRUE, theC nodal indexes are plotted next to the nodes.CC Input parameters are not altered by this routine.CC On output:CC IER = Error indicator:C IER = 0 if no errors were encountered.C IER = 1 if LUN, PLTSIZ, NCC, or N is outsideC its valid range. LCC is not testedC for validity.C IER = 2 if WX1 >= WX2 or WY1 >= WY2.C IER = 3 if an error was encountered in writingC to unit LUN.CC Various plotting options can be controlled by alteringC the data statement below.CC Modules required by TRPLOT: NoneCC Intrinsic functions called by TRPLOT: ABS, CHAR, NINT,C DBLECC***********************************************************C INTEGER I, IFRST, IH, ILAST, IPX1, IPX2, IPY1, IPY2, . IW, LP, LPL, N0, N0BAK, N0FOR, N1, NLS LOGICAL ANNOT, CNSTR, PASS1 DOUBLE PRECISION DASHL, DX, DY, FSIZN, FSIZT, R, SFX, . SFY, T, TX, TY, X0, Y0C DATA ANNOT/.TRUE./, DASHL/4.0/, FSIZN/10.0/, . FSIZT/16.0/CC Local parameters:CC ANNOT = Logical variable with value TRUE iff the plotC is to be annotated with the values of WX1,C WX2, WY1, and WY2C CNSTR Logical variable used to flag constraint arcs:C TRUE iff N0-N1 lies in a constraint regionC DASHL = Length (in points, at 72 points per inch) ofC dashes and spaces in a dashed line patternC used for drawing constraint arcsC DX = Window width WX2-WX1C DY = Window height WY2-WY1C FSIZN = Font size in points for labeling nodes withC their indexes if NUMBR = TRUEC FSIZT = Font size in points for the title (andC annotation if ANNOT = TRUE)C I = Constraint index (1 to NCC)C IFRST = Index of the first node in constraint IC IH = Height of the viewport in pointsC ILAST = Index of the last node in constraint IC IPX1,IPY1 = X and y coordinates (in points) of the lowerC left corner of the bounding box or viewportC IPX2,IPY2 = X and y coordinates (in points) of the upperC right corner of the bounding box or viewportC IW = Width of the viewport in pointsC LP = LIST index (pointer)C LPL = Pointer to the last neighbor of N0C N0 = Nodal index and DO-loop indexC N0BAK = Predecessor of N0 in a constraint curveC (sequence of adjacent constraint nodes)C N0FOR = Successor to N0 in a constraint curveC N1 = Index of a neighbor of N0C NLS = Index of the last non-constraint nodeC PASS1 = Logical variable used to flag the first passC through the constraint nodesC R = Aspect ratio DX/DYC SFX,SFY = Scale factors for mapping world coordinatesC (window coordinates in [WX1,WX2] X [WY1,WY2])C to viewport coordinates in [IPX1,IPX2] XC [IPY1,IPY2]C T = Temporary variableC TX,TY = Translation vector for mapping world coordi-C nates to viewport coordinatesC X0,Y0 = X(N0),Y(N0) or label locationCCC Test for error 1, and set NLS to the last non-constraintC node.C IF (LUN .LT. 0 .OR. LUN .GT. 99 .OR. . PLTSIZ .LT. 1.0 .OR. PLTSIZ .GT. 8.5 .OR. . NCC .LT. 0 .OR. N .LT. 3) GO TO 11 NLS = N IF (NCC .GT. 0) NLS = LCC(1)-1CC Compute the aspect ratio of the window.C DX = WX2 - WX1 DY = WY2 - WY1 IF (DX .LE. 0.0 .OR. DY .LE. 0.0) GO TO 12 R = DX/DYCC Compute the lower left (IPX1,IPY1) and upper rightC (IPX2,IPY2) corner coordinates of the bounding box.C The coordinates, specified in default user space unitsC (points, at 72 points/inch with origin at the lowerC left corner of the page), are chosen to preserve theC aspect ratio R, and to center the plot on the 8.5 by 11C inch page. The center of the page is (306,396), andC T = PLTSIZ/2 in points.C T = 36.0*PLTSIZ IF (R .GE. 1.0) THEN IPX1 = 306 - NINT(T) IPX2 = 306 + NINT(T) IPY1 = 396 - NINT(T/R) IPY2 = 396 + NINT(T/R) ELSE IPX1 = 306 - NINT(T*R) IPX2 = 306 + NINT(T*R) IPY1 = 396 - NINT(T) IPY2 = 396 + NINT(T) ENDIFCC Output header comments.C WRITE (LUN,100,ERR=13) IPX1, IPY1, IPX2, IPY2 100 FORMAT ('%!PS-Adobe-3.0 EPSF-3.0'/ . '%%BoundingBox:',4I4/ . '%%Title: Triangulation'/ . '%%Creator: TRIPACK'/ . '%%EndComments') C C Set (IPX1,IPY1) and (IPX2,IPY2) to the corner coordinates C of a viewport obtained by shrinking the bounding box by C 12% in each dimension. C IW = NINT(0.88*DBLE(IPX2-IPX1)) IH = NINT(0.88*DBLE(IPY2-IPY1)) IPX1 = 306 - IW/2 IPX2 = 306 + IW/2 IPY1 = 396 - IH/2 IPY2 = 396 + IH/2 C C Set the line thickness to 2 points, and draw the C viewport boundary. C T = 2.0 WRITE (LUN,110,ERR=13) T WRITE (LUN,120,ERR=13) IPX1, IPY1 WRITE (LUN,130,ERR=13) IPX1, IPY2 WRITE (LUN,130,ERR=13) IPX2, IPY2 WRITE (LUN,130,ERR=13) IPX2, IPY1 WRITE (LUN,140,ERR=13) WRITE (LUN,150,ERR=13) 110 FORMAT (F12.6,' setlinewidth') 120 FORMAT (2I4,' moveto') 130 FORMAT (2I4,' lineto') 140 FORMAT ('closepath') 150 FORMAT ('stroke') C C Set up a mapping from the window to the viewport. C SFX = DBLE(IW)/DX SFY = DBLE(IH)/DY TX = IPX1 - SFX*WX1 TY = IPY1 - SFY*WY1 WRITE (LUN,160,ERR=13) TX, TY, SFX, SFY 160 FORMAT (2F12.6,' translate'/ . 2F12.6,' scale') C C The line thickness (believe it or fucking not) must be C changed to reflect the new scaling which is applied to C all subsequent output. Set it to 1.0 point. C T = 2.0/(SFX+SFY) WRITE (LUN,110,ERR=13) T C C Save the current graphics state, and set the clip path to C the boundary of the window. C WRITE (LUN,170,ERR=13) WRITE (LUN,180,ERR=13) WX1, WY1 WRITE (LUN,190,ERR=13) WX2, WY1 WRITE (LUN,190,ERR=13) WX2, WY2 WRITE (LUN,190,ERR=13) WX1, WY2 WRITE (LUN,200,ERR=13) 170 FORMAT ('gsave') 180 FORMAT (2F12.6,' moveto') 190 FORMAT (2F12.6,' lineto') 200 FORMAT ('closepath clip newpath') C C Draw the edges N0->N1, where N1 > N0, beginning with a C loop on non-constraint nodes N0. LPL points to the C last neighbor of N0. C DO 3 N0 = 1,NLS X0 = X(N0) Y0 = Y(N0) LPL = LEND(N0) LP = LPL C C Loop on neighbors N1 of N0. C 2 LP = LPTR(LP) N1 = ABS(LIST(LP)) IF (N1 .GT. N0) THEN C C Add the edge to the path. C WRITE (LUN,210,ERR=13) X0, Y0, X(N1), Y(N1) 210 FORMAT (2F12.6,' moveto',2F12.6,' lineto') ENDIF IF (LP .NE. LPL) GO TO 2 3 CONTINUE C C Loop through the constraint nodes twice. The non- C constraint arcs incident on constraint nodes are C drawn (with solid lines) on the first pass, and the C constraint arcs (both boundary and interior, if any) C are drawn (with dashed lines) on the second pass. C PASS1 = .TRUE. C C Loop on constraint nodes N0 with (N0BAK,N0,N0FOR) a sub- C sequence of constraint I. The outer loop is on C constraints I with first and last nodes IFRST and ILAST. C 4 IFRST = N+1 DO 8 I = NCC,1,-1 ILAST = IFRST - 1 IFRST = LCC(I) N0BAK = ILAST DO 7 N0 = IFRST,ILAST N0FOR = N0 + 1 IF (N0 .EQ. ILAST) N0FOR = IFRST LPL = LEND(N0) X0 = X(N0) Y0 = Y(N0) LP = LPL C C Loop on neighbors N1 of N0. CNSTR = TRUE iff N0-N1 is a C constraint arc. C C Initialize CNSTR to TRUE iff the first neighbor of N0 C strictly follows N0FOR and precedes or coincides with C N0BAK (in counterclockwise order). C 5 LP = LPTR(LP) N1 = ABS(LIST(LP)) IF (N1 .NE. N0FOR .AND. N1 .NE. N0BAK) GO TO 5 CNSTR = N1 .EQ. N0BAK LP = LPL C C Loop on neighbors N1 of N0. Update CNSTR and test for C N1 > N0. C 6 LP = LPTR(LP) N1 = ABS(LIST(LP)) IF (N1 .EQ. N0FOR) CNSTR = .TRUE. IF (N1 .GT. N0) THEN C C Draw the edge iff (PASS1=TRUE and CNSTR=FALSE) or C (PASS1=FALSE and CNSTR=TRUE); i.e., CNSTR and PASS1 C have opposite values. C IF (CNSTR .NEQV. PASS1) . WRITE (LUN,210,ERR=13) X0, Y0, X(N1), Y(N1) ENDIF IF (N1 .EQ. N0BAK) CNSTR = .FALSE. C C Bottom of loops. C IF (LP .NE. LPL) GO TO 6 N0BAK = N0 7 CONTINUE 8 CONTINUE IF (PASS1) THEN C C End of first pass: paint the path and change to dashed C lines for subsequent drawing. Since the scale factors C are applied to everything, the dash length must be C specified in world coordinates. C PASS1 = .FALSE. WRITE (LUN,150,ERR=13) T = DASHL*2.0/(SFX+SFY) WRITE (LUN,220,ERR=13) T 220 FORMAT ('[',F12.6,'] 0 setdash') GO TO 4 ENDIF C C Paint the path and restore the saved graphics state (with C no clip path). C WRITE (LUN,150,ERR=13) WRITE (LUN,230,ERR=13) 230 FORMAT ('grestore') IF (NUMBR) THEN C C Nodes in the window are to be labeled with their indexes. C Convert FSIZN from points to world coordinates, and C output the commands to select a font and scale it. C T = FSIZN*2.0/(SFX+SFY) WRITE (LUN,240,ERR=13) T 240 FORMAT ('/Helvetica findfont'/ . F12.6,' scalefont setfont') C C Loop on nodes N0 with coordinates (X0,Y0). C DO 9 N0 = 1,N X0 = X(N0) Y0 = Y(N0) IF (X0 .LT. WX1 .OR. X0 .GT. WX2 .OR. . Y0 .LT. WY1 .OR. Y0 .GT. WY2) GO TO 9 C C Move to (X0,Y0), and draw the label N0. The first char- C acter will have its lower left corner about one C character width to the right of the nodal position. C WRITE (LUN,180,ERR=13) X0, Y0 WRITE (LUN,250,ERR=13) N0 250 FORMAT ('(',I3,') show') 9 CONTINUE ENDIF C C Convert FSIZT from points to world coordinates, and output C the commands to select a font and scale it. C T = FSIZT*2.0/(SFX+SFY) WRITE (LUN,240,ERR=13) T C C Display TITLE centered above the plot: C Y0 = WY2 + 3.0*T WRITE (LUN,260,ERR=13) TITLE, (WX1+WX2)/2.0, Y0 260 FORMAT (A80/' stringwidth pop 2 div neg ',F12.6, . ' add ',F12.6,' moveto') WRITE (LUN,270,ERR=13) TITLE 270 FORMAT (A80/' show') IF (ANNOT) THEN C C Display the window extrema below the plot. C X0 = WX1 Y0 = WY1 - 100.0/(SFX+SFY) WRITE (LUN,180,ERR=13) X0, Y0 WRITE (LUN,280,ERR=13) WX1, WX2 Y0 = Y0 - 2.0*T WRITE (LUN,290,ERR=13) X0, Y0, WY1, WY2 280 FORMAT ('(Window: WX1 = ',E9.3,', WX2 = ',E9.3, . ') show') 290 FORMAT ('(Window: ) stringwidth pop ',F12.6,' add', . F12.6,' moveto'/ . '( WY1 = ',E9.3,', WY2 = ',E9.3,') show') ENDIF C C Paint the path and output the showpage command and C end-of-file indicator. C WRITE (LUN,300,ERR=13) 300 FORMAT ('stroke'/ . 'showpage'/ . '%%EOF') C C HP 's interpreters require a one-byte End-of-PostScript-JobC indicator (to eliminate a timeout error message):C ASCII 4.C WRITE (LUN,310,ERR=13) CHAR(4) 310 FORMAT (A1)CC No error encountered.C IER = 0 RETURNCC Invalid input parameter.C 11 IER = 1 RETURNCC DX or DY is not positive.C 12 IER = 2 RETURNCC Error writing to unit LUN.C 13 IER = 3 RETURN END SUBROUTINE TRPRNT (NCC,LCC,N,X,Y,LIST,LPTR,LEND,LOUT, . PRNTX) INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N), . LOUT LOGICAL PRNTX DOUBLE PRECISION X(N), Y(N)CC***********************************************************CC From TRIPACKC Robert J. RenkaC Dept. of Computer ScienceC Univ. of North TexasC renka@cs.unt.eduC 07/30/98CC Given a triangulation of a set of points in the plane,C this subroutine prints the adjacency lists and, option-C ally, the nodal coordinates on logical unit LOUT. TheC list of neighbors of a boundary node is followed by indexC 0. The numbers of boundary nodes, triangles, and arcs,C and the constraint curve starting indexes, if any, areC also printed.CCC On input:CC NCC = Number of constraints.CC LCC = List of constraint curve starting indexes (orC dummy array of length 1 if NCC = 0).CC N = Number of nodes in the triangulation.C 3 .LE. N .LE. 9999.CC X,Y = Arrays of length N containing the coordinatesC of the nodes in the triangulation -- not usedC unless PRNTX = TRUE.CC LIST,LPTR,LEND = Data structure defining the trian-C gulation. Refer to SubroutineC TRMESH.CC LOUT = Logical unit number for output. 0 .LE. LOUTC .LE. 99. Output is printed on unit 6 if LOUTC is outside its valid range on input.CC PRNTX = Logical variable with value TRUE if and onlyC if X and Y are to be printed (to 6 decimalC places).CC None of the parameters are altered by this routine.CC Modules required by TRPRNT: NoneCC***********************************************************C INTEGER I, INC, K, LP, LPL, LUN, NA, NABOR(100), NB, . ND, NL, NLMAX, NMAX, NODE, NN, NT DATA NMAX/9999/, NLMAX/60/C NN = N LUN = LOUT IF (LUN .LT. 0 .OR. LUN .GT. 99) LUN = 6CC Print a heading and test the range of N.C WRITE (LUN,100) NN IF (NN .LT. 3 .OR. NN .GT. NMAX) THENCC N is outside its valid range.C WRITE (LUN,110) GO TO 5 ENDIFCC Initialize NL (the number of lines printed on the currentC page) and NB (the number of boundary nodes encountered).C NL = 6 NB = 0 IF (.NOT. PRNTX) THENCC Print LIST only. K is the number of neighbors of NODEC which are stored in NABOR.C WRITE (LUN,101) DO 2 NODE = 1,NN LPL = LEND(NODE) LP = LPL K = 0C 1 K = K + 1 LP = LPTR(LP) ND = LIST(LP) NABOR(K) = ND IF (LP .NE. LPL) GO TO 1 IF (ND .LE. 0) THENCC NODE is a boundary node. Correct the sign of the lastC neighbor, add 0 to the end of the list, and incrementC NB.C NABOR(K) = -ND K = K + 1 NABOR(K) = 0 NB = NB + 1 ENDIFCC Increment NL and print the list of neighbors.C INC = (K-1)/14 + 2 NL = NL + INC IF (NL .GT. NLMAX) THEN WRITE (LUN,106) NL = INC ENDIF WRITE (LUN,103) NODE, (NABOR(I), I = 1,K) IF (K .NE. 14) WRITE (LUN,105) 2 CONTINUE ELSECC Print X, Y, and LIST.C WRITE (LUN,102) DO 4 NODE = 1,NN LPL = LEND(NODE) LP = LPL K = 0 3 K = K + 1 LP = LPTR(LP) ND = LIST(LP) NABOR(K) = ND IF (LP .NE. LPL) GO TO 3 IF (ND .LE. 0) THENCC NODE is a boundary node.C NABOR(K) = -ND K = K + 1 NABOR(K) = 0 NB = NB + 1 ENDIFCC Increment NL and print X, Y, and NABOR.C INC = (K-1)/8 + 2 NL = NL + INC IF (NL .GT. NLMAX) THEN WRITE (LUN,106) NL = INC ENDIF WRITE (LUN,104) NODE, X(NODE), Y(NODE), . (NABOR(I), I = 1,K) IF (K .NE. 8) WRITE (LUN,105) 4 CONTINUE ENDIFCC Print NB, NA, and NT (boundary nodes, arcs, andC triangles).C NT = 2*NN - NB - 2 NA = NT + NN - 1 IF (NL .GT. NLMAX-6) WRITE (LUN,106) WRITE (LUN,107) NB, NA, NTCC Print NCC and LCC.C 5 WRITE (LUN,108) NCC IF (NCC .GT. 0) WRITE (LUN,109) (LCC(I), I = 1,NCC) RETURNCC Print formats:C 100 FORMAT (///,26X,'Adjacency Sets, N = ',I5//) 101 FORMAT (1X,'Node',32X,'Neighbors of Node '//) 102 FORMAT (1X,'Node',5X,'X(Node)',8X,'Y(Node) ', . 20X,'Neighbors of Node '//) 103 FORMAT (1X,I4,5X,14I5/(1X,9X,14I5)) 104 FORMAT (1X,I4,2E15.6,5X,8I5/(1X,39X,8I5)) 105 FORMAT (1X) 106 FORMAT (///) 107 FORMAT (/1X,'NB = ',I4,' Boundary Nodes ',5X, . 'NA = ',I5,' Arcs',5X,'NT = ',I5, . ' Triangles ') 108 FORMAT (/1X,'NCC =',I3,' Constraint Curves ') 109 FORMAT (1X,9X,14I5) 110 FORMAT (1X,10X,'*** N is outside its valid ', . ' range ***

Generated by Doxygen 1.6.0 Back to index