Initial commit

1 files changed, 128 insertions, 0 deletions

diff --git a/sys/gio/ncarutil/conlib/condet.f b/sys/gio/ncarutil/conlib/condet.f
new file mode 100644
index 00000000..6b3a3077
--- /dev/null
+++ b/sys/gio/ncarutil/conlib/condet.f
@@ -0,0 +1,128 @@
+      SUBROUTINE CONDET (NDP,XD,YD,NCP,IPC)
+C                                                                               
+C +-----------------------------------------------------------------+           
+C |                                                                 |           
+C |                Copyright (C) 1986 by UCAR                       |           
+C |        University Corporation for Atmospheric Research          |           
+C |                    All Rights Reserved                          |           
+C |                                                                 |           
+C |                 NCARGRAPHICS  Version 1.00                      |           
+C |                                                                 |           
+C +-----------------------------------------------------------------+           
+C                                                                               
+C                                                                               
+C
+C******************************************************************
+C*                                                                *
+C*   THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB      *
+C*   FILES CONRAN , CONRAQ AND CONRAS.  SEE THOSE FILES FOR AN    *
+C*   EXPLAINATION OF THE ENTRY POINTS.                            *
+C*                                                                *
+C******************************************************************
+C
+C THIS SUBROUTINE SELECTS SEVERAL DATA POINTS THAT ARE CLOSEST
+C TO EACH OF THE DATA POINT.
+C THE INPUT PARAMETERS ARE
+C     NDP = NUMBER OF DATA POINTS,
+C     XD,YD = ARRAYS CONTAINING THE X AND Y COORDINATES
+C             OF DATA POINTS,
+C     NCP = NUMBER OF DATA POINTS CLOSEST TO EACH DATA
+C           POINTS.
+C THE OUTPUT PARAMETER IS
+C     IPC = INTEGER ARRAY OF DIMENSION NCP*NDP, WHERE THE
+C           POINT NUMBERS OF NCP DATA POINTS CLOSEST TO
+C           EACH OF THE NDP DATA POINTS ARE TO BE STORED.
+C THIS SUBROUTINE ARBITRARILY SETS A RESTRICTION THAT NCP MUST
+C NOT EXCEED 25 WITHOUT MODIFICATION TO THE ARRAYS DSQ0 AND IPC0.
+C DECLARATION STATEMENTS
+C
+      COMMON /CONRA3/ IREC
+      DIMENSION       XD(NDP)    ,YD(NDP)    ,IPC(1)
+      DIMENSION       DSQ0(25)   ,IPC0(25)
+C
+        SAVE
+C
+C STATEMENT FUNCTION
+C
+      DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2
+C
+C CALCULATION
+C
+      DO  220 IP1=1,NDP
+C
+C - SELECTS NCP POINTS.
+C
+         X1 = XD(IP1)
+         Y1 = YD(IP1)
+         J1 = 0
+         DSQMX = 0.0
+         DO  110 IP2=1,NDP
+            IF (IP2 .EQ. IP1) GO TO  110
+            DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2))
+            J1 = J1+1
+            DSQ0(J1) = DSQI
+            IPC0(J1) = IP2
+            IF (DSQI .LE. DSQMX) GO TO  100
+            DSQMX = DSQI
+            JMX = J1
+  100       IF (J1 .GE. NCP) GO TO  120
+  110    CONTINUE
+  120    IP2MN = IP2+1
+         IF (IP2MN .GT. NDP) GO TO  150
+         DO  140 IP2=IP2MN,NDP
+            IF (IP2 .EQ. IP1) GO TO  140
+            DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2))
+            IF (DSQI .GE. DSQMX) GO TO  140
+            DSQ0(JMX) = DSQI
+            IPC0(JMX) = IP2
+            DSQMX = 0.0
+            DO  130 J1=1,NCP
+               IF (DSQ0(J1) .LE. DSQMX) GO TO  130
+               DSQMX = DSQ0(J1)
+               JMX = J1
+  130       CONTINUE
+  140    CONTINUE
+C
+C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR.
+C
+  150    IP2 = IPC0(1)
+         DX12 = XD(IP2)-X1
+         DY12 = YD(IP2)-Y1
+         DO  160 J3=2,NCP
+            IP3 = IPC0(J3)
+            DX13 = XD(IP3)-X1
+            DY13 = YD(IP3)-Y1
+            IF ((DY13*DX12-DX13*DY12) .NE. 0.0) GO TO  200
+  160    CONTINUE
+C
+C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT.
+C
+         NCLPT = 0
+         DO  190 IP3=1,NDP
+            IF (IP3 .EQ. IP1) GO TO  190
+            DO  170 J4=1,NCP
+               IF (IP3 .EQ. IPC0(J4)) GO TO  190
+  170       CONTINUE
+            DX13 = XD(IP3)-X1
+            DY13 = YD(IP3)-Y1
+            IF ((DY13*DX12-DX13*DY12) .EQ. 0.0) GO TO  190
+            DSQI = DSQF(X1,Y1,XD(IP3),YD(IP3))
+            IF (NCLPT .EQ. 0) GO TO  180
+            IF (DSQI .GE. DSQMN) GO TO  190
+  180       NCLPT = 1
+            DSQMN = DSQI
+            IP3MN = IP3
+  190    CONTINUE
+         DSQMX = DSQMN
+         IPC0(JMX) = IP3MN
+C
+C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY.
+C
+  200    J1 = (IP1-1)*NCP
+         DO  210 J2=1,NCP
+            J1 = J1+1
+            IPC(J1) = IPC0(J2)
+  210    CONTINUE
+  220 CONTINUE
+      RETURN
+      END