You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
213 lines
6.9 KiB
213 lines
6.9 KiB
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
|
|
|