OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
merge_bucket_search.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| merge_bucket_search ../starter/source/elements/nodes/merge_bucket_search.F
25!||--- called by ------------------------------------------------------
26!|| merge_node ../starter/source/elements/nodes/merge_node.F
27!||--- calls -----------------------------------------------------
28!|| decode_merge ../starter/source/elements/nodes/merge_bucket_search.F
29!|| usrtos ../starter/source/system/sysfus.F
30!|| usrtosc ../starter/source/model/submodel/merge.F
31!||--- uses -----------------------------------------------------
32!|| message_mod ../starter/share/message_module/message_mod.F
33!||====================================================================
34 SUBROUTINE merge_bucket_search(X,ITAB,ITABM1,IMERGE0,CMERGE,
35 . DBUC,NN1,NN2,LIST1,LIST2,
36 . DDD,FLAG,LIST1_IDMERGE,LIST1_NBMERGE,LIST2_IDMERGE,
37 . LIST2_NBMERGE)
38C
39 USE message_mod
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C G l o b a l P a r a m e t e r s
46C-----------------------------------------------
47#include "com04_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 INTEGER ITAB(NUMNOD), ITABM1(2*NUMNOD), IMERGE0(*), NN1, NN2,LIST1(*),
52 . LIST2(*),FLAG,LIST1_IDMERGE(*),LIST2_IDMERGE(*),LIST1_NBMERGE(*),
53 . LIST2_NBMERGE(*)
54 TARGET itab
55 my_real
56 . x(3,numnod),cmerge(*),ddd(*),dbuc
57C-----------------------------------------------
58C L o c a l V a r i a b l e s
59C-----------------------------------------------
60 INTEGER I,J,K,N,IB,IG,JG,KP,NC,NS,NN,
61 . IBZ,IBY,IBX,KS,
62 . NBOX,NBOY,NBOZ,NBX,NBY,NBZ,NBAND,IBOITE
63C
64 ! Declaration of integer scalar variables
65 INTEGER :: NUMNOD1, TAG
66 INTEGER, ALLOCATABLE, DIMENSION(:) :: NOBX, NOBY, NOBZ
67 INTEGER, ALLOCATABLE, DIMENSION(:) :: NOBCX, NOBCY, NOBCZ
68 INTEGER, ALLOCATABLE, DIMENSION(:) :: TABS, TABC
69C
70 INTEGER, DIMENSION(:),POINTER :: ITABC
71 INTEGER, DIMENSION(:),ALLOCATABLE ::
72 . NPX,IPX,NPY,IPY,NPZ,IPZ,NPCX,IPCX,NPCY,IPCY,NPCZ,IPCZ
73C
74 my_real
75 . xi, yi, zi, xj, yj, zj,
76 . dist2,dvois,eps,xmin,xmax,ymin,ymax,zmin,
77 . zmax,dmx,dmy,dmz,dmerge
78C-----------------------------------------------
79 INTEGER
80 . USRTOS,USRTOSC
81 EXTERNAL USRTOS,USRTOSC
82C
83C=======================================================================
84C - BUCKET SEARCH FOR MERGING OF NODES
85C - --> FLAG = 1 : merging of nodes with cnodes
86C - --> FLAG = 2 : merging of nodes with modes (/MERGE/NODE)
87C
88C - --> LIST1 / NN1 : list of nodes candidate for merging
89C - --> LIST2 / NN2 : list of destinations
90C=======================================================================
91C
92 ALLOCATE(nobx(numnod))
93 ALLOCATE(noby(numnod))
94 ALLOCATE(nobz(numnod))
95 ALLOCATE(nobcx(nn2))
96 ALLOCATE(nobcy(nn2))
97 ALLOCATE(nobcz(nn2))
98 ALLOCATE(tabs(nb_merge_node))
99 ALLOCATE(tabc(nb_merge_node))
100 dbuc = two*dbuc
101 eps=em3*dbuc
102 xmin=ep30
103 xmax=-ep30
104 ymin=ep30
105 ymax=-ep30
106 zmin=ep30
107 zmax=-ep30
108C
109 DO i=1,nn1
110 n = list1(i)
111 nn = usrtos(itab(n),itabm1)
112 xmin= min(xmin,x(1,nn))
113 ymin= min(ymin,x(2,nn))
114 zmin= min(zmin,x(3,nn))
115 xmax= max(xmax,x(1,nn))
116 ymax= max(ymax,x(2,nn))
117 zmax= max(zmax,x(3,nn))
118 ENDDO
119C
120 xmin=xmin-eps
121 ymin=ymin-eps
122 zmin=zmin-eps
123 xmax=xmax+eps
124 ymax=ymax+eps
125 zmax=zmax+eps
126C
127 dmx=xmax-xmin
128 dmy=ymax-ymin
129 dmz=zmax-zmin
130C
131 nbx =max(1,int(dmx/dbuc))
132 nby =max(1,int(dmy/dbuc))
133 nbz =max(1,int(dmz/dbuc))
134C
135 DO i=1,nn1
136 n = list1(i)
137 nn = usrtos(itab(n),itabm1)
138 nobx(i) = int( (x(1,nn)-xmin)/dbuc)
139 noby(i) = int( (x(2,nn)-ymin)/dbuc)
140 nobz(i) = int( (x(3,nn)-zmin)/dbuc)
141 ENDDO
142C
143 IF (flag == 1) THEN
144C-- destinations are cnodes (NN2 = NUMCNOD)
145 numnod1 = numnod0-numcnod
146 itabc => itab(numnod1+1:numnod0)
147 DO i=1,nn2
148 n = list2(i)
149 nn = usrtosc(itabc(n),itabm1)
150 nobcx(n) =int( (x(1,nn)-xmin)/dbuc)
151 nobcy(n) =int( (x(2,nn)-ymin)/dbuc)
152 nobcz(n) =int( (x(3,nn)-zmin)/dbuc)
153 ENDDO
154 ELSE
155 itabc => null()
156C-- destinations are nodes
157 DO i=1,nn2
158 n = list2(i)
159 nn = usrtos(itab(n),itabm1)
160 nobcx(i) = int( (x(1,nn)-xmin)/dbuc)
161 nobcy(i) = int( (x(2,nn)-ymin)/dbuc)
162 nobcz(i) = int( (x(3,nn)-zmin)/dbuc)
163 ENDDO
164 ENDIF
165C
166 nband = max(nbx, nby,nbz) + 1
167C
168 ALLOCATE( npx(0:nn1+nband ) , npy(0:3*(nn1+nband)),
169 . npz(0:9*(nn1+nband)) , ipx(nn1+nband) ,
170 . ipy(nn1+nband) , ipz(nn1+nband),
171 . npcx(0:nn2+nband) , npcy(0:nn2+nband) ,
172 . npcz(0:nn2+nband) , ipcx(nn2+nband) ,
173 . ipcy(nn2+nband) , ipcz(nn2+nband))
174
175C--------------------------------------------------
176C CLASSEMENT DES BUCKETS X
177C--------------------------------------------------
178C
179C--- bande NBX uniquement.
180C
181 DO ib=0,nbx+1
182 npx(ib)=0
183 ENDDO
184 DO n=1,nn1
185 nbox=nobx(n)+1
186 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
187 npx(nbox)=npx(nbox)+1
188 ENDIF
189 ENDDO
190 DO ib=1,nbx+1
191 npx(ib)=npx(ib)+npx(ib-1)
192 ENDDO
193 DO ib=nbx+1,1,-1
194 npx(ib)=npx(ib-1)
195 ENDDO
196 DO n=1,nn1
197 nbox=nobx(n)+1
198C bande NBX uniquement.
199 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
200 npx(nbox)=npx(nbox)+1
201 ipx(npx(nbox))=n
202 ENDIF
203 ENDDO
204C
205C Cnode bande nbx
206C
207 DO ib=0,nbx+1
208 npcx(ib)=0
209 ENDDO
210 DO n=1,nn2
211 nbox=nobcx(n)+1
212 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
213 npcx(nbox)=npcx(nbox)+1
214 ENDIF
215 ENDDO
216 DO ib=1,nbx+1
217 npcx(ib)=npcx(ib)+npcx(ib-1)
218 ENDDO
219 DO ib=nbx+1,1,-1
220 npcx(ib)=npcx(ib-1)
221 ENDDO
222 DO n=1,nn2
223 nbox=nobcx(n)+1
224C bande NBX uniquement.
225 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
226 npcx(nbox)=npcx(nbox)+1
227 ipcx(npcx(nbox))=n
228 ENDIF
229 ENDDO
230C-----
231 DO ibx=1,nbx+1
232 iboite = 0
233 DO kp= npcx(ibx-1)+1,npcx(ibx)
234 IF(ipcx(kp)> 0)iboite =1
235 ENDDO
236C
237 IF(iboite > 0) THEN
238 DO iby=0,nby+1
239 npy(iby)=0
240 ENDDO
241 DO ks=npx(max(ibx-2,0))+1,npx(min(ibx+1,nbx+1))
242 n =ipx(ks)
243 nboy=noby(n)+1
244C bande NBY uniquement.
245 IF(nboy >= 1 .AND. nboy <= nby+1)THEN
246 npy(nboy)=npy(nboy)+1
247 ENDIF
248 ENDDO
249 DO iby=1,nby+1
250 npy(iby)=npy(iby)+npy(iby-1)
251 ENDDO
252 DO iby=nby+1,1,-1
253 npy(iby)=npy(iby-1)
254 ENDDO
255 DO ks=npx(max(ibx-2,0))+1,npx(min(ibx+1,nbx+1))
256 n =ipx(ks)
257 nboy=noby(n)+1
258C bande NBY uniquement.
259 IF(nboy >= 1 .AND. nboy <= nby+1)THEN
260 npy(nboy)=npy(nboy)+1
261 ipy(npy(nboy))=n
262 ENDIF
263 ENDDO
264C
265C Cnode Bande Y
266C
267 DO iby=0,nby+1
268 npcy(iby)=0
269 ENDDO
270 DO ks=npcx(ibx-1)+1,npcx(ibx)
271 n =ipcx(ks)
272 nboy=nobcy(n)+1
273C bande NBY uniquement.
274 IF(nboy >= 1.AND.nboy <= nby+1)THEN
275 npcy(nboy)=npcy(nboy)+1
276 ENDIF
277 ENDDO
278C
279 DO iby=1,nby+1
280 npcy(iby)=npcy(iby)+npcy(iby-1)
281 ENDDO
282C
283 DO iby=nby+1,1,-1
284 npcy(iby)=npcy(iby-1)
285 ENDDO
286 DO ks=npcx(ibx-1)+1,npcx(ibx)
287 n =ipcx(ks)
288 nboy=nobcy(n)+1
289C bande NBY uniquement.
290 IF(nboy >= 1.AND. nboy <= nby+1)THEN
291 npcy(nboy)=npcy(nboy)+1
292 ipcy(npcy(nboy))=n
293 ENDIF
294 ENDDO
295C
296C -- les boites suivantes z
297C
298 DO iby=1,nby+1
299 iboite = 0
300 DO kp= npcy(iby-1)+1,npcy(iby)
301 IF(ipcy(kp) > 0)iboite = 1
302 ENDDO
303C
304 IF(iboite > 0) THEN
305 DO ibz=0,nbz+1
306 npz(ibz)=0
307 ENDDO
308 DO ks=npy(max(iby-2,0))+1,npy(min(iby+1, nby+1))
309 n =ipy(ks)
310 nboz=nobz(n)+1
311C bande NBZ uniquement.
312 IF(nboz >= 1.AND.nboz <= nbz+1)THEN
313 npz(nboz)=npz(nboz)+1
314 ENDIF
315 ENDDO
316 DO ibz=1,nbz+1
317 npz(ibz)=npz(ibz)+npz(ibz-1)
318 ENDDO
319 DO ibz=nbz+1,1,-1
320 npz(ibz)=npz(ibz-1)
321 ENDDO
322 DO ks=npy(max(iby-2,0))+1,npy(min(iby+1, nby+1))
323 n =ipy(ks)
324 nboz=nobz(n)+1
325C bande NBZ uniquement.
326 IF(nboz >= 1 .AND. nboz <= nbz+1)THEN
327 npz(nboz)=npz(nboz)+1
328 ipz(npz(nboz))=n
329 ENDIF
330 ENDDO
331C
332C Cnode Bande Z
333C
334 DO ibz=0,nbz+1
335 npcz(ibz)=0
336 ENDDO
337 DO ks=npcy(iby-1)+1,npcy(iby)
338 n =ipcy(ks)
339 nboz=nobcz(n)+1
340 IF(nboz >= 1.AND.nboz <= nbz+1)THEN
341 npcz(nboz)=npcz(nboz)+1
342 ENDIF
343 ENDDO
344 DO ibz=1,nbz+1
345 npcz(ibz)=npcz(ibz)+npcz(ibz-1)
346 ENDDO
347 DO ibz=nbz+1,1,-1
348 npcz(ibz)=npcz(ibz-1)
349 ENDDO
350 DO ks=npcy(iby-1)+1,npcy(iby)
351 n =ipcy(ks)
352 nboz=nobcz(n)+1
353 IF(nboz >= 1.AND. nboz <= nbz+1)THEN
354 npcz(nboz)=npcz(nboz)+1
355 ipcz(npcz(nboz))=n
356 ENDIF
357 ENDDO
358C
359C ---recherche cnode par boite tt d'abord
360C
361 dvois = huge(dvois)
362 DO ibz=1,nbz+1
363 DO kp= npcz(ibz-1)+1,npcz(ibz)
364 IF(ipcz(kp) > 0) THEN
365 DO ks=npz(max(ibz-2,0))+1,npz(min(ibz+1,nbz+1))
366 IF (flag == 1) THEN
367C----------------------------------------------------------------------------------------
368C-- Merging with cnodes - cnode is destination for closest node
369C----------------------------------------------------------------------------------------
370 nc =ipcz(kp)
371 ns =ipz(ks)
372 ig = usrtosc(itabc(nc),itabm1)
373 xi =x(1,ig)
374 yi =x(2,ig)
375 zi =x(3,ig)
376 dmerge = cmerge(nc)*cmerge(nc)
377 jg=usrtos(itab(ns),itabm1)
378 xj =(x(1,jg)-xi)
379 yj =(x(2,jg)-yi)
380 zj =(x(3,jg)-zi)
381 dist2=xj**2 + yj**2 + zj**2
382 IF(itabc(nc)/=itab(ns).AND.dist2<=dmerge)THEN
383 IF(imerge0(nc) == 0) THEN
384 imerge0(nc) = itab(ns)
385 dvois = dist2
386 ELSEIF(dist2 < dvois)THEN
387 imerge0(nc) = itab(ns)
388 dvois = dist2
389 ENDIF
390 ENDIF
391 ELSE
392C---------------------------------------------------------------------------------------------
393C-- Merging with nodes - node with lowest user id is the destination
394C---------------------------------------------------------------------------------------------
395 nc = list2(ipcz(kp))
396 ns = list1(ipz(ks))
397 ig=usrtos(itab(nc),itabm1)
398 xi =x(1,ig)
399 yi =x(2,ig)
400 zi =x(3,ig)
401 jg=usrtos(itab(ns),itabm1)
402 xj =(x(1,jg)-xi)
403 yj =(x(2,jg)-yi)
404 zj =(x(3,jg)-zi)
405 dist2=xj**2 + yj**2 + zj**2
406C
407 CALL decode_merge(list2_idmerge(ipcz(kp)),list2_nbmerge(ipcz(kp)),tabc,nb_merge_node)
408 CALL decode_merge(list1_idmerge(ipz(ks)),list1_nbmerge(ipz(ks)),tabs,nb_merge_node)
409C
410 tag = 0
411 dmerge = zero
412 DO j=1,list2_nbmerge(ipcz(kp))
413 DO k=1,list1_nbmerge(ipz(ks))
414 IF (abs(tabc(j)) == tabs(k)) THEN
415C-- pair is retained only if referred by same merge/node
416C-- tabc < 0 if merge_type = 2 - criteria itab(ns) < itab(nc) not used
417 dmerge = cmerge(tabs(k))*cmerge(tabs(k))
418 IF ((itab(ns)>itab(nc)).OR.((tabc(j)<0).AND.(ns/=nc))) THEN
419 IF (dist2<=dmerge) THEN
420 IF(imerge0(ipz(ks)) == 0) THEN
421 imerge0(ipz(ks)) = itab(nc)
422 ddd(ipz(ks)) = dist2
423 ELSEIF(imerge0(ipz(ks)) > itab(nc))THEN
424 imerge0(ipz(ks)) = itab(nc)
425 ddd(ipz(ks)) = dist2
426 ENDIF
427 ENDIF
428 ENDIF
429 ENDIF
430 ENDDO
431 ENDDO
432C
433 ENDIF
434 ENDDO
435 ENDIF
436 ENDDO
437 ENDDO
438 ENDIF
439 ENDDO
440 ENDIF
441 ENDDO
442 DEALLOCATE(nobx)
443 DEALLOCATE(noby)
444 DEALLOCATE(nobz)
445 DEALLOCATE(nobcx)
446 DEALLOCATE(nobcy)
447 DEALLOCATE(nobcz)
448 DEALLOCATE(tabs)
449 DEALLOCATE(tabc)
450C--------
451 RETURN
452 END
453
454!||====================================================================
455!|| decode_merge ../starter/source/elements/nodes/merge_bucket_search.F
456!||--- called by ------------------------------------------------------
457!|| merge_bucket_search ../starter/source/elements/nodes/merge_bucket_search.F
458!||====================================================================
459 SUBROUTINE decode_merge(CODE,NVAL,TAB,NB_MERGE)
460C-----------------------------------------------
461C I m p l i c i t T y p e s
462C-----------------------------------------------
463#include "implicit_f.inc"
464C-----------------------------------------------
465C D u m m y A r g u m e n t s
466C-----------------------------------------------
467 INTEGER CODE,NVAL,TAB(*),NB_MERGE
468C-----------------------------------------------
469C L o c a l V a r i a b l e s
470C-----------------------------------------------
471 INTEGER I,J,CODE_TEMP,BASE
472C-----------------------------------------------
473C S o u r c e L i n e s
474C-----------------------------------------------
475C
476C-- decode id merge
477C
478 base = 2*nb_merge
479C
480 tab(1:nb_merge) = 0
481C
482 code_temp = code
483 DO i=1,nval
484 tab(i) = code_temp / (base**(nval-i))
485C TAB(I) = FLOOR(DIV)
486 code_temp = code_temp - (base**(nval-i))*tab(i)
487 IF (tab(i) > nb_merge) tab(i) = -(tab(i)-nb_merge)
488 ENDDO
489C
490 END SUBROUTINE decode_merge
my_real
#define my_real
Definition cppsort.cpp:32
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:272
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
decode_merge
subroutine decode_merge(code, nval, tab, nb_merge)
Definition merge_bucket_search.F:460
merge_bucket_search
subroutine merge_bucket_search(x, itab, itabm1, imerge0, cmerge, dbuc, nn1, nn2, list1, list2, ddd, flag, list1_idmerge, list1_nbmerge, list2_idmerge, list2_nbmerge)
Definition merge_bucket_search.F:38
message_mod
Definition message_mod.F:1249