C Copyright(C) 1999-2021 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
C -*- Mode: fortran -*-
C=======================================================================
SUBROUTINE EXPXYZ (NDIM,
$ MATNS1, MATNS2, NNNPS, IXNNPS, LTNNPS,
$ NUMNP1, XN1, YN1, ZN1,
$ NUMNP2, XN2, YN2, ZN2,
$ IX1, IX2, nod1, nod2, IXNP2,
$ nelbl1, ID1, nelb1, nlnk1, link1,
$ nelbl2, id2, nelb2, nlnk2, link2,
$ NMATCH, TOLER, CLOSE, MATMAT)
C=======================================================================
C --*** EXPXYZ *** (GJOIN) Find matching nodes
C -- Written by Greg Sjaardema, 8-25-92 - gdsjaar -
C -- Modified from MATXYZ
C --
C --EXPXYZ matches nodes from the first and second database by comparing
C --the coordinates. Since some slack is needed in the equality check,
C --the comparison may not work for all meshes. The nodes to be matched
C --may be limited to nodes in two nodal point sets. Nodes are limited
C --by material blocks -- only match if the materials match. Used to
C --avoid matches across slidelines.
C --
C --Parameters:
C -- NDIM - IN - the number of coordinates per node
C -- MATNS1 - IN - the number of the first nodal point set
C -- MATNS2 - IN - the number of the second nodal point set
C -- NNNPS - IN - the number of nodes for each set
C -- IXNNPS - IN - the indices of the nodes for each set
C -- LTNNPS - IN - the nodes for each set
C -- LNPS2 - IN - the length of the nodal point set for the second database
C -- NPS2 - IN - the nodes in the nodal point set for the second database
C -- NUMNP1 - IN - the number of nodes in the first database
C -- XN1, YN1, ZN1 - IN - the coordinates in the first database
C -- NUMNP2 - IN - the number of nodes in the second database
C -- XN2, YN2, ZN2 - IN - the coordinates in the second database
C -- IX1 - SCRATCH - size = NUMNP1
C -- IX2 - SCRATCH - size = NUMNP2
C -- nod1 - SCRATCH - size = NUMNP1
C -- nod2 - SCRATCH - size = NUMNP2
C -- IXNP2 - IN/OUT - the index of the matching first database node;
C -- negative if no match; reset if NMATCH = 0
C -- NMATCH - IN/OUT - the number of matching nodes
C -- CLOSE - IN/OUT - true if match closest node, false if match any
C -- node within tolerance.
C -- MATMAT - IN/OUT - true if match by material
include 'gj_filnum.blk'
INTEGER NNNPS(*), IXNNPS(*), LTNNPS(*)
REAL XN1(*), YN1(*), ZN1(*)
REAL XN2(*), YN2(*), ZN2(*)
INTEGER IX1(*), IX2(*), nod1(*), nod2(*)
INTEGER IXNP2(*)
LOGICAL CLOSE, MATMAT
INTEGER ID1(*), NELB1(*), NLNK1(*), LINK1(*)
INTEGER ID2(*), NELB2(*), NLNK2(*), LINK2(*)
PARAMETER (MXNAM = 1)
DIMENSION KV(MXNAM), RV(MXNAM), IVAL(MXNAM)
CHARACTER*8 CV(MXNAM)
CHARACTER*80 STRING
LOGICAL INIT
LOGICAL BYSET
LOGICAL OK
NSVMAT = 0
BYSET = (MATNS1 .GT. 0) .AND. (MATNS2 .GT. 0)
C --Index nodes to match in the nodal point sets
ioff1 = 0
do 200 iblk = 1, nelbl1
INIT = (NMATCH .LE. 0)
id = id1(iblk)
ioff2 = 0
do 20 iblk2 = 1, nelbl2
if (id .eq. id2(iblk2)) go to 30
ioff2 = ioff2 + (nelb2(iblk2) * nlnk2(iblk2))
20 continue
C ... Fell through do loop - no matching material in mesh 2.
write (*,*) 'Material ',id,' not present in mesh 2'
go to 190
30 continue
C Now know that id1(iblk) == id2(iblk2). Set flag in nod1 and nod2
C corresponding to whether node exists in these blocks
call iniint (numnp1, 0, nod1)
call iniint (numnp2, 0, nod2)
do 40 i = 1, (nelb1(iblk) * nlnk1(iblk))
nod1(link1(i+ioff1)) = 1
40 continue
do 50 i = 1, (nelb2(iblk2) * nlnk2(iblk2))
nod2(link2(i+ioff2)) = 1
50 continue
IF (BYSET) THEN
IN1 = 0
IX0 = IXNNPS(MATNS1) - 1
DO 60 N = 1, NNNPS(MATNS1)
if (nod1(ltnnps(ix0+n)) .eq. 1) then
IN1 = IN1 + 1
IX1(IN1) = LTNNPS(IX0+N)
end if
60 CONTINUE
IN2 = 0
IX0 = IXNNPS(MATNS2) - 1
DO 70 N = 1, NNNPS(MATNS2)
if (nod2(ltnnps(ix0+n)) .eq. 1) then
IN2 = IN2 + 1
IX2(IN2) = LTNNPS(IX0+N)
end if
70 CONTINUE
else
C ... Construct ix1 and ix2 from nod1 and nod2
in1 = 0
do 80 n = 1, numnp1
if (nod1(n) .eq. 1) then
in1 = in1 + 1
ix1(in1) = n
end if
80 continue
in2 = 0
do 90 n = 1, numnp2
if (nod2(n) .eq. 1) then
in2 = in2 + 1
ix2(in2) = n
end if
90 continue
END IF
time0 = 0.0
time1 = 0.0
time2 = 0.0
C --Find the limits of the overlapping area of the two databases
CALL MINMXS (IN1, IX1, XN1, X1MIN, X1MAX)
CALL MINMXS (IN2, IX2, XN2, X2MIN, X2MAX)
CALL MINMXS (IN1, IX1, YN1, Y1MIN, Y1MAX)
CALL MINMXS (IN2, IX2, YN2, Y2MIN, Y2MAX)
IF (NDIM .GE. 3) THEN
CALL MINMXS (IN1, IX1, ZN1, Z1MIN, Z1MAX)
CALL MINMXS (IN2, IX2, ZN2, Z2MIN, Z2MAX)
END IF
XMIN = MAX (X1MIN, X2MIN)
XMAX = MIN (X1MAX, X2MAX)
YMIN = MAX (Y1MIN, Y2MIN)
YMAX = MIN (Y1MAX, Y2MAX)
IF (NDIM .GE. 3) THEN
ZMIN = MAX (Z1MIN, Z2MIN)
ZMAX = MIN (Z1MAX, Z2MAX)
ELSE
ZMIN = 0.0
ZMAX = 0.0
END IF
EPS = ((XMAX - XMIN) + (YMAX - YMIN) + (ZMAX - ZMIN)) / 1E3
IF (EPS .LT. 0.0) THEN
CALL PRTERR ('ERROR', 'Nodes do not overlap')
GOTO 180
END IF
IF (TOLER .GE. 0.0) THEN
EPS = TOLER
ELSE
WRITE (*, 10040) EPS
10040 FORMAT (/' Default tolerance = ',1PE10.3)
CALL FREFLD (0, 0,
* 'Enter new value for tolerance (<ret> for default): ',
* MXNAM, IOS, NF, KV, CV, IVAL, RV)
IF (IOS .NE. 0) RV(1) = 0.0
IF (RV(1) .NE. 0.0) EPS = RV(1)
CALL OUTLOG (KLOG, 1, 1, CV, IVAL, EPS)
ENDIF
OK = .TRUE.
OK = OK .AND.
& ((MIN (X1MAX, X2MAX) - MAX (X1MIN, X2MIN)) .GT. -EPS)
OK = OK .AND.
& ((MIN (Y1MAX, Y2MAX) - MAX (Y1MIN, Y2MIN)) .GT. -EPS)
IF (NDIM .EQ. 3) THEN
OK = OK .AND.
& ((MIN (Z1MAX, Z2MAX) - MAX (Z1MIN, Z2MIN)) .GT. -EPS)
END IF
IF (.NOT. OK) THEN
CALL PRTERR ('ERROR', 'Nodes do not overlap')
GOTO 180
END IF
XMIN = XMIN - EPS
XMAX = XMAX + EPS
YMIN = YMIN - EPS
YMAX = YMAX + EPS
ZMIN = ZMIN - EPS
ZMAX = ZMAX + EPS
in1sv = in1
IN1 = 0
Z3D = 0.0
DO 120 INP = 1, in1sv
IF (IX1(INP) .GT. 0) THEN
in = ix1(inp)
IF ((XN1(IN) .GE. XMIN) .AND. (XN1(IN) .LE. XMAX)) THEN
IF ((YN1(IN) .GE. YMIN) .AND. (YN1(IN) .LE. YMAX)) THEN
IF (NDIM .GE. 3) Z3D = ZN1(IN)
IF ((Z3D .GE. ZMIN) .AND. (Z3D .LE. ZMAX)) THEN
IN1 = IN1 + 1
IX1(IN1) = IN
END IF
END IF
END IF
end if
120 CONTINUE
in2sv = in2
IN2 = 0
IF (NDIM .LT. 3) Z3D = 0.0
DO 130 INP = 1, in2sv
IF (IX2(INP) .GT. 0) THEN
in = ix2(inp)
IF ((XN2(IN) .GE. XMIN) .AND. (XN2(IN) .LE. XMAX)) THEN
IF ((YN2(IN) .GE. YMIN) .AND. (YN2(IN) .LE. YMAX)) THEN
IF (NDIM .GE. 3) Z3D = ZN2(IN)
IF ((Z3D .GE. ZMIN) .AND. (Z3D .LE. ZMAX)) THEN
IN2 = IN2 + 1
IX2(IN2) = IN
END IF
END IF
END IF
end if
130 CONTINUE
C --Blank out the IXNP2 array
IF (INIT) THEN
DO 140 INP = 1, NUMNP2
IXNP2(INP) = -999
140 CONTINUE
ELSE
DO 150 INP = 1, NUMNP2
IF (IXNP2(INP) .GT. 0) THEN
I = LOCINT (INP, IN2, IX2)
IF (I .GT. 0) THEN
IX2(I) = IX2(IN2)
IN2 = IN2 - 1
END IF
I = LOCINT (IXNP2(INP), IN1, IX1)
IF (I .GT. 0) THEN
IX1(I) = IX1(IN1)
IN1 = IN1 - 1
END IF
END IF
150 CONTINUE
END IF
C --Find all matching nodes by comparing coordinates of nodes in overlap area
call excpus(time0)
call prterr('CMDSPEC', 'Entering Sorting Phase')
call indexn(xn1, 1, 1, ix1, in1, .FALSE.)
call indexn(xn2, 1, 1, ix2, in2, .FALSE.)
call prterr('CMDSPEC', 'Entering Comparison Phase')
time2 = 0.0
CALL EXCPUS(time1)
DISMIN = 1.0E38
DISMAX = -1.0E38
NCOMP = 0
nout = 0
WRITE (*,'(A)') ' '
WRITE (*,'(A)') ' '
NSVMAT = NMATCH
Z3D = 0.0
Z = 0.0
IN1SV = IN1
in2sv = in2
i2beg = 1
DO 170 I1 = 1, IN1SV
INP1 = IX1(I1)
X = XN1(INP1)
Y = YN1(INP1)
IF (NDIM .GE. 3) Z = ZN1(INP1)
DMIN = 1.0E38
NDMIN = 0
I2BEGS = I2BEG
DO 160 I2 = I2BEGS, IN2SV
NCOMP = NCOMP + 1
nout = nout + 1
IF ( nout .ge. 100000) THEN
NCMPX = (IN1SV - I1) * IN2 + (IN2 - I2)
WRITE (*, 10020) NCOMP, NCMPX
nout = 0
END IF
INP2 = IX2(I2)
if (inp2 .le. 0) goto 160
if (x-eps .gt. xn2(inp2)) i2beg = i2
C ... Since we are sorted on X, if set 2 X greater than set 1 X+eps,
C go to next X1 coord.
if (xn2(inp2)-eps .gt. x) goto 165
IF (NDIM .GE. 3) Z3D = ZN2(INP2)
DIS = MAX (ABS (XN2(INP2) - X), ABS(YN2(INP2) - Y),
& ABS (Z3D - Z) )
IF ( (DIS .LE. EPS .AND. .NOT. CLOSE) .OR.
& DIS .EQ. 0.0) THEN
DISMAX = MAX(DISMAX, DIS)
NMATCH = NMATCH + 1
IXNP2(INP2) = INP1
IX2(I2) = -IX2(IN2)
IN2 = IN2 - 1
IX1(I1) = 0
IN1 = IN1 - 1
GOTO 170
ELSE IF (DIS .LE. EPS .AND. CLOSE) THEN
IF (DIS .LT. DMIN) THEN
DMIN = DIS
NDMIN = I2
END IF
ELSE
DISMIN = MIN(DISMIN, DIS)
END IF
160 CONTINUE
165 CONTINUE
IF (CLOSE) THEN
IF (DMIN .LE. EPS) THEN
DISMAX = MAX(DISMAX, DMIN)
NMATCH = NMATCH + 1
INP2 = IX2(NDMIN)
IXNP2(INP2) = INP1
IX2(NDMIN) = -IX2(NDMIN)
IN2 = IN2 - 1
IX1(I1) = 0
IN1 = IN1 - 1
END IF
END IF
170 CONTINUE
CALL EXCPUS(time2)
IF (BYSET) THEN
IF ((IN1 .GT. 0) .AND. (IN2 .GT. 0)) THEN
CALL PRTERR ('WARNING',
& 'All nodes in nodal point set cannot be matched')
END IF
END IF
WRITE (*, 10050) NCOMP
WRITE (*, 10021) EPS
IF (DISMAX .GT. -1.0E37) THEN
WRITE (*, 10025) DISMAX
END IF
IF (DISMIN .LT. 1.0E37) THEN
WRITE (*, 10030) DISMIN
END IF
IF (CLOSE) THEN
WRITE (*, 10035)
END IF
180 CONTINUE
IF (INIT) THEN
WRITE (STRING, 10000) ID, NMATCH
ELSE
WRITE (STRING, 10000) ID, NMATCH, NMATCH-NSVMAT
10000 FORMAT ('Material ID ',I8,' -->',
& I8, ' nodes matched', :, ', ', I8, ' this set')
END IF
CALL SQZSTR (STRING, LSTR)
WRITE (*, 10010) STRING(:LSTR)
if (ncomp .gt. 0) then
if ((time2 - time1) .ne. 0.0) then
Write (*, 10055) Time2-Time1, NCOMP/(time2-time1)
else
write (*, 10060) Time2-Time1
end if
end if
190 continue
ioff1 = ioff1 + (nelb1(iblk) * nlnk1(iblk))
200 continue
RETURN
10010 FORMAT (/, 4X, A)
10020 FORMAT (' Number of equivalence comparisons = ',T38,I15,T60,I15)
10050 FORMAT (' Number of equivalence comparisons = ',T60,I15)
10021 FORMAT (' Tolerance used for matching = ',T60,1PE10.3)
10025 FORMAT (' Maximum distance between matched nodes = ',T60,
* 1PE10.3)
10030 FORMAT (' Minimum distance between nonmatched nodes = ',T60,
* 1PE10.3)
10035 FORMAT (' Equivalencing based on closest node within tolerance')
10055 FORMAT (' Cpu Time = ',1PE10.3, ', comparison/sec = ',1PE10.3)
10060 FORMAT (' Cpu Time = ',1PE10.3, ', comparison/sec = Infinite')
END