OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_intsub.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "r2r_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_intsub (igrnod, igrsurf, nom_opt, igrslin, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_intsub()

subroutine hm_read_intsub ( type (group_), dimension(ngrnod) igrnod,
type (surf_), dimension(nsurf), target igrsurf,
integer, dimension(lnopt1,*) nom_opt,
type (surf_), dimension(nslin), target igrslin,
type(submodel_data), dimension(*) lsubmodel )

Definition at line 45 of file hm_read_intsub.F.

46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE message_mod
50 USE groupdef_mod
51 USE hm_option_read_mod
52 USE submodel_mod
53 USE r2r_mod
54 USE names_and_titles_mod , ONLY : nchartitle, ncharline, ncharfield
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "scr17_c.inc"
63#include "com04_c.inc"
64#include "units_c.inc"
65#include "r2r_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER NOM_OPT(LNOPT1,*)
70C-----------------------------------------------
71 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
72 TYPE (SURF_) ,TARGET, DIMENSION(NSURF) :: IGRSURF
73 TYPE (SURF_) ,TARGET, DIMENSION(NSLIN) :: IGRSLIN
74 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER WORK(70000)
79 INTEGER I,NI,NOINT,L,J,K,NISUB,ID,IDINT,IDGRN,IDSURF,IDSURF1,IDSURF2,TRU,N,J10(10),IA,ITH,INDEX_NOM_OPT
80 INTEGER UID,SUB_ID,ID1,ID2,ID3,INTSUB_TYP(NINTSUB),ISLIN1,ISLIN2,ISU1,ISU2,ISURF1,ISURF2,NFLAG,STAT
81 INTEGER, DIMENSION(:), ALLOCATABLE :: ID_INTER,FLAG_INTER
82 my_real bid
83 CHARACTER(LEN=NCHARTITLE) :: TITR
84 CHARACTER MESS*40
85 CHARACTER(LEN=NCHARLINE) :: KEY,COPT
86 CHARACTER(LEN=NCHARFIELD) :: KEY2
87 INTEGER, DIMENSION(:), POINTER :: INGR2USR
88 INTEGER :: II, NVAR, IDSMAX, NTHINTER,IVAR,NB,ID_TYPE19,OKSURF
89 LOGICAL IS_AVAILABLE
90C-----------------------------------------------
91C E x t e r n a l F u n c t i o n s
92C-----------------------------------------------
93 INTEGER NGR2USR
94C-----------------------------------------------
95C D a t a
96C-----------------------------------------------
97 DATA mess/'INTERFACES '/
98C-----------------------------------------------
99 WRITE(iout,1000)
100C
101 ni =0
102 index_nom_opt = 0
103 ALLOCATE (id_inter(hm_ninter),stat=stat)
104 id_inter(1:(hm_ninter)) = 0
105 ALLOCATE (flag_inter(hm_ninter),stat=stat)
106 flag_inter(1:(hm_ninter)) = 0
107C
108 CALL hm_option_start('/INTER')
109C
110 nb = 0
111C
112 DO i =1,hm_ninter
113C
114 nb = nb+1
115C----------Multidomaines --> on ignore les interfaces et sous-interfaces non tagees---
116 IF (nsubdom>0) THEN
117 IF(tagint(nb)==0) CALL hm_sz_r2r(tagint,nb,lsubmodel)
118 ENDIF
119C------------------------------------------------------------------
120C
121C--------------------------------------------------
122C EXTRACT DATAS OF /INTER/... LINE
123C--------------------------------------------------
124 CALL hm_option_read_key(lsubmodel,
125 . option_id = noint,
126 . unit_id = uid,
127 . option_titr = titr,
128 . keyword2 = key)
129
130 IF(key(1:len_trim(key))/='SUB') THEN
131 ni=ni+1
132 index_nom_opt=index_nom_opt+1
133C
134C-- read of type19 flag
135 id_type19=0
136 CALL hm_get_intv('ID_TYPE19',id_type19,is_available,lsubmodel)
137
138 SELECT CASE(key(1:len_trim(key)))
139
140 CASE ('TYPE25')
141 flag_inter(ni) =25
142c comment to plug t19 convert
143 CASE ('TYPE7','TYPE10','TYPE24')
144 flag_inter(ni) =0
145 IF (id_type19/=0) THEN
146C-- type7 interface generated from type19
147 flag_inter(ni) =2
148 ENDIF
149 CASE ('TYPE11')
150 flag_inter(ni) =1
151 IF (id_type19/=0) THEN
152C-- type11 interface generated from type19
153 flag_inter(ni) =2
154 ENDIF
155 CASE DEFAULT
156 flag_inter(ni) =-1
157 END SELECT
158C
159 id_inter(ni) = noint
160 nom_opt(1,index_nom_opt)=noint
161C
162 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,ni),ltitr)
163 ENDIF
164 ENDDO
165C
166 nb = hm_ninter
167C
168 nflag = ni
169C
170C-------------------------------------
171C
172 CALL hm_option_start('/INTER')
173 nisub=0
174 nb = 0
175C
176 DO i =1,hm_ninter
177C
178 nb = nb+1
179C----------Multidomaines --> on ignore les interfaces et sous-interfaces non tagees---
180 IF (nsubdom>0) THEN
181 IF(tagint(nb)==0) CALL hm_sz_r2r(tagint,nb,lsubmodel)
182 ENDIF
183C------------------------------------------------------------------
184c
185C--------------------------------------------------
186C EXTRACT DATAS OF /INTER/... LINE
187C--------------------------------------------------
188 CALL hm_option_read_key(lsubmodel,
189 . option_id = id,
190 . unit_id = uid,
191 . option_titr = titr,
192 . submodel_index = sub_id,
193 . keyword2 = key)
194
195 IF(key(1:len_trim(key))=='SUB') THEN
196 nisub=nisub+1
197 nom_opt(1,ninter+nisub)=id
198 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,
199 . ninter+nisub),ltitr)
200C--------------------------------------------------
201C EXTRACT DATAS (INTEGER VALUES)
202C--------------------------------------------------
203 CALL hm_get_intv('InterfaceId',idint,is_available,lsubmodel)
204 CALL hm_get_intv('mainentityids',id1,is_available,lsubmodel)
205 CALL hm_get_intv('secondaryentityids',id2,is_available,lsubmodel)
206 CALL hm_get_intv('Main_ID2',id3,is_available,lsubmodel)
207
208 nom_opt(2,ninter+nisub)=idint
209 nom_opt(3,ninter+nisub)=id1
210 nom_opt(4,ninter+nisub)=id2
211 nom_opt(6,ninter+nisub)=id3
212 END IF
213 END DO
214C
215C-------------------------------------
216C Recherche des ID doubles
217C-------------------------------------
218 CALL udouble(nom_opt,lnopt1,ninter+nintsub,mess,0,bid)
219C-------------------------------------
220C verification des ss-interfaces (interfaces concernees) et definition du type
221C-------------------------------------
222 DO i=1,nintsub
223 idint=nom_opt(2,ninter+i)
224 id=nom_opt(1,ninter+i)
225 CALL fretitl2(titr,
226 . nom_opt(lnopt1-ltitr+1,ninter+i),ltitr)
227 IF(idint /= 0) THEN
228 DO ni=1,nflag
229 IF(id_inter(ni) == idint)THEN
230 intsub_typ(i) = flag_inter(ni)
231 GO TO 320
232 END IF
233 END DO
234 CALL ancmsg(msgid=578,
235 . msgtype=msgerror,
236 . anmode=aninfo,
237 . i1=id,
238 . c1=titr,
239 . i2=idint)
240 intsub_typ(i) = 2
241 320 CONTINUE
242C
243 IF(flag_inter(ni)==-1)THEN
244 CALL ancmsg(msgid=579,
245 . msgtype=msgerror,
246 . anmode=aninfo,
247 . i1=id,
248 . c1=titr)
249 END IF
250 ELSE
251 intsub_typ(i) = 100
252 ENDIF
253 END DO
254C-------------------------------------
255C decodage de INTSUB (nos internes des surfaces, groupes de noeuds).
256C-------------------------------------
257 DO i=1,nintsub
258C
259 IF (intsub_typ(i)==25 )THEN
260C
261C-- Interf 25
262C
263 idsurf=nom_opt(3,ninter+i)
264 id=nom_opt(1,ninter+i)
265 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,
266 . ninter+i),ltitr)
267 DO j=1,nsurf
268 IF(igrsurf(j)%ID==idsurf)THEN
269 nom_opt(3,ninter+i)=j
270 GO TO 400
271 END IF
272 END DO
273 CALL ancmsg(msgid=576,
274 . msgtype=msgerror,
275 . anmode=aninfo,
276 . i1=id,
277 . c1=titr,
278 . i2=idsurf)
279 400 CONTINUE
280
281 idgrn=nom_opt(4,ninter+i)
282 IF(idgrn/=0)THEN
283 DO j=1,ngrnod
284 IF (igrnod(j)%ID==idgrn) THEN
285 nom_opt(4,ninter+i)=j
286 GO TO 410
287 END IF
288 END DO
289 CALL ancmsg(msgid=577,
290 . msgtype=msgerror,
291 . anmode=aninfo,
292 . i1=id,
293 . c1=titr,
294 . i2=idgrn)
295 410 CONTINUE
296 END IF
297C
298 idsurf=nom_opt(6,ninter+i)
299 IF(idsurf/=0)THEN
300 DO j=1,nsurf
301 IF(igrsurf(j)%ID==idsurf)THEN
302 nom_opt(6,ninter+i)=j
303 GO TO 420
304 END IF
305 END DO
306 CALL ancmsg(msgid=576,
307 . msgtype=msgerror,
308 . anmode=aninfo,
309 . i1=id,
310 . c1=titr,
311 . i2=idsurf)
312 420 CONTINUE
313 END IF
314C
315 idsurf1=nom_opt(3,ninter+i)
316 idsurf2=nom_opt(6,ninter+i)
317 idgrn=nom_opt(4,ninter+i)
318 IF(idsurf1/=0.AND.idsurf2==0.AND.idgrn==0) THEN
319 CALL ancmsg(msgid=2055,
320 . msgtype=msgwarning,
321 . anmode=aninfo,
322 . i1=id,
323 . c1=titr)
324 ENDIF
325 IF(idsurf2/=0.AND.idsurf1==0.AND.idgrn==0) THEN
326 CALL ancmsg(msgid=2055,
327 . msgtype=msgwarning,
328 . anmode=aninfo,
329 . i1=id,
330 . c1=titr)
331 ENDIF
332 IF(idgrn/=0.AND.idsurf1==0.AND.idsurf2==0) THEN
333 CALL ancmsg(msgid=2055,
334 . msgtype=msgwarning,
335 . anmode=aninfo,
336 . i1=id,
337 . c1=titr)
338 ENDIF
339 ELSEIF (intsub_typ(i)==0 )THEN
340C
341C-- Interf 7,10,20,24
342C
343 idsurf=nom_opt(3,ninter+i)
344 id=nom_opt(1,ninter+i)
345 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,
346 . ninter+i),ltitr)
347 DO j=1,nsurf
348 IF(igrsurf(j)%ID==idsurf)THEN
349 nom_opt(3,ninter+i)=j
350 GO TO 300
351 END IF
352 END DO
353 CALL ancmsg(msgid=576,
354 . msgtype=msgerror,
355 . anmode=aninfo,
356 . i1=id,
357 . c1=titr,
358 . i2=idsurf)
359 300 CONTINUE
360 idgrn=nom_opt(4,ninter+i)
361 DO j=1,ngrnod
362 IF (igrnod(j)%ID==idgrn) THEN
363 nom_opt(4,ninter+i)=j
364 GO TO 310
365 END IF
366 END DO
367 CALL ancmsg(msgid=577,
368 . msgtype=msgerror,
369 . anmode=aninfo,
370 . i1=id,
371 . c1=titr,
372 . i2=idgrn)
373 310 CONTINUE
374C
375 ELSEIF (intsub_typ(i)==1) THEN
376C
377C-- Interf 11
378C
379 isu1=nom_opt(3,ninter+i)
380 isu2=nom_opt(4,ninter+i)
381 id=nom_opt(1,ninter+i)
382 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,
383 . ninter+i),ltitr)
384C
385 ingr2usr => igrslin(1:nslin)%ID
386 islin1=ngr2usr(isu1,ingr2usr,nslin)
387 islin2=ngr2usr(isu2,ingr2usr,nslin)
388 nom_opt(3,ninter+i)=islin1
389 nom_opt(4,ninter+i)=islin2
390C
391 IF (islin1==0) THEN
392 CALL ancmsg(msgid=1187,
393 . msgtype=msgerror,
394 . anmode=aninfo,
395 . i1=id,
396 . c1=titr,
397 . i2=isu1)
398 ENDIF
399C
400 IF (islin2==0) THEN
401 CALL ancmsg(msgid=1187,
402 . msgtype=msgerror,
403 . anmode=aninfo,
404 . i1=id,
405 . c1=titr,
406 . i2=isu2)
407 ENDIF
408C
409 ELSEIF (intsub_typ(i)==2) THEN
410C
411C-- Interf 19
412C
413 isu1=nom_opt(3,ninter+i)
414 isu2=nom_opt(4,ninter+i)
415 id=nom_opt(1,ninter+i)
416 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,
417 . ninter+i),ltitr)
418C
419C ------ If one of the 2 surface is empty then type7 is symmetric ------
420 IF ((isu1==0).AND.(isu2/=0)) THEN
421 isu1 = isu2
422 ELSEIF ((isu1/=0).AND.(isu2==0)) THEN
423 isu2 = isu1
424 ENDIF
425C
426 ingr2usr => igrsurf(1:nsurf)%ID
427 isurf1=ngr2usr(isu1,ingr2usr,nsurf)
428 isurf2=ngr2usr(isu2,ingr2usr,nsurf)
429 nom_opt(3,ninter+i)=isurf1
430 nom_opt(4,ninter+i)=isurf2
431C
432 IF (isurf1==0) THEN
433 CALL ancmsg(msgid=1197,
434 . msgtype=msgerror,
435 . anmode=aninfo,
436 . i1=id,
437 . c1=titr,
438 . i2=isu1)
439 ENDIF
440C
441 IF (isurf2==0) THEN
442 CALL ancmsg(msgid=1197,
443 . msgtype=msgerror,
444 . anmode=aninfo,
445 . i1=id,
446 . c1=titr,
447 . i2=isu2)
448 ENDIF
449C
450 ELSEIF (intsub_typ(i)==100 )THEN
451C
452C-- Interf 0 : adding all contacts
453C
454
455 idsurf=nom_opt(6,ninter+i)
456 id=nom_opt(1,ninter+i)
457 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,
458 . ninter+i),ltitr)
459 oksurf = 0
460 DO j=1,nsurf
461 IF(igrsurf(j)%ID==idsurf)THEN
462 nom_opt(6,ninter+i)=j
463 oksurf = 1
464 END IF
465 END DO
466 IF(oksurf == 0 ) THEN
467 CALL ancmsg(msgid=576,
468 . msgtype=msgerror,
469 . anmode=aninfo,
470 . i1=id,
471 . c1=titr,
472 . i2=idsurf)
473 ENDIF
474C
475 idsurf=nom_opt(3,ninter+i)
476 IF(idsurf/=0)THEN
477 oksurf = 0
478 DO j=1,nsurf
479 IF(igrsurf(j)%ID==idsurf)THEN
480 nom_opt(3,ninter+i)=j
481 oksurf = 1
482 END IF
483 END DO
484 IF(oksurf == 0 ) THEN
485 CALL ancmsg(msgid=576,
486 . msgtype=msgerror,
487 . anmode=aninfo,
488 . i1=id,
489 . c1=titr,
490 . i2=idsurf)
491 ENDIF
492
493 END IF
494C
495 ENDIF
496C
497 END DO
498C-------------------------------------
499C tri des sous-interfaces par interface
500C-------------------------------------
501C-------------------------------------
502C recherche si la ss-interface est ecrite sur TH (tag)
503C (sinon la ss-interface est inutile)
504C-------------------------------------
505
506 CALL hm_option_count('/TH/INTER' ,nthinter )
507 CALL hm_option_start('/TH/INTER')
508 IF (nthinter > 0) THEN
509 DO ii=1,nthinter
510 CALL hm_option_read_key(lsubmodel, option_id=id, option_titr=titr)
511 CALL hm_get_intv('idsmax',IDSMAX,IS_AVAILABLE,LSUBMODEL)
512 DO IVAR=1,IDSMAX
513 CALL HM_GET_INT_ARRAY_INDEX('ids',N,IVAR,IS_AVAILABLE,LSUBMODEL)
514 DO K=1,NINTSUB
515 IF(N==NOM_OPT(1,NINTER+K))THEN
516 NOM_OPT(5,NINTER+K)=1
517 EXIT
518 END IF
519 END DO !next K
520 ENDDO!NEXT IVAR
521 ENDDO !next II
522 ENDIF
523C-------------------------------------
524C L00
525C-------------------------------------
526 DO I=1,NINTSUB
527 ID =NOM_OPT(1,NINTER+I)
528 IDINT =NOM_OPT(2,NINTER+I)
529 ITH =NOM_OPT(5,NINTER+I)
530 IF (INTSUB_TYP(I)==25) THEN
531 IDSURF1=IGRSURF(NOM_OPT(3,NINTER+I))%ID
532 IDGRN =NOM_OPT(4,NINTER+I)
533 IF(IDGRN/=0) IDGRN =IGRNOD(IDGRN)%ID
534 IDSURF2=NOM_OPT(6,NINTER+I)
535 IF(IDSURF2/=0)IDSURF2=IGRSURF(IDSURF2)%ID
536 WRITE(IOUT,1125) ID,IDINT,IDSURF1,IDSURF2,IDGRN,ITH
537 ELSEIF (INTSUB_TYP(I)==0) THEN
538 IDSURF=IGRSURF(NOM_OPT(3,NINTER+I))%ID
539 IDGRN =IGRNOD(NOM_OPT(4,NINTER+I))%ID
540 WRITE(IOUT,1100) ID,IDINT,IDSURF,IDGRN,ITH
541 ELSEIF (INTSUB_TYP(I)==1) THEN
542 ISU1 = IGRSLIN(NOM_OPT(3,NINTER+I))%ID
543 ISU2 = IGRSLIN(NOM_OPT(4,NINTER+I))%ID
544 WRITE(IOUT,1200) ID,IDINT,ISU1,ISU2,ITH
545 ELSEIF (INTSUB_TYP(I)==2) THEN
546 ISURF1 = IGRSURF(NOM_OPT(3,NINTER+I))%ID
547 ISURF2 = IGRSURF(NOM_OPT(4,NINTER+I))%ID
548 WRITE(IOUT,1300) ID,IDINT,ISU1,ISU2,ITH
549 ENDIF
550 END DO
551C-------------------------------------
552 DEALLOCATE(ID_INTER,FLAG_INTER)
553C-------------------------------------
554 1000 FORMAT( /1X,' sub-interfaces ' /
555 . 1X,' -------------- '// )
556 1100 FORMAT(//
557 . ' sub-INTERFACE id. . . . . . . . . . . . . ',I10/,
558 . ' INTERFACE id. . . . . . . . . . . . . . . ',I10/,
559 . ' surface id. . . . . . . . . . . . . . . . ',I10/,
560 . ' nodes group id. . . . . . . . . . . . . . ',I10/,
561 . ' output to th(0:no,1:yes) . . . . . . . . ',I10/)
562 1125 FORMAT(//
563 . ' sub-INTERFACE id. . . . . . . . . . . . . ',I10/,
564 . ' INTERFACE id. . . . . . . . . . . . . . . ',I10/,
565 . ' surface id 1. . . . . . . . . . . . . . . ',I10/,
566 . ' surface id 2. . . . . . . . . . . . . . . ',I10/,
567 . ' nodes group id. . . . . . . . . . . . . . ',I10/,
568 . ' output to th(0:no,1:yes) . . . . . . . . ',I10/)
569 1200 FORMAT(//
570 . ' sub-INTERFACE id. . . . . . . . . . . . . ',I10/,
571 . ' INTERFACE id. . . . . . . . . . . . . . . ',I10/,
572 . ' main line id . . . . . . . . . . . . . . ',I10/,
573 . ' secondary line id . . . . . . . . . . . . ',I10/,
574 . ' output to th(0:no,1:yes) . . . . . . . . ',I10/)
575 1300 FORMAT(//
576 . ' sub-INTERFACE id. . . . . . . . . . . . . ',I10/,
577 . ' INTERFACE id. . . . . . . . . . . . . . . ',I10/,
578 . ' main surface id. . . . . . . . . . . . . .',I10/,
579 . ' secondary surface id. . . . . . . . . . . ',I10/,
580 . ' output to th(0:no,1:yes) . . . . . . . . ',I10/)
581 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
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
groupdef_mod
Definition groupdef_mod.F:662
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::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
names_and_titles_mod::ncharline
integer, parameter ncharline
Definition names_and_titles_mod.F:1001
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tagint
integer, dimension(:), allocatable tagint
Definition r2r_mod.F:132
submodel_mod
Definition submodel_mod.F:712
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:325
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:300
main
int main(int argc, char *argv[])
Definition CMakeCCompilerId.c:841
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589