C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

      SUBROUTINE SRCHQ (
     *  NPSRF,   NFSRF,   LINKSRF, XYZSRF,
     *  NPTS,    XYZPTS,  TOLSRCH,
     *  NISR,    NRSR,    NISS,    NRSS,    ISRCHR,  RSRCHR,
     *  LIST,    IERR )

C-----------------------------------------------------------------------

C DESCRIPTION:

C THIS SUBROUTINE CALCULATES THE CLOSEST POINT PROBLEM
C BETWEEN NPTS POINTS AND NFSRF SURFACES AND RETURNS RESULTS OF
C SEARCH IN ISRCHR,RSRCHR

C USED HERE FOR FINDING LOCATION OF EITHER NODE OR ELEMENT CENTROID
C FROM MESH-B IN QUAD-4 ELEMENT OF MESH-A

C-----------------------------------------------------------------------

C FORMAL PARAMETERS

C MEMORY      : P=PERMANENT, S=SCRATCH
C NAME        : IMPLICIT A-H,O-Z REAL, I-N INTEGER
C TYPE        : INPUT_STATUS/OUTPUT_STATUS (I=INPUT,O=OUTPUT,P=PASSED,
C               U=UNMODIFIED,-=UNDEFINED)
C DESCRIPTION : DESCRIPTION OF VARIABLE

C-----------------------------------------------------------------------

C CALLING ARGUMENTS:

C MEMORY NAME     TYPE   DESCRIPTION
C ---    ----     ---    -----------
C  P     NPSRF    I/U    NUMBER OF POINTS THAT DEFINE THE SURFACE
C  P     NFSRF    I/U    NUMBER OF SURFACES
C  P     LINKSRF  I/U    CONNECTIVITY OF SURFACES OF SIZE (4*NFSRF),
C                        NUMBERS REFER TO LOCATIONS IN XYZSRF ARRAY
C  P     XYZSRF   I/U    XYZ COORDS OF POINTS DEFINING SURFACE
C  P     NPTS     I/U    NUMBER OF POINTS TO BE SEARCHED
C  P     XYZPTS   I/U    XYZ COORDS OF POINTS TO BE SEARCHED
C  P     TOLSRCH  I/U    PROXIMITY TOLERANCE FOR POINT-TO-SURFACE SEARCH
C  P     NISR     I/U    NUMBER OF INTEGER SEARCH RESULTS (>=1)
C  P     NRSR     I/U    NUMBER OF REAL SEARCH RESULTS (>=4)
C  P     NISS     I/U    NUMBER OF INTEGER SEARCH SCRATCH (=5)
C  P     NRSS     I/U    NUMBER OF REAL SEARCH SCRATCH (=10)
C  P     ISRCHR   -/O    INTEGER SEARCH RESULTS
C  P     RSRCHR   -/O    REAL SEARCH RESULTS
C  S     LIST     -/-    LIST OF POTENTIAL CONTACTS FOR A SURFACE
C  P     IERR     -/O    ERROR FLAG

C-----------------------------------------------------------------------

      include 'amesh.blk'
      include 'tapes.blk'
      include 'debg.blk'

C INPUT/OUTPUT ARRAYS

C ... Needed to interact with C routines on 64-bit systems which have
C     8-byte integers in Fortran and 4-byte integers in C.
      INTEGER*4 NPTS4, NDIM4, NLIST, LIST(*)

      DIMENSION
     *  LINKSRF(NELNDA,NFSRF),   XYZSRF(NPSRF,3),
     *  XYZPTS(NPTS,3),
     *  ISRCHR(NISR,NPTS),  RSRCHR(NRSR,NPTS)
      DIMENSION
     *  XMIN(2), XMAX(2), GXMIN(2), GXMAX(2)

C ISRCHR and RSRCHR must be initialized to zero

      DO 1 I = 1, NPTS
        DO 2 J = 1, NISR
          ISRCHR(J,I) = 0
 2      CONTINUE
        DO 3 K = 1, NRSR
          RSRCHR(K,I) = 0.
 3      CONTINUE
 1    CONTINUE

      IF( NISR .LT. 1 .OR. NRSR .LT. 2 .OR. NISS .LT. 5 .OR.
     *    NRSS .LT. 10 )THEN
        IERR = 1
        RETURN
      ENDIF

C DIMENSION OF COORDINATES
      NDIM = 2
      NDIM4 = NDIM
      NPTS4 = NPTS

c ... Calculate min/max extents of all points...
      GXMIN(1) = XYZPTS(1,1)
      GXMAX(1) = XYZPTS(1,1)
      GXMIN(2) = XYZPTS(1,2)
      GXMAX(2) = XYZPTS(1,2)
      DO 10 I=2,NPTS
        GXMIN(1) = MIN(GXMIN(1), XYZPTS(I,1))
        GXMIN(2) = MIN(GXMIN(2), XYZPTS(I,2))

        GXMAX(1) = MAX(GXMAX(1), XYZPTS(I,1))
        GXMAX(2) = MAX(GXMAX(2), XYZPTS(I,2))
 10   CONTINUE

C Build KD Tree
      if (idebug .ge. 2) then
        call excpus(t1)
        write(nout, *) '        In kdBuildTree ', npts4
        write(ntpout, *) '      In kdBuildTree ', npts4
      end if

      call kdbuildtree(xyzpts, npts4, ndim4)

      if (idebug .ge. 2) then
        call excpus(t2)
        write(nout, *) '        Out of kdBuildTree', t2-t1
        write(ntpout, *) '      Out of kdBuildTree', t2-t1
      end if

C LOOP OVER SURFACES AND SEARCH FOR POINTS WITHIN CAPTURE BOX
      qt = 0.0
      j = 0
      nlistt = 0
      nlistp = 0
      nskip  = 0
      call excpus(t3p)

C LOOP OVER SURFACES AND SEARCH FOR POINTS WITHIN CAPTURE BOX
      DO 100 IFSRF = 1, NFSRF
          NI = LINKSRF(1,IFSRF)
          NJ = LINKSRF(2,IFSRF)
          NK = LINKSRF(3,IFSRF)
          NL = LINKSRF(4,IFSRF)

          XMINMS = MIN(XYZSRF(NI,1),XYZSRF(NJ,1),
     *                 XYZSRF(NK,1),XYZSRF(NL,1))
          XMAXMS = MAX(XYZSRF(NI,1),XYZSRF(NJ,1),
     *                 XYZSRF(NK,1),XYZSRF(NL,1))
          YMINMS = MIN(XYZSRF(NI,2),XYZSRF(NJ,2),
     *                 XYZSRF(NK,2),XYZSRF(NL,2))
          YMAXMS = MAX(XYZSRF(NI,2),XYZSRF(NJ,2),
     *                 XYZSRF(NK,2),XYZSRF(NL,2))
          TOLER = TOLSRCH * (XMAXMS - XMINMS)
          XMIN(1) = XMINMS - TOLER
          XMAX(1) = XMAXMS + TOLER
          TOLER = TOLSRCH * (YMAXMS - YMINMS)
          XMIN(2) = YMINMS - TOLER
          XMAX(2) = YMAXMS + TOLER

C ... Build a list of points in the query region...
        j = j + 1
C ... Skip past points that are outside search domain.
C     This is much faster than the failed search in kdrectquery, but
C     does add overhead if all points are in the domain....

        if (xmax(1) .lt. gxmin(1) .or. xmin(1) .gt. gxmax(1) .or.
     *      xmax(2) .lt. gxmin(2) .or. xmin(2) .gt. gxmax(2)) then
          nskip = nskip + 1
          nlist = 0
        else
          call excpus(t4)
          call kdrectquery(xyzpts,npts4,ndim4, xmin,xmax, list,nlist)
          call excpus(t5)
          qt = qt + (t5-t4)
        end if

C ... Debugging statistics.  Also give user an idea that calculation is progressing...
        if (idebug .ge. 2) then
          nlistp = nlistp + nlist
          nlistt = nlistt + nlist
          if (j .eq. 100000 .or. ifsrf .eq. nfsrf) then
            call excpus(t3)
            write (nout, 190) ifsrf, nfsrf, t3-t3p, t3-t2,
     *        j/(t3-t3p), ifsrf/(t3-t2), nlistp, nlistt
            write (ntpout, 190) ifsrf, nfsrf, t3-t3p, t3-t2,
     *        j/(t3-t3p), ifsrf/(t3-t2), nlistp, nlistt
            j = 0
            t3p = t3
            nlistp = 0
          end if
        end if

        DO 140 K = 1, NLIST
          lval = list(k)
          CALL QADSRC(
     *      NDIM,     NPTS,     NPSRF,    NFSRF,    NISR,
     *      NRSR,     NRSS,     XYZSRF,   XYZPTS,   LINKSRF,
     *      ISRCHR,   RSRCHR,   LVAL,     IFSRF,    IERR   )
 140    CONTINUE
 100  CONTINUE

C ... More debugging stats
      if (idebug .ge. 2) then
        call excpus(t3)
        write(nout, *) '  Finish Queries', t3-t2, NFSRF/(t3-t2), qt
        write(ntpout, *) '  Finish Queries', t3-t2, NFSRF/(t3-t2), qt
        write(nout, *) '  Matches = ',nlistt,' Rate = ',nlistt/(t3-t2)
        write(ntpout, *) '  Matches = ',nlistt,' Rate = ',nlistt/(t3-t2)
      end if

      call kdkilltree()

 190  format(1x,i9,'/',i9,' T= ',1pe10.3,'/',1pe10.3,
     *  ', R= ',1pe10.3,'/',1pe10.3,' M = ',i10,'/',i10)

      RETURN
      END

