C      ALGORITHM 660, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 14, NO. 2, P.149.
C
C			   QS2TEST
C
C   THIS PROGRAM TESTS THE SCATTERED DATA INTERPOLATION
C PACKAGE QSHEP2D BY PRINTING THE MAXIMUM ERRORS ASSOCIATED
C WITH INTERPOLATED VALUES AND GRADIENTS ON A 10 BY 10
C UNIFORM GRID IN THE UNIT SQUARE.  THE DATA SET CONSISTS
C OF 36 NODES WITH DATA VALUES TAKEN FROM A QUADRATIC FUNC-
C TION FOR WHICH THE METHOD IS EXACT.  THE RATIO OF MAXIMUM
C INTERPOLATION ERROR RELATIVE TO THE MACHINE PRECISION IS
C ALSO PRINTED.  THIS SHOULD BE O(1).  THE INTERPOLATED
C VALUES FROM QS2VAL AND QS2GRD ARE COMPARED FOR AGREEMENT.
C
      INTEGER LCELL(3,3), LNEXT(36)
      REAL    X(36), Y(36), F(36), RSQ(36), A(5,36), P(10)
C
C QSHEP2 PARAMETERS AND LOGICAL UNIT FOR OUTPUT
C
      DATA N/36/,  NQ/13/,  NW/19/,  NR/3/,  LOUT/6/
C
C QUADRATIC TEST FUNCTION AND PARTIAL DERIVATIVES
C
      FQ(XX,YY) = ((XX + 2.*YY)/3.)**2
      FX(XX,YY) = 2.*(XX + 2.*YY)/9.
      FY(XX,YY) = 4.*(XX + 2.*YY)/9.
C
C GENERATE A 6 BY 6 GRID OF NODES IN THE UNIT SQUARE WITH
C   THE NATURAL ORDERING.
C
      K = 0
      DO 1 J = 1,6
	YK = FLOAT(6-J)/5.
	DO 1 I = 1,6
	  K = K + 1
	  X(K) = FLOAT(I-1)/5.
    1	  Y(K) = YK
C
C COMPUTE THE DATA VALUES.
C
      DO 2 K = 1,N
    2	F(K) = FQ(X(K),Y(K))
C
C COMPUTE PARAMETERS DEFINING THE INTERPOLANT Q.
C
      CALL QSHEP2 (N,X,Y,F,NQ,NW,NR, LCELL,LNEXT,XMIN,YMIN,
     .           DX,DY,RMAX,RSQ,A,IER)
      IF (IER .NE. 0) GO TO 6
C
C GENERATE A 10 BY 10 UNIFORM GRID OF INTERPOLATION POINTS
C   (P(I),P(J)) IN THE UNIT SQUARE.  THE FOUR CORNERS COIN-
C   CIDE WITH NODES.
C
      DO 3 I = 1,10
    3	P(I) = FLOAT(I-1)/9.
C
C COMPUTE THE MACHINE PRECISION EPS.
C
      EPS = 1.
    4 EPS = EPS/2.
      EP1 = EPS + 1.
      IF (STORE(EP1) .GT. 1.) GO TO 4
      EPS = EPS*2.
C
C COMPUTE INTERPOLATION ERRORS AND TEST FOR AGREEMENT IN THE
C   Q VALUES RETURNED BY QS2VAL AND QS2GRD.
C
      EQ = 0.
      EQX = 0.
      EQY = 0.
      DO 5 J = 1,10
	PY = P(J)
	DO 5 I = 1,10
	  PX = P(I)
	  Q1 = QS2VAL (PX,PY,N,X,Y,F,NR,LCELL,LNEXT,XMIN,
     .               YMIN,DX,DY,RMAX,RSQ,A)
	  CALL QS2GRD (PX,PY,N,X,Y,F,NR,LCELL,LNEXT,XMIN,
     .               YMIN,DX,DY,RMAX,RSQ,A, Q,QX,QY,IER)
	  IF (IER .NE. 0) GO TO 7
	  IF (ABS(Q1-Q) .GT. 3.*ABS(Q)*EPS) GO TO 8
	  EQ = AMAX1(EQ,ABS(FQ(PX,PY)-Q))
	  EQX = AMAX1(EQX,ABS(FX(PX,PY)-QX))
    5	  EQY = AMAX1(EQY,ABS(FY(PX,PY)-QY))
C
C PRINT ERRORS AND THE RATIO EQ/EPS.
C
      RQ = EQ/EPS
      WRITE (LOUT,100)
      WRITE (LOUT,110) EQ, RQ
      WRITE (LOUT,120) EQX
      WRITE (LOUT,130) EQY
      STOP
  100 FORMAT (///1H ,31HMAXIMUM ABSOLUTE ERRORS IN THE ,
     .          25HINTERPOLANT Q AND PARTIAL/
     .          1H ,31HDERIVATIVES QX AND QY RELATIVE ,
     .          24HTO MACHINE PRECISION EPS//
     .          1H ,10X,8HFUNCTION,3X,9HMAX ERROR,3X,
     .          13HMAX ERROR/EPS/)
  110 FORMAT (1H ,13X,1HQ,7X,E9.3,7X,F4.2)
  120 FORMAT (1H ,13X,2HQX,6X,E9.3)
  130 FORMAT (1H ,13X,2HQY,6X,E9.3)
C
C ERROR IN QSHEP2
C
    6 WRITE (LOUT,200) IER
      STOP
  200 FORMAT (///1H ,28H*** ERROR IN QSHEP2 -- IER =,I2,
     .          4H ***)
C
C ERROR IN QS2GRD
C
    7 WRITE (LOUT,210) IER
      STOP
  210 FORMAT (///1H ,28H*** ERROR IN QS2GRD -- IER =,I2,
     .          4H ***)
C
C VALUES RETURNED BY QS2VAL AND QS2GRD DIFFER BY A RELATIVE
C   AMOUNT GREATER THAN 3*EPS.
C
    8 WRITE (LOUT,220) Q1, Q
      STOP
  220 FORMAT (///1H ,33H*** ERROR -- INTERPOLATED VALUES ,
     .          37HQ1 (QS2VAL) AND Q2 (QS2GRD) DIFFER --//
     .          1H ,5X,5HQ1 = ,E21.14,5X,5HQ2 = ,E21.14)
      END
      FUNCTION STORE (X)
      REAL X
C
C***********************************************************
C
C						ROBERT RENKA
C				     NORTH TEXAS STATE UNIV.
C					      (817) 565-2767
C
C   THIS FUNCTION FORCES ITS ARGMENT X TO BE STORED IN MAIN
C MEMORY.  THIS IS USEFUL FOR COMPUTING MACHINE DEPENDENT
C PARAMETERS (SUCH AS THE MACHINE PRECISION) WHERE IT IS
C NECESSARY TO AVOID COMPUTATION IN HIGH PRECISION REG-
C ISTERS.
C
C INPUT PARAMETER -
C
C	X - VALUE TO BE STORED.
C
C X IS NOT ALTERED BY THIS FUNCTION.
C
C OUTPUT PARAMETER -
C
C	STORE - VALUE OF X AFTER IT HAS BEEN STORED AND
C		(POSSIBLY) TRUNCATED OR ROUNDED TO THE
C		MACHINE WORD LENGTH.
C
C MODULES REQUIRED BY STORE - NONE
C
C***********************************************************
C
      COMMON/STCOM/Y
      Y = X
      STORE = Y
      RETURN
      END
      SUBROUTINE QSHEP2 (N,X,Y,F,NQ,NW,NR, LCELL,LNEXT,XMIN,
     .             YMIN,DX,DY,RMAX,RSQ,A,IER)
      INTEGER N, NQ, NW, NR, LCELL(NR,NR), LNEXT(N), IER
      REAL    X(N), Y(N), F(N), XMIN, YMIN, DX, DY, RMAX,
     .          RSQ(N), A(5,N)
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C						    01/08/90
C
C   THIS SUBROUTINE COMPUTES A SET OF PARAMETERS A AND RSQ
C DEFINING A SMOOTH (ONCE CONTINUOUSLY DIFFERENTIABLE) BI-
C VARIATE FUNCTION Q(X,Y) WHICH INTERPOLATES DATA VALUES F
C AT SCATTERED NODES (X,Y).  THE INTERPOLANT Q MAY BE EVAL-
C UATED AT AN ARBITRARY POINT BY FUNCTION QS2VAL, AND ITS
C FIRST DERIVATIVES ARE COMPUTED BY SUBROUTINE QS2GRD.
C   THE INTERPOLATION SCHEME IS A MODIFIED QUADRATIC SHEPARD
C METHOD --
C
C Q = (W(1)*Q(1)+W(2)*Q(2)+..+W(N)*Q(N))/(W(1)+W(2)+..+W(N))
C
C FOR BIVARIATE FUNCTIONS W(K) AND Q(K).  THE NODAL FUNC-
C TIONS ARE GIVEN BY
C
C Q(K)(X,Y) = A(1,K)*(X-X(K))**2 + A(2,K)*(X-X(K))*(Y-Y(K))
C	    + A(3,K)*(Y-Y(K))**2 + A(4,K)*(X-X(K))
C	    + A(5,K)*(Y-Y(K))	 + F(K) .
C
C THUS, Q(K) IS A QUADRATIC FUNCTION WHICH INTERPOLATES THE
C DATA VALUE AT NODE K.  ITS COEFFICIENTS A(,K) ARE OBTAINED
C BY A WEIGHTED LEAST SQUARES FIT TO THE CLOSEST NQ DATA
C POINTS WITH WEIGHTS SIMILAR TO W(K).    NOTE THAT THE RADIUS
C OF INFLUENCE FOR THE LEAST SQUARES FIT IS FIXED FOR EACH
C K, BUT VARIES WITH K.
C   THE WEIGHTS ARE TAKEN TO BE
C
C W(K)(X,Y) = ( (R(K)-D(K))+ / R(K)*D(K) )**2
C
C WHERE (R(K)-D(K))+ = 0 IF R(K) .LE. D(K) AND D(K)(X,Y) IS
C THE EUCLIDEAN DISTANCE BETWEEN (X,Y) AND (X(K),Y(K)).  THE
C RADIUS OF INFLUENCE R(K) VARIES WITH K AND IS CHOSEN SO
C THAT NW NODES ARE WITHIN THE RADIUS.    NOTE THAT W(K) IS
C NOT DEFINED AT NODE (X(K),Y(K)), BUT Q(X,Y) HAS LIMIT F(K)
C AS (X,Y) APPROACHES (X(K),Y(K)).
C
C ON INPUT --
C
C	N = NUMBER OF NODES AND ASSOCIATED DATA VALUES.
C	    N .GE. 6.
C
C	X,Y = ARRAYS OF LENGTH N CONTAINING THE CARTESIAN
C	      COORDINATES OF THE NODES.
C
C	F = ARRAY OF LENGTH N CONTAINING THE DATA VALUES
C	    IN ONE-TO-ONE CORRESPONDENCE WITH THE NODES.
C
C	NQ = NUMBER OF DATA POINTS TO BE USED IN THE LEAST
C	     SQUARES FIT FOR COEFFICIENTS DEFINING THE NODAL
C	     FUNCTIONS Q(K).  A HIGHLY RECOMMENDED VALUE IS
C	     NQ = 13.  5 .LE. NQ .LE. MIN(40,N-1).
C
C	NW = NUMBER OF NODES WITHIN (AND DEFINING) THE RADII
C	     OF INFLUENCE R(K) WHICH ENTER INTO THE WEIGHTS
C	     W(K).  FOR N SUFFICIENTLY LARGE, A RECOMMENDED
C	     VALUE IS NW = 19.    1 .LE. NW .LE. MIN(40,N-1).
C
C	NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID DE-
C	     FINED IN SUBROUTINE STORE2.  A RECTANGLE CON-
C	     TAINING THE NODES IS PARTITIONED INTO CELLS IN
C	     ORDER TO INCREASE SEARCH EFFICIENCY.  NR =
C	     SQRT(N/3) IS RECOMMENDED.    NR .GE. 1.
C
C THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C	LCELL = ARRAY OF LENGTH .GE. NR**2.
C
C	LNEXT = ARRAY OF LENGTH .GE. N.
C
C	RSQ = ARRAY OF LENGTH .GE. N.
C
C	A = ARRAY OF LENGTH .GE. 5N.
C
C ON OUTPUT --
C
C	LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED
C		WITH CELLS.  REFER TO STORE2.
C
C	LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDI-
C		CES.  REFER TO STORE2.
C
C	XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL
C			  DIMENSIONS.  REFER TO STORE2.
C
C	RMAX = SQUARE ROOT OF THE LARGEST ELEMENT IN RSQ --
C	       MAXIMUM RADIUS R(K).
C
C	RSQ = ARRAY CONTAINING THE SQUARES OF THE RADII R(K)
C	      WHICH ENTER INTO THE WEIGHTS W(K).
C
C	A = 5 BY N ARRAY CONTAINING THE COEFFICIENTS FOR
C	    QUADRATIC NODAL FUNCTION Q(K) IN COLUMN K.
C
C   NOTE THAT THE ABOVE OUTPUT PARAMETERS ARE NOT DEFINED
C UNLESS IER = 0.
C
C	IER = ERROR INDICATOR --
C	      IER = 0 IF NO ERRORS WERE ENCOUNTERED.
C	      IER = 1 IF N, NQ, NW, OR NR IS OUT OF RANGE.
C	      IER = 2 IF DUPLICATE NODES WERE ENCOUNTERED.
C	      IER = 3 IF ALL NODES ARE COLLINEAR.
C
C MODULES REQUIRED BY QSHEP2 -- GETNP2, GIVENS, ROTATE,
C				  SETUP2, STORE2
C
C INTRINSIC FUNCTIONS CALLED BY QSHEP2 -- ABS, AMIN1, FLOAT,
C					    MAX0, MIN0, SQRT
C
C***********************************************************
C
      INTEGER I, IB, IERR, IP1, IRM1, IROW, J, JP1, K, LMAX,
     .          LNP, NEQ, NN, NNQ, NNR, NNW, NP, NPTS(40),
     .          NQWMAX
      REAL    AV, AVSQ, B(6,6), C, DDX, DDY, DMIN, DTOL, FK,
     .          RQ, RS, RSMX, RSOLD, RTOL, RWS, S, SF, SUM, T,
     .          XK, XMN, YK, YMN
C
      DATA    RTOL/1.E-5/, DTOL/.01/, SF/1./
C
C LOCAL PARAMETERS --
C
C AV =	       ROOT-MEAN-SQUARE DISTANCE BETWEEN K AND THE
C		 NODES IN THE LEAST SQUARES SYSTEM (UNLESS
C		 ADDITIONAL NODES ARE INTRODUCED FOR STABIL-
C		 ITY).    THE FIRST 3 COLUMNS OF THE MATRIX
C		 ARE SCALED BY 1/AVSQ, THE LAST 2 BY 1/AV
C AVSQ =       AV*AV
C B =	       TRANSPOSE OF THE AUGMENTED REGRESSION MATRIX
C C =	       FIRST COMPONENT OF THE PLANE ROTATION USED TO
C		 ZERO THE LOWER TRIANGLE OF B**T -- COMPUTED
C		 BY SUBROUTINE GIVENS
C DDX,DDY =    LOCAL VARIABLES FOR DX AND DY
C DMIN =       MINIMUM OF THE MAGNITUDES OF THE DIAGONAL
C		 ELEMENTS OF THE REGRESSION MATRIX AFTER
C		 ZEROS ARE INTRODUCED BELOW THE DIAGONAL
C DTOL =       TOLERANCE FOR DETECTING AN ILL-CONDITIONED
C		 SYSTEM.  THE SYSTEM IS ACCEPTED WHEN DMIN
C		 .GE. DTOL
C FK =	       DATA VALUE AT NODE K -- F(K)
C I =	       INDEX FOR A, B, AND NPTS
C IB =	       DO-LOOP INDEX FOR BACK SOLVE
C IERR =       ERROR FLAG FOR THE CALL TO STORE2
C IP1 =        I+1
C IRM1 =       IROW-1
C IROW =       ROW INDEX FOR B
C J =	       INDEX FOR A AND B
C JP1 =        J+1
C K =	       NODAL FUNCTION INDEX AND COLUMN INDEX FOR A
C LMAX =       MAXIMUM NUMBER OF NPTS ELEMENTS (MUST BE CON-
C		 SISTENT WITH THE DIMENSION STATEMENT ABOVE)
C LNP =        CURRENT LENGTH OF NPTS
C NEQ =        NUMBER OF EQUATIONS IN THE LEAST SQUARES FIT
C NN,NNQ,NNR = LOCAL COPIES OF N, NQ, AND NR
C NNW =        LOCAL COPY OF NW
C NP =	       NPTS ELEMENT
C NPTS =       ARRAY CONTAINING THE INDICES OF A SEQUENCE OF
C		 NODES TO BE USED IN THE LEAST SQUARES FIT
C		 OR TO COMPUTE RSQ.  THE NODES ARE ORDERED
C		 BY DISTANCE FROM K AND THE LAST ELEMENT
C		 (USUALLY INDEXED BY LNP) IS USED ONLY TO
C		 DETERMINE RQ, OR RSQ(K) IF NW .GT. NQ
C NQWMAX =     MAX(NQ,NW)
C RQ =	       RADIUS OF INFLUENCE WHICH ENTERS INTO THE
C		 WEIGHTS FOR Q(K) (SEE SUBROUTINE SETUP2)
C RS =	       SQUARED DISTANCE BETWEEN K AND NPTS(LNP) --
C		 USED TO COMPUTE RQ AND RSQ(K)
C RSMX =       MAXIMUM RSQ ELEMENT ENCOUNTERED
C RSOLD =      SQUARED DISTANCE BETWEEN K AND NPTS(LNP-1) --
C		 USED TO COMPUTE A RELATIVE CHANGE IN RS
C		 BETWEEN SUCCEEDING NPTS ELEMENTS
C RTOL =       TOLERANCE FOR DETECTING A SUFFICIENTLY LARGE
C		 RELATIVE CHANGE IN RS.  IF THE CHANGE IS
C		 NOT GREATER THAN RTOL, THE NODES ARE
C		 TREATED AS BEING THE SAME DISTANCE FROM K
C RWS =        CURRENT VALUE OF RSQ(K)
C S =	       SECOND COMPONENT OF THE PLANE GIVENS ROTATION
C SF =	       MARQUARDT STABILIZATION FACTOR USED TO DAMP
C		 OUT THE FIRST 3 SOLUTION COMPONENTS (SECOND
C		 PARTIALS OF THE QUADRATIC) WHEN THE SYSTEM
C		 IS ILL-CONDITIONED.  AS SF INCREASES, THE
C		 FITTING FUNCTION APPROACHES A LINEAR
C SUM =        SUM OF SQUARED EUCLIDEAN DISTANCES BETWEEN
C		 NODE K AND THE NODES USED IN THE LEAST
C		 SQUARES FIT (UNLESS ADDITIONAL NODES ARE
C		 ADDED FOR STABILITY)
C T =	       TEMPORARY VARIABLE FOR ACCUMULATING A SCALAR
C		 PRODUCT IN THE BACK SOLVE
C XK,YK =      COORDINATES OF NODE K -- X(K), Y(K)
C XMN,YMN =    LOCAL VARIABLES FOR XMIN AND YMIN
C
      NN = N
      NNQ = NQ
      NNW = NW
      NNR = NR
      NQWMAX = MAX0(NNQ,NNW)
      LMAX = MIN0(40,NN-1)
      IF (5 .GT. NNQ  .OR.  1 .GT. NNW    .OR.  NQWMAX .GT.
     .      LMAX    .OR.  NNR .LT. 1) GO TO 20
C
C CREATE THE CELL DATA STRUCTURE, AND INITIALIZE RSMX.
C
      CALL STORE2 (NN,X,Y,NNR, LCELL,LNEXT,XMN,YMN,DDX,DDY,
     .           IERR)
      IF (IERR .NE. 0) GO TO 22
      RSMX = 0.
C
C OUTER LOOP ON NODE K
C
      DO 18 K = 1,NN
	XK = X(K)
	YK = Y(K)
	FK = F(K)
C
C MARK NODE K TO EXCLUDE IT FROM THE SEARCH FOR NEAREST
C   NEIGHBORS.
C
	LNEXT(K) = -LNEXT(K)
C
C INITIALIZE FOR LOOP ON NPTS.
C
	RS = 0.
	SUM = 0.
	RWS = 0.
	RQ = 0.
	LNP = 0
C
C COMPUTE NPTS, LNP, RWS, NEQ, RQ, AND AVSQ.
C
    1	SUM = SUM + RS
	  IF (LNP .EQ. LMAX) GO TO 3
	  LNP = LNP + 1
	  RSOLD = RS
	  CALL GETNP2 (XK,YK,X,Y,NNR,LCELL,LNEXT,XMN,YMN,
     .               DDX,DDY, NP,RS)
	  IF (RS .EQ. 0.) GO TO 21
	  NPTS(LNP) = NP
	  IF ( (RS-RSOLD)/RS .LT. RTOL ) GO TO 1
	  IF (RWS .EQ. 0.  .AND.  LNP .GT. NNW) RWS = RS
	  IF (RQ .NE. 0.  .OR.    LNP .LE. NNQ) GO TO 2
C
C   RQ = 0 (NOT YET COMPUTED) AND LNP .GT. NQ.    RQ =
C     SQRT(RS) IS SUFFICIENTLY LARGE TO (STRICTLY) INCLUDE
C     NQ NODES.  THE LEAST SQUARES FIT WILL INCLUDE NEQ =
C     LNP - 1 EQUATIONS FOR 5 .LE. NQ .LE. NEQ .LT. LMAX
C     .LE. N-1.
C
	  NEQ = LNP - 1
	  RQ = SQRT(RS)
	  AVSQ = SUM/FLOAT(NEQ)
C
C   BOTTOM OF LOOP -- TEST FOR TERMINATION.
C
    2	  IF (LNP .GT. NQWMAX) GO TO 4
	  GO TO 1
C
C ALL LMAX NODES ARE INCLUDED IN NPTS.    RWS AND/OR RQ**2 IS
C   (ARBITRARILY) TAKEN TO BE 10 PERCENT LARGER THAN THE
C   DISTANCE RS TO THE LAST NODE INCLUDED.
C
    3	IF (RWS .EQ. 0.) RWS = 1.1*RS
	IF (RQ .NE. 0.) GO TO 4
	  NEQ = LMAX
	  RQ = SQRT(1.1*RS)
	  AVSQ = SUM/FLOAT(NEQ)
C
C STORE RSQ(K), UPDATE RSMX IF NECESSARY, AND COMPUTE AV.
C
    4	RSQ(K) = RWS
	IF (RWS .GT. RSMX) RSMX = RWS
	AV = SQRT(AVSQ)
C
C SET UP THE AUGMENTED REGRESSION MATRIX (TRANSPOSED) AS THE
C   COLUMNS OF B, AND ZERO OUT THE LOWER TRIANGLE (UPPER
C   TRIANGLE OF B) WITH GIVENS ROTATIONS -- QR DECOMPOSITION
C   WITH ORTHOGONAL MATRIX Q NOT STORED.
C
	I = 0
    5	  I = I + 1
	  NP = NPTS(I)
	  IROW = MIN0(I,6)
	  CALL SETUP2 (XK,YK,FK,X(NP),Y(NP),F(NP),AV,AVSQ,
     .               RQ, B(1,IROW))
	  IF (I .EQ. 1) GO TO 5
	  IRM1 = IROW-1
	  DO 6 J = 1,IRM1
	    JP1 = J + 1
	    CALL GIVENS (B(J,J),B(J,IROW),C,S)
    6	    CALL ROTATE (6-J,C,S,B(JP1,J),B(JP1,IROW))
	  IF (I .LT. NEQ) GO TO 5
C
C TEST THE SYSTEM FOR ILL-CONDITIONING.
C
	DMIN = AMIN1( ABS(B(1,1)),ABS(B(2,2)),ABS(B(3,3)),
     .              ABS(B(4,4)),ABS(B(5,5)) )
	IF (DMIN*RQ .GE. DTOL) GO TO 13
	IF (NEQ .EQ. LMAX) GO TO 10
C
C INCREASE RQ AND ADD ANOTHER EQUATION TO THE SYSTEM TO
C   IMPROVE THE CONDITIONING.  THE NUMBER OF NPTS ELEMENTS
C   IS ALSO INCREASED IF NECESSARY.
C
    7	RSOLD = RS
	NEQ = NEQ + 1
	IF (NEQ .EQ. LMAX) GO TO 9
	IF (NEQ .EQ. LNP) GO TO 8
C
C   NEQ .LT. LNP
C
	NP = NPTS(NEQ+1)
	RS = (X(NP)-XK)**2 + (Y(NP)-YK)**2
	IF ( (RS-RSOLD)/RS .LT. RTOL ) GO TO 7
	RQ = SQRT(RS)
	GO TO 5
C
C   ADD AN ELEMENT TO NPTS.
C
    8	LNP = LNP + 1
	CALL GETNP2 (XK,YK,X,Y,NNR,LCELL,LNEXT,XMN,YMN,
     .             DDX,DDY, NP,RS)
	IF (NP .EQ. 0) GO TO 21
	NPTS(LNP) = NP
	IF ( (RS-RSOLD)/RS .LT. RTOL ) GO TO 7
	RQ = SQRT(RS)
	GO TO 5
C
    9	RQ = SQRT(1.1*RS)
	GO TO 5
C
C STABILIZE THE SYSTEM BY DAMPING SECOND PARTIALS -- ADD
C   MULTIPLES OF THE FIRST THREE UNIT VECTORS TO THE FIRST
C   THREE EQUATIONS.
C
   10	DO 12 I = 1,3
	  B(I,6) = SF
	  IP1 = I + 1
	  DO 11 J = IP1,6
   11	    B(J,6) = 0.
	  DO 12 J = I,5
	    JP1 = J + 1
	    CALL GIVENS (B(J,J),B(J,6),C,S)
   12	    CALL ROTATE (6-J,C,S,B(JP1,J),B(JP1,6))
C
C TEST THE STABILIZED SYSTEM FOR ILL-CONDITIONING.
C
	DMIN = AMIN1( ABS(B(1,1)),ABS(B(2,2)),ABS(B(3,3)),
     .              ABS(B(4,4)),ABS(B(5,5)) )
	IF (DMIN*RQ .LT. DTOL) GO TO 22
C
C SOLVE THE 5 BY 5 TRIANGULAR SYSTEM FOR THE COEFFICIENTS
C
   13	DO 15 IB = 1,5
	  I = 6-IB
	  T = 0.
	  IF (I .EQ. 5) GO TO 15
	  IP1 = I + 1
	  DO 14 J = IP1,5
   14	    T = T + B(J,I)*A(J,K)
   15	  A(I,K) = (B(6,I)-T)/B(I,I)
C
C SCALE THE COEFFICIENTS TO ADJUST FOR THE COLUMN SCALING.
C
	DO 16 I = 1,3
   16	  A(I,K) = A(I,K)/AVSQ
	A(4,K) = A(4,K)/AV
	A(5,K) = A(5,K)/AV
C
C UNMARK K AND THE ELEMENTS OF NPTS.
C
	LNEXT(K) = -LNEXT(K)
	DO 17 I = 1,LNP
	  NP = NPTS(I)
   17	  LNEXT(NP) = -LNEXT(NP)
   18	CONTINUE
C
C NO ERRORS ENCOUNTERED.
C
      XMIN = XMN
      YMIN = YMN
      DX = DDX
      DY = DDY
      RMAX = SQRT(RSMX)
      IER = 0
      RETURN
C
C N, NQ, NW, OR NR IS OUT OF RANGE.
C
   20 IER = 1
      RETURN
C
C DUPLICATE NODES WERE ENCOUNTERED BY GETNP2.
C
   21 IER = 2
      RETURN
C
C NO UNIQUE SOLUTION DUE TO COLLINEAR NODES.
C
   22 XMIN = XMN
      YMIN = YMN
      DX = DDX
      DY = DDY
      IER = 3
      RETURN
      END
      FUNCTION QS2VAL (PX,PY,N,X,Y,F,NR,LCELL,LNEXT,XMIN,
     .               YMIN,DX,DY,RMAX,RSQ,A)
      INTEGER N, NR, LCELL(NR,NR), LNEXT(N)
      REAL    PX, PY, X(N), Y(N), F(N), XMIN, YMIN, DX, DY,
     .          RMAX, RSQ(N), A(5,N)
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C						    10/28/87
C
C   THIS FUNCTION RETURNS THE VALUE Q(PX,PY) WHERE Q IS THE
C WEIGHTED SUM OF QUADRATIC NODAL FUNCTIONS DEFINED IN SUB-
C ROUTINE QSHEP2.  QS2GRD MAY BE CALLED TO COMPUTE A GRADI-
C ENT OF Q ALONG WITH THE VALUE, AND/OR TO TEST FOR ERRORS.
C
C ON INPUT --
C
C	PX,PY = CARTESIAN COORDINATES OF THE POINT P AT
C		WHICH Q IS TO BE EVALUATED.
C
C	N = NUMBER OF NODES AND DATA VALUES DEFINING Q.
C	    N .GE. 6.
C
C	X,Y,F = ARRAYS OF LENGTH N CONTAINING THE NODES AND
C		DATA VALUES INTERPOLATED BY Q.
C
C	NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID.
C	     REFER TO STORE2.  NR .GE. 1.
C
C	LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED
C		WITH CELLS.  REFER TO STORE2.
C
C	LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDI-
C		CES.  REFER TO STORE2.
C
C	XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL
C			  DIMENSIONS.  DX AND DY MUST BE
C			  POSITIVE.  REFER TO STORE2.
C
C	RMAX = SQUARE ROOT OF THE LARGEST ELEMENT IN RSQ --
C	       MAXIMUM RADIUS.
C
C	RSQ = ARRAY OF LENGTH N CONTAINING THE SQUARED RADII
C	      WHICH ENTER INTO THE WEIGHTS DEFINING Q.
C
C	A = 5 BY N ARRAY CONTAINING THE COEFFICIENTS FOR THE
C	    NODAL FUNCTIONS DEFINING Q.
C
C   INPUT PARAMETERS ARE NOT ALTERED BY THIS FUNCTION.    THE
C PARAMETERS OTHER THAN PX AND PY SHOULD BE INPUT UNALTERED
C FROM THEIR VALUES ON OUTPUT FROM QSHEP2.  THIS FUNCTION
C SHOULD NOT BE CALLED IF A NONZERO ERROR FLAG WAS RETURNED
C BY QSHEP2.
C
C ON OUTPUT --
C
C	QS2VAL = FUNCTION VALUE Q(PX,PY) UNLESS N, NR, DX,
C		 DY, OR RMAX IS INVALID, IN WHICH CASE NO
C		 VALUE IS RETURNED.
C
C MODULES REQUIRED BY QS2VAL -- NONE
C
C INTRINSIC FUNCTIONS CALLED BY QS2VAL -- IFIX, SQRT
C
C***********************************************************
C
      XP = PX
      YP = PY
      QS2VAL = -9999.99
      IF (N .LT. 6  .OR.  NR .LT. 1  .OR.  DX .LE. 0.  .OR.
     .      DY .LE. 0.  .OR.  RMAX .LT. 0.) RETURN
C
C SET IMIN, IMAX, JMIN, AND JMAX TO CELL INDICES DEFINING
C   THE RANGE OF THE SEARCH FOR NODES WHOSE RADII INCLUDE
C   P.    THE CELLS WHICH MUST BE SEARCHED ARE THOSE INTER-
C   SECTED BY (OR CONTAINED IN) A CIRCLE OF RADIUS RMAX
C   CENTERED AT P.
C
      IMIN = IFIX((XP-XMIN-RMAX)/DX) + 1
      IMAX = IFIX((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN .LT. 1) IMIN = 1
      IF (IMAX .GT. NR) IMAX = NR
      JMIN = IFIX((YP-YMIN-RMAX)/DY) + 1
      JMAX = IFIX((YP-YMIN+RMAX)/DY) + 1
      IF (JMIN .LT. 1) JMIN = 1
      IF (JMAX .GT. NR) JMAX = NR
C
C THE FOLLOWING IS A TEST FOR NO CELLS WITHIN THE CIRCLE
C   OF RADIUS RMAX.
C
      IF (IMIN .GT. IMAX  .OR.    JMIN .GT. JMAX) GO TO 5
C
C ACCUMULATE WEIGHT VALUES IN SW AND WEIGHTED NODAL FUNCTION
C   VALUES IN SWQ.  THE WEIGHTS ARE W(K) = ((R-D)+/(R*D))**2
C   FOR R**2 = RSQ(K) AND D = DISTANCE BETWEEN P AND NODE K.
C
      SW = 0.
      SWQ = 0.
C
C OUTER LOOP ON CELLS (I,J).
C
      DO 3 J = JMIN,JMAX
	DO 3 I = IMIN,IMAX
	  K = LCELL(I,J)
	  IF (K .EQ. 0) GO TO 3
C
C INNER LOOP ON NODES K.
C
    1	  DELX = XP - X(K)
	  DELY = YP - Y(K)
	  DXSQ = DELX*DELX
	  DYSQ = DELY*DELY
	  DS = DXSQ + DYSQ
	  RS = RSQ(K)
	  IF (DS .GE. RS) GO TO 2
	  IF (DS .EQ. 0.) GO TO 4
	  RDS = RS*DS
	  RD = SQRT(RDS)
	  W = (RS+DS-RD-RD)/RDS
	  SW = SW + W
	  SWQ = SWQ + W*(A(1,K)*DXSQ + A(2,K)*DELX*DELY +
     .             A(3,K)*DYSQ + A(4,K)*DELX +
     .             A(5,K)*DELY + F(K))
C
C BOTTOM OF LOOP ON NODES IN CELL (I,J).
C
    2	  KP = K
	  K = LNEXT(KP)
	  IF (K .NE. KP) GO TO 1
    3	  CONTINUE
C
C SW = 0 IFF P IS NOT WITHIN THE RADIUS R(K) FOR ANY NODE K.
C
      IF (SW .EQ. 0.) GO TO 5
      QS2VAL = SWQ/SW
      RETURN
C
C (PX,PY) = (X(K),Y(K))
C
    4 QS2VAL = F(K)
      RETURN
C
C ALL WEIGHTS ARE 0 AT P.
C
    5 QS2VAL = 0.
      RETURN
      END
      SUBROUTINE QS2GRD (PX,PY,N,X,Y,F,NR,LCELL,LNEXT,XMIN,
     .             YMIN,DX,DY,RMAX,RSQ,A, Q,QX,QY,IER)
      INTEGER N, NR, LCELL(NR,NR), LNEXT(N), IER
      REAL    PX, PY, X(N), Y(N), F(N), XMIN, YMIN, DX, DY,
     .          RMAX, RSQ(N), A(5,N), Q, QX, QY
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C						    10/28/87
C
C   THIS SUBROUTINE COMPUTES THE VALUE AND GRADIENT AT
C (PX,PY) OF THE INTERPOLATORY FUNCTION Q DEFINED IN SUB-
C ROUTINE QSHEP2.  Q(X,Y) IS A WEIGHTED SUM OF QUADRATIC
C NODAL FUNCTIONS.
C
C ON INPUT --
C
C	PX,PY = CARTESIAN COORDINATES OF THE POINT AT WHICH
C		Q AND ITS PARTIALS ARE TO BE EVALUATED.
C
C	N = NUMBER OF NODES AND DATA VALUES DEFINING Q.
C	    N .GE. 6.
C
C	X,Y,F = ARRAYS OF LENGTH N CONTAINING THE NODES AND
C		DATA VALUES INTERPOLATED BY Q.
C
C	NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID.
C	     REFER TO STORE2.  NR .GE. 1.
C
C	LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED
C		WITH CELLS.  REFER TO STORE2.
C
C	LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDI-
C		CES.  REFER TO STORE2.
C
C	XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL
C			  DIMENSIONS.  DX AND DY MUST BE
C			  POSITIVE.  REFER TO STORE2.
C
C	RMAX = SQUARE ROOT OF THE LARGEST ELEMENT IN RSQ --
C	       MAXIMUM RADIUS.
C
C	RSQ = ARRAY OF LENGTH N CONTAINING THE SQUARED RADII
C	      WHICH ENTER INTO THE WEIGHTS DEFINING Q.
C
C	A = 5 BY N ARRAY CONTAINING THE COEFFICIENTS FOR THE
C	    NODAL FUNCTIONS DEFINING Q.
C
C   INPUT PARAMETERS ARE NOT ALTERED BY THIS SUBROUTINE.
C THE PARAMETERS OTHER THAN PX AND PY SHOULD BE INPUT UNAL-
C TERED FROM THEIR VALUES ON OUTPUT FROM QSHEP2.  THIS SUB-
C ROUTINE SHOULD NOT BE CALLED IF A NONZERO ERROR FLAG WAS
C RETURNED BY QSHEP2.
C
C ON OUTPUT --
C
C	Q = VALUE OF Q AT (PX,PY) UNLESS IER .EQ. 1, IN
C	    WHICH CASE NO VALUES ARE RETURNED.
C
C	QX,QY = FIRST PARTIAL DERIVATIVES OF Q AT (PX,PY)
C		UNLESS IER .EQ. 1.
C
C	IER = ERROR INDICATOR
C	      IER = 0 IF NO ERRORS WERE ENCOUNTERED.
C	      IER = 1 IF N, NR, DX, DY OR RMAX IS INVALID.
C	      IER = 2 IF NO ERRORS WERE ENCOUNTERED BUT
C		      (PX,PY) IS NOT WITHIN THE RADIUS R(K)
C		      FOR ANY NODE K (AND THUS Q=QX=QY=0).
C
C MODULES REQUIRED BY QS2GRD -- NONE
C
C INTRINSIC FUNCTIONS CALLED BY QS2GRD -- IFIX, SQRT
C
C***********************************************************
C
      XP = PX
      YP = PY
      IF (N .LT. 6  .OR.  NR .LT. 1  .OR.  DX .LE. 0.  .OR.
     .      DY .LE. 0.  .OR.  RMAX .LT. 0.) GO TO 5
C
C SET IMIN, IMAX, JMIN, AND JMAX TO CELL INDICES DEFINING
C   THE RANGE OF THE SEARCH FOR NODES WHOSE RADII INCLUDE
C   P.    THE CELLS WHICH MUST BE SEARCHED ARE THOSE INTER-
C   SECTED BY (OR CONTAINED IN) A CIRCLE OF RADIUS RMAX
C   CENTERED AT P.
C
      IMIN = IFIX((XP-XMIN-RMAX)/DX) + 1
      IMAX = IFIX((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN .LT. 1) IMIN = 1
      IF (IMAX .GT. NR) IMAX = NR
      JMIN = IFIX((YP-YMIN-RMAX)/DY) + 1
      JMAX = IFIX((YP-YMIN+RMAX)/DY) + 1
      IF (JMIN .LT. 1) JMIN = 1
      IF (JMAX .GT. NR) JMAX = NR
C
C THE FOLLOWING IS A TEST FOR NO CELLS WITHIN THE CIRCLE
C   OF RADIUS RMAX.
C
      IF (IMIN .GT. IMAX  .OR.    JMIN .GT. JMAX) GO TO 6
C
C Q = SWQ/SW = SUM(W(K)*Q(K))/SUM(W(K)) WHERE THE SUM IS
C   FROM K = 1 TO N, Q(K) IS THE QUADRATIC NODAL FUNCTION,
C   AND W(K) = ((R-D)+/(R*D))**2 FOR RADIUS R(K) AND DIST-
C   ANCE D(K).    THUS
C
C	 QX = (SWQX*SW - SWQ*SWX)/SW**2  AND
C	 QY = (SWQY*SW - SWQ*SWY)/SW**2
C
C   WHERE SWQX AND SWX ARE PARTIAL DERIVATIVES WITH RESPECT
C   TO X OF SWQ AND SW, RESPECTIVELY.  SWQY AND SWY ARE DE-
C   FINED SIMILARLY.
C
      SW = 0.
      SWX = 0.
      SWY = 0.
      SWQ = 0.
      SWQX = 0.
      SWQY = 0.
C
C OUTER LOOP ON CELLS (I,J).
C
      DO 3 J = JMIN,JMAX
	DO 3 I = IMIN,IMAX
	  K = LCELL(I,J)
	  IF (K .EQ. 0) GO TO 3
C
C INNER LOOP ON NODES K.
C
    1	  DELX = XP - X(K)
	  DELY = YP - Y(K)
	  DXSQ = DELX*DELX
	  DYSQ = DELY*DELY
	  DS = DXSQ + DYSQ
	  RS = RSQ(K)
	  IF (DS .GE. RS) GO TO 2
	  IF (DS .EQ. 0.) GO TO 4
	  RDS = RS*DS
	  RD = SQRT(RDS)
	  W = (RS+DS-RD-RD)/RDS
	  T = 2.*(RD-RS)/(DS*RDS)
	  WX = DELX*T
	  WY = DELY*T
	  QKX = 2.*A(1,K)*DELX + A(2,K)*DELY
	  QKY = A(2,K)*DELX + 2.*A(3,K)*DELY
	  QK = (QKX*DELX + QKY*DELY)/2.
	  QKX = QKX + A(4,K)
	  QKY = QKY + A(5,K)
	  QK = QK + A(4,K)*DELX + A(5,K)*DELY + F(K)
	  SW = SW + W
	  SWX = SWX + WX
	  SWY = SWY + WY
	  SWQ = SWQ + W*QK
	  SWQX = SWQX + WX*QK + W*QKX
	  SWQY = SWQY + WY*QK + W*QKY
C
C BOTTOM OF LOOP ON NODES IN CELL (I,J).
C
    2	  KP = K
	  K = LNEXT(KP)
	  IF (K .NE. KP) GO TO 1
    3	  CONTINUE
C
C SW = 0 IFF P IS NOT WITHIN THE RADIUS R(K) FOR ANY NODE K.
C
      IF (SW .EQ. 0.) GO TO 6
      Q = SWQ/SW
      SWS = SW*SW
      QX = (SWQX*SW - SWQ*SWX)/SWS
      QY = (SWQY*SW - SWQ*SWY)/SWS
      IER = 0
      RETURN
C
C (PX,PY) = (X(K),Y(K))
C
    4 Q = F(K)
      QX = A(4,K)
      QY = A(5,K)
      IER = 0
      RETURN
C
C INVALID INPUT PARAMETER.
C
    5 IER = 1
      RETURN
C
C NO CELLS CONTAIN A POINT WITHIN RMAX OF P, OR
C   SW = 0 AND THUS DS .GE. RSQ(K) FOR ALL K.
C
    6 Q = 0.
      QX = 0.
      QY = 0.
      IER = 2
      RETURN
      END
      SUBROUTINE GETNP2 (PX,PY,X,Y,NR,LCELL,LNEXT,XMIN,YMIN,
     .             DX,DY, NP,DSQ)
      INTEGER NR, LCELL(NR,NR), LNEXT(1), NP
      REAL    PX, PY, X(1), Y(1), XMIN, YMIN, DX, DY, DSQ
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C
C   GIVEN A SET OF N NODES AND THE DATA STRUCTURE DEFINED IN
C SUBROUTINE STORE2, THIS SUBROUTINE USES THE CELL METHOD TO
C FIND THE CLOSEST UNMARKED NODE NP TO A SPECIFIED POINT P.
C NP IS THEN MARKED BY SETTING LNEXT(NP) TO -LNEXT(NP).  (A
C NODE IS MARKED IF AND ONLY IF THE CORRESPONDING LNEXT ELE-
C MENT IS NEGATIVE.  THE ABSOLUTE VALUES OF LNEXT ELEMENTS,
C HOWEVER, MUST BE PRESERVED.)	THUS, THE CLOSEST M NODES TO
C P MAY BE DETERMINED BY A SEQUENCE OF M CALLS TO THIS ROU-
C TINE.  NOTE THAT IF THE NEAREST NEIGHBOR TO NODE K IS TO
C BE DETERMINED (PX = X(K) AND PY = Y(K)), THEN K SHOULD BE
C MARKED BEFORE THE CALL TO THIS ROUTINE.
C   THE SEARCH IS BEGUN IN THE CELL CONTAINING (OR CLOSEST
C TO) P AND PROCEEDS OUTWARD IN RECTANGULAR LAYERS UNTIL ALL
C CELLS WHICH CONTAIN POINTS WITHIN DISTANCE R OF P HAVE
C BEEN SEARCHED, WHERE R IS THE DISTANCE FROM P TO THE FIRST
C UNMARKED NODE ENCOUNTERED (INFINITE IF NO UNMARKED NODES
C ARE PRESENT).
C
C ON INPUT --
C
C	PX,PY = CARTESIAN COORDINATES OF THE POINT P WHOSE
C		NEAREST UNMARKED NEIGHBOR IS TO BE FOUND.
C
C	X,Y = ARRAYS OF LENGTH N, FOR N .GE. 2, CONTAINING
C	      THE CARTESIAN COORDINATES OF THE NODES.
C
C	NR = NUMBER OF ROWS AND COLUMNS IN THE CELL GRID.
C	     NR .GE. 1.
C
C	LCELL = NR BY NR ARRAY OF NODAL INDICES ASSOCIATED
C		WITH CELLS.
C
C	LNEXT = ARRAY OF LENGTH N CONTAINING NEXT-NODE INDI-
C		CES (OR THEIR NEGATIVES).
C
C	XMIN,YMIN,DX,DY = MINIMUM NODAL COORDINATES AND CELL
C			  DIMENSIONS.  DX AND DY MUST BE
C			  POSITIVE.
C
C   INPUT PARAMETERS OTHER THAN LNEXT ARE NOT ALTERED BY
C THIS ROUTINE.  WITH THE EXCEPTION OF (PX,PY) AND THE SIGNS
C OF LNEXT ELEMENTS, THESE PARAMETERS SHOULD BE UNALTERED
C FROM THEIR VALUES ON OUTPUT FROM SUBROUTINE STORE2.
C
C ON OUTPUT --
C
C	NP = INDEX (FOR X AND Y) OF THE NEAREST UNMARKED
C	     NODE TO P, OR 0 IF ALL NODES ARE MARKED OR NR
C	     .LT. 1 OR DX .LE. 0 OR DY .LE. 0.    LNEXT(NP)
C	     .LT. 0 IF NP .NE. 0.
C
C	DSQ = SQUARED EUCLIDEAN DISTANCE BETWEEN P AND NODE
C	      NP, OR 0 IF NP = 0.
C
C MODULES REQUIRED BY GETNP2 -- NONE
C
C INTRINSIC FUNCTIONS CALLED BY GETNP2 -- IABS, IFIX, SQRT
C
C***********************************************************
C
      LOGICAL FIRST
      XP = PX
      YP = PY
C
C TEST FOR INVALID INPUT PARAMETERS.
C
      IF (NR .LT. 1  .OR.  DX .LE. 0.  .OR.  DY .LE. 0.)
     .    GO TO 9
C
C INITIALIZE PARAMETERS --
C
C   FIRST = TRUE IFF THE FIRST UNMARKED NODE HAS YET TO BE
C	    ENCOUNTERED,
C   IMIN,IMAX,JMIN,JMAX = CELL INDICES DEFINING THE RANGE OF
C			  THE SEARCH,
C   DELX,DELY = PX-XMIN AND PY-YMIN,
C   I0,J0 = CELL CONTAINING OR CLOSEST TO P,
C   I1,I2,J1,J2 = CELL INDICES OF THE LAYER WHOSE INTERSEC-
C		  TION WITH THE RANGE DEFINED BY IMIN,...,
C		  JMAX IS CURRENTLY BEING SEARCHED.
C
      FIRST = .TRUE.
      IMIN = 1
      IMAX = NR
      JMIN = 1
      JMAX = NR
      DELX = XP - XMIN
      DELY = YP - YMIN
      I0 = IFIX(DELX/DX) + 1
      IF (I0 .LT. 1) I0 = 1
      IF (I0 .GT. NR) I0 = NR
      J0 = IFIX(DELY/DY) + 1
      IF (J0 .LT. 1) J0 = 1
      IF (J0 .GT. NR) J0 = NR
      I1 = I0
      I2 = I0
      J1 = J0
      J2 = J0
C
C OUTER LOOP ON LAYERS, INNER LOOP ON LAYER CELLS, EXCLUDING
C   THOSE OUTSIDE THE RANGE (IMIN,IMAX) X (JMIN,JMAX).
C
    1 DO 6 J = J1,J2
	IF (J .GT. JMAX) GO TO 7
	IF (J .LT. JMIN) GO TO 6
	DO 5 I = I1,I2
	  IF (I .GT. IMAX) GO TO 6
	  IF (I .LT. IMIN) GO TO 5
	  IF (J .NE. J1  .AND.    J .NE. J2  .AND.  I .NE. I1
     .          .AND.  I .NE. I2) GO TO 5
C
C SEARCH CELL (I,J) FOR UNMARKED NODES L.
C
	  L = LCELL(I,J)
	  IF (L .EQ. 0) GO TO 5
C
C   LOOP ON NODES IN CELL (I,J).
C
    2	  LN = LNEXT(L)
	  IF (LN .LT. 0) GO TO 4
C
C   NODE L IS NOT MARKED.
C
	  RSQ = (X(L)-XP)**2 + (Y(L)-YP)**2
	  IF (.NOT. FIRST) GO TO 3
C
C   NODE L IS THE FIRST UNMARKED NEIGHBOR OF P ENCOUNTERED.
C     INITIALIZE LMIN TO THE CURRENT CANDIDATE FOR NP, AND
C     RSMIN TO THE SQUARED DISTANCE FROM P TO LMIN.  IMIN,
C     IMAX, JMIN, AND JMAX ARE UPDATED TO DEFINE THE SMAL-
C     LEST RECTANGLE CONTAINING A CIRCLE OF RADIUS R =
C     SQRT(RSMIN) CENTERED AT P, AND CONTAINED IN (1,NR) X
C     (1,NR) (EXCEPT THAT, IF P IS OUTSIDE THE RECTANGLE
C     DEFINED BY THE NODES, IT IS POSSIBLE THAT IMIN .GT.
C     NR, IMAX .LT. 1, JMIN .GT. NR, OR JMAX .LT. 1).  FIRST
C     IS RESET TO FALSE.
C
	  LMIN = L
	  RSMIN = RSQ
	  R = SQRT(RSMIN)
	  IMIN = IFIX((DELX-R)/DX) + 1
	  IF (IMIN .LT. 1) IMIN = 1
	  IMAX = IFIX((DELX+R)/DX) + 1
	  IF (IMAX .GT. NR) IMAX = NR
	  JMIN = IFIX((DELY-R)/DY) + 1
	  IF (JMIN .LT. 1) JMIN = 1
	  JMAX = IFIX((DELY+R)/DY) + 1
	  IF (JMAX .GT. NR) JMAX = NR
	  FIRST = .FALSE.
	  GO TO 4
C
C   TEST FOR NODE L CLOSER THAN LMIN TO P.
C
    3	  IF (RSQ .GE. RSMIN) GO TO 4
C
C   UPDATE LMIN AND RSMIN.
C
	  LMIN = L
	  RSMIN = RSQ
C
C   TEST FOR TERMINATION OF LOOP ON NODES IN CELL (I,J).
C
    4	  IF (IABS(LN) .EQ. L) GO TO 5
	  L = IABS(LN)
	  GO TO 2
    5	  CONTINUE
    6	CONTINUE
C
C TEST FOR TERMINATION OF LOOP ON CELL LAYERS.
C
    7 IF (I1 .LE. IMIN .AND. I2 .GE. IMAX  .AND.
     .      J1 .LE. JMIN .AND.  J2 .GE. JMAX) GO TO 8
      I1 = I1 - 1
      I2 = I2 + 1
      J1 = J1 - 1
      J2 = J2 + 1
      GO TO 1
C
C UNLESS NO UNMARKED NODES WERE ENCOUNTERED, LMIN IS THE
C   CLOSEST UNMARKED NODE TO P.
C
    8 IF (FIRST) GO TO 9
      NP = LMIN
      DSQ = RSMIN
      LNEXT(LMIN) = -LNEXT(LMIN)
      RETURN
C
C ERROR -- NR, DX, OR DY IS INVALID OR ALL NODES ARE MARKED.
C
    9 NP = 0
      DSQ = 0.
      RETURN
      END
      SUBROUTINE GIVENS ( A,B, C,S)
      REAL A, B, C, S
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C
C   THIS ROUTINE CONSTRUCTS THE GIVENS PLANE ROTATION --
C     ( C  S)
C G = (     ) WHERE C*C + S*S = 1 -- WHICH ZEROS THE SECOND
C     (-S  C)
C ENTRY OF THE 2-VECTOR (A B)-TRANSPOSE.  A CALL TO GIVENS
C IS NORMALLY FOLLOWED BY A CALL TO ROTATE WHICH APPLIES
C THE TRANSFORMATION TO A 2 BY N MATRIX.  THIS ROUTINE WAS
C TAKEN FROM LINPACK.
C
C ON INPUT --
C
C	A,B = COMPONENTS OF THE 2-VECTOR TO BE ROTATED.
C
C ON OUTPUT --
C
C	A = VALUE OVERWRITTEN BY R = +/-SQRT(A*A + B*B)
C
C	B = VALUE OVERWRITTEN BY A VALUE Z WHICH ALLOWS C
C	    AND S TO BE RECOVERED AS FOLLOWS --
C	      C = SQRT(1-Z*Z), S=Z     IF ABS(Z) .LE. 1.
C	      C = 1/Z, S = SQRT(1-C*C) IF ABS(Z) .GT. 1.
C
C	C = +/-(A/R)
C
C	S = +/-(B/R)
C
C MODULES REQUIRED BY GIVENS -- NONE
C
C INTRINSIC FUNCTIONS CALLED BY GIVENS - ABS, SQRT
C
C***********************************************************
C
      REAL AA, BB, R, U, V
C
C LOCAL PARAMETERS --
C
C AA,BB = LOCAL COPIES OF A AND B
C R =	  C*A + S*B = +/-SQRT(A*A+B*B)
C U,V =   VARIABLES USED TO SCALE A AND B FOR COMPUTING R
C
      AA = A
      BB = B
      IF (ABS(AA) .LE. ABS(BB)) GO TO 1
C
C ABS(A) .GT. ABS(B)
C
      U = AA + AA
      V = BB/U
      R = SQRT(.25 + V*V) * U
      C = AA/R
      S = V * (C + C)
C
C NOTE THAT R HAS THE SIGN OF A, C .GT. 0, AND S HAS
C   SIGN(A)*SIGN(B).
C
      B = S
      A = R
      RETURN
C
C ABS(A) .LE. ABS(B)
C
    1 IF (BB .EQ. 0.) GO TO 2
      U = BB + BB
      V = AA/U
C
C STORE R IN A.
C
      A = SQRT(.25 + V*V) * U
      S = BB/A
      C = V * (S + S)
C
C NOTE THAT R HAS THE SIGN OF B, S .GT. 0, AND C HAS
C   SIGN(A)*SIGN(B).
C
      B = 1.
      IF (C .NE. 0.) B = 1./C
      RETURN
C
C A = B = 0.
C
    2 C = 1.
      S = 0.
      RETURN
      END
      SUBROUTINE ROTATE (N,C,S, X,Y )
      INTEGER N
      REAL    C, S, X(N), Y(N)
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C
C					     ( C  S)
C   THIS ROUTINE APPLIES THE GIVENS ROTATION (	   ) TO THE
C					     (-S  C)
C		(X(1) ... X(N))
C 2 BY N MATRIX (	      ).
C		(Y(1) ... Y(N))
C
C ON INPUT --
C
C	N = NUMBER OF COLUMNS TO BE ROTATED.
C
C	C,S = ELEMENTS OF THE GIVENS ROTATION.    THESE MAY BE
C	      DETERMINED BY SUBROUTINE GIVENS.
C
C	X,Y = ARRAYS OF LENGTH .GE. N CONTAINING THE VECTORS
C	      TO BE ROTATED.
C
C PARAMETERS N, C, AND S ARE NOT ALTERED BY THIS ROUTINE.
C
C ON OUTPUT --
C
C	X,Y = ROTATED VECTORS.
C
C MODULES REQUIRED BY ROTATE -- NONE
C
C***********************************************************
C
      INTEGER I
      REAL    XI, YI
C
C LOCAL PARAMETERS --
C
C I =	  DO-LOOP INDEX
C XI,YI = X(I), Y(I)
C
      IF (N .LE. 0 .OR. (C .EQ. 1. .AND. S .EQ. 0.)) RETURN
      DO 1 I = 1,N
	XI = X(I)
	YI = Y(I)
	X(I) = C*XI + S*YI
	Y(I) = -S*XI + C*YI
    1	CONTINUE
      RETURN
      END
      SUBROUTINE SETUP2 (XK,YK,FK,XI,YI,FI,S1,S2,R, ROW)
      REAL XK, YK, FK, XI, YI, FI, S1, S2, R, ROW(6)
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C
C   THIS ROUTINE SETS UP THE I-TH ROW OF AN AUGMENTED RE-
C GRESSION MATRIX FOR A WEIGHTED LEAST-SQUARES FIT OF A
C QUADRATIC FUNCTION Q(X,Y) TO A SET OF DATA VALUES F, WHERE
C Q(XK,YK) = FK.  THE FIRST 3 COLUMNS (QUADRATIC TERMS) ARE
C SCALED BY 1/S2 AND THE FOURTH AND FIFTH COLUMNS (LINEAR
C TERMS) ARE SCALED BY 1/S1.  THE WEIGHT IS (R-D)/(R*D) IF
C R .GT. D AND 0 IF R .LE. D, WHERE D IS THE DISTANCE
C BETWEEN NODES I AND K.
C
C ON INPUT --
C
C	XK,YK,FK = COORDINATES AND DATA VALUE AT NODE K --
C		   INTERPOLATED BY Q.
C
C	XI,YI,FI = COORDINATES AND DATA VALUE AT NODE I.
C
C	S1,S2 = RECIPROCALS OF THE SCALE FACTORS.
C
C	R = RADIUS OF INFLUENCE ABOUT NODE K DEFINING THE
C	    WEIGHT.
C
C	ROW = ARRAY OF LENGTH 6.
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C ON OUTPUT --
C
C	ROW = VECTOR CONTAINING A ROW OF THE AUGMENTED
C	      REGRESSION MATRIX.
C
C MODULES REQUIRED BY SETUP2 -- NONE
C
C INTRINSIC FUNCTION CALLED BY SETUP2 -- SQRT
C
C***********************************************************
C
      INTEGER I
      REAL    DX, DY, DXSQ, DYSQ, D, W, W1, W2
C
C LOCAL PARAMETERS -
C
C I =	 DO-LOOP INDEX
C DX =	 XI - XK
C DY =	 YI - YK
C DXSQ = DX*DX
C DYSQ = DY*DY
C D =	 DISTANCE BETWEEN NODES K AND I
C W =	 WEIGHT ASSOCIATED WITH THE ROW
C W1 =	 W/S1
C W2 =	 W/S2
C
      DX = XI - XK
      DY = YI - YK
      DXSQ = DX*DX
      DYSQ = DY*DY
      D = SQRT(DXSQ + DYSQ)
      IF (D .LE. 0.  .OR.  D .GE. R) GO TO 1
      W = (R-D)/R/D
      W1 = W/S1
      W2 = W/S2
      ROW(1) = DXSQ*W2
      ROW(2) = DX*DY*W2
      ROW(3) = DYSQ*W2
      ROW(4) = DX*W1
      ROW(5) = DY*W1
      ROW(6) = (FI - FK)*W
      RETURN
C
C NODES K AND I COINCIDE OR NODE I IS OUTSIDE OF THE RADIUS
C   OF INFLUENCE.  SET ROW TO THE ZERO VECTOR.
C
    1 DO 2 I = 1,6
    2	ROW(I) = 0.
      RETURN
      END
      SUBROUTINE STORE2 (N,X,Y,NR, LCELL,LNEXT,XMIN,YMIN,DX,
     .             DY,IER)
      INTEGER N, NR, LCELL(NR,NR), LNEXT(N), IER
      REAL    X(N), Y(N), XMIN, YMIN, DX, DY
C
C***********************************************************
C
C						ROBERT RENKA
C					UNIV. OF NORTH TEXAS
C					      (817) 565-2767
C
C   GIVEN A SET OF N ARBITRARILY DISTRIBUTED NODES IN THE
C PLANE, THIS SUBROUTINE CREATES A DATA STRUCTURE FOR A
C CELL-BASED METHOD OF SOLVING CLOSEST-POINT PROBLEMS.    THE
C SMALLEST RECTANGLE CONTAINING THE NODES IS PARTITIONED
C INTO AN NR BY NR UNIFORM GRID OF CELLS, AND NODES ARE AS-
C SOCIATED WITH CELLS.    IN PARTICULAR, THE DATA STRUCTURE
C STORES THE INDICES OF THE NODES CONTAINED IN EACH CELL.
C FOR A UNIFORM RANDOM DISTRIBUTION OF NODES, THE NEAREST
C NODE TO AN ARBITRARY POINT CAN BE DETERMINED IN CONSTANT
C EXPECTED TIME.
C
C ON INPUT --
C
C	N = NUMBER OF NODES.  N .GE. 2.
C
C	X,Y = ARRAYS OF LENGTH N CONTAINING THE CARTESIAN
C	      COORDINATES OF THE NODES.
C
C	NR = NUMBER OF ROWS AND COLUMNS IN THE GRID.  THE
C	     CELL DENSITY (AVERAGE NUMBER OF NODES PER CELL)
C	     IS D = N/(NR**2).    A RECOMMENDED VALUE, BASED
C	     ON EMPIRICAL EVIDENCE, IS D = 3 -- NR =
C	     SQRT(N/3).  NR .GE. 1.
C
C THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C	LCELL = ARRAY OF LENGTH .GE. NR**2.
C
C	LNEXT = ARRAY OF LENGTH .GE. N.
C
C ON OUTPUT --
C
C	LCELL = NR BY NR CELL ARRAY SUCH THAT LCELL(I,J)
C		CONTAINS THE INDEX (FOR X AND Y) OF THE
C		FIRST NODE (NODE WITH SMALLEST INDEX) IN
C		CELL (I,J), OR LCELL(I,J) = 0 IF NO NODES
C		ARE CONTAINED IN THE CELL.  THE UPPER RIGHT
C		CORNER OF CELL (I,J) HAS COORDINATES (XMIN+
C		I*DX,YMIN+J*DY).  LCELL IS NOT DEFINED IF
C		IER .NE. 0.
C
C	LNEXT = ARRAY OF NEXT-NODE INDICES SUCH THAT
C		LNEXT(K) CONTAINS THE INDEX OF THE NEXT NODE
C		IN THE CELL WHICH CONTAINS NODE K, OR
C		LNEXT(K) = K IF K IS THE LAST NODE IN THE
C		CELL FOR K = 1,...,N.  (THE NODES CONTAINED
C		IN A CELL ARE ORDERED BY THEIR INDICES.)
C		IF, FOR EXAMPLE, CELL (I,J) CONTAINS NODES
C		2, 3, AND 5 (AND NO OTHERS), THEN LCELL(I,J)
C		= 2, LNEXT(2) = 3, LNEXT(3) = 5, AND
C		LNEXT(5) = 5.  LNEXT IS NOT DEFINED IF
C		IER .NE. 0.
C
C	XMIN,YMIN = CARTESIAN COORDINATES OF THE LOWER LEFT
C		    CORNER OF THE RECTANGLE DEFINED BY THE
C		    NODES (SMALLEST NODAL COORDINATES) UN-
C		    LESS IER = 1.  THE UPPER RIGHT CORNER IS
C		    (XMAX,YMAX) FOR XMAX = XMIN + NR*DX AND
C		    YMAX = YMIN + NR*DY.
C
C	DX,DY = DIMENSIONS OF THE CELLS UNLESS IER = 1.  DX
C		= (XMAX-XMIN)/NR AND DY = (YMAX-YMIN)/NR
C		WHERE XMIN, XMAX, YMIN, AND YMAX ARE THE
C		EXTREMA OF X AND Y.
C
C	IER = ERROR INDICATOR --
C	      IER = 0 IF NO ERRORS WERE ENCOUNTERED.
C	      IER = 1 IF N .LT. 2 OR NR .LT. 1.
C	      IER = 2 IF DX = 0 OR DY = 0.
C
C MODULES REQUIRED BY STORE2 -- NONE
C
C INTRINSIC FUNCTIONS CALLED BY STORE2 -- FLOAT, IFIX
C
C***********************************************************
C
      NN = N
      NNR = NR
      IF (NN .LT. 2  .OR.  NNR .LT. 1) GO TO 4
C
C COMPUTE THE DIMENSIONS OF THE RECTANGLE CONTAINING THE
C   NODES.
C
      XMN = X(1)
      XMX = XMN
      YMN = Y(1)
      YMX = YMN
      DO 1 K = 2,NN
	IF (X(K) .LT. XMN) XMN = X(K)
	IF (X(K) .GT. XMX) XMX = X(K)
	IF (Y(K) .LT. YMN) YMN = Y(K)
    1	IF (Y(K) .GT. YMX) YMX = Y(K)
      XMIN = XMN
      YMIN = YMN
C
C COMPUTE CELL DIMENSIONS AND TEST FOR ZERO AREA.
C
      DELX = (XMX-XMN)/FLOAT(NNR)
      DELY = (YMX-YMN)/FLOAT(NNR)
      DX = DELX
      DY = DELY
      IF (DELX .EQ. 0.    .OR.  DELY .EQ. 0.) GO TO 5
C
C INITIALIZE LCELL.
C
      DO 2 J = 1,NNR
	DO 2 I = 1,NNR
    2	  LCELL(I,J) = 0
C
C LOOP ON NODES, STORING INDICES IN LCELL AND LNEXT.
C
      NP1 = NN + 1
      DO 3 K = 1,NN
	KB = NP1 - K
	I = IFIX((X(KB)-XMN)/DELX) + 1
	IF (I .GT. NNR) I = NNR
	J = IFIX((Y(KB)-YMN)/DELY) + 1
	IF (J .GT. NNR) J = NNR
	L = LCELL(I,J)
	LNEXT(KB) = L
	IF (L .EQ. 0) LNEXT(KB) = KB
    3	LCELL(I,J) = KB
C
C NO ERRORS ENCOUNTERED
C
      IER = 0
      RETURN
C
C INVALID INPUT PARAMETER
C
    4 IER = 1
      RETURN
C
C DX = 0 OR DY = 0
C
    5 IER = 2
      RETURN
      END


program test
  integer :: a(10, 10), b(10,10), c(10, 10)
  integer:: i = 1,j =1

  do while (i <= 10)
    j = 1
    do while (j <= 10)
      a(j,i) = i
      b(j,i) = j
      j = j + 1
    end do
    i = i + 1
  end do

  i = 1
  do while (i <= 10)
    j = 1
    do while (j <= 10)
      c(j,i) = a(j,i) + b(j,i)
      j = j + 1
    end do
    i = i + 1
  end do

  print *, c
end program test


      SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the convolution or deconvolution of two real signals
C     A and B using the Hartley transform.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     CONV    CHARACTER*1
C             Indicates whether convolution or deconvolution is to be
C             performed as follows:
C             = 'C':  Convolution;
C             = 'D':  Deconvolution.
C
C     WGHT    CHARACTER*1
C             Indicates whether the precomputed weights are available
C             or not, as follows:
C             = 'A':  available;
C             = 'N':  not available.
C             Note that if N > 1 and WGHT = 'N' on entry, then WGHT is
C             set to 'A' on exit.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of samples.  N must be a power of 2.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the first signal.
C             On exit, this array contains the convolution (if
C             CONV = 'C') or deconvolution (if CONV = 'D') of the two
C             signals.
C
C     B       (input) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the second signal.
C             NOTE that this array is overwritten.
C
C     W       (input/output) DOUBLE PRECISION array,
C                            dimension (N - LOG2(N))
C             On entry with WGHT = 'A', this array must contain the long
C             weight vector computed by a previous call of this routine
C             or of the SLICOT Library routine DG01OD.f, with the same
C             value of N. If WGHT = 'N', the contents of this array on
C             entry is ignored.
C             On exit, this array contains the long weight vector.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     This routine computes the convolution or deconvolution of two
C     real signals A and B using three scrambled Hartley transforms
C     (SLICOT Library routine DG01OD).
C
C     REFERENCES
C
C     [1] Van Loan, Charles.
C         Computational frameworks for the fast Fourier transform.
C         SIAM, 1992.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(N log(N)) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, April 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     KEYWORDS
C
C     Convolution, deconvolution, digital signal processing,
C     fast Hartley transform, real signals.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  HALF, TWO
      PARAMETER         ( HALF = 0.5D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         CONV, WGHT
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*), W(*)
C     .. Local Scalars ..
      LOGICAL           LCONV, LWGHT
      INTEGER           J, L, LEN, M, P1, R1
      DOUBLE PRECISION  T1, T2, T3
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DG01OD, DLADIV, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MOD
C     .. Executable Statements ..
C
      INFO  = 0
      LCONV = LSAME( CONV, 'C' )
      LWGHT = LSAME( WGHT, 'A' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN
         INFO = -2
      ELSE
         M = 0
         J = 0
         IF( N.GE.1 ) THEN
            J = N
C           WHILE ( MOD( J, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( J, 2 ).EQ.0 ) THEN
               J = J/2
               M = M + 1
               GO TO 10
            END IF
C           END WHILE 10
            IF ( J.NE.1 ) INFO = -3
         ELSE IF ( N.LT.0 ) THEN
            INFO = -3
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DE01PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.LE.0 ) THEN
         RETURN
      ELSE IF ( N.EQ.1 ) THEN
         IF ( LCONV ) THEN
            A(1) = A(1)*B(1)
         ELSE
            A(1) = A(1)/B(1)
         END IF
         RETURN
      END IF
C
C     Scrambled Hartley transforms of A and B.
C
      CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO )
      CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO )
C
C     Something similar to a Hadamard product/quotient.
C
      LEN = 1
      IF( LCONV )  THEN
         A(1) = TWO*A(1)*B(1)
         A(2) = TWO*A(2)*B(2)
C
         DO 30 L = 1, M - 1
            LEN = 2*LEN
            R1  = 2*LEN
C
            DO 20 P1 = LEN + 1, LEN + LEN/2
               T1 = B(P1) + B(R1)
               T2 = B(P1) - B(R1)
               T3 = T2*A(P1)
               A(P1) = T1*A(P1) + T2*A(R1)
               A(R1) = T1*A(R1) - T3
               R1 = R1 - 1
   20       CONTINUE
C
   30    CONTINUE
C
      ELSE
C
         A(1) = HALF*A(1)/B(1)
         A(2) = HALF*A(2)/B(2)
C
         DO 50 L = 1, M - 1
            LEN = 2*LEN
            R1  = 2*LEN
C
            DO 40 P1 = LEN + 1, LEN + LEN/2
               CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1,
     $                      T2 )
               A(P1) = T1
               A(R1) = T2
               R1 = R1 - 1
   40       CONTINUE
C
   50    CONTINUE
C
      END IF
C
C     Transposed Hartley transform of A.
C
      CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO )
      IF ( LCONV ) THEN
         CALL DSCAL( N, HALF/DBLE( N ), A, 1 )
      ELSE
         CALL DSCAL( N, TWO/DBLE( N ), A, 1 )
      END IF
C
      RETURN
C *** Last line of DE01PD ***
      END


      subroutine csroot(xr,xi,yr,yi)
      double precision xr,xi,yr,yi
c
c     (yr,yi) = complex dsqrt(xr,xi)
c     branch chosen so that yr .ge. 0.0 and sign(yi) .eq. sign(xi)
c
      double precision s,tr,ti,pythag
      tr = xr
      ti = xi
      s = dsqrt(0.5d0*(pythag(tr,ti) + dabs(tr)))
      if (tr .ge. 0.0d0) yr = s
      if (ti .lt. 0.0d0) s = -s
      if (tr .le. 0.0d0) yi = s
      if (tr .lt. 0.0d0) yr = 0.5d0*(ti/yi)
      if (tr .gt. 0.0d0) yi = 0.5d0*(ti/yr)
      return
      end


module supercell
  use linalg, only: determinant_3x3_real, frobnorm_3x3_real, matinv3x3

  contains

    !> Compute deviation from the target metric, given that cell is normed
    pure function get_deviation(cell, target_metric, norm) result(deviation)
      real*8, dimension(3,3), intent(in) :: cell
      real*8, dimension(3,3), intent(in) :: target_metric
      logical,      optional, intent(in) :: norm
      logical                            :: nrm
      real*8                             :: ncell(3,3)

      nrm = .true.
      if (present(norm)) nrm = norm

      ! Normalize the input lattice
      if (nrm) then
        ncell = cell * (determinant_3x3_real(cell) / determinant_3x3_real(target_metric))**(-1./3.)
      else
        ncell = cell
      end if

      deviation = frobnorm_3x3_real(ncell - target_metric)

    end function

    !> Find optimal supercell matrix to realize supercell lattice of given
    !> metric, e.g., cubic.
    function find_optimal_cell(cell, target_metric, target_size, lower_limit, &
        upper_limit, verbose) result(smatrix)
      real*8,  intent(in)   :: cell(3,3)
      real*8,  intent(in)   :: target_metric(3,3)
      real*8,  intent(in)   :: target_size
      integer, intent(in)   :: lower_limit, upper_limit
      logical, intent(in)   :: verbose
      integer               :: smatrix(3,3)
      optional              :: lower_limit, upper_limit, verbose
      integer               :: llim, ulim
      logical               :: vrbs, found
      integer               :: i1, i2, i3, i4, i5, i6, i7, i8, i9, nn
      integer               :: initial_P(3,3), P(3,3), dP(3,3)
      real*8                :: norm, score, best_score, ideal_P(3,3), ccell(3,3)

      ! options and defaults
      llim = -2
      ulim =  2
      vrbs = .false.
      if(present(lower_limit)) llim = lower_limit
      if(present(upper_limit)) ulim = upper_limit
      if(present(verbose))     vrbs = verbose

      ! initialize matrices and values
      smatrix    = -1
      score      = 1.e7
      best_score = 1.e6
      ccell      = cell
      found      = .false.
      P          = 0

      if (vrbs) then
        write(*,*) 'Settings:'
        write (*,"(A,/,3(F7.2))") 'Input cell:   ', cell
        write (*,"(A,/,3(F7.2))") 'Target metric:', target_metric
        write (*,"(A,(F7.2))")    'Target size:  ', target_size
        write (*,"(A,2(I3))")     'Limits:       ', llim, ulim
      end if

      ! Normalize the input lattice
      norm = (target_size * determinant_3x3_real(cell) / determinant_3x3_real(target_metric))**(-1./3.)
      ccell = norm * cell

      if (vrbs) write(*,"(A,(F7.3))") 'Normalization factor: ', norm
      if (vrbs) write (*,"(A,/,3(F7.2))") 'Normed cell:  ', ccell

      ! Approximate the perfect smatrix
      ideal_P   = matmul(target_metric, matinv3x3(ccell))
      initial_P = nint(ideal_P)
      if (vrbs) write (*,"(A,/,3(F7.3))") 'Ideal P:   ' , ideal_P
      if (vrbs) write (*,"(A,/,3(I7))") 'Initial P: ' , initial_P

      !> Expand brute force
      do i1=llim, ulim
      do i2=llim, ulim
      do i3=llim, ulim
      do i4=llim, ulim
      do i5=llim, ulim
      do i6=llim, ulim
      do i7=llim, ulim
      do i8=llim, ulim
      do i9=llim, ulim
        dP(1,1:3) =  (/ i1, i2, i3 /)
        dP(2,1:3) =  (/ i4, i5, i6 /)
        dP(3,1:3) =  (/ i7, i8, i9 /)
        P = initial_P + dP
        nn = nint(determinant_3x3_real(real(P, 8)))
        ! Allow up to 20% increase in size from target shape
        if ((nn < target_size  ) .or. (nn > 1.2*target_size)) cycle
        score = get_deviation(matmul(ccell, P), target_metric)
        ! Save the result if it was a good one
        if (score < best_score) then
          found = .true.
          best_score = score
          smatrix = P
        end if
      end do
      end do
      end do
      end do
      end do
      end do
      end do
      end do
      end do

      if (vrbs) then
        write (*,"(A,/,(F7.3))") 'Best score: ' , best_score
        write (*,"(A,/,3(I7))")  'P:          ' , smatrix
        write (*,"(A,/,F7.3,I5)")  'N_target, N:' , target_size, nint(determinant_3x3_real(real(smatrix, 8)))
      end if

      if (.not. found) write(*,*) 'No supercell matrix found.'

    end function
end module


C----------------------------------------------------------------
C Set of subroutines used by PATCH1 and PATCH_GRI
C Version of 20/07/87
C
C Warning : if you have error messages like "FLOATING UNDERFLOW"
C           don't worry and compile your program with
C	    the option FORTRAN/CHECK=(NOUNDERFLOW)
C
C Contains : NEQSOL,REJECT, and POLY
C------------------------------------------------------------------
      SUBROUTINE NEQSOL(X,Y,Z,NDIM,NPTS,NTERMS,NOTO,IOOR,D,SE,
     1 RDOE,SDOR)
C **************************************************************
C
C     SUBROUTINE NEQSOL(X,Y,Z,NDIM,NPTS,NTERMS,NOTO,IOOR,D,SE,RDOE,SDOR)
C
C THIS SUBROUTINE COMPUTES THE COEFFICIENTS, D, WHICH DEFINE THAT LINEAR
C FUNCTION, Y, OF LINEARLY INDEPENDENT FUNCTIONS WHICH BEST FITS, IN THE
C LEAST SQUARES SENSE, A GIVEN SET OF DATA. OR EQUIVALENTLY, IT FINDS
C THE SOLUTION TO THE SYSTEM OF NORMAL EQUATIONS WHICH IS CALLED THE
C NORMAL EQUATIONS SOLUTION.
C
C     WRITTEN AND DOCUMENTED BY:
C
C     JONES, W B, OBITTS, D L, GALLET, R M, AND DE VAUCOULEURS, G,
C     'ASTRONOMICAL SURFACE PHOTOMETRY BY NUMERICAL MAPPING
C     TECHNIQUES', PUBLICATION OF THE ASTRONOMY DEPARTMENT, UNIV.
C     OF TEXAS, AUSTIN, SERIES II, VOL. I, NO. 8, FEB. 1967
C
C     MODIFIED BY W D PENCE, UNIV. OF SUSSEX, SEPT. 1980
C
C     X(NPTS,2) = COORDINATES OF POINTS: X(I,1) = X COORD.  (R*4)
C                                      X(I,2) = Y COORD.  (R*4)
C     Y(NPTS) = VALUE OF POINT AT X(NPTS,1),X(NPTS,2)  (R*4)
C     Z = SCRATCH ARRAY  (DOUBLE PRECISION, R*8)
C     NDIM = FIRST DIMENSION OF X, Y AND Z (I*4)
C     NPTS = NO. OF POINTS IN LEAST SQUARES FIT  (I*4)
C     NTERMS = NO. OF COEFS TO BE SOLVED FOR  (I*4)
C     NOTO = NO. OF TOTAL ORTHOGONALIZATIONS TO PERFORM (I*4)
C     IOOR = POSITIVE INTEGER IF OPTIONAL OUTPUT IS REQUIRED
C     D(NTERMS) = COEFFICIENTS OF THE POLYNOMIAL (DOUBLE PRECISION, R*8)
C                 Maximum: NTERMS=30
C     SE(K) = RMS OF FIT USING ONLY THE FIRST K COEFFICIENTS (R*8)
C     RDOE(NTERMS) = INDICATES THE STATISTICAL SIGNIFICANCE OF EACH TERM (R*8)
C     SDOR = STANDARD DEVIATION OF RESIDUALS  (R*4)
C     VALMINI = SMALLEST VALUE TOLERABLE TO AVOID "FLOATING UNDERFLOW"
C              (Be carefull if you increase this value, the fit is bad...)
C
C ***************************************************************

      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 X(NDIM,2),Y(NDIM),SDOR
      REAL*8 Z(NDIM),D(30),SUM
      REAL*8 A(30),AKJ(30,30),AA(30),CE(30),DT(30),DYGC(30)
      REAL*8 GGSQT(30),GG(30,30),Q(30,30,2),RDOE(30),REE(30)
      REAL*8 RREE(30),RYG(30),SD(30),SE(30),S(30,30),YGC(30),YG(30)
      DOUBLE PRECISION POLY
      EXTERNAL POLY

      IF(NTERMS.GT.30)THEN
        WRITE(6,*)'NEQSOL/Fatal error: too many terms: NTERMS=',NTERMS
        STOP
      ENDIF
C Smallest value to avoid floating underflow (in computing products of
C such values ...)
C Tried 0.1d-15 too large
C       0.1d-30 too large (where I use it ...)
C@	VALMINI=0.1D-30

      GO TO  (1,9)NOTO
C COMPUTE THE SQUARE OF THE NORM OF THE VECTOR OF THE DEPENDENT VARIABLE,
C COMPUTE THE MEAN OF THE DEPENDENT VARIABLE, YBAR.
1     FLNPTS=NPTS
      YY=Y(1)*Y(1)
      YBAR=Y(1)
      DO 2 I=2,NPTS
      YY=YY+Y(I)*Y(I)
2     YBAR=YBAR+Y(I)
C COMPUTE THE MATRIX OF INNER PRODUCTS OF THE NORMALIZED FITTING FUNCTIONS
      YBAR=YBAR/FLNPTS
      IX=0
      JY=-1
      DO 8 J=1,NTERMS
        IF (IX .NE. 0)THEN
          IX=IX-1
          JY=JY+1
        ELSE
          IX=JY+1
          JY=0
        END IF
       T=0.
       SUM=0.
        DO 4 I=1,NPTS
          GK=1.
          IF (IX .NE. 0) GK=X(I,1)**IX
          IF (JY .NE. 0) GK=GK*X(I,2)**JY
          Z(I)=GK
          T=T+GK*GK
4       SUM=SUM+Y(I)*GK
        GGSQT(J)=DSQRT(T)
        YG(J)=SUM/GGSQT(J)
        GG(J,J)=1.0
        IF (J-1)8,8,5
5       KUL=J-1
        IXX=0
        JYY=-1
        DO 7 K=1,KUL
         IF (IXX .NE. 0)THEN
          IXX=IXX-1
          JYY=JYY+1
         ELSE
          IXX=JYY+1
          JYY=0
         END IF
         T=0.
          DO 6 I=1,NPTS
           GK=1.
           IF (IXX .NE. 0) GK=X(I,1)**IXX
           IF (JYY .NE. 0) GK=GK*X(I,2)**JYY
6          T=T+Z(I)*GK
        GG(J,K)=T/(GGSQT(J)*GGSQT(K))
7       GG(K,J)=GG(J,K)
8     CONTINUE
C COMPUTE THE MATRIX OF COEFFICIENTS, Q, DEFINING THE ORTHOGONAL FUNCTIONS
C IN TERMS OF THE FITTING FUNCTIONS.
9     Q(1,1,NOTO)=1.
      S(1,1)=1.
      AA(1)=1.
      GO TO  (10,12)NOTO
10     DO 11 K=2,NTERMS
         AKJ(K,1)=-GG(K,1)
11     CONTINUE
      GO TO 15
12     DO 14 K=2,NTERMS
        SUM=0.
         DO 13 J=1,K
13       SUM=SUM+Q(K,J,1)*GG(J,1)
14     AKJ(K,1)=-SUM
15    DO 32 K=2,NTERMS
       Q(K,K,NOTO)=1.
       S(K,K)=1.
       JUL=K-1
        DO 19 J=1,JUL
         GO TO (16,17)NOTO
16       T=AKJ(K,J)
         GO TO 19
17       T=0.
           DO 18 L=J,JUL
18         T=T+AKJ(K,L)*S(L,J)
19      S(K,J)=T
        DO 23 J=1,JUL
         SUM=0.
          DO 20 L=J,JUL
20        SUM=SUM+S(K,L)*Q(L,J,1)
         GO TO (21,22)NOTO
21       Q(K,J,1)=SUM
         GO TO 23
22       Q(K,J,2)=SUM+Q(K,J,1)
23      CONTINUE
       SUM=0.
        DO 25 J=1,K
         T=0.
          DO 24 L=1,K
C COMPUTE THE VECTOR OF THE SQUARE OF THE NORM OF THE ORTHOGONAL FUNCTIONS
24        T=T+Q(K,L,NOTO)*GG(L,J)

C To avoid floating underflow :
C	   IF(ABS(T).LT.VALMINI)T=0.

         SUM=SUM+Q(K,J,NOTO)*T
25       CONTINUE
         AA(K)=SUM
         IF (K-NTERMS)26,32,32
26       KPO=K+1
          DO 31 J=KPO,NTERMS
           SUM=0.
            DO 30 L=1,K
             GO TO (27,28)NOTO
27           T=GG(J,L)
             GO TO 30
28           T=0.
               DO 29 M=1,J
29             T=T+Q(J,M,1)*GG(M,L)
30          SUM=SUM+Q(K,L,NOTO)*T
31        AKJ(J,K)=-SUM/AA(K)
32    CONTINUE

C COMPUTE THE LEAST SQUARES COEFFICIENTS, A, FOR THE SOLUTION IN TERMS OF
C THE ORTHOGONAL FUNCTIONS.
      DO 34 K=1,NTERMS
        SUM=0.
         DO 33 J=1,K
33       SUM=SUM+Q(K,J,NOTO)*YG(J)
         A(K)=SUM/AA(K)
C         PRINT *,'JLP2006/ AA(',K,')=',A(K),' SUM=',SUM
34       CONTINUE

C COMPUTE THE LEAST SQUARES COEFFICIENTS,D, FOR THE SOLUTION IN TERMS OF
C THE FITTING FUNCTIONS.
       DO 36 K=1,NTERMS
       SUM=0.
        DO 35 J=K,NTERMS
35      SUM=SUM+Q(J,K,NOTO)*A(J)
       D(K)=SUM/GGSQT(K)
36     DT(K)=SUM
C COMPUTE THE STANDARD DEVIATION OF THE RESIDUALS, SDOR.
      SDOR=0.
      DO 38 I=1,NPTS
        SUM=POLY(X(I,1),X(I,2),D)
C        IF(I.LE.5)PRINT *,'Y,X(I,1),X(I,2),SUM',Y(I),X(I,1),
C     1  X(I,2),SUM
        T=Y(I)-SUM
        SDOR=SDOR+T*T
38    CONTINUE
      SDOR=DSQRT(SDOR/(FLNPTS-NTERMS))
      IF (IOOR)99,99,39
C COMPUTE THE OPTIONAL OUTPUT ONLY IF (IOOR) IS POSITIVE.
39    DO 42 K=1,NTERMS
C COMPUTE THE CHECK FOR THE CONSISTENCY OF THE COEFFICIENTS D.
40     Z(K+200)=YG(K)
       SUM=0.
       DO 41 J=1,NTERMS
        SUM=SUM+DT(J)*GG(K,J)
41     CONTINUE
       YGC(K)=SUM
       DYGC(K)=SUM-YG(K)
       RYG(K)=DYGC(K)/YG(K)
42    CONTINUE
C Compute the orthonormal coefficients, the sum of the squares of residuals,
C the estimates of the standard deviation of the residuals, and the
C term significance ratio.
      SD(1)=A(1)
      CE(1)=YY-A(1)*A(1)*AA(1)
      DEN=NPTS-1
      SE(1)=DSQRT(CE(1)/DEN)
      RDOE(1)=SD(1)/SE(1)
      DO 50 K=2,NTERMS
      IF (AA(K)) 43,44,45
43    SD(K)=-DSQRT(-AA(K))*A(K)
      GO TO 46
44    SD(K)=0.
      GO TO 46
45    SD(K)=DSQRT(AA(K))*A(K)
46    CE(K)=CE(K-1)-A(K)*A(K)*AA(K)
      DEN=NPTS-K
      IF (CE(K))47,48,49
47    SE(K)=-DSQRT(-CE(K)/DEN)
      GO TO 50
48    SE(K)=1.0E-33
      GO TO 50
49    SE(K)=DSQRT(CE(K)/DEN)
50    RDOE(K)=SD(K)/SE(K)
C COMPUTE THE ESTIMATE OF THE ERROR DUE TO ROUNDING AND THE RELATIVE ERROR
C IN THE LEAST SQUARES COEFFICIENTS,A.
      DO 60 K=1,NTERMS
      KMO=K-1
      KPO=K+1
      T=0.
C
      IF (KMO)55,55,51
51    DO 54 J=1,KMO
       SUM=0.
        DO 53 L=1,J
         T1=0.
          DO 52 M=1,K
           T1=T1+Q(K,M,NOTO)*GG(L,M)
52        CONTINUE
         SUM=SUM+Q(J,L,NOTO)*T1
53      CONTINUE
       T=T+A(J)*SUM
54    CONTINUE
C
      IF(K-NTERMS)55,59,59
55    DO 58 J=KPO,NTERMS
      SUM=0.
      DO 57 L=1,J
       T1=0.
        DO 56 M=1,K
         T1=T1+Q(K,M,NOTO)*GG(L,M)
56      CONTINUE
       SUM=SUM+Q(J,L,NOTO)*T1
57    CONTINUE
      T=T+A(J)*SUM
58    CONTINUE
C
59    REE(K)=-T/AA(K)
60    RREE(K)=REE(K)/A(K)

99    CONTINUE
      RETURN
      END
C-------------------------------------------------------------------------
      SUBROUTINE REJECT(X,Y,NDIM,D,NN,KK,TT,M,J)
C*****************************************************************
C
C     SUBROUTINE REJECT(X,Y,NDIM,D,N,K,TT,M,J)
C
C     WRITTEN BY JONES ET AL., 1967
C     MODIFIED BY W D PENCE, 1980
C
C     REJECT ANY POINT WHOSE RESIDUAL IS GREATER THAN BETA*SIGMA
C     FROM THE POLYNOMIAL DEFINED BY THE COEFFICIENTS D.
C
C     X = INDEPENDENT VARIABLE (R*4)
C     Y = THE DEPENDENT VARIABLE (R*4)
C     NDIM = FIRST DIMENSION OF X AND Y  (I*4)
C     D(30) = ARRAY CONTAINING THE POLYNOMIAL COEFFICIENTS (R*8)
C     N = NUMBER OF VALUES TO BE TESTED
C     K = THE NUMBER OF TERMS IN THE POLYNOMIAL
C     TT = THE TEST VALUE USED TO SPECIFY THE REJECTION LEVEL
C     M = THE MODIFIED NUMBER OF VALUES AFTER REJECTION
C     J = AN INDICATOR WHICH IS ZERO ONLY ON THE LAST CALL
C         ( THIS PREVENTS ANY POINTS FROM BEING REJECTED)
C
C***********************************************************
      REAL*4 X(NDIM,2),Y(NDIM)
      INTEGER*4 INDXP(21),INDXN(21)
      INTEGER*4 KK,M,J,NN
      DOUBLE PRECISION D(30),S
      DOUBLE PRECISION POLY
      EXTERNAL POLY
C
      N=NN
      T=TT
      AVR=0.
      DO 9 M=1,21
       INDXN(M)=0
       INDXP(M)=0
9      CONTINUE
      U=0.
      V=0.
      NPOS=0
      NNEG=0
      M=1
      DO 23 I=1,N
      X(M,1)=X(I,1)
      X(M,2)=X(I,2)
      Y(M)=Y(I)
      S=POLY(X(I,1),X(I,2),D)
C
C     R=RESIDUAL FROM POLYNOMIAL FIT
C
      R=Y(I)-S
C      IF(I.LE.3)PRINT *,'Y,X(I,1),X(I,2),S',Y(I),X(I,1),X(I,2),S
      AVR=AVR+R
      IF (R)11,15,12
11    NNEG=NNEG+1
      S=-R
      GO TO 13
12    NPOS=NPOS+1
      S=R
C
C DO NOT INCREMENT COUNTER M IF RESIDUAL IS GREATER THAN T LIMIT
C
13    IF (S-T)15,15,14
14    IF (J)15,15,16
15    M=M+1
16    U=U+R*R
      V=V+R*R*R
      IF (R)17,22,20
17    IF (R+.2)18,19,19
18    INDXN(21)=INDXN(21)+1
      GO TO 23
19    JJ=1.-100.*R
      INDXN(JJ)=INDXN(JJ)+1
      GO TO  23
20    IF (R-0.2)22,22,21
21    INDXP(21)=INDXP(21)+1
      GO TO 23
22    JJ=1.+100.*R
      INDXP(JJ)=INDXP(JJ)+1
23    CONTINUE
      M=M-1
C
      RETURN
      END
C-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION POLY(Z1,Z2,D)
C
C **********************************************************************
C
C    FUNCTION POLY(X,Y,D)
C
C    EVALUATES THE POLYNOMIAL DEFINED BY THE COEFFICIENTS D, AT
C    THE NORMALIZED COORDINATE (X,Y).
C
C    Z1 = NORMALIZED X COORDINATE  (R*4)
C    2 = NORMALIZED Y COORDINATE  (R*4)
C    D(30) = ARRAY CONTAINING THE COEFFICIENTS OF THE POLYNOMIAL (R*8)
C
C    WRITTEN BY W D PENCE, NOV. 1980
C
C **********************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Y)
      REAL*4 Z1,Z2
      REAL*8 X,D(30)
      REAL*8 YLAST,Y1,Y2,Y3,Y4,Y5,Y6
      REAL*8 C0,C1,C2,C3,C4,C5,C6,C7
      DATA YLAST/-2./
      SAVE YLAST
C
C    FIRST, CALC 1-D POLYNOMIAL IN X FOR GIVEN Y VALUE, IF
C    NOT ALREADY DONE
C
      X=Z1
      Y1=Z2
C
      IF (Y1 .NE. YLAST)THEN
       Y2=Y1*Y1
       Y3=Y2*Y1
       Y4=Y3*Y1
       Y5=Y4*Y1
       Y6=Y5*Y1
C
       C0=D(1)+D(3)*Y1+D(6)*Y2+D(10)*Y3+D(15)*Y4+D(21)*Y5+D(28)*Y6
       C1=     D(2)   +D(5)*Y1+D(9) *Y2+D(14)*Y3+D(20)*Y4+D(27)*Y5
       C2=             D(4)   +D(8) *Y1+D(13)*Y2+D(19)*Y3+D(26)*Y4
       C3=                     D(7)    +D(12)*Y1+D(18)*Y2+D(25)*Y3
       C4=                              D(11)   +D(17)*Y1+D(24)*Y2
       C5=                                       D(16)   +D(23)*Y1
       C6=D(22)+D(30)*Y1
       C7=D(29)

      END IF
C
C     EVALUATE POLYNOMIAL IN X
C
      POLY=((((((C7*X+C6)*X+C5)*X+C4)*X+C3)*X+C2)*X+C1)*X+C0
C      IF(I.LE.5) PRINT *,' Z1,Z2,POLY',Z1,Z2,POLY
C
      YLAST=Y1
      RETURN
      END


MODULE Fisher_Test
IMPLICIT NONE

CONTAINS

SUBROUTINE fisher (x, m, y, n, total, possib, p, ifault)

!     ALGORITHM AS 304.1 APPL.STATIST. (1996), VOL.45, NO.3

!     Fisher's non-parametric randomization test for two small
!     independent random samples

IMPLICIT NONE
INTEGER, INTENT(IN OUT)  :: m, n
INTEGER, INTENT(OUT)     :: ifault, total, possib
REAL, INTENT(IN OUT)     :: x(*), y(*)
REAL, INTENT(OUT)        :: p

INTEGER, PARAMETER  :: maxsam = 14, maxsiz = 3432

!        Important : set MAXSIZ >= COMB(MAXSAM, MAXSAM / 2)

INTEGER  :: k, size1, size2, ws3(maxsam)
REAL     :: sumx, sumy, ws1(maxsiz), ws2(maxsiz)

! mean(summ, count) = summ / REAL(count)

IF (comb(maxsam, maxsam/2) > maxsiz) THEN
  ifault = 1
ELSE IF (m > maxsam .OR. n > maxsam) THEN
  ifault = 2
ELSE
  ifault = 0
  sumx = SUM( x(1:m) )
  sumy = SUM( y(1:n) )
  IF (mean(sumx, m) > mean(sumy, n)) THEN
    CALL exchng(x, m, y, n, sumx, sumy)
  END IF
  total = 0
  IF (m == n) THEN
    DO k = 1, (m-1)/2
      CALL ktrade(x, m, ws1, size1, ws3, k)
      CALL ktrade(y, n, ws2, size2, ws3, k)
      total = total + trades(ws1, size1, ws2, size2)
      CALL cmplmt(ws1, size1, sumx)
      CALL cmplmt(ws2, size2, sumy)
      total = total + trades(ws1, size1, ws2, size2)
    END DO
    IF (MOD(m, 2) == 0) THEN
      CALL ktrade(x, m, ws1, size1, ws3, k)
      CALL ktrade(y, n, ws2, size2, ws3, k)
      total = total + trades(ws1, size1, ws2, size2)
    END IF
  ELSE
    DO k = 1, MIN(m, n)
      CALL ktrade(x, m, ws1, size1, ws3, k)
      CALL ktrade(y, n, ws2, size2, ws3, k)
      total = total + trades(ws1, size1, ws2, size2)
    END DO
  END IF
  possib = comb(m+n, m)
  p = REAL(total + 1) / REAL(possib)
END IF

RETURN
END SUBROUTINE fisher

FUNCTION mean(summ, count) RESULT(fn_val)
IMPLICIT NONE

REAL, INTENT(IN)     :: summ
INTEGER, INTENT(IN)  :: count
REAL                 :: fn_val

fn_val = summ / REAL(count)

RETURN
END FUNCTION mean

SUBROUTINE exchng (x, m, y, n, sx, sy)

!     ALGORITHM AS 304.2 APPL.STATIST. (1996), VOL.45, NO.3

!     Exchanges the sample data.  Assumes both X and Y have been
!     previously dimensioned to at least max(M, N) elements

IMPLICIT NONE
INTEGER, INTENT(IN OUT)  :: m, n
REAL, INTENT(IN OUT)     :: x(*), y(*), sx, sy

INTEGER  :: c, k
REAL     :: temp

temp = sx
sx = sy
sy = temp

c = MIN(m, n)
DO k = 1, c
  temp = x(k)
  x(k) = y(k)
  y(k) = temp
END DO
IF (m > n) THEN
  DO k = c+1, m
    y(k) = x(k)
  END DO
  n = m
  m = c
ELSE IF (m < n) THEN
  DO k = c+1, n
    x(k) = y(k)
  END DO
  m = n
  n = c
END IF

RETURN
END SUBROUTINE exchng

SUBROUTINE ktrade (w, k, wprime, kprime, ws, r)

!   ALGORITHM AS 304.3 APPL.STATIST. (1996), VOL.45, NO.3

!   Generates and sorts the sums of the R-combinations of the elements of W.

INTEGER, INTENT(IN)      :: k, r
INTEGER, INTENT(IN OUT)  :: ws(*)
INTEGER, INTENT(OUT)     :: kprime
REAL, INTENT(IN OUT)     :: w(*)
REAL, INTENT(OUT)        :: wprime(*)

kprime = comb(k, r)
IF (r <= k - r .OR. r == k) THEN
  CALL gener(w, k, wprime, kprime, ws, r)
  CALL sort(wprime, kprime)
ELSE
  CALL gener(w, k, wprime, kprime, ws, k - r)
  CALL sort(wprime, kprime)
  CALL cmplmt(wprime, kprime, SUM( w(1:k) ))
END IF

RETURN
END SUBROUTINE ktrade

FUNCTION trades (xprime, mprime, yprime, nprime) RESULT(fn_val)

!     ALGORITHM AS 304.4 APPL.STATIST. (1996), VOL.45, NO.3

!     Returns the number of 1-for-1 trades that refutes the null hypothesis.
!     Assumes that XPRIME has the smaller mean and
!     that both arrays are sorted in ascending order.

INTEGER, INTENT(IN)  :: mprime, nprime
REAL, INTENT(IN)     :: xprime(*), yprime(*)
INTEGER              :: fn_val

INTEGER :: i, j

fn_val = 0
i = 1
j = 1
10 IF (j > nprime) GO TO 40
20 IF (xprime(i) >= yprime(j)) GO TO 30
i = i + 1
IF (i <= mprime) GO TO 20
30 fn_val = fn_val + (mprime - i + 1)
j = j + 1
IF (i <= mprime) GO TO 10

40 RETURN
END FUNCTION trades

SUBROUTINE cmplmt (wprime, kprime, sum)

!        ALGORITHM AS 304.5 APPL.STATIST. (1996), VOL.45, NO.3

!        Reverse and complement the data in WPRIME

IMPLICIT NONE
INTEGER, INTENT(IN)   :: kprime
REAL, INTENT(IN)      :: sum
REAL, INTENT(IN OUT)  :: wprime(*)

INTEGER  :: i, j
REAL     :: temp

j = kprime
DO i = 1, kprime / 2 + MOD(kprime, 2)
  temp = wprime(i)
  wprime(i) = REAL(DBLE(sum) - DBLE(wprime(j)))
  wprime(j) = REAL(DBLE(sum) - DBLE(temp))
  j = j - 1
END DO

RETURN
END SUBROUTINE cmplmt

SUBROUTINE gener (w, n, wprime, nprime, INDEX, r)

!     ALGORITHM AS 304.6 APPL.STATIST. (1996), VOL.45, NO.3

!     Computes an array of sums of the various R-combinations of
!     the elements of W

IMPLICIT NONE
INTEGER, INTENT(IN)      :: n, nprime, r
INTEGER, INTENT(IN OUT)  :: INDEX(r)
REAL, INTENT(IN)         :: w(n)
REAL, INTENT(OUT)        :: wprime(nprime)
INTEGER, PARAMETER       :: dp = SELECTED_REAL_KIND(14, 60)

INTEGER    :: i, j
REAL (dp)  :: sum
LOGICAL    :: init

init = .true.

DO i = 1, nprime
  CALL next(INDEX, r, n, init)
  sum = 0.0D0
  DO j = 1, r
    sum = sum + DBLE(w(INDEX(j)))
  END DO
  wprime(i) = REAL(sum)
END DO

RETURN
END SUBROUTINE gener

SUBROUTINE next (rcombo, r, n, init)

!     ALGORITHM AS 304.7 APPL.STATIST. (1996), VOL.45, NO.3

!     Accepts some R-combination of the first N integers and then
!     computes the next R-combination in the lexicographic
!     ordering of the N! / (R! * (N - R)!) such R-combinations.
!     Returns the first R-combination if the initialization
!     indicator is .true. and then resets the indicator.

IMPLICIT NONE
INTEGER, INTENT(IN)      :: r, n
INTEGER, INTENT(IN OUT)  :: rcombo(r)
LOGICAL, INTENT(IN OUT)  :: init

INTEGER :: i, j, d

IF (init) THEN
  DO i = 1, r
    rcombo(i) = i
  END DO
  init = .false.
ELSE
  d = n - r
  j = r

!        The counter J is not prevented from going out of bounds
!        which will happen if there is no next R-combination

  20 IF (rcombo(j) < d + j) GO TO 30
  j = j - 1
  GO TO 20

  30 rcombo(j) = rcombo(j) + 1
  DO i = j + 1, r
    rcombo(i) = rcombo(i - 1) + 1
  END DO
END IF

RETURN
END SUBROUTINE next

!        General purpose subroutines

SUBROUTINE sort (x, n)

!     ALGORITHM AS 304.8 APPL.STATIST. (1996), VOL.45, NO.3

!     Sorts the N values stored in array X in ascending order

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN OUT)  :: x(n)

INTEGER  :: i, j, incr
REAL     :: temp

incr = 1

!        Loop : calculate the increment

10 incr = 3 * incr + 1
IF (incr <= n) GO TO 10

!        Loop : Shell-Metzner sort

20 incr = incr / 3
i = incr + 1
30 IF (i > n) GO TO 60
temp = x(i)
j = i
40 IF (x(j - incr) < temp) GO TO 50
x(j) = x(j - incr)
j = j - incr
IF (j > incr) GO TO 40
50 x(j) = temp
i = i + 1
GO TO 30
60 IF (incr > 1) GO TO 20

RETURN
END SUBROUTINE sort

FUNCTION comb (n, k) RESULT(fn_val)

!        ALGORITHM AS 304.9 APPL.STATIST. (1996), VOL.45, NO.3

!        Returns the number of combinations of N things taken K at a
!        time or 0 if the parameters are incompatible

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n, k
INTEGER              :: fn_val

INTEGER  :: m, i
REAL     :: numer, denom

IF (k < 0 .OR. k > n) THEN
  fn_val = 0
ELSE
  m = n - k
  numer = 1.0
  DO i = n, 1 + MAX(k, m), -1
    numer = numer * REAL(i)
  END DO
  denom = fact(MIN(k, m))
  fn_val = nint(numer / denom)
END IF

RETURN
END FUNCTION comb

FUNCTION fact (n) RESULT(fn_val)

!     ALGORITHM AS 304.10 APPL.STATIST. (1996), VOL.45, NO.3

!     Returns the factorial of N or 0.0 if the parameter is negative.

IMPLICIT NONE
INTEGER, INTENT(IN) :: n
REAL                :: fn_val

INTEGER  :: i

IF (n < 0) THEN
  fn_val = 0.0
ELSE
  fn_val = 1.0
  DO i = 2, n
    fn_val = fn_val * REAL(i)
  END DO
END IF

RETURN
END FUNCTION fact

END MODULE Fisher_Test


      INTEGER          FUNCTION ICMAX1( N, CX, INCX )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
*     ..
*     .. Array Arguments ..
      COMPLEX            CX( * )
*     ..
*
*  Purpose
*  =======
*
*  ICMAX1 finds the index of the element whose real part has maximum
*  absolute value.
*
*  Based on ICAMAX from Level 1 BLAS.
*  The change is to use the 'genuine' absolute value.
*
*  Contributed by Nick Higham for use with CLACON.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of elements in the vector CX.
*
*  CX      (input) COMPLEX array, dimension (N)
*          The vector whose elements will be summed.
*
*  INCX    (input) INTEGER
*          The spacing between successive values of CX.  INCX >= 1.
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IX
      REAL               SMAX
      COMPLEX            ZDUM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Statement Functions ..
      REAL               CABS1
*     ..
*     .. Statement Function definitions ..
*
*     NEXT LINE IS THE ONLY MODIFICATION.
      CABS1( ZDUM ) = ABS( ZDUM )
*     ..
*     .. Executable Statements ..
*
      ICMAX1 = 0
      IF( N.LT.1 )
     $   RETURN
      ICMAX1 = 1
      IF( N.EQ.1 )
     $   RETURN
      IF( INCX.EQ.1 )
     $   GO TO 30
*
*     CODE FOR INCREMENT NOT EQUAL TO 1
*
      IX = 1
      SMAX = CABS1( CX( 1 ) )
      IX = IX + INCX
      DO 20 I = 2, N
         IF( CABS1( CX( IX ) ).LE.SMAX )
     $      GO TO 10
         ICMAX1 = I
         SMAX = CABS1( CX( IX ) )
   10    CONTINUE
         IX = IX + INCX
   20 CONTINUE
      RETURN
*
*     CODE FOR INCREMENT EQUAL TO 1
*
   30 CONTINUE
      SMAX = CABS1( CX( 1 ) )
      DO 40 I = 2, N
         IF( CABS1( CX( I ) ).LE.SMAX )
     $      GO TO 40
         ICMAX1 = I
         SMAX = CABS1( CX( I ) )
   40 CONTINUE
      RETURN
*
*     End of ICMAX1
*
      END


      !standard fortran interface

      !my function descriptions will be here,
      !other lapack cheats show only different interfaces.

      subroutine assert_eqi( a, b )

        integer a, b

        if ( a /= b) then
          write(*,*) 'assert_eqi failed'
          write(*,*) 'a', a
          write(*,*) 'b', b
          stop 1
        endif

      end

      subroutine assert_eqr( x, y, err )

        real x, y, err

        if ( abs( x - y ) >= err ) then
          write(*,*) 'assert_eqr failed'
          write(*,*) 'y', x
          write(*,*) 'x', y
          write(*,*) 'err', err
          stop 1
        endif

      end

      !euclidean distance |x-y|_2
      function dist2( n, x, y )

        integer n
        real x(n), y(n)

        call saxpy( 2, -1.0, x, 1, y, 1 )
        dist2 = snrm2( n, y, 1 )
        return

      end

      !assert |x-y|_2 <= err
      subroutine assert_eqvr2( n, x, y, err )

        integer n
        real x(n), y(n), err
        real dist2

        if ( dist2( n, x, y ) >= err ) then
          write(*,*) 'assert_eq_vr_norm2 failed'
          write(*,*) 'x', x
          write(*,*) 'y', y
          write(*,*) 'err', err
          stop 1
        endif

      end

      program main

        integer n, nrhs, lda, ldb, info, pivots(2)
        real a2x2(2,2), b2(2), c2(2), x2(2), x4(4), y2(2), err

        err = 10e-6

        !#blas

          !#common arguments

          !most commands start with the array dimension as argument

            !ex:

              x4(1) = 1.0
              x4(2) = 1.0
              x4(3) = 1.0
              x4(4) = 1.0
              call assert_eqr( snrm2(4, x4, 1), 2.0, err )
              !                      ^
              !                      array length

          !#indx

            !argument present on lots of the level 1 ops.

            !takes every nth value only.

            !array must be indx times larger

            !TODO make this work

            x4(1) = 1.0
            x4(2) = 1.0
            x4(3) = 1.0
            x4(4) = 1.0
            !call assert_eqr( snrm2(4, x4, 2), sqrt(2.0), err )
            !                             ^
            !                             indx

          !#nrm2

            !euclidean norm 2

            x2(1) = 1.0
            x2(2) = -2.0
            call assert_eqr( snrm2(2, x2, 1), sqrt(5.0), err )

          !#axpy

            !y = \alpha * x + y

            !x
            x2(1) = 1.0
            x2(2) = -2.0

            !y
            y2(1) = 3.0
            y2(2) = -4.0

            call saxpy(2, 2.0, x2, 1, y2, 1)
            !             1        2      3
            !1: \alpha
            !2: incx
            !3: incy
            call assert_eqr( y2(1), 5.0,  err )
            call assert_eqr( y2(2), -8.0, err )

          !#scal

            !x = \alpha x

            x2(1) = 1.0
            x2(2) = -2.0
            call sscal( 2, 2.0, x2, 1 )

            y2(1) = 2.0
            y2(2) = -4.0
            call assert_eqvr2( 2, x2, y2, err )

          !#i.amax

            !index of largest absolute value in array

            x4(1) = 1.0
            x4(2) = -1.0
            x4(3) = -2.0
            x4(4) = 0.0
            call assert_eqi( isamax(4, x4, 1), 3 )

        !#lapack

          !#gesv

            !solve general linear system

            n         = 2
            nrhs      = 1     !number of columns of b: if many solves several eqs with same A
            a2x2(1,1) = 1.0
            a2x2(1,2) = 2.0
            a2x2(2,1) = 3.0
            a2x2(2,2) = 4.0
            lda       = 2     !max N,1. Leading Dimenstion A
            b2(1)     = 5.0
            b2(2)     = 11.0
            ldb       = 2     !max 1,N

            !result returned inside of b itself:
            !return status returned on `info`:
            !pivots returned on `pivots`:
            call sgesv( n, nrhs, a2x2, lda, pivots, b2, ldb, info )

            c2(1) = 1.0
            c2(2) = 2.0
            call assert_eqi( info, 0 )
            call assert_eqvr2( 2, b2, c2, err );

          !#

        stop
      end


program test_math_is_close

    call test_math_is_close_real
    call test_math_is_close_complex
    print *, "All tests in `test_math_is_close` passed."

contains

    subroutine test_math_is_close_real
        use forlab_math, only: is_close
        use stdlib_error, only: check

        call check(is_close(2.5, 2.5, rel_tol=1.0e-5), msg="is_close(2.5, 2.5, rel_tol=1.0e-5) failed.")
        call check(all(is_close([2.5, 3.2], [2.5, 10.0], rel_tol=1.0e-5)), &
                   msg="all(is_close([2.5, 3.2], [2.5, 10.0], rel_tol=1.0e-5)) failed (expected).", warn=.true.)
        call check(all(is_close(reshape([2.5, 3.2, 2.2, 1.0], [2, 2]), reshape([2.5, 3.2001, 2.25, 1.1], [2, 2]), &
                   abs_tol=1.0e-5, rel_tol=0.1)), &
                   msg="all(is_close(reshape([2.5, 3.2, 2.2, 1.0],[2,2]), reshape([2.5, 3.2001, 2.25, 1.1],[2,2]), &
                   &rel_tol=1.0e-5, abs_tol=0.1)) failed.")

        !> Tests for zeros
        call check(is_close(0.0, -0.0), msg="is_close(0.0, -0.0) failed.")

    end subroutine test_math_is_close_real

    subroutine test_math_is_close_complex
        use forlab_math, only: is_close
        use stdlib_error, only: check

        call check(is_close((2.5,1.2), (2.5,1.2), rel_tol=1.0e-5), &
                   msg="is_close((2.5,1.2), (2.5,1.2), rel_tol=1.0e-5) failed.")
        call check(all(is_close([(2.5,1.2), (3.2,1.2)], [(2.5,1.2), (10.0,1.2)], rel_tol=1.0e-5)), &
                   msg="all(is_close([(2.5,1.2), (3.2,1.2)], [(2.5,1.2), (10.0,1.2)], rel_tol=1.0e-5)) failed (expected).", &
                   warn=.true.)
        call check(all(is_close(reshape([(2.5,1.2009), (3.2,1.199999)], [1, 2]), reshape([(2.4,1.2009), (3.15,1.199999)], [1, 2]), &
                   abs_tol=1.0e-5, rel_tol=0.1)), &
                   msg="all(is_close(reshape([(2.5,1.2009), (3.2,1.199999)], [1, 2]), &
                   &reshape([(2.4,1.2009), (3.15,1.199999)], [1, 2]), &
                   &rel_tol=1.0e-5, abs_tol=0.1)) failed.")

        !> Tests for zeros
        call check(is_close((0.0, -0.0), (-0.0, 0.0)), msg="is_close((0.0, -0.0), (-0.0, 0.0)) failed.")

    end subroutine test_math_is_close_complex

end program test_math_is_close


subroutine getConstants(n, k, q, Voc, V0, AT, Isat)

  implicit none

  !Output
  double precision, intent(out) ::  n, k, q, Voc, V0, AT, Isat

  n = 1.35
  k = 1.38065e-23
  q = 1.60218e-19
  Voc = 2.68/3.0
  V0 = -0.6
  AT = 2.66e-3
  Isat = 2.809e-12

end subroutine getConstants

subroutine computeVcurve(nT, nA, nI, T, A, I, V)

  implicit none

  !Fortran-python interface directives
  !f2py intent(in) nT, nA, nI, T, A, I
  !f2py intent(out) V
  !f2py depend(nT) T
  !f2py depend(nA) A
  !f2py depend(nI) I
  !f2py depend(nT,nA,nI) V

  !Input
  integer, intent(in) ::  nT, nA, nI
  double precision, intent(in) ::  T(nT), A(nA), I(nI)

  !Output
  double precision, intent(out) ::  V(nT,nA,nI)

  !Working
  double precision n, k, q, Voc, V0, AT, Isat
  double precision Isc, Vt
  double precision arg, den
  integer iT, iA, iI

  call getConstants(n, k, q, Voc, V0, AT, Isat)

  do iI=1,nI
     do iA=1,nA
        do iT=1,nT
           Isc = 0.453*A(iA)/AT
           Vt = n*k*T(iT)/q
           arg = (Isc + Isat - I(iI)) / Isat
           den = I(iI) - Isc - V0*Isat/Vt
           if (I(iI) .le. Isc) then
              V(iT,iA,iI) = Vt*log(arg)
           else
              V(iT,iA,iI) = V0**2*Isat/Vt/den + V0
           end if
        end do
     end do
  end do

end subroutine computeVcurve