1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
INTEGER FUNCTION CONXCH (X,Y,I1,I2,I3,I4)
C
C +-----------------------------------------------------------------+
C | |
C | Copyright (C) 1986 by UCAR |
C | University Corporation for Atmospheric Research |
C | All Rights Reserved |
C | |
C | NCARGRAPHICS Version 1.00 |
C | |
C +-----------------------------------------------------------------+
C
C
C
C THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO
C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION
C BY C. L. LAWSON.
C THE INPUT PARAMETERS ARE
C X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA
C POINTS,
C I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2,
C P3, AND P4 THAT FORM A QUADRILATERAL
C WITH P3 AND P4 CONNECTED DIADONALLY.
C THIS FUNCTION RETURNS A VALUE 1 (ONE) WHEN AN EXCHANGE IS
C NEEDED, AND 0 (ZERO) OTHERWISE.
C DECLARATION STATEMENTS
C
DIMENSION X(1) ,Y(1)
DIMENSION X0(4) ,Y0(4)
EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ),(A4SQ,B1SQ),
1 (B4SQ,A2SQ),(C4SQ,C3SQ)
C
SAVE
C
C STATEMENT FUNCTIONS
C
C CALCULATION
C
X0(1) = X(I1)
Y0(1) = Y(I1)
X0(2) = X(I2)
Y0(2) = Y(I2)
X0(3) = X(I3)
Y0(3) = Y(I3)
X0(4) = X(I4)
Y0(4) = Y(I4)
IDX = 0
U3 = (Y0(2)-Y0(3))*(X0(1)-X0(3))-(X0(2)-X0(3))*(Y0(1)-Y0(3))
U4 = (Y0(1)-Y0(4))*(X0(2)-X0(4))-(X0(1)-X0(4))*(Y0(2)-Y0(4))
IF (U3*U4 .LE. 0.0) GO TO 100
U1 = (Y0(3)-Y0(1))*(X0(4)-X0(1))-(X0(3)-X0(1))*(Y0(4)-Y0(1))
U2 = (Y0(4)-Y0(2))*(X0(3)-X0(2))-(X0(4)-X0(2))*(Y0(3)-Y0(2))
A1SQ = (X0(1)-X0(3))**2+(Y0(1)-Y0(3))**2
B1SQ = (X0(4)-X0(1))**2+(Y0(4)-Y0(1))**2
C1SQ = (X0(3)-X0(4))**2+(Y0(3)-Y0(4))**2
A2SQ = (X0(2)-X0(4))**2+(Y0(2)-Y0(4))**2
B2SQ = (X0(3)-X0(2))**2+(Y0(3)-Y0(2))**2
C3SQ = (X0(2)-X0(1))**2+(Y0(2)-Y0(1))**2
S1SQ = U1*U1/(C1SQ*AMAX1(A1SQ,B1SQ))
S2SQ = U2*U2/(C2SQ*AMAX1(A2SQ,B2SQ))
S3SQ = U3*U3/(C3SQ*AMAX1(A3SQ,B3SQ))
S4SQ = U4*U4/(C4SQ*AMAX1(A4SQ,B4SQ))
IF (AMIN1(S1SQ,S2SQ) .LT. AMIN1(S3SQ,S4SQ)) IDX = 1
100 CONXCH = IDX
RETURN
C
END
|
