OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
remn_self24.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine remn_self24 (x, ixs, ixs10, ixs16, ixs20, knod2els, nod2els, ipari, intbuf_tab, itab, nom_opt, nremov, s_nod2els, iddlevel)

Function/Subroutine Documentation

◆ remn_self24()

subroutine remn_self24 ( intent(in) x,
integer, dimension(nixs,numels), intent(in) ixs,
integer, dimension(6,numels10), intent(in) ixs10,
integer, dimension(8,numels16), intent(in) ixs16,
integer, dimension(12,numels20), intent(in) ixs20,
integer, dimension(numnod+1), intent(in) knod2els,
integer, dimension(s_nod2els), intent(in) nod2els,
integer, dimension(npari,ninter), intent(inout) ipari,
type(intbuf_struct_), dimension(ninter), intent(inout) intbuf_tab,
integer, dimension(numnod), intent(in) itab,
integer, dimension(lnopt1,snom_opt), intent(in) nom_opt,
integer, dimension(ninter), intent(inout) nremov,
integer, intent(in) s_nod2els,
integer, intent(in) iddlevel )
Parameters
[in]iddlevelflag : 0 for the 1rst step, 1 for the 2nd step

Definition at line 36 of file remn_self24.F.

40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE my_alloc_mod
44 USE message_mod
45 USE intbufdef_mod
46 USE names_and_titles_mod , ONLY : nchartitle
47 use element_mod , only :nixs
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "param_c.inc"
56#include "com04_c.inc"
57#include "scr17_c.inc"
58#include "tabsiz_c.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER, DIMENSION(NPARI,NINTER) ,INTENT(INOUT) :: IPARI
63 INTEGER, DIMENSION(NIXS,NUMELS) ,INTENT(IN) :: IXS
64 INTEGER, DIMENSION(6,NUMELS10) ,INTENT(IN) :: IXS10
65 INTEGER, DIMENSION(8,NUMELS16) ,INTENT(IN) :: IXS16
66 INTEGER, DIMENSION(12,NUMELS20) ,INTENT(IN) :: IXS20
67 INTEGER, DIMENSION(NUMNOD+1) ,INTENT(IN) :: KNOD2ELS
68 INTEGER, INTENT(IN) :: S_NOD2ELS
69 INTEGER, DIMENSION(S_NOD2ELS) ,INTENT(IN) :: NOD2ELS
70 INTEGER, DIMENSION(NUMNOD) ,INTENT(IN) :: ITAB
71 INTEGER, DIMENSION(LNOPT1,SNOM_OPT) ,INTENT(IN) :: NOM_OPT
72 INTEGER, DIMENSION(NINTER) ,INTENT(INOUT) :: NREMOV
73 my_real, DIMENSION(NUMNOD*3) ,INTENT(IN) :: x
74 TYPE(INTBUF_STRUCT_), DIMENSION(NINTER),INTENT(INOUT):: INTBUF_TAB
75 INTEGER, INTENT(in) :: IDDLEVEL !< flag : 0 for the 1rst step, 1 for the 2nd step
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79 INTEGER N,NTY,FLAGREMNODE,I,NI
80 INTEGER II,J,NSN,NRTM,
81 . IFLAG,
82 . NNOD,NNREM,
83 . KI,KL,JJ,NREMOV1(NINTER),NS,MAXNM
84 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGD,TAGNOD
85 INTEGER ID,NC(20),NMC(4)
86 CHARACTER(LEN=NCHARTITLE) :: TITR
87
88
89 INTEGER :: JJJ,NOINT,E_ID,IADA
90 INTEGER :: FIRST,LAST,NNREM_SAVE
91 INTEGER :: OFFSET, NBR_INTRA,NBR_EXTRA,TOTAL_INSERTED
92 INTEGER :: SIZE_INSERTED_NODE,MAX_INSERTED_NODE
93 INTEGER, DIMENSION(:), ALLOCATABLE :: NBR_INSERT_II,ADRESS_II
94 INTEGER, DIMENSION(:), ALLOCATABLE :: KREMNODE_SAVE,INSERTED_NODE,REMNODE
95 my_real
96 . area
97! -------------------------------
98! FIRST : integer , first block of inserted nodes
99! LAST : integer , last block of inserted nodes
100! NNREM_SAVE : integer , internal counter
101! offset : integer , internal offset for the REMNODE array
102! NBR_INTRA : integer , number of old nodes between 2 blocks
103! NBR_EXTRA : integer , number of old remaining nodes
104! TOTAL_INSERTED : integer , total number of inserted nodes
105! NBR_INSERT_II : integer, dimension = NRTM , number of inserted nodes for each II segment
106! ADRESS_II : integer, dimension = NRTM , adress of the first inserted nodes for each II segment
107! KREMNODE_SAVE : integer, dimension = NRTM+1 , list of old nodes
108! SIZE_INSERTED_NODE : integer, size of the INSERTED_NODE array ; SIZE_INSERTED_NODE is an upper bound,
109! can be optimized!
110! INSERTED_NODE : integer, dimension = SIZE_INSERTED_NODE, list inserted nodes
111! REMNODE : integer, dimension = NRTM + TOTAL_INSERTED, new array with old and inserted nodes
112! -------------------------------
113C-----------------------------------------------
114C----creat list of SECONDARY nodes of self-contact to be removed per M_seg
115 max_inserted_node = 1
116 ALLOCATE(tagnod(numnod),tagd(numnod))
117 DO n=1,ninter
118 nty=ipari(7,n)
119 nremov1(n)=0
120 IF (nty/=24) cycle
121 nsn =ipari(5,n)
122 nrtm =ipari(4,n)
123 noint =ipari(15,n)
124 tagnod(1:numnod)=0
125 DO jj=1,nsn
126 ns = intbuf_tab(n)%NSV(jj)
127 IF (ns<=numnod) tagnod(ns)=1
128 ENDDO
129C----- dimensioning
130 DO ii=1,nrtm
131 CALL insol3et(x ,intbuf_tab(n)%IRECTM,ixs ,
132 . n ,e_id,ii ,area ,
133 . noint ,knod2els,nod2els,ixs10 ,
134 . ixs16,ixs20 ,nnod)
135 SELECT CASE (nnod)
136 CASE(8)
137 nc(1:8)=ixs(2:9,e_id)
138 CASE(10)
139 nc(1) =ixs(2,e_id)
140 nc(2) =ixs(4,e_id)
141 nc(3) =ixs(7,e_id)
142 nc(4) =ixs(6,e_id)
143 nc(5:10)=ixs10(1:6,e_id-numels8)
144 CASE(20)
145 nc(1:8)=ixs(2:9,e_id)
146 nc(9:20)=ixs20(1:12,e_id-numels8-numels10)
147 CASE(16)
148 nc(1:8)=ixs(2:9,e_id)
149 nc(9:16)=ixs16(1:8,e_id-numels8-numels10-numels20)
150 END SELECT
151C
152 nmc(1:4)=intbuf_tab(n)%IRECTM(4*(ii-1)+1:4*(ii-1)+4)
153 maxnm = 0
154 DO i = 1,nnod
155 ni= nc(i)
156 IF (ni==0) cycle
157 IF (tagnod(ni)>0 .AND.ni/=nmc(1).AND.ni/=nmc(2)
158 . .AND.ni/=nmc(3).AND.ni/=nmc(4)) THEN
159 nremov1(n) = nremov1(n)+ 1
160 maxnm = maxnm + 1
161 END IF
162 END DO
163 max_inserted_node = max(max_inserted_node,maxnm)
164 END DO
165 END DO !N=1,NINTER
166
167
168
169! ------------------------------------------------
170C---------
171 DO n=1,ninter
172 IF(nremov1(n)==0) cycle
173 nty=ipari(7,n)
174 nsn =ipari(5,n)
175 nrtm =ipari(4,n)
176
177 ALLOCATE( nbr_insert_ii(nrtm) )
178 ALLOCATE( adress_ii(nrtm) )
179 ALLOCATE( kremnode_save(nrtm+1) )
180 nbr_insert_ii(1:nrtm) = 0
181 adress_ii(1:nrtm) = 0
182 kremnode_save(1:nrtm+1) = 0
183
184C----- --
185 tagnod(1:numnod)=0
186 tagd(1:numnod)=2
187 jjj = 0
188C--------dim first
189 nnrem = 0
190 DO jj=1,nsn
191 ns = intbuf_tab(n)%NSV(jj)
192 IF (ns<=numnod) tagd(ns)=0
193 IF (ns<=numnod) tagnod(ns)=1
194 ENDDO
195 iflag =0
196 nremov(n) = ipari(62,n)
197 flagremnode=ipari(63,n)
198 IF(iddlevel==0.AND.flagremnode==1.AND.nremov(n)>0) flagremnode = 2
199 iada= 1
200 IF(nremov(n)>0) kremnode_save(1:nrtm+1) = intbuf_tab(n)%KREMNODE(1:nrtm+1)
201
202 size_inserted_node = max_inserted_node*nrtm
203 CALL my_alloc(inserted_node,size_inserted_node)
204
205 DO ii=1,nrtm
206 nnrem_save = nnrem
207C
208 IF (flagremnode==2)THEN
209 ki = intbuf_tab(n)%KREMNODE(ii)+1
210 kl = intbuf_tab(n)%KREMNODE(ii+1)
211 DO j=ki,kl
212 ns = intbuf_tab(n)%REMNODE(j)
213 tagd(ns)=1
214 END DO
215 END IF !IF(FLAGREMNODE==2)THEN
216C
217 CALL insol3et(x ,intbuf_tab(n)%IRECTM,ixs ,
218 . n ,e_id,ii,area ,
219 . noint ,knod2els,nod2els,ixs10 ,
220 . ixs16,ixs20 ,nnod)
221 SELECT CASE (nnod)
222 CASE(8)
223 nc(1:8)=ixs(2:9,e_id)
224 CASE(10)
225 nc(1) =ixs(2,e_id)
226 nc(2) =ixs(4,e_id)
227 nc(3) =ixs(7,e_id)
228 nc(4) =ixs(6,e_id)
229 nc(5:10)=ixs10(1:6,e_id-numels8)
230 CASE(20)
231 nc(1:8)=ixs(2:9,e_id)
232 nc(9:20)=ixs20(1:12,e_id-numels8-numels10)
233 CASE(16)
234 nc(1:8)=ixs(2:9,e_id)
235 nc(9:16)=ixs16(1:8,e_id-numels8-numels10-numels20)
236 END SELECT
237C
238 nmc(1:4)=intbuf_tab(n)%IRECTM(4*(ii-1)+1:4*(ii-1)+4)
239 DO i = 1,nnod
240 ni= nc(i)
241 IF (ni==0) cycle
242 IF (tagnod(ni)>0 .AND.ni/=nmc(1).AND.ni/=nmc(2)
243 . .AND.ni/=nmc(3).AND.ni/=nmc(4)) THEN
244 IF(tagd(ni)==0) THEN
245 nnrem = nnrem + 1
246 tagd(ni)=1
247 jjj = jjj + 1
248 inserted_node(jjj) = ni
249 ENDIF
250 END IF
251 END DO
252 ! -------------------
253 ! number of inserted nodes
254 nbr_insert_ii(ii) = nnrem - nnrem_save
255 kremnode_save(ii) = kremnode_save(ii+1) - kremnode_save(ii)
256 iada = iada + kremnode_save(ii)
257 ! adress of the first inserted node
258 adress_ii(ii) = iada
259 kremnode_save(ii) = iada + nbr_insert_ii(ii) - 1
260 iada = iada + nbr_insert_ii(ii)
261 ! -------------------
262
263C-----reset TAGD=0
264 DO i = 1,nnod
265 ni= nc(i)
266 IF (ni==0) cycle
267 IF (tagnod(ni)>0 .AND.ni/=nmc(1).AND.ni/=nmc(2)
268 . .AND.ni/=nmc(3).AND.ni/=nmc(4)) THEN
269 IF(tagd(ni)==1) tagd(ni)=0
270 END IF
271 END DO
272 IF (flagremnode==2)THEN
273 DO j=ki,kl
274 ns = intbuf_tab(n)%REMNODE(j)
275 tagd(ns)=0
276 END DO
277 END IF
278C
279 END DO !II=1,NRTM
280
281
282 IF(nnrem>0) THEN
283
284 ! get the first and the last inserted node
285 first = 0
286 last = 0
287 DO ii = 1,nrtm
288 IF(first==0) THEN
289 IF( nbr_insert_ii(ii)/=0 ) first = ii
290 ENDIF
291 IF(last==0) THEN
292 IF( nbr_insert_ii(nrtm+1-ii)/=0 ) last = nrtm+1-ii
293 ENDIF
294 ENDDO
295 ! count the total number of inserted nodes
296 total_inserted = 0
297 DO ii=1,nrtm
298 total_inserted = total_inserted + nbr_insert_ii(ii)
299 ENDDO
300 ! allocate the buffer array
301 ALLOCATE( remnode(nremov(n)+total_inserted) )
302
303 j = 0
304 i = 0
305 offset = 0
306 IF( first>0 ) THEN
307 ! insertion of the first chunk of node : if ADRESS_II(FIRST) > 1
308 ! --> need to copy the old nodes
309 IF( adress_ii(first)>1 ) THEN
310 remnode(1:adress_ii(first)-1) = intbuf_tab(n)%REMNODE(1:adress_ii(first)-1)
311 offset = offset + adress_ii(first)-1
312 i = i + adress_ii(first)-1
313 ENDIF
314
315 DO ii=first,last
316 ! insertion of the nodes
317 IF( nbr_insert_ii(ii)>0 ) THEN
318 DO jj = 1,nbr_insert_ii(ii)
319 j = j + 1
320 remnode(offset+nbr_insert_ii(ii)+1-jj) = inserted_node(j)
321 ENDDO
322 offset = offset + nbr_insert_ii(ii)
323 ENDIF
324 IF(ii<last.AND.nremov(n)>0) THEN
325 ! copy of the old nodes
326 nbr_intra = adress_ii(ii+1) - adress_ii(ii)-nbr_insert_ii(ii)
327 IF( nbr_intra>0 )THEN
328 DO jj = 1,nbr_intra
329 i = i + 1
330 remnode(jj+offset) = intbuf_tab(n)%REMNODE(i)
331 ENDDO
332 offset = offset + nbr_intra
333 ENDIF
334 ENDIF
335 ENDDO
336 ENDIF
337 ! copy of the old nodes for the LAST chunk
338
339 IF( i<nremov(n) ) THEN
340 nbr_extra = nremov(n) - i
341 remnode(offset+1:offset+nbr_extra) = intbuf_tab(n)%REMNODE(i+1:nremov(n))
342 ENDIF
343 id=nom_opt(1,n)
344 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
345 ! -----------------
346 ! only print the message for the 2nd sorting
347 IF(iddlevel>0) THEN
348 CALL ancmsg(msgid=3014,
349 . msgtype=msginfo,
350 . anmode=aninfo_blind_1,
351 . i1=id,
352 . c1=titr,
353 . i2=nnrem)
354 ENDIF
355 ! -----------------
356 ! update of NNREM and deallocation / allocation of the new array
357
358 nnrem = nnrem + nremov(n)
359C---- no need, done in UPGRADE_REMNODE2 IPARI(63,N) = 2
360 CALL upgrade_remnode2(n,nnrem,intbuf_tab(n),nty)
361 intbuf_tab(n)%REMNODE(1:nnrem) = remnode(1:nnrem)
362 intbuf_tab(n)%KREMNODE(2:nrtm+1) = kremnode_save(1:nrtm)
363 intbuf_tab(n)%KREMNODE(1)=0
364C----------used for Iedge=1
365 nremov(n) = nnrem
366 END IF !IF (NNREM>0) THEN
367 IF(ALLOCATED(remnode)) DEALLOCATE( remnode )
368 IF(ALLOCATED(inserted_node)) DEALLOCATE( inserted_node )
369
370C
371
372 DEALLOCATE( nbr_insert_ii )
373 DEALLOCATE( adress_ii )
374 DEALLOCATE( kremnode_save )
375 END DO
376
377 DEALLOCATE(tagd,tagnod)
378C----
379 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
insol3et
subroutine insol3et(x, irect, ixs, nint, nel, i, area, noint, knod2els, nod2els, ixs10, ixs16, ixs20, nnod)
Definition i24sti3.F:962
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29
upgrade_remnode2
subroutine upgrade_remnode2(ni, nremnode, intbuf_tab, nty)
Definition upgrade_remnode.F:112