OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
merge.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 ../starter/source/model/submodel/merge.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| merge_cnod_cnod ../starter/source/model/submodel/merge_cnod_cnod.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(X ,ITAB ,ITABM1 ,CMERGE ,IMERGE,
35 . IMERGE2,IADMERGE2,NMERGE_TOT)
36 USE message_mod
37C-----------------------------------------------
38C I m p l i c i t T y p e s
39C-----------------------------------------------
40#include "implicit_f.inc"
41C-----------------------------------------------
42C G l o b a l P a r a m e t e r s
43C-----------------------------------------------
44#include "units_c.inc"
45#include "com04_c.inc"
46#include "titr_c.inc"
47C-----------------------------------------------
48C D u m m y A r g u m e n t s
49C-----------------------------------------------
50 INTEGER ITAB(NUMNOD), ITABM1(2*NUMNOD),IMERGE(*),
51 . imerge2(numnod+1),iadmerge2(numnod+1),nmerge_tot
52 TARGET itab
53 my_real
54 . x(3,numnod),cmerge(*)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER I,J,K,M,N,I1,IB,IG,JG,J1,JK,KK,KP,N1,N2,NC,NS,NN,NM,
59 . ibz1,ibz,iby1,iby,ibx1,ibx,ks,numnod1,numcnod1,
60 . nbox,nboy,nboz,nbx,nby,nbz,nband,iboite
61C
62 INTEGER, DIMENSION(:),POINTER :: ITABC
63 INTEGER, DIMENSION(:),ALLOCATABLE ::
64 . npx,ipx,npy,ipy,npz,ipz,npcx,ipcx,npcy,ipcy,npcz,ipcz,imerge0
65 INTEGER,DIMENSION(:), ALLOCATABLE :: NOBX
66 INTEGER,DIMENSION(:), ALLOCATABLE :: NOBY
67 INTEGER,DIMENSION(:), ALLOCATABLE :: NOBZ
68 INTEGER,DIMENSION(:), ALLOCATABLE :: NOBCX
69 INTEGER,DIMENSION(:), ALLOCATABLE :: NOBCY
70 INTEGER,DIMENSION(:), ALLOCATABLE :: NOBCZ
71 INTEGER,DIMENSION(:), ALLOCATABLE :: LBUF
72 INTEGER,DIMENSION(:), ALLOCATABLE :: IADMERGE2TMP
73 my_real
74 . xi, yi, zi, xj, yj, zj, dk,
75 . dist2,dvois,dbuc,eps,xmin,xmax,ymin,ymax,zmin,
76 . zmax,dmx,dmy,dmz,dmerge,ddd(numcnod)
77C-----------------------------------------------
78 INTEGER
79 . usrtos,usrtosc
80 EXTERNAL usrtos,usrtosc
81C=======================================================================
82
83 ALLOCATE(nobx(numnod))
84 ALLOCATE(noby(numnod))
85 ALLOCATE(nobz(numnod))
86 ALLOCATE(nobcx(numcnod))
87 ALLOCATE(nobcy(numcnod))
88 ALLOCATE(nobcz(numcnod))
89 ALLOCATE(lbuf(numnod))
90 ALLOCATE(iadmerge2tmp(numnod+1))
91C------- dbuc------------------------------
92 DO n=1,2*numcnod
93 imerge(n) = 0
94 END DO
95 DO n=1,numnod+1
96 imerge2(n) = 0
97 iadmerge2(n) = 0
98 END DO
99C
100 numnod1 = numnod0-numcnod
101 itabc => itab(numnod1+1:numnod0)
102 dbuc = zero
103 DO n=1,numcnod
104 nn = usrtosc(itabc(n),itabm1)
105 dbuc = max(dbuc,cmerge(n))
106 ENDDO
107C
108 dbuc = two*dbuc
109 eps=em3*dbuc
110 xmin=ep30
111 xmax=-ep30
112 ymin=ep30
113 ymax=-ep30
114 zmin=ep30
115 zmax=-ep30
116C
117 DO n=1,numnod0
118 nn = usrtos(itab(n),itabm1)
119 xmin= min(xmin,x(1,nn))
120 ymin= min(ymin,x(2,nn))
121 zmin= min(zmin,x(3,nn))
122 xmax= max(xmax,x(1,nn))
123 ymax= max(ymax,x(2,nn))
124 zmax= max(zmax,x(3,nn))
125 ENDDO
126C
127 xmin=xmin-eps
128 ymin=ymin-eps
129 zmin=zmin-eps
130 xmax=xmax+eps
131 ymax=ymax+eps
132 zmax=zmax+eps
133C
134 dmx=xmax-xmin
135 dmy=ymax-ymin
136 dmz=zmax-zmin
137C
138 nbx =max(1,int(dmx/dbuc))
139 nby =max(1,int(dmy/dbuc))
140 nbz =max(1,int(dmz/dbuc))
141C
142 DO n=1,numnod1
143 nn = usrtos(itab(n),itabm1)
144 nobx(n) = (x(1,nn)-xmin)/dbuc
145 noby(n) = (x(2,nn)-ymin)/dbuc
146 nobz(n) = (x(3,nn)-zmin)/dbuc
147 ENDDO
148C
149 DO n=1,numcnod
150 nn = usrtosc(itabc(n),itabm1)
151 nobcx(n) = (x(1,nn)-xmin)/dbuc
152 nobcy(n) = (x(2,nn)-ymin)/dbuc
153 nobcz(n) = (x(3,nn)-zmin)/dbuc
154 ENDDO
155C
156 nband = max(nbx, nby,nbz) + 1
157C
158 ALLOCATE( npx(0:numnod1+nband ) , npy(0:3*(numnod1+nband)),
159 . npz(0:9*(numnod1+nband)) , ipx(numnod1+nband) ,
160 . ipy(numnod1+nband) , ipz(numnod1+nband),
161 . npcx(0:numcnod+nband) , npcy(0:numcnod+nband) ,
162 . npcz(0:numcnod+nband) , ipcx(numcnod+nband) ,
163 . ipcy(numcnod+nband) , ipcz(numcnod+nband),
164 . imerge0(numcnod))
165 imerge0(1:numcnod) = 0
166C--------------------------------------------------
167C CLASSEMENT DES BUCKETS X
168C--------------------------------------------------
169C
170C--- bande NBX uniquement.
171C
172 DO ib=0,nbx+1
173 npx(ib)=0
174 ENDDO
175 DO n=1,numnod1
176 nbox=nobx(n)+1
177 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
178 npx(nbox)=npx(nbox)+1
179 ENDIF
180 ENDDO
181 DO ib=1,nbx+1
182 npx(ib)=npx(ib)+npx(ib-1)
183 ENDDO
184 DO ib=nbx+1,1,-1
185 npx(ib)=npx(ib-1)
186 ENDDO
187 DO n=1,numnod1
188 nbox=nobx(n)+1
189C bande NBX uniquement.
190 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
191 npx(nbox)=npx(nbox)+1
192 ipx(npx(nbox))=n
193 ENDIF
194 ENDDO
195C
196C Cnode bande nbx
197C
198 DO ib=0,nbx+1
199 npcx(ib)=0
200 ENDDO
201 DO n=1,numcnod
202 nbox=nobcx(n)+1
203 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
204 npcx(nbox)=npcx(nbox)+1
205 ENDIF
206 ENDDO
207 DO ib=1,nbx+1
208 npcx(ib)=npcx(ib)+npcx(ib-1)
209 ENDDO
210 DO ib=nbx+1,1,-1
211 npcx(ib)=npcx(ib-1)
212 ENDDO
213 DO n=1,numcnod
214 nbox=nobcx(n)+1
215C bande NBX uniquement.
216 IF(nbox >= 1.AND.nbox <= nbx+1)THEN
217 npcx(nbox)=npcx(nbox)+1
218 ipcx(npcx(nbox))=n
219 ENDIF
220 ENDDO
221C-----
222 DO ibx=1,nbx+1
223 iboite = 0
224 DO kp= npcx(ibx-1)+1,npcx(ibx)
225 IF(ipcx(kp)> 0)iboite =1
226 ENDDO
227C
228 IF(iboite > 0) THEN
229 DO iby=0,nby+1
230 npy(iby)=0
231 ENDDO
232 DO ks=npx(max(ibx-2,0))+1,npx(min(ibx+1,nbx+1))
233 n =ipx(ks)
234 nboy=noby(n)+1
235C bande NBY uniquement.
236 IF(nboy >= 1 .AND. nboy <= nby+1)THEN
237 npy(nboy)=npy(nboy)+1
238 ENDIF
239 ENDDO
240 DO iby=1,nby+1
241 npy(iby)=npy(iby)+npy(iby-1)
242 ENDDO
243 DO iby=nby+1,1,-1
244 npy(iby)=npy(iby-1)
245 ENDDO
246 DO ks=npx(max(ibx-2,0))+1,npx(min(ibx+1,nbx+1))
247 n =ipx(ks)
248 nboy=noby(n)+1
249C bande NBY uniquement.
250 IF(nboy >= 1 .AND. nboy <= nby+1)THEN
251 npy(nboy)=npy(nboy)+1
252 ipy(npy(nboy))=n
253 ENDIF
254 ENDDO
255C
256C Cnode Bande Y
257C
258 DO iby=0,nby+1
259 npcy(iby)=0
260 ENDDO
261 DO ks=npcx(ibx-1)+1,npcx(ibx)
262 n =ipcx(ks)
263 nboy=nobcy(n)+1
264C bande NBY uniquement.
265 IF(nboy >= 1.AND.nboy <= nby+1)THEN
266 npcy(nboy)=npcy(nboy)+1
267 ENDIF
268 ENDDO
269C
270 DO iby=1,nby+1
271 npcy(iby)=npcy(iby)+npcy(iby-1)
272 ENDDO
273C
274 DO iby=nby+1,1,-1
275 npcy(iby)=npcy(iby-1)
276 ENDDO
277 DO ks=npcx(ibx-1)+1,npcx(ibx)
278 n =ipcx(ks)
279 nboy=nobcy(n)+1
280C bande NBY uniquement.
281 IF(nboy >= 1.AND. nboy <= nby+1)THEN
282 npcy(nboy)=npcy(nboy)+1
283 ipcy(npcy(nboy))=n
284 ENDIF
285 ENDDO
286C
287C -- les boites suivantes z
288C
289 DO iby=1,nby+1
290 iboite = 0
291 DO kp= npcy(iby-1)+1,npcy(iby)
292 IF(ipcy(kp) > 0)iboite = 1
293 ENDDO
294C
295 IF(iboite > 0) THEN
296 DO ibz=0,nbz+1
297 npz(ibz)=0
298 ENDDO
299 DO ks=npy(max(iby-2,0))+1,npy(min(iby+1, nby+1))
300 n =ipy(ks)
301 nboz=nobz(n)+1
302C bande NBZ uniquement.
303 IF(nboz >= 1.AND.nboz <= nbz+1)THEN
304 npz(nboz)=npz(nboz)+1
305 ENDIF
306 ENDDO
307 DO ibz=1,nbz+1
308 npz(ibz)=npz(ibz)+npz(ibz-1)
309 ENDDO
310 DO ibz=nbz+1,1,-1
311 npz(ibz)=npz(ibz-1)
312 ENDDO
313 DO ks=npy(max(iby-2,0))+1,npy(min(iby+1, nby+1))
314 n =ipy(ks)
315 nboz=nobz(n)+1
316C bande NBZ uniquement.
317 IF(nboz >= 1 .AND. nboz <= nbz+1)THEN
318 npz(nboz)=npz(nboz)+1
319 ipz(npz(nboz))=n
320 ENDIF
321 ENDDO
322C
323C Cnode Bande Z
324C
325 DO ibz=0,nbz+1
326 npcz(ibz)=0
327 ENDDO
328 DO ks=npcy(iby-1)+1,npcy(iby)
329 n =ipcy(ks)
330 nboz=nobcz(n)+1
331 IF(nboz >= 1.AND.nboz <= nbz+1)THEN
332 npcz(nboz)=npcz(nboz)+1
333 ENDIF
334 ENDDO
335 DO ibz=1,nbz+1
336 npcz(ibz)=npcz(ibz)+npcz(ibz-1)
337 ENDDO
338 DO ibz=nbz+1,1,-1
339 npcz(ibz)=npcz(ibz-1)
340 ENDDO
341 DO ks=npcy(iby-1)+1,npcy(iby)
342 n =ipcy(ks)
343 nboz=nobcz(n)+1
344 IF(nboz >= 1.AND. nboz <= nbz+1)THEN
345 npcz(nboz)=npcz(nboz)+1
346 ipcz(npcz(nboz))=n
347 ENDIF
348 ENDDO
349C
350C ---recherche cnode par boite tt d'abord
351C
352 dvois = huge(dvois)
353 DO ibz=1,nbz+1
354 DO kp= npcz(ibz-1)+1,npcz(ibz)
355 nc =ipcz(kp)
356 IF(nc > 0) THEN
357 DO ks=npz(max(ibz-2,0))+1,npz(min(ibz+1,nbz+1))
358 ns =ipz(ks)
359 ig = usrtosc(itabc(nc),itabm1)
360 xi =x(1,ig)
361 yi =x(2,ig)
362 zi =x(3,ig)
363 dmerge = cmerge(nc)*cmerge(nc)
364 jg=usrtos(itab(ns),itabm1)
365 xj =(x(1,jg)-xi)
366 yj =(x(2,jg)-yi)
367 zj =(x(3,jg)-zi)
368 dist2=xj**2 + yj**2 + zj**2
369 ddd(nc) = dist2
370 IF(itabc(nc)/=itab(ns).AND.dist2<=dmerge)THEN
371 IF(imerge0(nc) == 0) THEN
372 imerge0(nc) = itab(ns)
373 dvois = dist2
374 ddd(nc) = dist2
375 ELSEIF(dist2 < dvois)THEN
376 imerge0(nc) = itab(ns)
377 dvois = dist2
378 ddd(nc) = dist2
379 ENDIF
380 ENDIF
381 ENDDO
382 ENDIF
383 ENDDO
384
385 ENDDO
386
387 ENDIF
388 ENDDO
389 ENDIF
390 ENDDO
391C--------------------------------------------------
392C COMPACT IMERGE -> No systeme
393C--------------------------------------------------
394 nm = 0
395 DO i= 1,numcnod
396 IF (imerge0(i) > 0) THEN
397 nm = nm+1
398 imerge(nmerge_tot+nm) = usrtosc(imerge0(i),itabm1)
399 imerge(nm) = usrtosc(itabc(i) ,itabm1)
400! ELSE
401! CALL ANCMSG(MSGID=739,
402! . MSGTYPE=MSGWARNING,
403! . ANMODE=ANINFO_BLIND_1,
404! . i1=itabc(i))
405 ENDIF
406 ENDDO
407 nmerged = nm
408C--------------------------------------------------
409C TAB ID_NODE systeme -> ID_CNODE systeme
410C--------------------------------------------------
411 IF (nm > 0) THEN
412 lbuf = 0
413 DO i = 1,numcnod
414 IF (imerge(nmerge_tot+i) > 0) THEN
415 n = imerge(nmerge_tot+i)
416 lbuf(n) = lbuf(n) + 1
417 ENDIF
418 ENDDO
419 iadmerge2(1) = 1
420 iadmerge2tmp(1) = 1
421 DO i = 2,numnod+1
422 iadmerge2(i) = iadmerge2(i-1) + lbuf(i-1)
423 iadmerge2tmp(i) = iadmerge2tmp(i-1) + lbuf(i-1)
424 ENDDO
425 DO i = 1,numcnod
426 IF (imerge(nmerge_tot+i) > 0) THEN
427 n = imerge(nmerge_tot+i)
428 imerge2(iadmerge2tmp(n)) = imerge(i)
429 iadmerge2tmp(n)=iadmerge2tmp(n)+1
430 ENDIF
431 ENDDO
432 ENDIF
433C--------------------------------------------------
434 WRITE(iout,'(//A/A//A/)')titre(114),titre(115),titre(116)
435 j=0
436 DO n=1,nmerged,50
437 j=j+50
438 j=min(j,nmerged)
439 DO i=n,j
440 WRITE(iout,'(5X,I10,8X,I10)')
441 . itab(imerge(i)),itab(imerge(nmerge_tot+i))
442 ENDDO
443 ENDDO
444C--------
445 DEALLOCATE(npx ,npy ,npz ,ipx ,ipy ,ipz ,
446 . npcx ,npcy ,npcz ,ipcx ,ipcy ,ipcz )
447C--------
448C Merging CNODE to CNODE
449C--------
450 CALL merge_cnod_cnod(x ,itab ,itabm1 ,cmerge ,imerge,
451 . imerge2,iadmerge2,imerge0,nmerge_tot)
452 DEALLOCATE(imerge0)
453 DEALLOCATE(nobx)
454 DEALLOCATE(noby)
455 DEALLOCATE(nobz)
456 DEALLOCATE(nobcx)
457 DEALLOCATE(nobcy)
458 DEALLOCATE(nobcz)
459 DEALLOCATE(lbuf)
460 DEALLOCATE(iadmerge2tmp)
461 RETURN
462 END
463C------------------------------------------------------------
464!||====================================================================
465!|| usrtosc ../starter/source/model/submodel/merge.F
466!||--- called by ------------------------------------------------------
467!|| merge ../starter/source/model/submodel/merge.f
468!|| merge_bucket_search ../starter/source/elements/nodes/merge_bucket_search.F
469!|| merge_cnod_cnod ../starter/source/model/submodel/merge_cnod_cnod.F
470!|| merge_node ../starter/source/elements/nodes/merge_node.f
471!||====================================================================
472 INTEGER FUNCTION usrtosc(IU,ITABM1)
473C IDENTIQUE A USR2SYS, SANS GENERER D'ERREUR
474C FONCTION DONNE N0 SYSTEME DU NOEUD USER IU
475C-----------------------------------------------
476C I m p l i c i t T y p e s
477C-----------------------------------------------
478#include "implicit_f.inc"
479C-----------------------------------------------
480C D u m m y A r g u m e n t s
481C-----------------------------------------------
482 INTEGER iu
483 INTEGER itabm1(*)
484C-----------------------------------------------
485C C o m m o n B l o c k s
486C-----------------------------------------------
487#include "com04_c.inc"
488C-----------------------------------------------
489C L o c a l V a r i a b l e s
490C-----------------------------------------------
491 INTEGER jinf, jsup, j
492 jinf=1
493 jsup=numnod0
494 j=max(1,numcnod/2)
495 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
496 usrtosc=0
497 RETURN
498 ENDIF
499 IF((iu-itabm1(j))==0)THEN
500C >CAS IU=TABM FIN DE LA RECHERCHE
501 usrtosc=itabm1(j+numnod0)
502 RETURN
503 ELSE IF (iu-itabm1(j)<0) THEN
504C >CAS IU<TABM
505 jsup=j-1
506 ELSE
507C >CAS IU>TABM
508 jinf=j+1
509 ENDIF
510 j=(jsup+jinf)/2
511 GO TO 10
512 END
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
merge
subroutine merge(x, itab, itabm1, cmerge, imerge, imerge2, iadmerge2, nmerge_tot)
Definition merge.F:36
usrtosc
integer function usrtosc(iu, itabm1)
Definition merge.F:473
merge_cnod_cnod
subroutine merge_cnod_cnod(x, itab, itabm1, cmerge, imerge, imerge2, iadmerge2, imerge0, nmerge_tot)
Definition merge_cnod_cnod.F:35
merge_node
subroutine merge_node(x, itab, itabm1, imerge, imerge2, iadmerge2, nmerge_tot, merge_node_tab, merge_node_tol, nmerge_node_cand, nmerge_node_dest, ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, eani, igrnod)
Definition merge_node.F:41
message_mod
Definition message_mod.F:1249
usrtos
integer function usrtos(iu, itabm1)
Definition sysfus.F:255
starter
program starter
Definition starter.F:39