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