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