      !!###USER MODULE: CShep2
      MODULE USR_CShep2
      !!#PURPOSE
      !! Constructs an interpolating spline for two dimensions
      !! via a modified Cubic Shepard method (see below for details).

      !!#ARCHITECT
      !!   William A. Wieselquist | william.wieselquist AT gmail.com
      !!
      !! Simple modifications to behave in a module.
      !!  @ commented out EXTERNAL and flagged with [WAW]
      !!  @ replaced procedure END with END FUNCTION and END SUBROUTINE
      !!  @ added default private and public only for CSHEP2 and CVAL2

      !!#DEFAULT ACCESS
      PRIVATE

      !!#PUBLIC ACCESS LIST
      PUBLIC :: CSHEP2,CS2VAL

      CONTAINS

C--**--CH3808--792--C:Fix--13:6:2000
C--**--CH3805--790--P:DP--13:6:2000
      SUBROUTINE CSHEP2(N,X,Y,F,NC,NW,NR,LCELL,LNEXT,XMIN,YMIN,DX,DY,
     +                  RMAX,RW,A,IER)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/13/97
C
C   This subroutine computes a set of parameters defining a
C C2 (twice continuously differentiable) bivariate function
C C(X,Y) which interpolates data values F at a set of N
C arbitrarily distributed points (X,Y) in the plane (nodes).
C The interpolant C may be evaluated at an arbitrary point
C by function CS2VAL, and its first partial derivatives are
C computed by Subroutine CS2GRD.
C
C   The interpolation scheme is a modified Cubic Shepard
C method:
C
C C = [W(1)*C(1)+W(2)*C(2)+..+W(N)*C(N)]/[W(1)+W(2)+..+W(N)]
C
C for bivariate functions W(k) and C(k).  The nodal func-
C tions are given by
C
C  C(k)(x,y) = A(1,k)*(x-X(k))**3 +
C              A(2,k)*(x-X(k))**2*(y-Y(k)) +
C              A(3,k)*(x-X(k))*(y-Y(k))**2 +
C              A(4,k)*(y-Y(k))**3 + A(5,k)*(x-X(k))**2 +
C              A(6,k)*(x-X(k))*(y-Y(k)) + A(7,k)*(y-Y(k))**2
C              + A(8,k)*(x-X(k)) + A(9,k)*(y-Y(k)) + F(k) .
C
C Thus, C(k) is a cubic function which interpolates the data
C value at node k.  Its coefficients A(,k) are obtained by a
C weighted least squares fit to the closest NC data points
C with weights similar to W(k).  Note that the radius of
C influence for the least squares fit is fixed for each k,
C but varies with k.
C
C The weights are taken to be
C
C   W(k)(x,y) = ( (R(k)-D(k))+ / R(k)*D(k) )**3 ,
C
C where (R(k)-D(k))+ = 0 if R(k) < 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 C(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 data values.  N .GE. 10.
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       NC = Number of data points to be used in the least
C            squares fit for coefficients defining the nodal
C            functions C(k).  Values found to be optimal for
C            test data sets ranged from 11 to 25.  A recom-
C            mended value for general data sets is NC = 17.
C            For nodes lying on (or close to) a rectangular
C            grid, the recommended value is NC = 11.  In any
C            case, NC must be in the range 9 to 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 = 30.  In general, NW should be
C            about 1.5*NC.  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       RW = Array of length .GE. N.
C
C       A = Array of length .GE. 9N.
C
C On output:
C
C       LCELL = NR by NR array of nodal indexes associated
C               with cells.  Refer to Subroutine STORE2.
C
C       LNEXT = Array of length N containing next-node
C               indexes.  Refer to Subroutine STORE2.
C
C       XMIN,YMIN,DX,DY = Minimum nodal coordinates and cell
C                         dimensions.  Refer to Subroutine
C                         STORE2.
C
C       RMAX = Largest element in RW -- maximum radius R(k).
C
C       RW = Array containing the the radii R(k) which enter
C            into the weights W(k).
C
C       A = 9 by N array containing the coefficients for
C           cubic nodal function C(k) in column k.
C
C   Note that the output parameters described above are not
C defined unless IER = 0.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if N, NC, NW, or NR is outside its
C                     valid range.
C             IER = 2 if duplicate nodes were encountered.
C             IER = 3 if all nodes are collinear.
C
C Modules required by CSHEP2:  GETNP2, GIVENS, ROTATE,
C                                SETUP2, STORE2
C
C Intrinsic functions called by CSHEP2:  ABS, DBLE, MAX,
C                                          MIN, SQRT
C
C***********************************************************
C
C     .. Parameters ..
      INTEGER LMX
      PARAMETER (LMX=40)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION DX,DY,RMAX,XMIN,YMIN
      INTEGER IER,N,NC,NR,NW
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION A(9,N),F(N),RW(N),X(N),Y(N)
      INTEGER LCELL(NR,NR),LNEXT(N)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION C,DDX,DDY,DMIN,DTOL,FK,RC,RS,RSMX,RSOLD,RTOL,RWS,
     +                 S,SF,SFC,SFS,STF,SUM,T,XK,XMN,YK,YMN
      INTEGER I,IERR,IP1,IRM1,IROW,J,JP1,K,LMAX,LNP,NCWMAX,NEQ,NN,NNC,
     +        NNR,NNW,NP
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION B(10,10)
      INTEGER NPTS(LMX)
C     ..
C     .. External Subroutines ..
c WAW      EXTERNAL GETNP2,GIVENS,ROTATE,SETUP2,STORE2
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,DBLE,MAX,MIN,SQRT
C     ..
C     .. Data statements ..
C
      DATA RTOL/1.D-5/,DTOL/.01D0/
C     ..
C
C Local parameters:
C
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
C                DMIN*RC .GE. DTOL.
C FK =         Data value at mode K -- F(K)
C I =          Index for A, B, and NPTS
C IERR =       Error flag for the call to Subroutine 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
C LMX =        Maximum value of LMAX
C LNP =        Current length of NPTS
C NEQ =        Number of equations in the least squares fit
C NN,NNC,NNR = Local copies of N, NC, and NR
C NNW =        Local copy of NW
C NP =         NPTS element
C NPTS =       Array containing the indexes of a sequence of
C                nodes to be used in the least squares fit
C                or to compute RW.  The nodes are ordered
C                by distance from K, and the last element
C                (usually indexed by LNP) is used only to
C                determine RC, or RW(K) if NW > NC.
C NCWMAX =     Max(NC,NW)
C RC =         Radius of influence which enters into the
C                weights for C(K) (see Subroutine SETUP2)
C RS =         Squared distance between K and NPTS(LNP) --
C                used to compute RC and RW(K)
C RSMX =       Maximum squared RW 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 squared value of RW(K)
C S =          Second component of the plane rotation deter-
C                mined by subroutine GIVENS
C SF =        Scale factor for the linear terms (columns 8
C               and 9) in the least squares fit -- inverse
C               of the root-mean-square distance between K
C               and the nodes (other than K) in the least
C               squares fit
C SFS =       Scale factor for the quadratic terms (columns
C               5, 6, and 7) in the least squares fit --
C               SF*SF
C SFC =       Scale factor for the cubic terms (first 4
C               columns) in the least squares fit -- SF**3
C STF =        Marquardt stabilization factor used to damp
C                out the first 4 solution components (third
C                partials of the cubic) when the system is
C                ill-conditioned.  As STF increases, the
C                fitting function approaches a quadratic
C                polynomial.
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
      NNC = NC
      NNW = NW
      NNR = NR
      NCWMAX = MAX(NNC,NNW)
      LMAX = MIN(LMX,NN-1)
      IF (NNC.LT.9 .OR. NNW.LT.1 .OR. NCWMAX.GT.LMAX .OR.
     +    NNR.LT.1) GO TO 170
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 190
      RSMX = 0.
C
C Outer loop on node K:
C
      DO 160 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.
          RC = 0.
          LNP = 0
C
C Compute NPTS, LNP, RWS, NEQ, RC, and SFS.
C
   10     SUM = SUM + RS
          IF (LNP.EQ.LMAX) GO TO 20
          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 180
          NPTS(LNP) = NP
          IF ((RS-RSOLD)/RS.LT.RTOL) GO TO 10
          IF (RWS.EQ.0. .AND. LNP.GT.NNW) RWS = RS
          IF (RC.EQ.0. .AND. LNP.GT.NNC) THEN
C
C   RC = 0 (not yet computed) and LNP > NC.  RC = Sqrt(RS)
C     is sufficiently large to (strictly) include NC nodes.
C     The least squares fit will include NEQ = LNP - 1
C     equations for 9 .LE. NC .LE. NEQ .LT. LMAX .LE. N-1.
C
              NEQ = LNP - 1
              RC = SQRT(RS)
              SFS = DBLE(NEQ)/SUM
          END IF
C
C   Bottom of loop -- test for termination.
C
          IF (LNP.GT.NCWMAX) GO TO 30
          GO TO 10
C
C All LMAX nodes are included in NPTS.  RWS and/or RC**2 is
C   (arbitrarily) taken to be 10 percent larger than the
C   distance RS to the last node included.
C
   20     IF (RWS.EQ.0.) RWS = 1.1*RS
          IF (RC.EQ.0.) THEN
              NEQ = LMAX
              RC = SQRT(1.1*RS)
              SFS = DBLE(NEQ)/SUM
          END IF
C
C Store RW(K), update RSMX if necessary, and compute SF
C   and SFC.
C
   30     RW(K) = SQRT(RWS)
          IF (RWS.GT.RSMX) RSMX = RWS
          SF = SQRT(SFS)
          SFC = SF*SFS
C
C A Q-R decomposition is used to solve the least squares
C   system.  The transpose of the augmented regression
C   matrix is stored in B with columns (rows of B) defined
C   as follows:  1-4 are the cubic terms, 5-7 are the quad-
C   ratic terms, 8 and 9 are the linear terms, and the last
C   column is the right hand side.
C
C Set up the equations and zero out the lower triangle with
C   Givens rotations.
C
          I = 0
   40     I = I + 1
          NP = NPTS(I)
          IROW = MIN(I,10)
          CALL SETUP2(XK,YK,FK,X(NP),Y(NP),F(NP),SF,SFS,SFC,RC,
     +                B(1,IROW))
          IF (I.EQ.1) GO TO 40
          IRM1 = IROW - 1
          DO 50 J = 1,IRM1
              JP1 = J + 1
              CALL GIVENS(B(J,J),B(J,IROW),C,S)
              CALL ROTATE(10-J,C,S,B(JP1,J),B(JP1,IROW))
   50     CONTINUE
          IF (I.LT.NEQ) GO TO 40
C
C Test the system for ill-conditioning.
C
          DMIN = MIN(ABS(B(1,1)),ABS(B(2,2)),ABS(B(3,3)),ABS(B(4,4)),
     +           ABS(B(5,5)),ABS(B(6,6)),ABS(B(7,7)),ABS(B(8,8)),
     +           ABS(B(9,9)))
          IF (DMIN*RC.GE.DTOL) GO TO 110
          IF (NEQ.EQ.LMAX) GO TO 70
C
C Increase RC and add another equation to the system to
C   improve the conditioning.  The number of NPTS elements
C   is also increased if necessary.
C
   60     RSOLD = RS
          NEQ = NEQ + 1
          IF (NEQ.EQ.LMAX) THEN
              RC = SQRT(1.1*RS)
              GO TO 40

          END IF

          IF (NEQ.LT.LNP) THEN
C
C   NEQ < LNP.
C
              NP = NPTS(NEQ+1)
              RS = (X(NP)-XK)**2 + (Y(NP)-YK)**2
              IF ((RS-RSOLD)/RS.LT.RTOL) GO TO 60
              RC = SQRT(RS)
              GO TO 40

          END IF
C
C   NEQ = LNP.  Add an element to NPTS.
C
          LNP = LNP + 1
          CALL GETNP2(XK,YK,X,Y,NNR,LCELL,LNEXT,XMN,YMN,DDX,DDY,NP,RS)
          IF (NP.EQ.0) GO TO 180
          NPTS(LNP) = NP
          IF ((RS-RSOLD)/RS.LT.RTOL) GO TO 60
          RC = SQRT(RS)
          GO TO 40
C
C Stabilize the system by damping third partials -- add
C   multiples of the first four unit vectors to the first
C   four equations.
C
   70     STF = 1.0/RC
          DO 100 I = 1,4
              B(I,10) = STF
              IP1 = I + 1
              DO 80 J = IP1,10
                  B(J,10) = 0.
   80         CONTINUE
              DO 90 J = I,9
                  JP1 = J + 1
                  CALL GIVENS(B(J,J),B(J,10),C,S)
                  CALL ROTATE(10-J,C,S,B(JP1,J),B(JP1,10))
   90         CONTINUE
  100     CONTINUE
C
C Test the damped system for ill-conditioning.
C
          DMIN = MIN(ABS(B(5,5)),ABS(B(6,6)),ABS(B(7,7)),ABS(B(8,8)),
     +           ABS(B(9,9)))
          IF (DMIN*RC.LT.DTOL) GO TO 190
C
C Solve the 9 by 9 triangular system for the coefficients.
C
  110     DO 130 I = 9,1,-1
              T = 0.
              IF (I.NE.9) THEN
                  IP1 = I + 1
                  DO 120 J = IP1,9
                      T = T + B(J,I)*A(J,K)
  120             CONTINUE
              END IF

              A(I,K) = (B(10,I)-T)/B(I,I)
  130     CONTINUE
C
C Scale the coefficients to adjust for the column scaling.
C
          DO 140 I = 1,4
              A(I,K) = A(I,K)*SFC
  140     CONTINUE
          A(5,K) = A(5,K)*SFS
          A(6,K) = A(6,K)*SFS
          A(7,K) = A(7,K)*SFS
          A(8,K) = A(8,K)*SF
          A(9,K) = A(9,K)*SF
C
C Unmark K and the elements of NPTS.
C
          LNEXT(K) = -LNEXT(K)
          DO 150 I = 1,LNP
              NP = NPTS(I)
              LNEXT(NP) = -LNEXT(NP)
  150     CONTINUE
  160 CONTINUE
C
C No errors encountered.
C
      XMIN = XMN
      YMIN = YMN
      DX = DDX
      DY = DDY
      RMAX = SQRT(RSMX)
      IER = 0
      RETURN
C
C N, NC, NW, or NR is outside its valid range.
C
  170 IER = 1
      RETURN
C
C Duplicate nodes were encountered by GETNP2.
C
  180 IER = 2
      RETURN
C
C No unique solution due to collinear nodes.
C
  190 XMIN = XMN
      YMIN = YMN
      DX = DDX
      DY = DDY
      IER = 3
      RETURN

      END SUBROUTINE

      DOUBLE PRECISION FUNCTION CS2VAL(PX,PY,N,X,Y,F,NR,LCELL,LNEXT,
     +                 XMIN,YMIN,DX,DY,RMAX,RW,A)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/03/97
C
C   This function returns the value C(PX,PY), where C is the
C weighted sum of cubic nodal functions defined in Subrou-
C tine CSHEP2.  CS2GRD may be called to compute a gradient
C of C along with the value, and/or to test for errors.
C CS2HES may be called to compute a value, first partial
C derivatives, and second partial derivatives at a point.
C
C On input:
C
C       PX,PY = Cartesian coordinates of the point P at
C               which C is to be evaluated.
C
C       N = Number of nodes and data values defining C.
C           N .GE. 10.
C
C       X,Y,F = Arrays of length N containing the nodes and
C               data values interpolated by C.
C
C       NR = Number of rows and columns in the cell grid.
C            Refer to Subroutine STORE2.  NR .GE. 1.
C
C       LCELL = NR by NR array of nodal indexes associated
C               with cells.  Refer to Subroutine STORE2.
C
C       LNEXT = Array of length N containing next-node
C               indexes.  Refer to Subroutine STORE2.
C
C       XMIN,YMIN,DX,DY = Minimum nodal coordinates and cell
C                         dimensions.  DX and DY must be
C                         positive.  Refer to Subroutine
C                         STORE2.
C
C       RMAX = Largest element in RW -- maximum radius R(k).
C
C       RW = Array containing the the radii R(k) which enter
C            into the weights W(k) defining C.
C
C       A = 9 by N array containing the coefficients for
C           cubic nodal function C(k) in column k.
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 CSHEP2.  This function
C should not be called if a nonzero error flag was returned
C by CSHEP2.
C
C On output:
C
C       CS2VAL = Function value C(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 CS2VAL:  NONE
C
C Intrinsic functions called by CS2VAL:  INT, SQRT
C
C***********************************************************
C
C
C Local parameters:
C
C D =         Distance between P and node K
C DELX =      XP - X(K)
C DELY =      YP - Y(K)
C I =         Cell row index in the range IMIN to IMAX
C IMIN,IMAX = Range of cell row indexes of the cells
C               intersected by a disk of radius RMAX
C               centered at P
C J =         Cell column index in the range JMIN to JMAX
C JMIN,JMAX = Range of cell column indexes of the cells
C               intersected by a disk of radius RMAX
C               centered at P
C K =         Index of a node in cell (I,J)
C KP =        Previous value of K in the sequence of nodes
C               in cell (I,J)
C R =         Radius of influence for node K
C SW =        Sum of weights W(K)
C SWC =       Sum of weighted nodal function values at P
C W =         Weight W(K) value at P:  ((R-D)+/(R*D))**3,
C               where (R-D)+ = 0 if R < D
C XP,YP =     Local copies of PX and PY -- coordinates of P
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION DX,DY,PX,PY,RMAX,XMIN,YMIN
      INTEGER N,NR
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION A(9,N),F(N),RW(N),X(N),Y(N)
      INTEGER LCELL(NR,NR),LNEXT(N)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION D,DELX,DELY,R,SW,SWC,W,XP,YP
      INTEGER I,IMAX,IMIN,J,JMAX,JMIN,K,KP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC INT,SQRT
C     ..
      XP = PX
      YP = PY
      IF (N.LT.10 .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 indexes 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 = INT((XP-XMIN-RMAX)/DX) + 1
      IMAX = INT((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN.LT.1) IMIN = 1
      IF (IMAX.GT.NR) IMAX = NR
      JMIN = INT((YP-YMIN-RMAX)/DY) + 1
      JMAX = INT((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 60
C
C Accumulate weight values in SW and weighted nodal function
C   values in SWC.  The weights are W(K) = ((R-D)+/(R*D))**3
C   for R = RW(K) and D = distance between P and node K.
C
      SW = 0.
      SWC = 0.
C
C Outer loop on cells (I,J).
C
      DO 40 J = JMIN,JMAX
          DO 30 I = IMIN,IMAX
              K = LCELL(I,J)
              IF (K.EQ.0) GO TO 30
C
C Inner loop on nodes K.
C
   10         DELX = XP - X(K)
              DELY = YP - Y(K)
              D = SQRT(DELX*DELX+DELY*DELY)
              R = RW(K)
              IF (D.GE.R) GO TO 20
              IF (D.EQ.0.) GO TO 50
              W = (1.0/D-1.0/R)**3
              SW = SW + W
              SWC = SWC + W* (((A(1,K)*DELX+A(2,K)*DELY+A(5,
     +              K))*DELX+ (A(3,K)*DELY+A(6,K))*DELY+A(8,K))*DELX+
     +              ((A(4,K)*DELY+A(7,K))*DELY+A(9,K))*DELY+F(K))
C
C Bottom of loop on nodes in cell (I,J).
C
   20         KP = K
              K = LNEXT(KP)
              IF (K.NE.KP) GO TO 10
   30     CONTINUE
   40 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 60
      CS2VAL = SWC/SW
      RETURN
C
C (PX,PY) = (X(K),Y(K)).
C
   50 CS2VAL = F(K)
      RETURN
C
C All weights are 0 at P.
C
   60 CS2VAL = 0.
      RETURN

      END FUNCTION

      SUBROUTINE CS2GRD(PX,PY,N,X,Y,F,NR,LCELL,LNEXT,XMIN,YMIN,DX,DY,
     +                  RMAX,RW,A,C,CX,CY,IER)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/03/97
C
C   This subroutine computes the value and gradient at P =
C (PX,PY) of the interpolatory function C defined in Sub-
C routine CSHEP2.  C is a weighted sum of cubic nodal
C functions.
C
C On input:
C
C       PX,PY = Cartesian coordinates of the point P at
C               which C and its partial derivatives are
C               to be evaluated.
C
C       N = Number of nodes and data values defining C.
C           N .GE. 10.
C
C       X,Y,F = Arrays of length N containing the nodes and
C               data values interpolated by C.
C
C       NR = Number of rows and columns in the cell grid.
C            Refer to Subroutine STORE2.  NR .GE. 1.
C
C       LCELL = NR by NR array of nodal indexes associated
C               with cells.  Refer to Subroutine STORE2.
C
C       LNEXT = Array of length N containing next-node
C               indexes.  Refer to Subroutine STORE2.
C
C       XMIN,YMIN,DX,DY = Minimum nodal coordinates and cell
C                         dimensions.  DX and DY must be
C                         positive.  Refer to Subroutine
C                         STORE2.
C
C       RMAX = Largest element in RW -- maximum radius R(k).
C
C       RW = Array of length N containing the the radii R(k)
C            which enter into the weights W(k) defining C.
C
C       A = 9 by N array containing the coefficients for
C           cubic nodal function C(k) in column k.
C
C   Input parameters are not altered by this subroutine.
C The parameters other than PX and PY should be input
C unaltered from their values on output from CSHEP2.  This
C subroutine should not be called if a nonzero error flag
C was returned by CSHEP2.
C
C On output:
C
C       C = Value of C at (PX,PY) unless IER .EQ. 1, in
C           which case no values are returned.
C
C       CX,CY = First partial derivatives of C 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 C=CX=CY=0).
C
C Modules required by CS2GRD:  None
C
C Intrinsic functions called by CS2GRD:  INT, SQRT
C
C***********************************************************
C
C
C Local parameters:
C
C CK =        Value of cubic nodal function C(K) at P
C CKX,CKY =   Partial derivatives of C(K) with respect to X
C               and Y, respectively
C D =         Distance between P and node K
C DELX =      XP - X(K)
C DELY =      YP - Y(K)
C I =         Cell row index in the range IMIN to IMAX
C IMIN,IMAX = Range of cell row indexes of the cells
C               intersected by a disk of radius RMAX
C               centered at P
C J =         Cell column index in the range JMIN to JMAX
C JMIN,JMAX = Range of cell column indexes of the cells
C               intersected by a disk of radius RMAX
C               centered at P
C K =         Index of a node in cell (I,J)
C KP =        Previous value of K in the sequence of nodes
C               in cell (I,J)
C R =         Radius of influence for node K
C SW =        Sum of weights W(K)
C SWC =       Sum of weighted nodal function values at P
C SWCX,SWCY = Partial derivatives of SWC with respect to X
C               and Y, respectively
C SWS =       SW**2
C SWX,SWY =   Partial derivatives of SW with respect to X
C               and Y, respectively
C T =         Temporary variable
C W =         Weight W(K) value at P:  ((R-D)+/(R*D))**3,
C               where (R-D)+ = 0 if R < D
C WX,WY =     Partial derivatives of W with respect to X
C               and Y, respectively
C XP,YP =     Local copies of PX and PY -- coordinates of P
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION C,CX,CY,DX,DY,PX,PY,RMAX,XMIN,YMIN
      INTEGER IER,N,NR
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION A(9,N),F(N),RW(N),X(N),Y(N)
      INTEGER LCELL(NR,NR),LNEXT(N)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION CK,CKX,CKY,D,DELX,DELY,R,SW,SWC,SWCX,SWCY,SWS,
     +                 SWX,SWY,T,W,WX,WY,XP,YP
      INTEGER I,IMAX,IMIN,J,JMAX,JMIN,K,KP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC INT,SQRT
C     ..
      XP = PX
      YP = PY
      IF (N.LT.10 .OR. NR.LT.1 .OR. DX.LE.0. .OR. DY.LE.0. .OR.
     +    RMAX.LT.0.) GO TO 60
C
C Set IMIN, IMAX, JMIN, and JMAX to cell indexes 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 = INT((XP-XMIN-RMAX)/DX) + 1
      IMAX = INT((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN.LT.1) IMIN = 1
      IF (IMAX.GT.NR) IMAX = NR
      JMIN = INT((YP-YMIN-RMAX)/DY) + 1
      JMAX = INT((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 70
C
C C = SWC/SW = Sum(W(K)*C(K))/Sum(W(K)), where the sum is
C   from K = 1 to N, C(K) is the cubic nodal function value,
C   and W(K) = ((R-D)+/(R*D))**3 for radius R(K) and dist-
C   ance D(K).  Thus
C
C        CX = (SWCX*SW - SWC*SWX)/SW**2  and
C        CY = (SWCY*SW - SWC*SWY)/SW**2
C
C   where SWCX and SWX are partial derivatives with respect
C   to X of SWC and SW, respectively.  SWCY and SWY are de-
C   fined similarly.
C
      SW = 0.
      SWX = 0.
      SWY = 0.
      SWC = 0.
      SWCX = 0.
      SWCY = 0.
C
C Outer loop on cells (I,J).
C
      DO 40 J = JMIN,JMAX
          DO 30 I = IMIN,IMAX
              K = LCELL(I,J)
              IF (K.EQ.0) GO TO 30
C
C Inner loop on nodes K.
C
   10         DELX = XP - X(K)
              DELY = YP - Y(K)
              D = SQRT(DELX*DELX+DELY*DELY)
              R = RW(K)
              IF (D.GE.R) GO TO 20
              IF (D.EQ.0.) GO TO 50
              T = (1.0/D-1.0/R)
              W = T**3
              T = -3.0*T*T/ (D**3)
              WX = DELX*T
              WY = DELY*T
              T = A(2,K)*DELX + A(3,K)*DELY + A(6,K)
              CKY = (3.0*A(4,K)*DELY+A(3,K)*DELX+2.0*A(7,K))*DELY +
     +              T*DELX + A(9,K)
              T = T*DELY + A(8,K)
              CKX = (3.0*A(1,K)*DELX+A(2,K)*DELY+2.0*A(5,K))*DELX + T
              CK = ((A(1,K)*DELX+A(5,K))*DELX+T)*DELX +
     +             ((A(4,K)*DELY+A(7,K))*DELY+A(9,K))*DELY + F(K)
              SW = SW + W
              SWX = SWX + WX
              SWY = SWY + WY
              SWC = SWC + W*CK
              SWCX = SWCX + WX*CK + W*CKX
              SWCY = SWCY + WY*CK + W*CKY
C
C Bottom of loop on nodes in cell (I,J).
C
   20         KP = K
              K = LNEXT(KP)
              IF (K.NE.KP) GO TO 10
   30     CONTINUE
   40 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 70
      C = SWC/SW
      SWS = SW*SW
      CX = (SWCX*SW-SWC*SWX)/SWS
      CY = (SWCY*SW-SWC*SWY)/SWS
      IER = 0
      RETURN
C
C (PX,PY) = (X(K),Y(K)).
C
   50 C = F(K)
      CX = A(8,K)
      CY = A(9,K)
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   60 IER = 1
      RETURN
C
C No cells contain a point within RMAX of P, or
C   SW = 0 and thus D .GE. RW(K) for all K.
C
   70 C = 0.
      CX = 0.
      CY = 0.
      IER = 2
      RETURN

      END SUBROUTINE

      SUBROUTINE CS2HES(PX,PY,N,X,Y,F,NR,LCELL,LNEXT,XMIN,YMIN,DX,DY,
     +                  RMAX,RW,A,C,CX,CY,CXX,CXY,CYY,IER)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/03/97
C
C   This subroutine computes the value, gradient, and
C Hessian at P = (PX,PY) of the interpolatory function C
C defined in Subroutine CSHEP2.  C is a weighted sum of
C cubic nodal functions.
C
C On input:
C
C       PX,PY = Cartesian coordinates of the point P at
C               which C and its partial derivatives are
C               to be evaluated.
C
C       N = Number of nodes and data values defining C.
C           N .GE. 10.
C
C       X,Y,F = Arrays of length N containing the nodes and
C               data values interpolated by C.
C
C       NR = Number of rows and columns in the cell grid.
C            Refer to Subroutine STORE2.  NR .GE. 1.
C
C       LCELL = NR by NR array of nodal indexes associated
C               with cells.  Refer to Subroutine STORE2.
C
C       LNEXT = Array of length N containing next-node
C               indexes.  Refer to Subroutine STORE2.
C
C       XMIN,YMIN,DX,DY = Minimum nodal coordinates and cell
C                         dimensions.  DX and DY must be
C                         positive.  Refer to Subroutine
C                         STORE2.
C
C       RMAX = Largest element in RW -- maximum radius R(k).
C
C       RW = Array of length N containing the the radii R(k)
C            which enter into the weights W(k) defining C.
C
C       A = 9 by N array containing the coefficients for
C           cubic nodal function C(k) in column k.
C
C   Input parameters are not altered by this subroutine.
C The parameters other than PX and PY should be input
C unaltered from their values on output from CSHEP2.  This
C subroutine should not be called if a nonzero error flag
C was returned by CSHEP2.
C
C On output:
C
C       C = Value of C at (PX,PY) unless IER .EQ. 1, in
C           which case no values are returned.
C
C       CX,CY = First partial derivatives of C at (PX,PY)
C               unless IER .EQ. 1.
C
C       CXX,CXY,CYY = Second partial derivatives of C at
C                     (PX,PY) 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 C = 0).
C
C Modules required by CS2HES:  None
C
C Intrinsic functions called by CS2HES:  INT, SQRT
C
C***********************************************************
C
C
C Local parameters:
C
C CK =        Value of cubic nodal function C(K) at P
C CKX,CKY =   Partial derivatives of C(K) with respect to X
C               and Y, respectively
C CKXX,CKXY,CKYY = Second partial derivatives of CK
C D =         Distance between P and node K
C DELX =      XP - X(K)
C DELY =      YP - Y(K)
C DXSQ,DYSQ = DELX**2, DELY**2
C I =         Cell row index in the range IMIN to IMAX
C IMIN,IMAX = Range of cell row indexes of the cells
C               intersected by a disk of radius RMAX
C               centered at P
C J =         Cell column index in the range JMIN to JMAX
C JMIN,JMAX = Range of cell column indexes of the cells
C               intersected by a disk of radius RMAX
C               centered at P
C K =         Index of a node in cell (I,J)
C KP =        Previous value of K in the sequence of nodes
C               in cell (I,J)
C R =         Radius of influence for node K
C SW =        Sum of weights W(K)
C SWC =       Sum of weighted nodal function values at P
C SWCX,SWCY = Partial derivatives of SWC with respect to X
C               and Y, respectively
C SWCXX,SWCXY,SWCYY = Second partial derivatives of SWC
C SWS =       SW**2
C SWX,SWY =   Partial derivatives of SW with respect to X
C               and Y, respectively
C SWXX,SWXY,SWYY = Second partial derivatives of SW
C T1,T2,T3,T4 = Temporary variables
C W =         Weight W(K) value at P:  ((R-D)+/(R*D))**3,
C               where (R-D)+ = 0 if R < D
C WX,WY =     Partial derivatives of W with respect to X
C               and Y, respectively
C WXX,WXY,WYY = Second partial derivatives of W
C XP,YP =     Local copies of PX and PY -- coordinates of P
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION C,CX,CXX,CXY,CY,CYY,DX,DY,PX,PY,RMAX,XMIN,YMIN
      INTEGER IER,N,NR
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION A(9,N),F(N),RW(N),X(N),Y(N)
      INTEGER LCELL(NR,NR),LNEXT(N)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION CK,CKX,CKXX,CKXY,CKY,CKYY,D,DELX,DELY,DXSQ,DYSQ,
     +                 R,SW,SWC,SWCX,SWCXX,SWCXY,SWCY,SWCYY,SWS,SWX,
     +                 SWXX,SWXY,SWY,SWYY,T1,T2,T3,T4,W,WX,WXX,WXY,WY,
     +                 WYY,XP,YP
      INTEGER I,IMAX,IMIN,J,JMAX,JMIN,K,KP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC INT,SQRT
C     ..
      XP = PX
      YP = PY
      IF (N.LT.10 .OR. NR.LT.1 .OR. DX.LE.0. .OR. DY.LE.0. .OR.
     +    RMAX.LT.0.) GO TO 60
C
C Set IMIN, IMAX, JMIN, and JMAX to cell indexes 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 = INT((XP-XMIN-RMAX)/DX) + 1
      IMAX = INT((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN.LT.1) IMIN = 1
      IF (IMAX.GT.NR) IMAX = NR
      JMIN = INT((YP-YMIN-RMAX)/DY) + 1
      JMAX = INT((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 70
C
C C = SWC/SW = Sum(W(K)*C(K))/Sum(W(K)), where the sum is
C   from K = 1 to N, C(K) is the cubic nodal function value,
C   and W(K) = ((R-D)+/(R*D))**3 for radius R(K) and dist-
C   ance D(K).  Thus
C
C        CX = (SWCX*SW - SWC*SWX)/SW**2  and
C        CY = (SWCY*SW - SWC*SWY)/SW**2
C
C   where SWCX and SWX are partial derivatives with respect
C   to x of SWC and SW, respectively.  SWCY and SWY are de-
C   fined similarly.  The second partials are
C
C        CXX = ( SW*(SWCXX -    2*SWX*CX) - SWC*SWXX )/SW**2
C        CXY = ( SW*(SWCXY-SWX*CY-SWY*CX) - SWC*SWXY )/SW**2
C        CYY = ( SW*(SWCYY -    2*SWY*CY) - SWC*SWYY )/SW**2
C
C   where SWCXX and SWXX are second partials with respect
C   to x, SWCXY and SWXY are mixed partials, and SWCYY and
C   SWYY are second partials with respect to y.
C
      SW = 0.
      SWX = 0.
      SWY = 0.
      SWXX = 0.
      SWXY = 0.
      SWYY = 0.
      SWC = 0.
      SWCX = 0.
      SWCY = 0.
      SWCXX = 0.
      SWCXY = 0.
      SWCYY = 0.
C
C Outer loop on cells (I,J).
C
      DO 40 J = JMIN,JMAX
          DO 30 I = IMIN,IMAX
              K = LCELL(I,J)
              IF (K.EQ.0) GO TO 30
C
C Inner loop on nodes K.
C
   10         DELX = XP - X(K)
              DELY = YP - Y(K)
              DXSQ = DELX*DELX
              DYSQ = DELY*DELY
              D = SQRT(DXSQ+DYSQ)
              R = RW(K)
              IF (D.GE.R) GO TO 20
              IF (D.EQ.0.) GO TO 50
              T1 = (1.0/D-1.0/R)
              W = T1**3
              T2 = -3.0*T1*T1/ (D**3)
              WX = DELX*T2
              WY = DELY*T2
              T1 = 3.0*T1* (2.0+3.0*D*T1)/ (D**6)
              WXX = T1*DXSQ + T2
              WXY = T1*DELX*DELY
              WYY = T1*DYSQ + T2
              T1 = A(1,K)*DELX + A(2,K)*DELY + A(5,K)
              T2 = T1 + T1 + A(1,K)*DELX
              T3 = A(4,K)*DELY + A(3,K)*DELX + A(7,K)
              T4 = T3 + T3 + A(4,K)*DELY
              CK = (T1*DELX+A(6,K)*DELY+A(8,K))*DELX +
     +             (T3*DELY+A(9,K))*DELY + F(K)
              CKX = T2*DELX + (A(3,K)*DELY+A(6,K))*DELY + A(8,K)
              CKY = T4*DELY + (A(2,K)*DELX+A(6,K))*DELX + A(9,K)
              CKXX = T2 + 3.0*A(1,K)*DELX
              CKXY = 2.0* (A(2,K)*DELX+A(3,K)*DELY) + A(6,K)
              CKYY = T4 + 3.0*A(4,K)*DELY
              SW = SW + W
              SWX = SWX + WX
              SWY = SWY + WY
              SWXX = SWXX + WXX
              SWXY = SWXY + WXY
              SWYY = SWYY + WYY
              SWC = SWC + W*CK
              SWCX = SWCX + WX*CK + W*CKX
              SWCY = SWCY + WY*CK + W*CKY
              SWCXX = SWCXX + W*CKXX + 2.0*WX*CKX + CK*WXX
              SWCXY = SWCXY + W*CKXY + WX*CKY + WY*CKX + CK*WXY
              SWCYY = SWCYY + W*CKYY + 2.0*WY*CKY + CK*WYY
C
C Bottom of loop on nodes in cell (I,J).
C
   20         KP = K
              K = LNEXT(KP)
              IF (K.NE.KP) GO TO 10
   30     CONTINUE
   40 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 70
      C = SWC/SW
      SWS = SW*SW
      CX = (SWCX*SW-SWC*SWX)/SWS
      CY = (SWCY*SW-SWC*SWY)/SWS
      CXX = (SW* (SWCXX-2.0*SWX*CX)-SWC*SWXX)/SWS
      CXY = (SW* (SWCXY-SWY*CX-SWX*CY)-SWC*SWXY)/SWS
      CYY = (SW* (SWCYY-2.0*SWY*CY)-SWC*SWYY)/SWS
      IER = 0
      RETURN
C
C (PX,PY) = (X(K),Y(K)).
C
   50 C = F(K)
      CX = A(8,K)
      CY = A(9,K)
      CXX = 2.0*A(5,K)
      CXY = A(6,K)
      CYY = 2.0*A(7,K)
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   60 IER = 1
      RETURN
C
C No cells contain a point within RMAX of P, or
C   SW = 0 and thus D .GE. RW(K) for all K.
C
   70 C = 0.
      CX = 0.
      CY = 0.
      CXX = 0.
      CXY = 0.
      CYY = 0.
      IER = 2
      RETURN

      END SUBROUTINE
      SUBROUTINE GETNP2(PX,PY,X,Y,NR,LCELL,LNEXT,XMIN,YMIN,DX,DY,NP,DSQ)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/03/97
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
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   This code is essentially unaltered from the subroutine
C of the same name in QSHEP2D.
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            Refer to Subroutine STORE2.  NR .GE. 1.
C
C       LCELL = NR by NR array of nodal indexes associated
C               with cells.  Refer to Subroutine STORE2.
C
C       LNEXT = Array of length N containing next-node
C               indexes (or their negatives).  Refer to
C               Subroutine STORE2.
C
C       XMIN,YMIN,DX,DY = Minimum nodal coordinates and cell
C                         dimensions.  DX and DY must be
C                         positive.  Refer to Subroutine
C                         STORE2.
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:  ABS, INT, SQRT
C
C***********************************************************
C
C
C Local parameters:
C
C DELX,DELY =   PX-XMIN, PY-YMIN
C FIRST =       Logical variable with value TRUE iff the
C                 first unmarked node has yet to be
C                 encountered
C I,J =         Cell indexes in the range [I1,I2] X [J1,J2]
C I0,J0 =       Indexes of the cell containing or closest
C                 to P
C I1,I2,J1,J2 = Range of cell indexes defining the layer
C                 whose intersection with the range
C                 [IMIN,IMAX] X [JMIN,JMAX] is currently
C                 being searched
C IMIN,IMAX =   Cell row indexes defining the range of the
C                 search
C JMIN,JMAX =   Cell column indexes defining the range of
C                 the search
C L,LN =        Indexes of nodes in cell (I,J)
C LMIN =        Current candidate for NP
C R =           Distance from P to node LMIN
C RSMIN =       Squared distance from P to node LMIN
C RSQ =         Squared distance from P to node L
C XP,YP =       Local copy of PX,PY -- coordinates of P
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION DSQ,DX,DY,PX,PY,XMIN,YMIN
      INTEGER NP,NR
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION X(*),Y(*)
      INTEGER LCELL(NR,NR),LNEXT(*)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION DELX,DELY,R,RSMIN,RSQ,XP,YP
      INTEGER I,I0,I1,I2,IMAX,IMIN,J,J0,J1,J2,JMAX,JMIN,L,LMIN,LN
      LOGICAL FIRST
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,INT,SQRT
C     ..
      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 90
C
C Initialize parameters.
C
      FIRST = .TRUE.
      IMIN = 1
      IMAX = NR
      JMIN = 1
      JMAX = NR
      DELX = XP - XMIN
      DELY = YP - YMIN
      I0 = INT(DELX/DX) + 1
      IF (I0.LT.1) I0 = 1
      IF (I0.GT.NR) I0 = NR
      J0 = INT(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
   10 DO 60 J = J1,J2
          IF (J.GT.JMAX) GO TO 70
          IF (J.LT.JMIN) GO TO 60
          DO 50 I = I1,I2
              IF (I.GT.IMAX) GO TO 60
              IF (I.LT.IMIN) GO TO 50
              IF (J.NE.J1 .AND. J.NE.J2 .AND. I.NE.I1 .AND.
     +            I.NE.I2) GO TO 50
C
C Search cell (I,J) for unmarked nodes L.
C
              L = LCELL(I,J)
              IF (L.EQ.0) GO TO 50
C
C   Loop on nodes in cell (I,J).
C
   20         LN = LNEXT(L)
              IF (LN.LT.0) GO TO 40
C
C   Node L is not marked.
C
              RSQ = (X(L)-XP)**2 + (Y(L)-YP)**2
              IF (.NOT.FIRST) GO TO 30
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 > NR,
C     IMAX < 1, JMIN > NR, or JMAX < 1).  FIRST is reset to
C     FALSE.
C
              LMIN = L
              RSMIN = RSQ
              R = SQRT(RSMIN)
              IMIN = INT((DELX-R)/DX) + 1
              IF (IMIN.LT.1) IMIN = 1
              IMAX = INT((DELX+R)/DX) + 1
              IF (IMAX.GT.NR) IMAX = NR
              JMIN = INT((DELY-R)/DY) + 1
              IF (JMIN.LT.1) JMIN = 1
              JMAX = INT((DELY+R)/DY) + 1
              IF (JMAX.GT.NR) JMAX = NR
              FIRST = .FALSE.
              GO TO 40
C
C   Test for node L closer than LMIN to P.
C
   30         IF (RSQ.GE.RSMIN) GO TO 40
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
   40         IF (ABS(LN).EQ.L) GO TO 50
              L = ABS(LN)
              GO TO 20

   50     CONTINUE
   60 CONTINUE
C
C Test for termination of loop on cell layers.
C
   70 IF (I1.LE.IMIN .AND. I2.GE.IMAX .AND. J1.LE.JMIN .AND.
     +    J2.GE.JMAX) GO TO 80
      I1 = I1 - 1
      I2 = I2 + 1
      J1 = J1 - 1
      J2 = J2 + 1
      GO TO 10
C
C Unless no unmarked nodes were encountered, LMIN is the
C   closest unmarked node to P.
C
   80 IF (FIRST) GO TO 90
      NP = LMIN
      DSQ = RSMIN
      LNEXT(LMIN) = -LNEXT(LMIN)
      RETURN
C
C Error:  NR, DX, or DY is invalid or all nodes are marked.
C
   90 NP = 0
      DSQ = 0.
      RETURN

      END SUBROUTINE

      SUBROUTINE GIVENS(A,B,C,S)
C
C***********************************************************
C
C                                               From SRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   This subroutine constructs the Givens plane rotation,
C
C           ( C  S)
C       G = (     ) , where C*C + S*S = 1,
C           (-S  C)
C
C which zeros the second component of the vector (A,B)**T
C (transposed).  Subroutine ROTATE may be called to apply
C the transformation to a 2 by N matrix.
C
C   This routine is identical to subroutine SROTG from the
C LINPACK BLAS (Basic Linear Algebra Subroutines).
C
C On input:
C
C       A,B = Components of the vector defining the rota-
C             tion.  These are overwritten by values R
C             and Z (described below) which define C and S.
C
C On output:
C
C       A = Signed Euclidean norm R of the input vector:
C           R = +/-SQRT(A*A + B*B)
C
C       B = Value Z such that:
C             C = SQRT(1-Z*Z) and S=Z if ABS(Z) .LE. 1, and
C             C = 1/Z and S = SQRT(1-C*C) if ABS(Z) > 1.
C
C       C = +/-(A/R) or 1 if R = 0.
C
C       S = +/-(B/R) or 0 if R = 0.
C
C Modules required by GIVENS:  None
C
C Intrinsic functions called by GIVENS:  ABS, SQRT
C
C***********************************************************
C
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
C     .. Scalar Arguments ..
      DOUBLE PRECISION A,B,C,S
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION AA,BB,R,U,V
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,SQRT
C     ..
      AA = A
      BB = B
      IF (ABS(AA).LE.ABS(BB)) GO TO 10
C
C ABS(A) > 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 > 0, and S has
C   SIGN(A)*SIGN(B).
C
      B = S
      A = R
      RETURN
C
C ABS(A) .LE. ABS(B).
C
   10 IF (BB.EQ.0.) GO TO 20
      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 > 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
   20 C = 1.
      S = 0.
      RETURN

      END SUBROUTINE

      SUBROUTINE ROTATE(N,C,S,X,Y)
C
C***********************************************************
C
C                                               From SRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C                                                ( C  S)
C   This subroutine applies the Givens rotation  (     )  to
C                                                (-S  C)
C                    (X(1) ... X(N))
C the 2 by N matrix  (             ) .
C                    (Y(1) ... Y(N))
C
C   This routine is identical to subroutine SROT from the
C LINPACK BLAS (Basic Linear Algebra Subroutines).
C
C On input:
C
C       N = Number of columns to be rotated.
C
C       C,S = Elements of the Givens rotation.  Refer to
C             subroutine GIVENS.
C
C The above parameters are not altered by this routine.
C
C       X,Y = Arrays of length .GE. N containing the compo-
C             nents of the vectors to be rotated.
C
C On output:
C
C       X,Y = Arrays containing the rotated vectors (not
C             altered if N < 1).
C
C Modules required by ROTATE:  None
C
C***********************************************************
C
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION C,S
      INTEGER N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION X(N),Y(N)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION XI,YI
      INTEGER I
C     ..
      DO 10 I = 1,N
          XI = X(I)
          YI = Y(I)
          X(I) = C*XI + S*YI
          Y(I) = -S*XI + C*YI
   10 CONTINUE
      RETURN

      END SUBROUTINE

      SUBROUTINE SETUP2(XK,YK,ZK,XI,YI,ZI,S1,S2,S3,R,ROW)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/03/97
C
C   This subroutine sets up the I-th row of an augmented re-
C gression matrix for a weighted least squares fit of a
C cubic function f(x,y) to a set of data values z, where
C f(XK,YK) = ZK.  The first four columns (cubic terms) are
C scaled by S3, the next three columns (quadratic terms)
C are scaled by S2, and the eighth and ninth columns (lin-
C ear terms) are scaled by S1.
C
C On input:
C
C       XK,YK = Coordinates of node K.
C
C       ZK = Data value at node K to be interpolated by f.
C
C       XI,YI,ZI = Coordinates and data value at node I.
C
C       S1,S2,S3 = Scale factors.
C
C       R = Radius of influence about node K defining the
C           weight.
C
C The above parameters are not altered by this routine.
C
C       ROW = Array of length 10.
C
C On output:
C
C       ROW = Array containing a row of the augmented re-
C             gression matrix.
C
C Modules required by SETUP2:  None
C
C Intrinsic function called by SETUP2:  SQRT
C
C***********************************************************
C
C
C Local parameters:
C
C D =    Distance between nodes K and I
C DX =   XI - XK
C DXSQ = DX*DX
C DY =   YI - YK
C DYSQ = DY*DY
C I =    DO-loop index
C W =    Weight associated with the row:  (R-D)/(R*D)
C          (0 if D = 0 or D > R)
C W1 =   S1*W
C W2 =   S2*W
C W3 =   W3*W
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION R,S1,S2,S3,XI,XK,YI,YK,ZI,ZK
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION ROW(10)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION D,DX,DXSQ,DY,DYSQ,W,W1,W2,W3
      INTEGER I
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC SQRT
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 10
      W = (R-D)/R/D
      W1 = S1*W
      W2 = S2*W
      W3 = S3*W
      ROW(1) = DXSQ*DX*W3
      ROW(2) = DXSQ*DY*W3
      ROW(3) = DX*DYSQ*W3
      ROW(4) = DYSQ*DY*W3
      ROW(5) = DXSQ*W2
      ROW(6) = DX*DY*W2
      ROW(7) = DYSQ*W2
      ROW(8) = DX*W1
      ROW(9) = DY*W1
      ROW(10) = (ZI-ZK)*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
   10 DO 20 I = 1,10
          ROW(I) = 0.
   20 CONTINUE
      RETURN

      END SUBROUTINE

      SUBROUTINE STORE2(N,X,Y,NR,LCELL,LNEXT,XMIN,YMIN,DX,DY,IER)
C
C***********************************************************
C
C                                               From CSHEP2D
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   03/28/97
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 indexes 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   This code is essentially unaltered from the subroutine
C of the same name in QSHEP2D.
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 indexes 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 indexes.)
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 < 2 or NR < 1.
C             IER = 2 if DX = 0 or DY = 0.
C
C Modules required by STORE2:  None
C
C Intrinsic functions called by STORE2:  DBLE, INT
C
C***********************************************************
C
C
C Local parameters:
C
C DELX,DELY = Components of the cell dimensions -- local
C               copies of DX,DY
C I,J =       Cell indexes
C K =         Nodal index
C L =         Index of a node in cell (I,J)
C NN =        Local copy of N
C NNR =       Local copy of NR
C XMN,XMX =   Range of nodal X coordinates
C YMN,YMX =   Range of nodal Y coordinates
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION DX,DY,XMIN,YMIN
      INTEGER IER,N,NR
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION X(N),Y(N)
      INTEGER LCELL(NR,NR),LNEXT(N)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION DELX,DELY,XMN,XMX,YMN,YMX
      INTEGER I,J,K,L,NN,NNR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC DBLE,INT
C     ..
      NN = N
      NNR = NR
      IF (NN.LT.2 .OR. NNR.LT.1) GO TO 50
C
C Compute the dimensions of the rectangle containing the
C   nodes.
C
      XMN = X(1)
      XMX = XMN
      YMN = Y(1)
      YMX = YMN
      DO 10 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)
          IF (Y(K).GT.YMX) YMX = Y(K)
   10 CONTINUE
      XMIN = XMN
      YMIN = YMN
C
C Compute cell dimensions and test for zero area.
C
      DELX = (XMX-XMN)/DBLE(NNR)
      DELY = (YMX-YMN)/DBLE(NNR)
      DX = DELX
      DY = DELY
      IF (DELX.EQ.0. .OR. DELY.EQ.0.) GO TO 60
C
C Initialize LCELL.
C
      DO 30 J = 1,NNR
          DO 20 I = 1,NNR
              LCELL(I,J) = 0
   20     CONTINUE
   30 CONTINUE
C
C Loop on nodes, storing indexes in LCELL and LNEXT.
C
      DO 40 K = NN,1,-1
          I = INT((X(K)-XMN)/DELX) + 1
          IF (I.GT.NNR) I = NNR
          J = INT((Y(K)-YMN)/DELY) + 1
          IF (J.GT.NNR) J = NNR
          L = LCELL(I,J)
          LNEXT(K) = L
          IF (L.EQ.0) LNEXT(K) = K
          LCELL(I,J) = K
   40 CONTINUE
C
C No errors encountered.
C
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   50 IER = 1
      RETURN
C
C DX = 0 or DY = 0.
C
   60 IER = 2
      RETURN

      END SUBROUTINE

      END MODULE


c *
c * fsdeitm implements the algorithm of the paper
c * "Fast Solution for the Diagonal Elements of the Inverse of a
c * Diagonal Matrix"
c *
      subroutine fsdeitm(right, diag, left, lambda, m)
      integer m, i
      complex*16 left(1:m), diag(1:m), right(1:m), lambda(1:m)

c * inup and indn are source vectors that when multiplied with the tridiagonal
c * matrix give a vector that contains all zeros exept for the last/first position.
c * The last/first position will probably contain a non-zero value.

      complex*16 inup(1:m), indn(1:m)
c *   intensity comming from left or above / right or above
      complex*16 factor, tmp, nz, tmp1, tmp2, tmp3, tmp4

      inup(1) = 1
      do i = 1, m
        tmp = diag(i) * inup(i)
        if (i.GT.1) then
          tmp = tmp + right(i) * inup(i-1)
        end if
        if (i.LT.m) then
          inup(i+1) = -tmp / left(i)
          tmp3 =      -tmp / left(i)
        endif

        if (i.NE.m .AND. i.NE.1) then
          tmp1= diag(i) * inup(i) + right(i) * inup(i-1)
          tmp2= tmp1 + inup(i+1) * left(i)
        endif
      end do

      indn(m) = 1
      do i = m, 1, -1
        tmp = diag(i) * indn(i)
        if (i.LT.m) then
          tmp = tmp + left(i) * indn(i+1)
        end if
        if (i.GT.1) then
          indn(i-1) = -tmp / right(i)
        endif

        if (i.NE.m .AND. i.NE.1) then
          tmp1= diag(i) * indn(i) + right(i) * indn(i-1)
          tmp2= tmp1 + indn(i+1) * left(i)
        endif
      end do

c * inup and indn now contain solutions that (except for their respective end points,
c * consist entirely of zeros, except at their respective ends.
c * Now, splice the start of inup with the end of indn, each with some factor, so that
c * applying the spliced vector to the tridiagonal matrix results in a vector that has
c * only one non-zero element. Use that to calculate the value of its corresponding lambda
c * value. The non-zero value can be on the left or right of the splice. Calculate both,
c * and use the better one.

      do i = 1,m

        nz = diag(i) * inup(i)
        if (i.NE.1) then
          nz = nz + right(i) * inup(i-1)
        endif

c * find out by how much the from the right has to be multiplied to get a zerro at i+1
        factor = inup(i) / indn(i)

        if (i.NE.m) then
          nz = nz + factor * left(i) * indn(i+1)
        endif

        lambda(i) = inup(i)/nz

c       write(6,*) "lambda", i, lambda(i)
      enddo
      end


program arithmetic
    implicit none

    real :: pi
    real :: radius
    real :: height
    real :: area
    real :: volume

    pi = 3.141592

    print *, 'Enter cylinder base radius:'
    read(*,*) radius

    print *, 'Enter cylinder height:'
    read(*,*) height

    area = pi*radius*2.0
    volume = area*height

    print *, 'Cylinder radius is: ',radius
    print *, 'Cylinder height is: ',height
    print *, 'Cylinder base area is: ',area
    print *, 'Cylinder volume is: ',volume

end program arithmetic


! This file is part of fortran_quaternion
! Author: Pierre de Buyl http://pdebuyl.be/
! License: BSD 3-clause

program test_base
  use quaternion
  use tester
  implicit none

  type(tester_t) :: test
  double precision :: q1(4), q2(4), q3(4)

  call test%init()

  write(*,*) 'Testing the basic relations i**2=-1, etc'

  q1 = [1, 0, 0, 0]
  q3 = [0, 0, 0, -1]

  call test% assert_close(qmul(q1, q1), q3)

  q1 = [0, 1, 0, 0]
  q3 = [0, 0, 0, -1]

  call test% assert_close(qmul(q1, q1), q3)

  q1 = [0, 0, 1, 0]
  q3 = [0, 0, 0, -1]

  call test% assert_close(qmul(q1, q1), q3)

  write(*,*) 'Testing the basic relations ij=k, ji=-k, etc'

  q1 = [1, 0, 0, 0]
  q2 = [0, 1, 0, 0]
  q3 = [0, 0, 1, 0]

  call test% assert_close(qmul(q1, q2), q3)

  q1 = [0, 1, 0, 0]
  q2 = [0, 0, 1, 0]
  q3 = [1, 0, 0, 0]

  call test% assert_close(qmul(q1, q2), q3)

  q1 = [0, 0, 1, 0]
  q2 = [1, 0, 0, 0]
  q3 = [0, 1, 0, 0]

  call test% assert_close(qmul(q1, q2), q3)

  q1 = [1, 0, 0, 0]
  q2 = [0, 0, 1, 0]
  q3 = [0, -1, 0, 0]

  call test% assert_close(qmul(q1, q2), q3)

  q1 = [0, 1, 0, 0]
  q2 = [1, 0, 0, 0]
  q3 = [0, 0, -1, 0]

  call test% assert_close(qmul(q1, q2), q3)

  q1 = [0, 0, 1, 0]
  q2 = [0, 1, 0, 0]
  q3 = [-1, 0, 0, 0]

  call test% assert_close(qmul(q1, q2), q3)

  write(*,*) 'Testing the inverse quaternion'

  q1 = [1, 2, 3, 4]
  q2 = qinv(q1)
  q3 = [0, 0, 0, 1]

  call test% assert_close(qmul(q1,q2), q3)

  write(*,*) 'Testing the other functions of the module'

  q1 = [1, 0, 0, 0]
  call test% assert_close(qnorm(q1), 1.d0)

  q1 = [1, 0, 0, 1]
  call test% assert_close(qnorm(q1), sqrt(2.d0))

  q1 = [1d0, 5d0, -3d0, 0.1d0]
  call test% assert_close(qnorm(qnormalize(q1)), 1.d0)

  q1 = [2, 0, 0, 1]
  q2 = [-2, 0, 0, 1]
  call test% assert_close(qconj(q1), q2)

  call test%print()

end program test_base


!
!*******************************************************************************
!
real(kind=8) function interp(x, num, xx, yy)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function interpolates the array yy, which is evalauted on
!    the equally spaced array xx at the value x.
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use variable_kinds
   implicit none
   real(kind=8), intent(in) :: x
   integer(kind=4), intent(in) :: num
   real(kind=8), intent(in) :: xx(num), yy(num)
!--------------------------------------------------------
   integer(kind=4) :: idex
   real(kind=8) :: dxx
   real(kind=8) :: p
!--------------------------------------------------------
   dxx = xx(2) - xx(1)
   idex = nint((x - xx(1))/dxx) + 1
   if(idex == 1) then
      p = (x - xx(1))/dxx
      interp = (1.0d0 - p)*yy(1) + p*yy(2)
      return
   elseif (idex == num)then
      p = (x - xx(num-1))/dxx
      interp = (1.0d0 - p)*yy(num-1) + p*yy(num)
      return
   else
      p = (x - xx(idex))/dxx
      interp = p*(p-1.0d0)/2.0d0*yy(idex-1) + (1.0d0-p**2)*yy(idex) +  &
               p*(p+1.0d0)/2.0d0*yy(idex+1)
      return
   end if
   return
end function interp


! 7.19a в учебнике
! 1. Количесвто элементов матрицы B, которые положительны
! 2. Вывести их индексы

program ex_7_19a
    implicit none
    integer, allocatable    :: B(:,:), Inline(:), Indexes(:,:), k(:)
    logical, allocatable    :: mask(:)
    integer                 :: x = 0, y = 0, In = 1, i = 0, j = 0, t = 0, pos = 0, Out = 0
    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt"

    open (file=input_file, newunit=In)
        read(In, *) x, y
        allocate(B(x,y))
        read(In, *) (B(:,i), i = 1, y)
    close (In)

    Inline = reshape(B, [x*y])
    mask = Inline > 0

    pos = count(mask)

    k = pack([(i,i=1,x*y)], mask)
    allocate(Indexes(pos,2))

    do t = 1, pos

        i = mod(k(t),x)
        j = k(t) / x

        if (i == 0) then
            i = x
        else
            j = j + 1
        endif

        Indexes(t,:) = [i, j]
    enddo

    open (file=output_file, newunit=Out)
        write(Out, *) pos, 'positive elements found within the array, coordinates:'
        write(Out, *) 'X, Y coordinates'
        write(Out, '(I2,A1,I2)') (Indexes(i,1), ',' ,Indexes(i,2), i = 1, pos)
    close (In)

end program ex_7_19a


!**********************************************************************
!   pi - compute pi by integrating f(x) = 4/(1 + x**2)
!
!  (C) 2001 by Argonne National Laboratory. MPICH example
!  Modified by Thomas Hauser
!
!   Each node:
!    1) receives the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!    3) Synchronizes for a global summation.
!   Node 0 prints the result.
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!****************************************************************************
PROGRAM main

  INTEGER, PARAMETER :: dp = KIND(1.0d0)
  REAL(dp)::  PI25DT = 3.141592653589793238462643d0

  REAL(dp) ::  pi, h, sum, x, f, a
  INTEGER :: n, i, rc
  !                                 function to integrate
  f(a) = 4.d0 / (1.d0 + a*a)

  WRITE(6, 98)
98 FORMAT('Enter the number of intervals:')
  READ(5,99) n
99 FORMAT(i10)

  !                                 calculate the interval size
  h = 1.0d0/n

  sum  = 0.0d0
!$OMP parallel do default(none), private(i,x), shared(n, h), reduction(+:sum)
  DO i = 1, n
     x = h * (DBLE(i) - 0.5d0)
     sum = sum + f(x)
  ENDDO
!OMP END DO
  pi = h * sum

  WRITE(6, 97) pi, ABS(pi - PI25DT)
97 FORMAT('  pi is approximately: ', F18.16, &
       '  Error is: ', F18.16)

END PROGRAM main


      SUBROUTINE fpoly(x,p,np)
      INTEGER np
      REAL x,p(np)
      INTEGER j
      p(1)=1.
      do 11 j=2,np
        p(j)=p(j-1)*x
11    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fpoly.for


! RUN: %python %S/test_folding.py %s %flang_fc1

! Test intrinsic operation folding

module m
! Check logical intrinsic operation folding
  logical, parameter :: test_not1 = .NOT..false.
  logical, parameter :: test_not2 = .NOT..NOT..true.

  logical, parameter :: test_parentheses1 = .NOT.(.false.)
  logical, parameter :: test_parentheses2 = .NOT..NOT.(.true.)

  logical, parameter :: test_and1 = .true..AND..true.
  logical, parameter :: test_and2 = .NOT.(.false..AND..true.)
  logical, parameter :: test_and3 = .NOT.(.false..AND..false.)
  logical, parameter :: test_and4 = .NOT.(.true..AND..false.)

  logical, parameter :: test_or1 = .true..OR..true.
  logical, parameter :: test_or2 = .false..OR..true.
  logical, parameter :: test_or3 = .NOT.(.false..OR..false.)
  logical, parameter :: test_or4 = .true..OR..false.

  logical, parameter :: test_eqv1 = .false..EQV..false.
  logical, parameter :: test_eqv2 = .true..EQV..true.
  logical, parameter :: test_eqv3 = .NOT.(.false..EQV..true.)
  logical, parameter :: test_eqv4 = .NOT.(.true..EQV..false.)

  logical, parameter :: test_neqv1 = .true..NEQV..false.
  logical, parameter :: test_neqv2 = .false..NEQV..true.
  logical, parameter :: test_neqv3 = .NOT.(.false..NEQV..false.)
  logical, parameter :: test_neqv4 = .NOT.(.true..NEQV..true.)

  logical, parameter :: test_logical1 = logical(logical(.true., 2))
  logical, parameter :: test_logical2 = .NOT.logical(logical(.false., 2))

! Check integer intrinsic operator folding

! Check integer relational intrinsic operation folding
  logical, parameter :: test_le_i1 = 1.LE.2
  logical, parameter :: test_le_i2 = .NOT.(2.LE.1)
  logical, parameter :: test_le_i3 = 2.LE.2
  logical, parameter :: test_le_i4 = -1.LE.2
  logical, parameter :: test_le_i5 = .NOT.(-2.LE.-3)

  logical, parameter :: test_lt_i1 = 1.LT.2
  logical, parameter :: test_lt_i2 = .NOT.(2.LT.1)
  logical, parameter :: test_lt_i3 = .NOT.(2.LT.2)
  logical, parameter :: test_lt_i4 = -1.LT.2
  logical, parameter :: test_lt_i5 = .NOT.(-2.LT.-3)

  logical, parameter :: test_ge_i1 = .NOT.(1.GE.2)
  logical, parameter :: test_ge_i2 =  2.GE.1
  logical, parameter :: test_ge_i3 = 2.GE.2
  logical, parameter :: test_ge_i4 = .NOT.(-1.GE.2)
  logical, parameter :: test_ge_i5 = -2.GE.-3

  logical, parameter :: test_gt_i1 = .NOT.(1.GT.2)
  logical, parameter :: test_gt_i2 =  2.GT.1
  logical, parameter :: test_gt_i3 = .NOT.(2.GT.2)
  logical, parameter :: test_gt_i4 = .NOT.(-1.GT.2)
  logical, parameter :: test_gt_i5 = -2.GT.-3

  logical, parameter :: test_eq_i1 = 2.EQ.2
  logical, parameter :: test_eq_i2 = .NOT.(-2.EQ.2)

  logical, parameter :: test_ne_i1 =.NOT.(2.NE.2)
  logical, parameter :: test_ne_i2 = -2.NE.2

! Check conversions
  logical, parameter :: test_cmplx1 = cmplx((1._4, -1._4)).EQ.((1._4, -1._4))
  logical, parameter :: test_cmplx2 = cmplx((1._4, -1._4), 8).EQ.((1._8, -1._8))
  logical, parameter :: test_cmplx3 = cmplx(1._4, -1._4).EQ.((1._4, -1._4))
  logical, parameter :: test_cmplx4 = cmplx(1._4, -1._4, 8).EQ.((1._8, -1._8))
  logical, parameter :: test_cmplx5 = cmplx(1._4).EQ.((1._4, 0._4))
  logical, parameter :: test_cmplx6 = cmplx(1._4, kind=8).EQ.((1._8, 0._8))

! Check integer intrinsic operation folding
  logical, parameter :: test_unaryminus_i = (-(-1)).EQ.1
  logical, parameter :: test_unaryplus_i = (+1).EQ.1

  logical, parameter :: test_plus_i1 = (1+1).EQ.2
  logical, parameter :: test_plus_i2 = ((-3)+1).EQ.-2

  logical, parameter :: test_minus_i1 = (1-1).EQ.0
  logical, parameter :: test_minus_i2 = (1-(-1)).EQ.2

  logical, parameter :: test_multiply_i1 = (2*2).EQ.4
  logical, parameter :: test_multiply_i2 = (0*1).EQ.0
  logical, parameter :: test_multiply_i3= ((-3)*2).EQ.(-6)

  logical, parameter :: test_divide_i1 = (5/3).EQ.(1)
  logical, parameter :: test_divide_i2 = (6/3).EQ.(2)
  logical, parameter :: test_divide_i3 = ((-7)/2).EQ.(-3)
  logical, parameter :: test_divide_i4 = (0/127).EQ.(0)

  logical, parameter :: test_pow1 = (2**0).EQ.(1)
  logical, parameter :: test_pow2 = (1**100).EQ.(1)
  logical, parameter :: test_pow3 = (2**4).EQ.(16)
  logical, parameter :: test_pow4 = (7**5).EQ.(16807)
  logical, parameter :: test_pow5 = kind(real(1., kind=8)**cmplx(1., kind=4)).EQ.(8)
  logical, parameter :: test_pow6 = kind(cmplx(1., kind=4)**real(1., kind=8)).EQ.(8)

  ! test MIN and MAX
  real, parameter :: x1 = -35., x2= -35.05, x3=0., x4=35.05, x5=35.
  real, parameter :: res_max_r = max(a1=x1, a2=x2, a3=x3, a4=x4, a5=x5)
  real, parameter :: res_min_r = min(x1, x2, x3, x4, x5)
  logical, parameter :: test_max_r = res_max_r.EQ.x4
  logical, parameter :: test_min_r = res_min_r.EQ.x2

  logical, parameter :: test_min_i = min(-3, 3).EQ.-3
  logical, parameter :: test_max_i = max(-3, 3).EQ.3
  integer, parameter :: i1 = 35, i2= 36, i3=0, i4=-35, i5=-36
  integer, parameter :: res_max_i = max(i1, i2, i3, i4, i5)
  integer, parameter :: res_min_i = min(i1, i2, i3, i4, i5)
  logical, parameter :: test_max_i2 = res_max_i.EQ.i2
  logical, parameter :: test_min_i2 = res_min_i.EQ.i5

  character(*), parameter :: c1 = "elephant", c2="elevator"
  character(*), parameter :: c3 = "excalibur", c4="z", c5="epsilon"
  character(*), parameter :: res_max_c = max(c1, c2, c3, c4, c5)
  character(*), parameter :: res_min_c = min(c1, c2, c3, c4, c5)
  ! length of result is length of longest arguments!
  character(len(c3)), parameter :: exp_min = c1
  character(len(c3)), parameter :: exp_max = c4
  logical, parameter :: test_max_c_1 = res_max_c.EQ.exp_max
  logical, parameter :: test_max_c_3 = len(res_max_c).EQ.len(c3)
  logical, parameter :: test_min_c_2 = res_min_c.EQ.exp_min
  logical, parameter :: test_min_c_3 = len(res_min_c).EQ.len(c3)

  integer, parameter :: x1a(*) = [1, 12, 3, 14]
  integer, parameter :: x2a(*) = [11, 2, 13, 4]
  logical, parameter :: test_max_a1 = all(max(x1a, x2a).EQ.[11, 12, 13, 14])
  logical, parameter :: test_min_a1 = all(min(x1a, x2a).EQ.[1, 2, 3, 4])

  logical, parameter :: test_not_zero = not(0).EQ.-1
  logical, parameter :: test_not_neg_one = not(-1).EQ.0
  logical, parameter :: test_not_array = all(not([5, 6, 7]).EQ.[-6, -7, -8])

end module


!	Set intercepts by a regression.

!	catobsrange maps observed to underlying categories.
!	dat is the array of responses.
!	numcat is the number of underlying categories per item.
!	numcatobs is the number of observed categories per item.
!	design is the design matrix.
!	obsweight is the vector of observation weights.
!	offset is the offset for beta.
!	tolsing is a tolerance for modified Cholesky decomposition.
!	gamma is the vector of starting value.
subroutine interceptstart(catobsrange,dat,numcat,numcatobs,design,obsweight,offset,tolsing,gamma)
implicit none
interface
	function chol(sym,tolsing)
!	chol is used to compute a modified Cholesky decomposition of the n by n matrix sym.
!	The singularity tolerance is tolsing.
		implicit none
		real(kind=8),intent(in)::sym(:,:),tolsing
	 	real(kind=8)::chol(size(sym,1),size(sym,1))
	end function chol
!		This program uses the modified Cholesky decomposition
!		in lu to solve the equation lusolve = b.
	function solve(lu,b)
		implicit none

		real(kind=8),intent(in)::lu(:,:)
		real(kind=8),intent(in)::b(:)
		real(kind=8)::solve(size(b))
		end function solve
end interface
integer,intent(in)::catobsrange(:,:),dat(:,:),numcat(:),numcatobs(:)
real(kind=8),intent(in)::design(:,:),obsweight(:),offset(:),tolsing
real(kind=8),intent(out)::gamma(:)
!	al is the allocation error flag.
!	cat looks at observed categories.
!	colsub is the number of columns in subdesign.
!	obs counts observations.
!	item counts items.
!	position and position1 count observed category groups.
!	sumnumcat is sum(numcat).
integer::al,cat,colsub,item,obs,position,position1,sumnumcat
!	gammas to use.
logical::usegamma(size(gamma))
!	ave is a average.
!	counts are marginal frequencies.
!	logs are adjusted log frequencies.
!	total is a total.
real(kind=8)::ave,counts(sum(numcat)),logs(sum(numcat)),total
!	solution is used for a solution associated with the subdesign.
!	subchol is used for a modified Cholesky decomposition associated with subdesign'subdesign.
!	subdesign is the portion of design used in computations of the gamma starting values for intercepts.
real(kind=8),allocatable::solution(:),subchol(:,:),subdesign(:,:)
counts=0.0_8
sumnumcat=sum(numcat)

!	Count marginal totals.
do obs=1,size(dat,2)
	position=1
	do item=1,size(numcat)
		if(dat(item,obs)>=0.and.dat(item,obs)<numcatobs(item))then
			cat=position+dat(item,obs)
			counts(catobsrange(1,cat):catobsrange(2,cat))=&
				counts(catobsrange(1,cat):catobsrange(2,cat))&
				+obsweight(obs)/(catobsrange(2,cat)-catobsrange(1,cat)+1.0_8)
		end if
		position=position+numcatobs(item)
	end do
end do

!	Obtain adjusted log frequencies.
position=1
do  item=1,size(dat,1)

	do cat=position,position+numcat(item)-1

		if(counts(cat)>0.0_8) then
			logs(cat)=log(counts(cat))-offset(cat)
		else
			logs(cat)=-log(2.0_8)-offset(cat)
		end if

	end do
	total=sum(counts(position:position+numcat(item)-1))
	if(total>0.0_8)then
		ave=dot_product(logs(position:position+numcat(item)-1), &
			counts(position:position+numcat(item)-1))/total
	else
		ave=0.0_8
	end if
	logs(position:position+numcat(item)-1)=logs(position:position+numcat(item)-1)-ave
	position=position+numcat(item)
end do
!	Find a matrix to use if possible.
usegamma=.false.

do position=1,size(gamma)
	if(maxval(abs(design(1:sumnumcat,position)))>0.0_8&
		.and.maxval(abs(design(sumnumcat+1:size(offset),position)))==0.0_8) &
		usegamma(position) = .true.
end do
!	Check for failure.
colsub=count(usegamma)

if(colsub==0)return
!	Set up submatrix.
allocate(subdesign(sumnumcat,colsub),subchol(colsub,colsub),solution(colsub),stat=al)
if(al/=0) stop "Allocation failed for calculation of starting values of intercepts."
position1=1
do position=1,size(gamma)
	if(usegamma(position))then
		subdesign(:,position1)=design(1:sumnumcat,position)
		position1=position1+1
	end if
end do

do position=1,colsub
	position1=1
	do  item=1,size(dat,1)
		total=sum(counts(position1:position1+numcat(item)-1))
		if(total>0.0_8)then
			ave=dot_product(subdesign(position1:position1+numcat(item)-1,position), &
				counts(position1:position1+numcat(item)-1))/total
		else
			ave=0.0_8
		end if
		subdesign(position1:position1+numcat(item)-1,position)=&
			subdesign(position1:position1+numcat(item)-1,position)-ave
		position1=position1+numcat(item)
	end do
	do position1=1,position
		subchol(position,position1)=sum(counts*subdesign(:,position)*subdesign(:,position1))
	end do
end do

subchol=chol(subchol,tolsing)
do position=1,colsub
	solution(position)=sum(subdesign(:,position)*counts*logs)
end do
solution=solve(subchol,solution)

position1=1
do position=1,size(gamma)
	if(usegamma(position))then
		gamma(position)=solution(position1)
		position1=position1+1
	end if
end do
return
end subroutine interceptstart


SUBROUTINE geom_freesurf(iel,nxe,fixed_seep,fixed_down,down,              &
  width,angs,surf,coord,num)
! Used in p73
! This subroutine forms the coordinates and steering vector
! for 4-node quads numbering in the x-direction
! (Laplace's equation, variable mesh, 1-freedom per node).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::width(:),angs(:),surf(:),down
 !
 REAL(iwp),INTENT(OUT)::coord(:,:)
 INTEGER,INTENT(IN)::iel,nxe,fixed_seep,fixed_down
 !
 INTEGER,INTENT(OUT)::num(:)
 REAL(iwp)::angr(SIZE(angs)),pi,b1,b2,tan1,tan2,fac1,fac2,zero=0.0_iwp,   &
   pt5=0.5_iwp,one=1.0_iwp,small=0.0001_iwp,d180=180.0_iwp
 INTEGER::ip,iq
 pi=ACOS(-one)
 angr=angs*pi/d180
 iq=(iel-1)/nxe+1
 ip=iel-(iq-1)*nxe
 num(1)=iq*(nxe+1)+ip
 num(2)=(iq-1)*(nxe+1)+ip
 num(3)=num(2)+1
 num(4)=num(1)+1
 IF(iq<=fixed_seep+1)THEN
   b1=(surf(ip)-down)/real(fixed_seep+1)
   b2=(surf(ip+1)-down)/real(fixed_seep+1)
   coord(1,2)=down+(fixed_seep+1-iq)*b1
   coord(2,2)=down+(fixed_seep+2-iq)*b1
   coord(3,2)=down+(fixed_seep+2-iq)*b2
   coord(4,2)=down+(fixed_seep+1-iq)*b2
 ELSE
   b1=real(fixed_down+fixed_seep-iq)/real(fixed_down-1)
   b2=real(fixed_down+fixed_seep-iq+1)/real(fixed_down-1)
   coord(1,2)=down*b1
   coord(2,2)=down*b2
   coord(3,2)=coord(2,2)
   coord(4,2)=coord(1,2)
 END IF
 IF(ABS(angr(ip)-pi*pt5)<small)THEN
   fac1=zero
 ELSE
   tan1=TAN(angr(ip))
   fac1=one/tan1
 END IF
 IF(ABS(angr(ip+1)-pi*pt5)<small)THEN
   fac2=zero
 ELSE
   tan2=TAN(angr(ip+1))
   fac2=one/tan2
 END IF
 coord(1,1)=width(ip)+coord(1,2)*fac1
 coord(2,1)=width(ip)+coord(2,2)*fac1
 coord(3,1)=width(ip+1)+coord(3,2)*fac2
 coord(4,1)=width(ip+1)+coord(4,2)*fac2
RETURN
END SUBROUTINE geom_freesurf


subroutine triad(a, b, scalar, c)
real, intent(in) :: a(:), b(:), scalar
real, intent(out) :: c(:)
integer :: N, i
N = size(a)
do concurrent (i = 1:N)
    c(i) = a(i) + scalar * b(i)
end do
end subroutine


! MIT License
! Copyright (c) 2019 Sam Miller
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module mod_intersections
  !< Summary: Provide procedures to calculate the intersection of a line segment and a circle
  !< Date: 05/20/2020
  !< Author: Sam Miller
  !< References:
  !<      [1] https://cp-algorithms.com/geometry/circle-line-intersection.html
  !< Notes: Reference [1] had some errors in it, but otherwise this is better than using
  !<        the quadratic formula to find the intersects. Using the quadratic formula is by far
  !<        the most common algorithim online.

  use, intrinsic :: iso_fortran_env, only: ik => int32, rk => real64
  implicit none

  private
  public :: intersect, is_on

  real(rk), parameter :: EPS = epsilon(1.0_rk)
  real(rk), parameter :: EPS_2X = 1e-15_rk

contains

  pure subroutine intersect(line_xy, circle_xy, circle_radius, intersection_xy, valid_intersections, angles)
    !< Find the interesection(s) of a line and a circle. This subroutine shifts and scales everything so that the
    !< origin of the circle is at (0,0) and the radius is 1. It provides the interesection (x,y) points, a boolean
    !< if the intersections are valid or not (it will find an intersection based on an infinite line), and the angle
    !< between the intersection point and the x-axis. This was modified from [1] (which had some errors in it)

    real(rk), dimension(2, 2), intent(in) :: line_xy !< ((x,y) (point_1, point_2)); Line location
    real(rk), dimension(2), intent(in) :: circle_xy !< (x,y); Circle origin
    real(rk), intent(in) :: circle_radius !< Radius of the circle
    real(rk), dimension(2, 2), intent(out) :: intersection_xy !< ((x,y), (point_1, point_2)); Intersection point
    logical, dimension(2), intent(out) :: valid_intersections !< (point_1, point_2); Is there an intersection or not?
    real(rk), dimension(2), intent(out) :: angles !< (point_1, point_2); Angle w/respect to the x-axis

    ! Locals
    integer(ik) :: n_intersections
    !< number of intersections (not all may be valid yet, since it assumes the line is infinite at first)

    real(rk), parameter :: r_sq = 1.0_rk !< r**2. This makes the code easier to read
    real(rk) :: x1, y1, x2, y2
    real(rk) :: ax, ay !< 1st intersection point
    real(rk) :: bx, by !< 2nd intersection point
    real(rk) :: x0, y0, d, m
    real(rk) :: A, B, C !< Ax + By = C
    real(rk) :: threshold !< filter to check for roundoff

    ! Defaults
    ax = 0.0_rk
    bx = 0.0_rk
    ay = 0.0_rk
    by = 0.0_rk
    angles = 0.0_rk
    n_intersections = 0
    intersection_xy = 0.0_rk
    valid_intersections = .false.

    x1 = line_xy(1, 1) - circle_xy(1)
    threshold = abs(line_xy(1, 1) + circle_xy(1)) * EPS
    if(abs(x1) < threshold) then
      x1 = 0.0_rk
    else
      x1 = x1 / circle_radius
    endif

    y1 = line_xy(2, 1) - circle_xy(2)
    threshold = abs(line_xy(2, 1) + circle_xy(2)) * EPS
    if(abs(y1) < threshold) then
      y1 = 0.0_rk
    else
      y1 = y1 / circle_radius
    endif

    x2 = line_xy(1, 2) - circle_xy(1)
    threshold = abs(line_xy(1, 2) + circle_xy(1)) * EPS
    if(abs(x2) < threshold) then
      x2 = 0.0_rk
    else
      x2 = x2 / circle_radius
    endif

    y2 = line_xy(2, 2) - circle_xy(2)
    threshold = abs(line_xy(2, 2) + circle_xy(2)) * EPS
    if(abs(y2) < threshold) then
      y2 = 0.0_rk
    else
      y2 = y2 / circle_radius
    endif

    A = y2 - y1
    if(abs(A) < epsilon(1.0_rk)) A = 0.0_rk

    B = x1 - x2
    if(abs(B) < epsilon(1.0_rk)) B = 0.0_rk

    C = x1 * y2 - x2 * y1
    if(abs(C) < epsilon(1.0_rk)) C = 0.0_rk

    if(C**2 > (A**2 + B**2)) then
      n_intersections = 0
    else if(abs(C**2 - (A**2 + B**2)) < epsilon(1.0_rk)) then
      n_intersections = 1
      x0 = (A * C) / (A**2 + B**2)
      y0 = (B * C) / (A**2 + B**2)
      ax = x0
      ay = y0
    else
      n_intersections = 2
      x0 = (A * C) / (A**2 + B**2)
      y0 = (B * C) / (A**2 + B**2)
      d = sqrt(r_sq - ((C**2) / (A**2 + B**2)))
      m = sqrt(d**2 / (A**2 + B**2))
      ax = x0 + B * m
      bx = x0 - B * m
      ay = y0 - A * m
      by = y0 + A * m
    endif

    ! Get rid of very small numbers and signed 0's, i.e. -0
    if(abs(ax) < tiny(1.0_rk)) ax = 0.0_rk
    if(abs(ay) < tiny(1.0_rk)) ay = 0.0_rk
    if(abs(bx) < tiny(1.0_rk)) bx = 0.0_rk
    if(abs(by) < tiny(1.0_rk)) by = 0.0_rk

    intersection_xy(:, 1) = ([ax, ay] * circle_radius) + circle_xy
    intersection_xy(:, 2) = ([bx, by] * circle_radius) + circle_xy

    if(n_intersections > 0) then
      valid_intersections(1) = is_on(a=[x1, y1], b=[x2, y2], c=[ax, ay])
      valid_intersections(2) = is_on(a=[x1, y1], b=[x2, y2], c=[bx, by])

      if(valid_intersections(1)) angles(1) = atan2(y=ay, x=ax)
      if(valid_intersections(2)) angles(2) = atan2(y=by, x=bx)
    endif

  endsubroutine intersect

  pure logical function between_zero_and_one(val)
    !< Stupidly simple function to check if a value is between 0 and 1 with
    !< machine epsilon checks included

    real(rk), intent(in) :: val

    if(val < 0.0_rk .or. (val - 1.0_rk) > EPS) then
      between_zero_and_one = .false.
    else
      between_zero_and_one = .true.
    endif
  endfunction between_zero_and_one

  pure logical function is_on(a, b, c)
    ! Check to see if the point c on the line segment ab

    real(rk), dimension(2), intent(in) :: a !< (x,y);
    real(rk), dimension(2), intent(in) :: b !< (x,y);
    real(rk), dimension(2), intent(in) :: c !< (x,y);

    real(rk) :: ab_dx !< delta x for the line segment AB
    real(rk) :: ab_dy !< delta y for the line segment AB
    real(rk) :: cb_dx !< delta x for the line segment CB
    real(rk) :: cb_dy !< delta y for the line segment CB

    real(rk) :: m1, m2 !< parameterization factor
    logical :: ab_is_horizontal
    logical :: ab_is_vertical

    ab_is_horizontal = .false.
    ab_is_vertical = .false.

    ab_dx = a(1) - b(1)
    ab_dy = a(2) - b(2)
    cb_dy = c(2) - b(2)
    cb_dx = c(1) - b(1)

    if(abs(ab_dy) < EPS_2X) ab_dy = 0.0_rk
    if(abs(cb_dx) < EPS_2X) cb_dx = 0.0_rk

    if(abs(ab_dy) < EPS_2X) then
      ab_is_horizontal = .true.
      ab_dy = 0.0_rk
    endif

    if(abs(ab_dx) < EPS_2X) then
      ab_is_vertical = .true.
      ab_dx = 0.0_rk
    endif

    if(abs(ab_dx) < EPS_2X .and. abs(ab_dy) < EPS_2X) then
      ! a and b are the same point,
      ! so check that c is the same as a and b
      is_on = (abs(cb_dx) < EPS_2X) .and. (abs(cb_dy) < EPS_2X)
    else
      if(ab_is_vertical) then
        m2 = cb_dy / ab_dy
        is_on = (abs(cb_dx) < EPS_2X) .and. between_zero_and_one(m2)
      else if(ab_is_horizontal) then
        m1 = cb_dx / ab_dx
        is_on = (abs(cb_dy) < EPS_2X) .and. between_zero_and_one(m1)
      else
        m1 = cb_dx / ab_dx
        if(.not. between_zero_and_one(m1)) then
          is_on = .false.
        else
          m2 = cb_dy / ab_dy
          is_on = abs(m2 - m1) < EPS_2X
        endif
      endif
    endif
  endfunction is_on

endmodule mod_intersections


!
! Copyright (C) 2004 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
subroutine invmat (n, a, a_inv, da)
  !-----------------------------------------------------------------------
  ! computes the inverse "a_inv" of matrix "a", both dimensioned (n,n)
  ! if the matrix is dimensioned 3x3, it also computes determinant "da"
  ! matrix "a" is unchanged on output - LAPACK
  !
  USE kinds, ONLY : DP
  implicit none
  integer :: n
  real(DP), DIMENSION (n,n) :: a, a_inv
  real(DP) :: da
  !
  integer :: info, lda, lwork, ipiv (n)
  ! info=0: inversion was successful
  ! lda   : leading dimension (the same as n)
  ! ipiv  : work space for pivoting (assumed of length lwork=n)
  real(DP) :: work (n)
  ! more work space
  !
  lda = n
  lwork=n
  !
  a_inv(:,:) = a(:,:)
  !
  call dgetrf (n, n, a_inv, lda, ipiv, info)
  call errore ('invmat', 'error in DGETRF', abs (info) )
  call dgetri (n, a_inv, lda, ipiv, work, lwork, info)
  call errore ('invmat', 'error in DGETRI', abs (info) )
  !
  if (n == 3) then
     da = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2)) + &
          a(1,2)*(a(2,3)*a(3,1)-a(2,1)*a(3,3)) + &
          a(1,3)*(a(2,1)*a(3,2)-a(3,1)*a(2,2))
     IF (ABS(da) < 1.d-10) CALL errore(' invmat ',' singular matrix ', 1)
  else
     da = 0.d0
  end if

  return
end subroutine invmat


program problem31
  implicit none
  integer, parameter :: limit=200
  integer, parameter :: av=200,bv=100,cv=50,dv=20,ev=10,fv=5,gv=2,hv=1
  integer            :: a,b,c,d,e,f,g,h,answer=0

  do a=0,(limit/av)
     do b=0,(limit/bv)
        if (a*av + b*bv > limit) exit
        do c=0,(limit/cv)
           if (a*av + b*bv + c*cv > limit) exit
           do d=0,(limit/dv)
              if (a*av + b*bv + c*cv + d*dv > limit) exit
              do e=0,(limit/ev)
                 if (a*av + b*bv + c*cv + d*dv + e*ev > limit) exit
                 do f=0,(limit/fv)
                    if (a*av + b*bv + c*cv + d*dv + e*ev + f*fv > limit) exit
                    do g=0,(limit/gv)
                       if (a*av + b*bv + c*cv + d*dv + e*ev + f*fv + g*gv > limit) exit
                       h = limit - (a*av + b*bv + c*cv + d*dv + e*ev + f*fv + g*gv)
                       if (0 <= h .and. h <= limit) answer=answer+1
                    end do
                 end do
              end do
           end do
        end do
     end do
  end do

  print *, answer

end program problem31