OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
nbadmesh.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "remesh_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine nbadmesh (lsubmodel, numnusr, unitab)

Function/Subroutine Documentation

◆ nbadmesh()

subroutine nbadmesh ( type(submodel_data), dimension(*) lsubmodel,
integer numnusr,
type (unit_type_), intent(in) unitab )

Definition at line 42 of file nbadmesh.F.

43C----------------------------------------------------------
44C M o d u l e s
45C-----------------------------------------------
46 USE message_mod
47 USE submodel_mod , ONLY : nsubmod, submodel_data
48 USE hm_option_read_mod
49 USE unitab_mod
50 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
51 USE reader_old_mod , ONLY : line, irec
52 USE user_id_mod , ONLY : id_limit
53 use element_mod , only : nixc,nixtg
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "com04_c.inc"
62#include "remesh_c.inc"
63#include "scr17_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER NUMNUSR
68 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
69 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
70C-----------------------------------------------
71C L o c a l V a r i a b l e s
72C-----------------------------------------------
73 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAB,ITABM1,KNOD2SH,NOD2SH
74 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IXC,IXTG,TAG
75 INTEGER IPART(4,NPART),
76 . N,IP,ID,I,J,NLEV,STAT,INDEX_PART,NPART_ADM
77 INTEGER USR2SYS,NUMNUSR1,NI,NJ,NK,NL,K,L,P,Q,QQ,
78 . UID,IP0,ID_IP
79 CHARACTER MESS*40
80 CHARACTER(LEN=NCHARTITLE) :: TITR
81 CHARACTER(LEN=NCHARKEY) :: KEY
82 INTEGER , DIMENSION(:), ALLOCATABLE :: IPARTC
83 INTEGER , DIMENSION(:), ALLOCATABLE :: IPARTTG
84 real*8 , DIMENSION(:), ALLOCATABLE :: sh_angle, sh_thk
85 real*8 , DIMENSION(:), ALLOCATABLE :: sh3_angle, sh3_thk
86 INTEGER, DIMENSION(:), ALLOCATABLE :: SUBID_SHELL,UID_SHELL
87 INTEGER, DIMENSION(:), ALLOCATABLE :: SUBID_SH3N,UID_SH3N
88 INTEGER, DIMENSION(:), ALLOCATABLE :: SUBID_NODES
89
90 LOGICAL IS_AVAILABLE
91C-----------------------------------------------
92 DATA mess /'OPTIONS FOR ADAPTIVE MESHING DEFINITION '/
93C-----------------------------------------------
94 ipart=0
95C------
96 ALLOCATE(itab(numnusr),itabm1(2*numnusr),
97 . ixc(nixc,numelc0),ixtg(nixtg,numeltg0),
98 . knod2sh(0:numnusr),nod2sh(4*numelc0+3*numeltg0),
99 . tag(4,numelc0+numeltg0))
100 tag=0
101C------
102C--------------------------------------------------
103C START BROWSING MODEL PARTS
104C--------------------------------------------------
105 CALL hm_option_start('PART')
106C--------------------------------------------------
107C BROWSING MODEL PARTS 1->NPART
108C--------------------------------------------------
109 DO ip=1,npart
110 titr = ''
111C--------------------------------------------------
112C EXTRACT DATAS OF /PART/... LINE
113C--------------------------------------------------
114 CALL hm_option_read_key(lsubmodel,
115 . option_id = id,
116 . unit_id = uid,
117 . option_titr = titr)
118 ipart(1,ip)=id
119 ENDDO
120C------
121
122C--------------------------------------------------
123C READING /ADMESH/GLOBAL
124C--------------------------------------------------
125
126 CALL hm_option_start('/ADMESH/GLOBAL')
127
128 DO n =1,nadmeshg
129 titr = ''
130
131 CALL hm_option_read_key(lsubmodel,
132 . option_titr = titr,
133 . keyword2 = key)
134
135C
136 is_available = .false.
137C
138C--------* EXTRACT DATAS (INTEGER VALUES) *------
139C
140 CALL hm_get_intv('LEVEL',levelmax,is_available,lsubmodel)
141 CALL hm_get_intv('Iadmrule',iadmrule,is_available,lsubmodel)
142 CALL hm_get_intv('Istatcnd',istatcnd,is_available,lsubmodel)
143C
144C--------* EXTRACT DATAS (REAL VALUES) *------
145C
146 CALL hm_get_floatv('Tdelay',dtadmesh,is_available,lsubmodel,unitab)
147C
148
149 ENDDO
150C------
151 IF(nadmeshstat > 0) iadmstat = 1
152
153 IF(iadmstat /= 0) id_limit%ADMESH=id_limit%GLOBAL
154C------
155
156C--------------------------------------------------
157C READING /ADMESH/SET
158C--------------------------------------------------
159
160 CALL hm_option_start('/ADMESH/SET')
161
162 DO n =1,nadmeshset
163 titr = ''
164
165 CALL hm_option_read_key(lsubmodel,
166 . option_id = id,
167 . option_titr = titr,
168 . keyword2 = key)
169C
170 is_available = .false.
171C
172C--------* EXTRACT DATAS (INTEGER VALUES) *------
173C
174 CALL hm_get_intv('NIP',npart_adm,is_available,lsubmodel)
175C
176 DO i=1,npart_adm
177
178 CALL hm_get_int_array_index('PartIds1',id_ip,i,is_available,lsubmodel)
179
180 IF(id_ip/=0)THEN
181 ip=0
182 DO j=1,npart
183 IF(ipart(1,j)==id_ip)THEN
184 ip=j
185 GOTO 100
186 END IF
187 END DO
188 100 CONTINUE
189 IF(ip/=0)THEN
190 ipart(4,ip)=levelmax
191 ELSE
192 CALL ancmsg(msgid=646,
193 . msgtype=msgerror,
194 . anmode=aninfo,
195 . i1=id,
196 . c1=titr,
197 . i2=id_ip)
198 END IF
199 END IF
200
201 ENDDO
202
203 ENDDO
204C--------------------------------------
205C nb shells and 3-node shells + nb nodes estimation (NUMNUSR < ...)
206C---------------
207 ALLOCATE (ipartc(numelc))
208 ALLOCATE (sh_angle(numelc))
209 ALLOCATE (sh_thk(numelc))
210C--------------------------------------------------
211C ALLOCS & INITS
212C--------------------------------------------------
213 ALLOCATE (subid_shell(numelc),stat=stat)
214 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
215 . msgtype=msgerror,
216 . c1='SUBID_SHELL')
217 ALLOCATE (uid_shell(numelc),stat=stat)
218 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
219 . msgtype=msgerror,
220 . c1='UID_SHELL')
221 subid_shell(1:numelc) = 0
222 uid_shell(1:numelc) = 0
223 index_part = -1
224 uid = -1
225C--------------------------------------------------
226C READING SHELLS INPUTS IN HM STRUCTURE
227C--------------------------------------------------
228 CALL cpp_shell_read(ixc,nixc,ipartc,sh_angle,sh_thk,subid_shell,uid_shell)
229C--------------------------------------------------
230C FILL OTHER STRUCTURES + CHECKS
231C--------------------------------------------------
232 ip = 0
233 ip0 = 0
234 DO i=1,numelc
235C--------------------------------------------------
236C INTERNAL PART ID
237C--------------------------------------------------
238 IF( ipartc(i) /= ip0)THEN
239 DO j=1,npart
240 IF(ipartc(i) == ipart(1,j))THEN
241 ip = j
242 ip0 = ipart(1,j)
243 ENDIF
244 ENDDO
245 ENDIF
246
247 IF(ip==0)THEN
248 CALL ancmsg(msgid=735,
249 . msgtype=msgerror,
250 . anmode=aninfo,
251 . i1=id)
252 ELSE
253 ixc(1,i)=ip
254 ipart(2,ip)=ipart(2,ip)+1
255 END IF
256 ENDDO
257c
258 IF(ALLOCATED(subid_shell)) DEALLOCATE(subid_shell)
259 IF(ALLOCATED(uid_shell)) DEALLOCATE(uid_shell)
260C------
261 ALLOCATE (iparttg(numeltg))
262 ALLOCATE (sh3_angle(numeltg))
263 ALLOCATE (sh3_thk(numeltg))
264C--------------------------------------------------
265C ALLOCS & INITS
266C--------------------------------------------------
267 ALLOCATE (subid_sh3n(numeltg),stat=stat)
268 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
269 . msgtype=msgerror,
270 . c1='SUBID_SH3N')
271 ALLOCATE (uid_sh3n(numeltg),stat=stat)
272 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
273 . msgtype=msgerror,
274 . c1='UID_SH3N')
275 subid_sh3n(1:numeltg) = 0
276 uid_sh3n(1:numeltg) = 0
277 index_part = 1
278 uid = -1
279C--------------------------------------------------
280C READING SH3N INPUTS IN HM STRUCTURE
281C--------------------------------------------------
282 CALL cpp_sh3n_read(ixtg,nixtg,iparttg,sh3_angle,sh3_thk,subid_sh3n,uid_sh3n)
283C--------------------------------------------------
284C FILL OTHER STRUCTURES + CHECKS
285C--------------------------------------------------
286 ip = 0
287 ip0 = 0
288 DO i=1,numeltg
289C--------------------------------------------------
290C INTERNAL PART ID
291C--------------------------------------------------
292 IF( iparttg(i) /= ip0)THEN
293 DO j=1,npart
294 IF(iparttg(i) == ipart(1,j))THEN
295 ip = j
296 ip0 = ipart(1,j)
297 ENDIF
298 ENDDO
299 ENDIF
300 IF(ip==0)THEN
301 CALL ancmsg(msgid=735,
302 . msgtype=msgerror,
303 . anmode=aninfo,
304 . i1=id)
305 ELSE
306 ixtg(1,i)=ip
307 ipart(3,ip)=ipart(3,ip)+1
308 END IF
309 ENDDO
310c
311 IF(ALLOCATED(subid_sh3n)) DEALLOCATE(subid_sh3n)
312 IF(ALLOCATED(uid_sh3n)) DEALLOCATE(uid_sh3n)
313C--------------------------------------
314C nb shells and 3-node shells + nb nodes exact calculation
315C--------------------------------------
316 IF(iadmstat /= 0)RETURN
317C--------------------------------------------------
318C ALLOCS & INITS
319C--------------------------------------------------
320 ALLOCATE (subid_nodes(numnusr),stat=stat)
321 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
322 . msgtype=msgerror,
323 . c1='SUBID_NODES')
324 subid_nodes(1:numnusr) = 0
325C--------------------------------------------------
326C READING NODES IDs IN HM STRUCTURE
327C--------------------------------------------------
328 CALL cpp_node_count(numnusr1)
329 CALL cpp_node_id_read(itab,subid_nodes)
330C--------------------------------------------------
331C CHECKS NODES & CNODES IDs
332C--------------------------------------------------
333 DO i=1,numnusr
334 IF (itab(i) > id_limit%ADMESH
335 . .AND. (itab(i) < id_limit%ADMESH_FT_NODE_AUTO .OR. itab(i) >= id_limit%ADMESH_LT_NODE_AUTO))THEN
336 CALL ancmsg(msgid=1069,anmode=aninfo,msgtype=msgerror,i1=itab(i),c1=line,c2='/NODE')
337 ENDIF
338 ENDDO
339 IF(ALLOCATED(subid_nodes)) DEALLOCATE(subid_nodes)
340C------
341C building the inverse node table
342C------
343C NUMNUSR=NUMNUSR1+NUMCNOD !
344 CALL constit(itab,itabm1,numnusr)
345C------
346C 4-node shells
347C------
348 DO i=1,numelc
349 IF (ixc(nixc,i)>id_limit%ADMESH) THEN
350 CALL ancmsg(msgid=1069,anmode=aninfo,msgtype=msgerror,
351 . i1=ixc(nixc,i),c1=line,c2='/SHELL')
352 ENDIF
353 DO j=2,5
354 ixc(j,i)=usr2sys(ixc(j,i),itabm1,mess,id)
355 ENDDO
356 ENDDO
357 IF(ALLOCATED(ipartc)) DEALLOCATE(ipartc)
358 IF(ALLOCATED(sh_angle)) DEALLOCATE(sh_angle)
359 IF(ALLOCATED(sh_thk)) DEALLOCATE (sh_thk)
360C------
361 DO i=1,numeltg
362 IF (ixtg(nixtg,i)>id_limit%ADMESH) THEN
363 CALL ancmsg(msgid=1069,anmode=aninfo,msgtype=msgerror,
364 . i1=ixtg(nixtg,i),c1=line,c2='/SH3N')
365 ENDIF
366 DO j=2,4
367 ixtg(j,i)=usr2sys(ixtg(j,i),itabm1,mess,id)
368 ENDDO
369 ENDDO
370 IF(ALLOCATED(iparttg)) DEALLOCATE(iparttg)
371 IF(ALLOCATED(sh3_angle)) DEALLOCATE (sh3_angle)
372 IF(ALLOCATED(sh3_thk)) DEALLOCATE (sh3_thk)
373C------
374C inverse connectivity at level 0
375C------
376 knod2sh=0
377 DO n=1,numelc0
378 DO i=1,4
379 ni=ixc(i+1,n)
380 knod2sh(ni)=knod2sh(ni)+1
381 END DO
382 END DO
383
384 DO n=1,numeltg0
385 DO i=1,3
386 ni=ixtg(i+1,n)
387 knod2sh(ni)=knod2sh(ni)+1
388 END DO
389 END DO
390
391 DO n=2,numnusr
392 knod2sh(n)=knod2sh(n)+knod2sh(n-1)
393 END DO
394
395 DO n=1,numelc0
396 DO i=1,4
397 ni=ixc(i+1,n)-1
398 knod2sh(ni)=knod2sh(ni)+1
399 nod2sh(knod2sh(ni))=n
400 END DO
401 END DO
402
403 DO n=1,numeltg0
404 DO i=1,3
405 ni=ixtg(i+1,n)-1
406 knod2sh(ni)=knod2sh(ni)+1
407 nod2sh(knod2sh(ni))=numelc0+n
408 END DO
409 END DO
410
411 DO n=numnusr,1,-1
412 knod2sh(n)=knod2sh(n-1)
413 END DO
414 knod2sh(0)=0
415C------
416C
417C------
418 numelc=0
419 DO n=1,numelc0
420 ip =ixc(1,n)
421 nlev=ipart(4,ip)
422 IF(nlev/=0) THEN
423 numnod=numnod+(2**nlev-1)*(2**nlev-1)
424 DO i=1,4
425 IF(tag(i,n)<nlev)THEN
426 numnod=numnod+(2**nlev-1)-(2**(tag(i,n))-1)
427 tag(i,n)=nlev
428
429 ni=ixc(i+1,n)
430 nj=ixc(mod(i,4)+2,n)
431 DO k=knod2sh(ni-1)+1,knod2sh(ni)
432 p=nod2sh(k)
433 IF(p/=n)THEN
434 DO l=knod2sh(nj-1)+1,knod2sh(nj)
435 q=nod2sh(l)
436 IF(q==p)THEN
437 IF(q<=numelc0)THEN
438 DO j=1,4
439 nk=ixc(j+1,q)
440 nl=ixc(mod(j,4)+2,q)
441 IF((nk==ni.AND.nl==nj).OR.
442 . (nl==ni.AND.nk==nj))THEN
443 tag(j,q)=nlev
444 END IF
445 END DO
446 ELSE
447 qq=q-numelc0
448 DO j=1,3
449 nk=ixtg(j+1,qq)
450 nl=ixtg(mod(j,3)+2,qq)
451 IF((nk==ni.AND.nl==nj).OR.
452 . (nl==ni.AND.nk==nj))THEN
453 tag(j,q)=nlev
454 END IF
455 END DO
456 END IF
457 END IF
458 END DO
459 END IF
460 END DO
461 END IF
462 END DO
463 END IF
464 numelc =numelc +(4**(nlev+1)-1)/3
465 END DO
466
467C
468 numeltg=0
469 DO n=1,numeltg0
470 ip =ixtg(1,n)
471 nlev=ipart(4,ip)
472 IF(nlev/=0) THEN
473 numnod =numnod+(2**(nlev-1)+1)*(2**nlev+1)-3*(2**nlev)
474 DO i=1,3
475 IF(tag(i,n+numelc0)<nlev)THEN
476 numnod=numnod+(2**nlev-1)-(2**(tag(i,n+numelc0))-1)
477 tag(i,n+numelc0)=nlev
478
479 ni=ixtg(i+1,n)
480 nj=ixtg(mod(i,3)+2,n)
481 DO k=knod2sh(ni-1)+1,knod2sh(ni)
482 p=nod2sh(k)
483 IF(p/=n+numelc0)THEN
484 DO l=knod2sh(nj-1)+1,knod2sh(nj)
485 q=nod2sh(l)
486 IF(q==p)THEN
487 IF(q<=numelc0)THEN
488 DO j=1,4
489 nk=ixc(j+1,q)
490 nl=ixc(mod(j,4)+2,q)
491 IF((nk==ni.AND.nl==nj).OR.
492 . (nl==ni.AND.nk==nj))THEN
493 tag(j,q)=nlev
494 END IF
495 END DO
496 ELSE
497 qq=q-numelc0
498 DO j=1,3
499 nk=ixtg(j+1,qq)
500 nl=ixtg(mod(j,3)+2,qq)
501 IF((nk==ni.AND.nl==nj).OR.
502 . (nl==ni.AND.nk==nj))THEN
503 tag(j,q)=nlev
504 END IF
505 END DO
506 END IF
507 END IF
508 END DO
509 END IF
510 END DO
511 END IF
512 END DO
513 END IF
514 numeltg =numeltg +(4**(nlev+1)-1)/3
515 END DO
516C-------------------------------------
517 DEALLOCATE(itab,itabm1,ixc,ixtg,knod2sh,nod2sh,tag)
518 RETURN
519C-------------------------------------
constit
subroutine constit(itab, itabm1, numnod)
Definition constit.F:35
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
id
initmumps id
Definition multiplerhs_example.m:4
hm_option_read_mod
Definition hm_option_read_mod.F:412
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
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
submodel_mod
Definition submodel_mod.F:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
unitab_mod
Definition unitab_mod.F:517
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
nl
character *2 function nl()
Definition message.F:2360
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:146
submodel_mod::submodel_data
Definition submodel_mod.F:728