End of file
Contents
Index
SUBROUTINE PROB3(NX, X, Y, Z, F,M, MARK, C, A, IWORK, WK)
C
C*****************************************************************
C *
C PROB3 computes three-dimensional surface splines for arbitrary *
C given points (X(I),Y(I),Z(I),F(X(I),Y(I)), I=1, ..., NX. *
C The nodes (X(I),Y(I),Z(I)) must be distinct and F must be a *
C function, i.e., for each (X,Y,Z) in the node set there must *
C correspond a unique F=F(X,Y,Z). The nodes need not be ordered.*
C The desired smoothness of the spline, i. e., its derivative *
C order should be stipulated as rather low since the condition *
C number of the system of equations that has to be solved worsens*
C with increasing derivative order. *
C Tests indicate that derivative orders between 3 and 5 can be *
C recommended. Higher orders showed improvement only in rare *
C cases. For an increasing number of nodes, i. e., a decreasing *
C distance between the nodes the condition number of the linear *
C system also tends to worsen. *
C *
C INPUT PARAMETERS: *
C ================= *
C NX : Number of nodes *
C X,Y,Z : NX-vectors ..(1:NX); the coordinates of the nodes *
C F : NX-vector F(1:NX); the functional values at the nodes*
C M : derivative order used to determine the coefficients *
C *
C OUTPUT PARAMETERS: *
C ================== *
C *
C C : vector C(1:(NX + M*(M+1)*(M+2)/6)); the coefficients *
C of the spline *
C *
C MARK : indicates whether the linear system could be solved: *
C MARK = 1: all is ok *
C MARK = 0: system matrix is numerically singular *
C *
C AUXILIARY PARAMETERS: *
C ===================== *
C A : vector A(1:((NX + M*(M+1)*(M+2)/6) * *
C * (NX + M*(M+1)*(M+2)/6 + 3))/2) *
C IWORK : integer vector IWORK(1:(NX + M*(M+1)*(M+2)/6)) *
C WK : vector WK(1:((NX + M*(M+1)*(M+2)/6)* *
C * (NX + M*(M+1)*(M+2)/6 + 1)/2)) *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: ALPHA3, GAMMA3, NEXT3, E3, CEPSPM, *
C ZSPMMK, PCOSOL, PCOLTG, SESSPM, SCAPRO, *
C VECMWC, ABSSUM, INDMAX, VECADD, VECXCH, *
C *
C*****************************************************************
C *
C Authors : Richard Reuter (1983), Hartmut Turowski *
C Date : 12.10.1989 *
C Source : FORTRAN 77 *
C *
C*****************************************************************
C..
C.. declarations
C..
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION X(NX),Y(NX),Z(NX),F(NX)
DIMENSION C(NX+M*(M+1)*(M+2)/6)
DIMENSION A((NX+M*(M+1)*(M+2)/6)*
F (NX+M*(M+1)*(M+2)/6+3)/2)
DIMENSION WK((NX+M*(M+1)*(M+2)/6)*
F ((NX+M*(M+1)*(M+2)/6)+1)/2)
DIMENSION IWORK(NX+M*(M+1)*(M+2)/6)
C..
C.. Order of the matrix
C..
M3 = M*(M+1)*(M+2)/6
NM = NX + M3
C..
C.. Pointer for the polynomial part of the system matrix
C..
NXX= 1 + (NX*(NX+1))/2
C..
C.. Initialize error parameter
C..
MARK = 1
C..
C.. Form system matrix:
C.. Polynomial part P appears in condensed form in upper right corner
C..
CALL ALPHA3(NX,X,Y,Z,M-1,A(NXX),
F IWORK(1),IWORK(1+M3),IWORK(1+2*M3))
C..
C.. G part of the matrix:
C.. condensed in upper left corner
C..
CALL GAMMA3(NX,X,Y,Z,M,A)
C..
C.. Set up right hand side
C..
DO 10 I = 1,NX
C(I) = F(I)
10 CONTINUE
DO 20 I = NX+1, NM
C(I) = 0.0D0
20 CONTINUE
C..
C.. factor the system matrix
C..
CALL CEPSPM(A,NM,C,IWORK,RCOND,A((NM*(NM+1))/2 + 1),WK)
C..
C.. Stop if the system matrix is numerically singular
C..
IF (1.0D0 .EQ. 1.0D0+RCOND) THEN
MARK = 0
RETURN
ENDIF
C..
C.. Solve the linear system
C..
CALL SESSPM(WK,NM,IWORK,C)
RETURN
END
C
C
SUBROUTINE ALPHA3(NX,X,Y,Z,M,A,IDX,IDY,IDZ)
C
C*****************************************************************
C *
C Computes the polynomial part P of the system matrix. *
C *
C INPUT PARAMETERS: *
C ================= *
C NX : number of nodes *
C X,Y,Z: NX-vectors ..(1:NX); the coordinates of the nodes *
C M : derivative order *
C *
C OUTPUT PARAMETERS: *
C ================== *
C A : polynomial part of the system matrix in condensed form: *
C A(1:(((M+1)*(M+2)*(M+3)/6) * *
C * (2*NX+((M+1)*(M+2)*(M+3)/6)+1)/2) *
C *
C AUXILIARY PARAMETERS: *
C ===================== *
C IDX : ] *
C IDY : ] vectors ..(1:((M+1)*(M+2)*(M+3)/6)) *
C IDZ : ] *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: NEXT3 *
C *
C*****************************************************************
C *
C Authors : Richard Reuter (1983), Hartmut Turowski *
C Date : 12.10.1989 *
C Source : FORTRAN 77 *
C *
C*****************************************************************
C..
C.. declarations
C..
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION X(NX),Y(NX),Z(NX)
DIMENSION A((M+1)*(M+2)*(M+3)/6*(2*NX
F +(M+1)*(M+2)*(M+3)/6+1)/2)
DIMENSION IDX(((M+1)*(M+2)*(M+3)/6))
DIMENSION IDY(((M+1)*(M+2)*(M+3)/6))
DIMENSION IDZ(((M+1)*(M+2)*(M+3)/6))
C..
C.. the first monomial is 1.0
C..
DO 10 I = 1, NX
A(I) = 1.0D0
10 CONTINUE
A(NX+1) = 0.0D0
IDX(1) = 0
IDY(1) = 0
IDZ(1) = 0
L = 1
DO 40 I = 1,M
DO 30 IX = I,0,-1
DO 20 IY = I-IX,0,-1
IZ = I - IY - IX
L = L+1
IDX(L) = IX
IDY(L) = IY
IDZ(L) = IZ
20 CONTINUE
30 CONTINUE
40 CONTINUE
DO 90 I = 2, L
C..
C.. determine the index of the monomial that needs
C.. to be multiplied by X,Y or Z
C..
CALL NEXT3(I,IDX,IDY,IDZ,ID,K)
KL = ID*(ID-1)/2 + NX*(ID-1)
KLI= I *(I -1)/2 + NX*(I -1)
IF (K .EQ. 1) THEN
DO 50 J = 1, NX
A(KLI+J) = A(KL+J)*X(J)
50 CONTINUE
ELSE IF (K .EQ. 2) THEN
DO 60 J = 1, NX
A(KLI+J) = A(KL+J)*Y(J)
60 CONTINUE
ELSE
DO 70 J = 1, NX
A(KLI+J) = A(KL+J)*Z(J)
70 CONTINUE
ENDIF
C..
C.. zero the rest of the system matrix
C..
DO 80 J = KLI+NX+1, KLI+NX+I
A(J) = 0.0D0
80 CONTINUE
90 CONTINUE
RETURN
END
C
C
SUBROUTINE NEXT3(I,IDX,IDY,IDZ,ID,K)
C
C*****************************************************************
C *
C SUBROUTINE that efficiently determines all three-dimensional *
C monomials up to degree M; refer to SUBROUTINE ALPHA3 *
C *
C INPUT PARAMETERS: *
C ================= *
C I : Index of the two-dimensional monomial that was last *
C computed *
C IDX : ] I-vectors ID..(1:I); the powers of X, Y or Z in the *
C IDY : ] monomials with index 1 to I *
C IDZ : ] *
C *
C OUTPUT PARAMETERS: *
C ================== *
C ID : Index of the monomial, that must be multiplied by X,Y *
C or Z in order to obtain the I-th monomial *
C K : Switch that toggles multiplication by X,Y or Z *
C K=1 : Monom(I) = Monom(ID)*X *
C K=2 : Monom(I) = Monom(ID)*Y *
C K=3 : Monom(I) = Monom(ID)*Z *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: none *
C *
C*****************************************************************
C *
C Authors : Richard Reuter (1983), Hartmut Turowski *
C Date : 12.10.1989 *
C Source : FORTRAN 77 *
C *
C*****************************************************************
C..
C.. declarations
C..
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IDX(I),IDY(I),IDZ(I)
C..
N = IDX(I) + IDY(I) + IDZ(I)
IF (IDX(I) .NE. 0) THEN
K = 1
ID = I -(N*(N+1))/2
ELSE IF (IDY(I) .NE. 0) THEN
K = 2
ID = I + 1 - ((N+1)*(N+2))/2
ELSE
K = 3
ID = I - ((N+1)*(N+2))/2
ENDIF
RETURN
END
C
C
C
SUBROUTINE GAMMA3(NX,X,Y,Z,M,A)
C
C*****************************************************************
C *
C Initialize the G part of the system matrix. *
C *
C INPUT PARAMETERS: *
C ================= *
C NX : number of nodes *
C X,Y,Z: NX-vectors ..(1:NX); the coordinates of the nodes *
C M : derivative order *
C *
C OUTPUT PARAMETERS: *
C ================== *
C A : vector A(1:(NX*(NX+1)/2)); the G part of the system *
C matrix in condensed form *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: E2 *
C *
C*****************************************************************
C *
C Authors : Richard Reuter (1983), Hartmut Turowski *
C Date : 12.10.1989 *
C Source : FORTRAN 77 *
C *
C*****************************************************************
C..
C.. declarations
C..
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION X(NX),Y(NX),Z(NX),A(NX*(NX+1)/2)
C..
C.. Calculate the G part
C..
L = 0
DO 20 I = 1, NX
DO 10 K = 1, I - 1
L = L + 1
C..
C.. for acceleration possibly use the inline-code of E3
C..
A(L) = E3(X(K)-X(I),Y(K)-Y(I),Z(K)-Z(I),M)
10 CONTINUE
L = L + 1
C..
C.. Set diagonal of G equal to zero
C..
A(L) = 0.0D0
20 CONTINUE
RETURN
END
C
C
DOUBLE PRECISION FUNCTION APPRX3(X0,Y0,Z0,NX,M,X,Y,Z,C)
C
C*****************************************************************
C *
C Evaluation FUNCTION for the interpolation *
C *
C INPUT PARAMETERS: *
C ================= *
C X0,Y0,Z0 : location where function is to be evaluated *
C NX : number of nodes *
C M : derivative order *
C X,Y,Z : NX-vectors ..(1:NX); the coordinates of the nodes *
C C : vector of coefficients C(1:(NX + M*(M+1)*(M+2)/6)) *
C *
C OUTPUT PARAMETER: *
C ================= *
C APPRX3 : Approximate value at (X0,Y0,Z0) *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: none *
C *
C*****************************************************************
C *
C Authors : Richard Reuter (1983), Hartmut Turowski *
C Date : 12.10.1989 *
C Source : FORTRAN 77 *
C *
C*****************************************************************
C..
C.. declarations
C..
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION X(NX),Y(NX),Z(NX),C(NX+(M*(M+1)*(M+2)/6))
C..
C.. for different M there are several cases:
C.. 1. M = 1, 2, 3 ; especially coded, fast
C.. 2. M > 3 ; each monomial is represented in the form
C.. (X**IX)*(Y**IY)*(Z**IZ), the evaluation is slow and
C.. rounding error prone.
C..
C.. the first polynomial is always 1
C..
AP = C(NX+1)
IF (M .EQ. 1) GOTO 40
IF (M .EQ. 2) THEN
C..
C.. remaining monomials of degree 1
C..
AP = AP + C(NX+2)*X0 + C(NX+3)*Y0 + C(NX+4)*Z0
ELSE IF (M .EQ. 3) THEN
C..
C.. remaining monomials of degree 2
C..
AP = AP + (C(NX+2) + C(NX+5)*X0 + C(NX+6)*Y0)*X0
F + (C(NX+3) + C(NX+8)*Y0 + C(NX+9)*Z0)*Y0
F + (C(NX+4) + C(NX+7)*X0 +C(NX+10)*Z0)*Z0
ELSE
C..
C.. remaining monomials of degree <= M-1
C..
L = 1
DO 30 I = 1,M-1
DO 20 IX = I,0,-1
DO 10 IY = I-IX,0,-1
IZ = I - IX -IY
L = L+1
IF (IX .NE. 0 .AND. IY .NE. 0 .AND. IZ .NE. 0) THEN
AP = AP + C(NX+L)*(X0**IX)*(Y0**IY)*(Z0**IZ)
ELSE IF (IX .NE. 0 .AND. IY .NE. 0) THEN
AP = AP + C(NX+L)*(X0**IX)*(Y0**IY)
ELSE IF (IX .NE. 0 .AND. IZ .NE. 0) THEN
AP = AP + C(NX+L)*(X0**IX)*(Z0**IZ)
ELSE IF (IY .NE. 0 .AND. IZ .NE. 0) THEN
AP = AP + C(NX+L)*(Y0**IY)*(Z0**IZ)
ELSE IF (IX .NE. 0) THEN
AP = AP + C(NX+L)*(X0**IX)
ELSE IF (IY .NE. 0) THEN
AP = AP + C(NX+L)*(Y0**IY)
ELSE
AP = AP + C(NX+L)*(Z0**IZ)
ENDIF
10 CONTINUE
20 CONTINUE
30 CONTINUE
ENDIF
40 CONTINUE
C..
C.. the G part of the system matrix
C..
C.. one might use the function E3(X,Y,Z) here, but this
C.. would slow down the evaluation.
C.. Hence this part is coded directly.
C..
DO 50 I = 1, NX
R = (X(I)-X0)**2 + (Y(I)-Y0)**2 + (Z(I)-Z0)**2
AP = AP + C(I)*(DSQRT(R)**(2*M-3))
50 CONTINUE
APPRX3 = AP
RETURN
END
C
C
DOUBLE PRECISION FUNCTION E3(X,Y,Z,M)
C
C*****************************************************************
C *
C We evaluate the function F at (X,Y,Z). *
C *
C REMARK: the normalizing factors mentioned by MEINGUET [MEING79]*
C are not used as they turn out to be insignificant in *
C the practical computations. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C X,Y,Z : location where the evaluation takes place *
C *
C M : derivative order *
C *
C OUTPUT PARAMETER: *
C ================= *
C E3 : Functional value *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: none *
C *
C*****************************************************************
C *
C Authors : Richard Reuter (1983), Hartmut Turowski *
C Date : 12.10.1989 *
C Source : FORTRAN 77 *
C *
C*****************************************************************
C..
C.. Compute the kernel function
C..
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
R = DSQRT(X*X + Y*Y + Z*Z)
E3 = R**(2*M - 3)
RETURN
END
Begin of file
Contents
Index