OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
routines_r2r.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| modif_tag ../starter/source/coupling/rad2rad/routines_r2r.F
25!||--- called by ------------------------------------------------------
26!|| r2r_prelec ../starter/source/coupling/rad2rad/r2r_prelec.F
27!|| tag_elem_void_r2r ../starter/source/coupling/rad2rad/tagelem_r2r.F
28!|| tag_elem_void_r2r_lin ../starter/source/coupling/rad2rad/tagelem_r2r.F
29!||====================================================================
30 SUBROUTINE modif_tag(TAG,NEW_TAG,MODIF)
31C-----------------------------------------------
32C I m p l i c i t T y p e s
33C-----------------------------------------------
34#include "implicit_f.inc"
35C-----------------------------------------------
36C D u m m y A r g u m e n t s
37C-----------------------------------------------
38 INTEGER TAG,NEW_TAG,MODIF
39C-----------------------------------------------
40C L o c a l V a r i a b l e s
41C-----------------------------------------------
42 INTEGER OLD_TAG
43C=======================================================================
44
45 old_tag = tag
46 tag = new_tag
47
48 IF (old_tag/=new_tag) modif = modif+1
49
50C-----------
51 RETURN
52 END SUBROUTINE modif_tag
53
54!||====================================================================
55!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.F
56!||--- called by ------------------------------------------------------
57!|| hm_read_eref ../starter/source/loads/reference_state/eref/hm_read_eref.F
58!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
59!|| hm_read_xref ../starter/source/loads/reference_state/xref/hm_read_xref.F
60!|| lecrefsta ../starter/source/loads/reference_state/refsta/lecrefsta.F
61!|| usr2sys ../starter/source/system/sysfus.F
62!|| usr2sys2 ../starter/source/system/sysfus.F
63!||--- calls -----------------------------------------------------
64!|| r2r_sys2 ../starter/source/coupling/rad2rad/routines_r2r.F
65!||====================================================================
66 INTEGER FUNCTION r2r_sys(IU,ITABM1,MESS)
67C-----------------------------------------------
68C I m p l i c i t T y p e s
69C-----------------------------------------------
70#include "implicit_f.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER iu
75 CHARACTER mess*40
76 INTEGER ITABM1(*)
77C-----------------------------------------------
78C C o m m o n B l o c k s
79C-----------------------------------------------
80#include "com04_c.inc"
81#include "r2r_c.inc"
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER jinf, jsup, j,sauv,nn
86 INTEGER, DIMENSION(:), POINTER :: itabm2
87 TARGET :: itabm1
88C-----------------------------------------------
89C E x t e r n a l F u n c t i o n s
90C-----------------------------------------------
91 INTEGER r2r_sys2
92C-----------------------------------------------
93
94 jinf=1
95 jsup=numnod
96 j=max(1,numnod/2)
97
98 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
99 r2r_sys=0
100C------------Check of the list of removed nodes-------------
101 itabm2 => itabm1(2*numnod+1:2*(numnod+nodsupr))
102 sauv = numnod
103 numnod = nodsupr
104 nn=r2r_sys2(iu,itabm2,mess)
105 IF (nn==0) r2r_sys=-1
106 numnod = sauv
107C-----------------------------------------------------------
108 RETURN
109 ENDIF
110
111 IF((iu-itabm1(j))==0)THEN
112C >IU=TABM - end of the search
113 r2r_sys=itabm1(j+numnod)
114 RETURN
115 ELSE IF (iu-itabm1(j)<0) THEN
116C >IU<TABM
117 jsup=j-1
118 ELSE
119C >IU>TABM
120 jinf=j+1
121 ENDIF
122 j=(jsup+jinf)/2
123 IF (j > 0) THEN
124 GO TO 10
125 ELSE
126 r2r_sys=0
127 ENDIF
128C
129 end function r2r_sys
130
131!||====================================================================
132!|| r2r_nin ../starter/source/coupling/rad2rad/routines_r2r.F
133!||--- called by ------------------------------------------------------
134!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
135!||====================================================================
136 INTEGER FUNCTION r2r_nin(IEXT,NTN,M,N)
137C-----------------------------------------------
138C I m p l i c i t T y p e s
139C-----------------------------------------------
140#include "implicit_f.inc"
141C-----------------------------------------------
142C D u m m y A r g u m e n t s
143C-----------------------------------------------
144 INTEGER iext, m, n
145 INTEGER ntn(m,n)
146C-----------------------------------------------
147C L o c a l V a r i a b l e s
148C-----------------------------------------------
149 INTEGER i
150C-----------------------------------------------
151 DO i=1,n
152 IF(ntn(m,i)==iext)THEN
153 r2r_nin=i
154 RETURN
155 ENDIF
156 ENDDO
157 r2r_nin=0
158C-------------------------------------------
159 RETURN
160 end function r2r_nin
161
162!||====================================================================
163!|| nodgr_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
164!||--- called by ------------------------------------------------------
165!|| hm_read_cload ../starter/source/loads/general/cload/hm_read_cload.F
166!||--- calls -----------------------------------------------------
167!|| ancmsg ../starter/source/output/message/message.F
168!||--- uses -----------------------------------------------------
169!|| message_mod ../starter/share/message_module/message_mod.F
170!|| r2r_mod ../starter/share/modules1/r2r_mod.F
171!||====================================================================
172 INTEGER FUNCTION nodgr_r2r(IGU,IGS,IBUF,IGRNOD,
173 . ITABM1 ,MESS )
174C-----------------------------------------------
175C M o d u l e s
176C-----------------------------------------------
177 USE groupdef_mod
178 USE message_mod
179 USE r2r_mod
180C-----------------------------------------------
181C I m p l i c i t T y p e s
182C-----------------------------------------------
183#include "implicit_f.inc"
184C-----------------------------------------------
185C C o m m o n B l o c k s
186C-----------------------------------------------
187#include "com04_c.inc"
188C-----------------------------------------------
189 INTEGER igu,igs,ibuf(*),itabm1(*)
190 CHARACTER mess*40
191C-----------------------------------------------
192 TYPE (group_) , DIMENSION(NGRNOD) :: igrnod
193C-----------------------------------------------
194 INTEGER i,nncpl,compt
195C=======================================================================
196 nodgr_r2r = 0
197 IF (igu > 0) THEN
198 igs=0
199 DO i=1,ngrnod
200 IF(igrnod(i)%ID == igu) THEN
201 igs=i
202 nodgr_r2r = igrnod(igs)%NENTITY
203 EXIT
204 ENDIF
205 ENDDO
206C
207 IF (igs == 0)THEN
208 CALL ancmsg(msgid=53,
209 . msgtype=msgerror,
210 . anmode=aninfo,
211 . c1= mess,
212 . i1=igu)
213 RETURN
214 ENDIF
215C
216 compt = 0
217 DO i=1,nodgr_r2r
218 IF (tagno(igrnod(igs)%ENTITY(i)+npart)/=2) THEN
219 compt = compt + 1
220 ibuf(compt)=igrnod(igs)%ENTITY(i)
221 ENDIF
222 ENDDO
223!
224 nodgr_r2r = nodgr_r2r - igrnod(igs)%R2R_SHARE
225 ENDIF
226C---
227 RETURN
228 end function nodgr_r2r
229
230!||====================================================================
231!|| sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.f
232!||--- called by ------------------------------------------------------
233!|| hm_pre_read_link ../starter/source/constraints/rigidlink/hm_pre_read_rlink.f
234!|| hm_read_gauge ../starter/source/output/gauge/hm_read_gauge.F
235!|| hm_read_link ../starter/source/constraints/rigidlink/hm_read_rlink.F
236!||--- calls -----------------------------------------------------
237!|| nextsla ../starter/source/starter/freform.F
238!||--- uses -----------------------------------------------------
239!|| reader_old_mod ../starter/share/modules1/reader_old_mod.f90
240!||====================================================================
241 SUBROUTINE sz_r2r(TAG,VAL)
242C-----------------------------------------------
243C M o d u l e s
244C-----------------------------------------------
245 USE reader_old_mod , ONLY : irec, nslash
246C-----------------------------------------------
247C I m p l i c i t T y p e s
248C-----------------------------------------------
249#include "implicit_f.inc"
250C-----------------------------------------------
251C C o m m o n B l o c k s
252C-----------------------------------------------
253#include "scr17_c.inc"
254C-----------------------------------------------
255C D u m m y A r g u m e n t s
256C-----------------------------------------------
257 INTEGER VAL,TAG(*)
258C-----------------------------------------------
259
260 CALL nextsla
261 DO WHILE (tag(val) == 0)
262 val=val+1
263 irec=irec+1
264 CALL nextsla
265 END DO
266
267 RETURN
268 END SUBROUTINE sz_r2r
269
270!||====================================================================
271!|| hm_sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
272!||--- called by ------------------------------------------------------
273!|| hm_prelecjoi ../starter/source/constraints/general/cyl_joint/hm_prelecjoi.F
274!|| hm_preread_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
275!|| hm_preread_rbe3 ../starter/source/constraints/general/rbe3/hm_preread_rbe3.F
276!|| hm_preread_rbody ../starter/source/constraints/general/rbody/hm_preread_rbody.F
277!|| hm_read_cyljoint ../starter/source/constraints/general/cyl_joint/hm_read_cyljoint.F
278!|| hm_read_gjoint ../starter/source/constraints/general/gjoint/hm_read_gjoint.F
279!|| hm_read_inivol ../starter/source/initial_conditions/inivol/hm_read_inivol.F90
280!|| hm_read_interfaces ../starter/source/interfaces/reader/hm_read_interfaces.F
281!|| hm_read_intsub ../starter/source/output/subinterface/hm_read_intsub.F
282!|| hm_read_mpc ../starter/source/constraints/general/mpc/hm_read_mpc.F
283!|| hm_read_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
284!|| hm_read_rbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
285!|| hm_read_rbody ../starter/source/constraints/general/rbody/hm_read_rbody.F
286!|| hm_read_rbody_lagmul ../starter/source/constraints/general/rbody/hm_read_rbody_lagmul.F
287!|| hm_read_spcnd ../starter/source/constraints/sph/hm_read_spcnd.F
288!|| lecsec42 ../starter/source/tools/sect/hm_read_sect.F
289!|| prelecsec ../starter/source/tools/sect/prelecsec.F
290!|| preread_rbody_lagmul ../starter/source/constraints/general/rbody/preread_rbody_lagmul.F
291!|| read_monvol ../starter/source/airbag/read_monvol.F
292!|| setrbyon ../starter/source/constraints/general/rbody/hm_read_rbody.F
293!||--- calls -----------------------------------------------------
294!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
295!||--- uses -----------------------------------------------------
296!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.f
297!|| submodel_mod ../starter/share/modules1/submodel_mod.F
298!||====================================================================
299 SUBROUTINE hm_sz_r2r(TAG,VAL,LSUBMODEL)
300C-----------------------------------------------
301C M o d u l e s
302C-----------------------------------------------
303 USE submodel_mod
304 USE hm_option_read_mod
305C-----------------------------------------------
306C I m p l i c i t T y p e s
307C-----------------------------------------------
308#include "implicit_f.inc"
309C-----------------------------------------------
310C D u m m y A r g u m e n t s
311C-----------------------------------------------
312 INTEGER VAL,TAG(*)
313 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
314C-----------------------------------------------
315C
316 DO WHILE (tag(val) == 0)
317 CALL hm_option_read_key(lsubmodel)
318 val=val+1
319 END DO
320C
321 RETURN
322 END SUBROUTINE hm_sz_r2r
323
324!||====================================================================
325!|| r2r_exist ../starter/source/coupling/rad2rad/routines_r2r.F
326!||--- called by ------------------------------------------------------
327!|| hm_read_thchecksum ../starter/source/output/th/hm_read_thchecksum.F90
328!|| hm_read_thgrki ../starter/source/output/th/hm_read_thgrki.F
329!|| hm_read_thgrki_rbody ../starter/source/output/th/hm_read_thgrki_rbody.F
330!|| hm_read_thgrpa ../starter/source/output/th/hm_read_thgrpa.F
331!|| hm_read_thgrpa_sub ../starter/source/output/th/hm_read_thgrpa.F
332!|| hm_read_thgrsens ../starter/source/output/th/hm_read_thgrsens.F
333!|| hm_read_thgrsurf ../starter/source/output/th/hm_read_thgrsurf.F
334!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
335!|| r2r_listcnt ../starter/source/coupling/rad2rad/routines_r2r.F
336!||--- calls -----------------------------------------------------
337!|| ancmsg ../starter/source/output/message/message.F
338!||--- uses -----------------------------------------------------
339!|| group_mod ../starter/share/modules1/group_mod.f
340!|| message_mod ../starter/share/message_module/message_mod.F
341!|| r2r_mod ../starter/share/modules1/r2r_mod.F
342!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
343!|| restmod ../starter/share/modules1/restart_mod.F
344!||====================================================================
345 INTEGER FUNCTION r2r_exist(TYP,ID)
346C-----------------------------------------------
347C M o d u l e s
348C-----------------------------------------------
349 USE r2r_mod
350 USE restmod
351 USE message_mod
352 USE groupdef_mod
353 USE group_mod
354 USE reader_old_mod , ONLY : kinter, nslash
355C-----------------------------------------------
356C I m p l i c i t T y p e s
357C-----------------------------------------------
358#include "implicit_f.inc"
359C-----------------------------------------------
360C C o m m o n B l o c k s
361C-----------------------------------------------
362#include "scr17_c.inc"
363#include "com04_c.inc"
364C-----------------------------------------------
365 INTEGER id,typ
366 INTEGER i,curs
367C--------------------------------------------------------
368C------ --> TH : check if corresponding option is kept---
369C--------------------------------------------------------
370
371 r2r_exist=0
372 curs = 0
373
374 IF (typ==107) THEN
375C-----------MONVOL------------------
376 DO i=1,nvolu
377 curs=curs+1
378 DO WHILE (tagmon(curs)==0)
379 curs=curs+1
380 END DO
381 IF (tagmon(curs)==id) r2r_exist=1
382 END DO
383 ELSEIF (typ==101) THEN
384C-----------INTER------------------
385 DO i=1,hm_ninter+nslash(kinter)
386 curs=curs+1
387 DO WHILE (tagint(curs)==0)
388 curs=curs+1
389 END DO
390 IF (tagint(curs)==id) r2r_exist=1
391 END DO
392 ELSEIF (typ==103) THEN
393C-----------RBY------------------
394 DO i=1,nrbody
395 curs=curs+1
396 DO WHILE (tagrby(curs)==0)
397 curs=curs+1
398 END DO
399 IF (tagrby(curs)==id) r2r_exist=1
400 END DO
401 ELSEIF (typ==105) THEN
402C-----------CYL_JOIN--------------
403 DO i=1,njoint
404 curs=curs+1
405 DO WHILE (tagcyl(curs)==0)
406 curs=curs+1
407 END DO
408 IF (tagcyl(curs)==id) r2r_exist=1
409 END DO
410 ELSEIF (typ==1001) THEN
411C-----------PART------------------
412 DO i=1,npart
413 IF (ipart(lipart1*(i-1)+4)==id) curs = i
414 END DO
415 IF (curs == 0) THEN
416 CALL ancmsg(msgid=258,
417 . msgtype=msgerror,
418 . anmode=aninfo_blind_1,
419 . c1="PART",
420 . i1=id)
421 ENDIF
422 IF (tag_part(curs)>0) r2r_exist=1
423 ELSEIF (typ==1002) THEN
424C-----------SUBSET------------------
425 DO i=1,nsubs
426 IF (subsets(i)%ID==id) curs = i
427 END DO
428 IF (curs == 0) THEN
429 CALL ancmsg(msgid=258,
430 . msgtype=msgerror,
431 . anmode=aninfo_blind_1,
432 . c1="SUBSET",
433 . i1=id)
434 ENDIF
435 r2r_exist=1
436 ELSEIF (typ==102) THEN
437C-----------RWALL-------------------
438 r2r_exist=1
439 ELSEIF (typ==104) THEN
440C-----------SECTION-----------------
441 DO i=1,nsect
442 curs=curs+1
443 DO WHILE (tagsec(curs)==0)
444 curs=curs+1
445 END DO
446 IF (tagsec(curs)==id) r2r_exist=1
447 END DO
448 ELSEIF (typ==108) THEN
449C-----------ACCELEROMETER-----------
450 r2r_exist=1
451 ELSEIF (typ==110) THEN
452C-----------FRAMES------------------
453 r2r_exist=1
454 ELSEIF (typ==113) THEN
455C-----------GAUGES------------------
456 DO i=1,nbgauge
457 curs=curs+1
458 DO WHILE (taggau(curs)==0)
459 curs=curs+1
460 END DO
461 IF (taggau(curs)==id) r2r_exist=1
462 END DO
463 ENDIF
464
465 RETURN
466 end function r2r_exist
467
468!||====================================================================
469!|| r2r_listcnt ../starter/source/coupling/rad2rad/routines_r2r.F
470!||--- called by ------------------------------------------------------
471!|| hm_read_thgrsurf ../starter/source/output/th/hm_read_thgrsurf.F
472!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
473!||--- calls -----------------------------------------------------
474!|| my_exit ../starter/source/output/analyse/analyse.c
475!|| r2r_exist ../starter/source/coupling/rad2rad/routines_r2r.F
476!||--- uses -----------------------------------------------------
477!|| format_mod ../starter/share/modules1/format_mod.F90
478!|| r2r_mod ../starter/share/modules1/r2r_mod.F
479!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
480!||====================================================================
481 INTEGER FUNCTION r2r_listcnt(NVAR,TYP)
482C-----------------------------------------------
483C M o d u l e s
484C-----------------------------------------------
485 USE r2r_mod
486 USE format_mod , ONLY : fmt_10i
487 USE reader_old_mod , ONLY : line, irec
488C-----------------------------------------------
489C I m p l i c i t T y p e s
490C-----------------------------------------------
491#include "implicit_f.inc"
492C-----------------------------------------------
493C C o m m o n B l o c k s
494C-----------------------------------------------
495#include "scr17_c.inc"
496#include "units_c.inc"
497C-----------------------------------------------
498 INTEGER nvar,typ
499C-----------------------------------------------
500C E x t e r n a l F u n c t i o n s
501C-----------------------------------------------
502 INTEGER r2r_exist
503C-----------------------------------------------
504 INTEGER i,jrec,j10(10),nvar_tmp
505C-----------------------------------------------------------
506C------ --> TH : re-count of nb of entities in TH groups----
507C-----------------------------------------------------------
508
509 r2r_listcnt=0
510 nvar=0
511 jrec=irec
512 jrec=jrec+1
513 READ(iin,rec=jrec,err=999,fmt='(A)')line
514 DO WHILE(line(1:1)/='/')
515 nvar_tmp = nvar
516 READ(line,err=999,fmt=fmt_10i) j10
517 DO i=1,10
518 IF(j10(i)/=0) THEN
519C-----------entity is counted if it is kept-------------------
520 IF (r2r_exist(typ,j10(i))==1) nvar=nvar+1
521C-------------------------------------------------------------
522 ENDIF
523 ENDDO
524 r2r_listcnt=r2r_listcnt+1
525 jrec=jrec+1
526 READ(iin,rec=jrec,err=999,fmt='(A)')line
527 ENDDO
528 RETURN
529 999 CALL freerr(1)
530 CALL my_exit(2)
531 end function r2r_listcnt
532
533C
534!||====================================================================
535!|| grsize_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
536!||--- called by ------------------------------------------------------
537!|| prelecsec ../starter/source/tools/sect/prelecsec.F
538!|| prelecsec4bolt ../starter/source/tools/sect/prelecsec4bolt.F
539!||--- uses -----------------------------------------------------
540!||====================================================================
541 INTEGER FUNCTION grsize_r2r(IGU,IGRELEM,GRLEN,TYP)
542C-----------------------------------------------
543C M o d u l e s
544C-----------------------------------------------
545 USE groupdef_mod
546C-----------------------------------------------
547C I m p l i c i t T y p e s
548C-----------------------------------------------
549#include "implicit_f.inc"
550C-----------------------------------------------
551C D u m m y A r g u m e n t s
552C-----------------------------------------------
553 INTEGER igu,grlen,typ
554C-----------------------------------------------
555 TYPE (group_) , DIMENSION(GRLEN) :: igrelem
556C-----------------------------------------------
557C L o c a l V a r i a b l e s
558C-----------------------------------------------
559 INTEGER i,igs
560C-----------------------------------------------
561 grsize_r2r = 0
562 IF (igu > 0) THEN
563 DO i=1,grlen
564 IF (igu == igrelem(i)%ID) THEN
565 IF (typ == 8) THEN ! before split
566 grsize_r2r = igrelem(i)%R2R_ALL
567 ELSEIF (typ == 9) THEN ! shared
568 grsize_r2r = igrelem(i)%R2R_SHARE
569 ENDIF
570 igs = i
571 EXIT
572 ENDIF
573 ENDDO
574 ENDIF
575C-----------
576 RETURN
577 end function grsize_r2r
578
579!||====================================================================
580!|| r2r_sys2 ../starter/source/coupling/rad2rad/routines_r2r.F
581!||--- called by ------------------------------------------------------
582!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.f
583!||--- calls -----------------------------------------------------
584!|| ancmsg ../starter/source/output/message/message.F
585!||--- uses -----------------------------------------------------
586!|| message_mod ../starter/share/message_module/message_mod.F
587!||====================================================================
588 INTEGER FUNCTION r2r_sys2(IU,ITABM1,MESS)
589 USE message_mod
590C-----------------------------------------------
591C I m p l i c i t T y p e s
592C-----------------------------------------------
593#include "implicit_f.inc"
594C-----------------------------------------------
595C D u m m y A r g u m e n t s
596C-----------------------------------------------
597 INTEGER iu
598 CHARACTER mess*40
599 INTEGER itabm1(*)
600C-----------------------------------------------
601C C o m m o n B l o c k s
602C-----------------------------------------------
603#include "com04_c.inc"
604C-----------------------------------------------
605C L o c a l V a r i a b l e s
606C-----------------------------------------------
607 INTEGER jinf, jsup, j
608C-----------------------------------------------
609C-- Same routine as USR2SYS -> used to avoid infinite loop in R2R_SYS
610
611 jinf=1
612 jsup=numnod
613 j=max(1,numnod/2)
614 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
615 CALL ancmsg(msgid=78,
616 . msgtype=msgerror,
617 . anmode=aninfo,
618 . c1=mess,
619 . i1=iu)
620 r2r_sys2=0
621 RETURN
622 ENDIF
623 IF((iu-itabm1(j))==0)THEN
624C >IU=TABM - end of search
625 r2r_sys2=itabm1(j+numnod)
626 RETURN
627 ELSE IF (iu-itabm1(j)<0) THEN
628C >IU<TABM
629 jsup=j-1
630 ELSE
631C >IU>TABM
632 jinf=j+1
633 ENDIF
634 j=(jsup+jinf)/2
635 IF (j > 0) THEN
636 GO TO 10
637 ELSE
638 r2r_sys2=0
639 ENDIF
640 end function r2r_sys2
641
642!||====================================================================
643!|| r2r_nom_opt ../starter/source/coupling/rad2rad/routines_r2r.F
644!||--- called by ------------------------------------------------------
645!|| lectur ../starter/source/starter/lectur.F
646!||--- uses -----------------------------------------------------
647!|| r2r_mod ../starter/share/modules1/r2r_mod.F
648!|| submodel_mod ../starter/share/modules1/submodel_mod.F
649!||====================================================================
650 SUBROUTINE r2r_nom_opt(NOM_OPT,INOM_OPT,IN10,IN20,SNOM_OPT_OLD)
651C-----------------------------------------------
652C M o d u l e s
653C-----------------------------------------------
654 USE r2r_mod
655 USE submodel_mod , ONLY : nsubmod
656C-----------------------------------------------
657C I m p l i c i t T y p e s
658C-----------------------------------------------
659#include "implicit_f.inc"
660C-----------------------------------------------
661C C o m m o n B l o c k s
662C-----------------------------------------------
663#include "scr17_c.inc"
664#include "com04_c.inc"
665C-----------------------------------------------
666C D u m m y A r g u m e n t s
667C-----------------------------------------------
668 INTEGER NOM_OPT(*),INOM_OPT(*),IN10,IN20,SNOM_OPT_OLD
669C-----------------------------------------------
670C L o c a l V a r i a b l e s
671C-----------------------------------------------
672 INTEGER I,J
673C=======================================================================
674C-- Split of NOM_OPT
675
676 ALLOCATE (nom_opt_temp(snom_opt_old))
677 DO i=1,snom_opt_old
678 nom_opt_temp(i) = nom_opt(i)
679 nom_opt(i) = 0
680 ENDDO
681
682C--- FUNCTIONS / TABLES --
683 DO i=1,lnopt1*nfunct
684 nom_opt(lnopt1*inom_opt(20)+i)=nom_opt_temp(lnopt1*in20+i)
685 END DO
686C--- FRAMES --
687 DO i=1,lnopt1*(numskw+1+numfram+1+nsubmod)
688 nom_opt(lnopt1*inom_opt(10)+i)=nom_opt_temp(lnopt1*in10+i)
689 END DO
690
691 DEALLOCATE (nom_opt_temp)
692
693C-----------
694 RETURN
695 END SUBROUTINE r2r_nom_opt
696
697!||====================================================================
698!|| chk_flg_fsi ../starter/source/coupling/rad2rad/routines_r2r.F
699!||--- called by ------------------------------------------------------
700!|| r2r_group ../starter/source/coupling/rad2rad/r2r_group.F
701!||--- uses -----------------------------------------------------
702!|| r2r_mod ../starter/share/modules1/r2r_mod.F
703!||====================================================================
704 SUBROUTINE chk_flg_fsi(IXS,PM,IPARTS,ALE_EULER,IGEO)
705C-----------------------------------------------
706C M o d u l e s
707C-----------------------------------------------
708 USE r2r_mod
709C-----------------------------------------------
710C I m p l i c i t T y p e s
711C-----------------------------------------------
712#include "implicit_f.inc"
713C-----------------------------------------------
714C C o m m o n B l o c k s
715C-----------------------------------------------
716#include "com04_c.inc"
717#include "param_c.inc"
718#include "r2r_c.inc"
719#include "tabsiz_c.inc"
720C-----------------------------------------------
721C D u m m y A r g u m e n t s
722C-----------------------------------------------
723 INTEGER IXS(NIXS,SIXS/NIXS),IPARTS(*),ALE_EULER
724 INTEGER,INTENT(IN) :: IGEO(NPROPGI,NUMGEO)
725 my_real pm(npropm,nummat)
726C-----------------------------------------------
727C L o c a l V a r i a b l e s
728C-----------------------------------------------
729 INTEGER M,JALE,ID_PART,IMAT0,IPROP0,ELEM_VOID,JALE_FROM_MAT, JALE_FROM_PROP
730C-----------------------------------------------
731C S o u r c e L i n e s
732C-----------------------------------------------
733 flg_fsi = 0
734 ale_euler = 0
735 DO m=1,numels
736 id_part=iparts(m)
737C---------------id of the original material -----------C
738 imat0=ipart_r2r(1,id_part) !original mat_id
739 iprop0=ipart_r2r(4,id_part) !original prop_id
740 jale_from_mat = nint(pm(72,imat0))
741 jale_from_prop = igeo(62,iprop0)
742 jale= max(jale_from_mat, jale_from_prop)
743C
744 elem_void = 0
745 IF ((tagno(id_part)==0).AND.(tag_els(m)>0)) elem_void=1
746 IF ((jale > 0).AND.(tagno(id_part) > 0)) ale_euler = 1
747 IF ((jale == 0).OR.(elem_void == 0)) cycle
748 flg_fsi = 1
749 END DO
750C-------------------------------------------
751 RETURN
752 END SUBROUTINE chk_flg_fsi
753
754!||====================================================================
755!|| r2r_check_seg ../starter/source/coupling/rad2rad/routines_r2r.F
756!||--- called by ------------------------------------------------------
757!|| r2r_clean_inter ../starter/source/coupling/rad2rad/r2r_clean_inter.F
758!||--- uses -----------------------------------------------------
759!|| nod2el_mod ../starter/share/modules1/nod2el_mod.F
760!|| r2r_mod ../starter/share/modules1/r2r_mod.F
761!|| restmod ../starter/share/modules1/restart_mod.F
762!||====================================================================
763 SUBROUTINE r2r_check_seg(ELTAG,FACE,IPARTC,IPARTG,IPARTS,ISOLNOD)
764C-----------------------------------------------
765C M o d u l e s
766C-----------------------------------------------
767 USE restmod
768 USE nod2el_mod
769 USE r2r_mod
770C-----------------------------------------------
771C I m p l i c i t T y p e s
772C-----------------------------------------------
773#include "implicit_f.inc"
774C-----------------------------------------------
775C C o m m o n B l o c k s
776C-----------------------------------------------
777#include "com04_c.inc"
778C-----------------------------------------------
779C D u m m y A r g u m e n t s
780C-----------------------------------------------
781 INTEGER ELTAG,FACE(4),IPARTC(*),IPARTG(*),IPARTS(*),ISOLNOD(*)
782C-----------------------------------------------
783C L o c a l V a r i a b l e s
784C-----------------------------------------------
785 INTEGER CUR_ID,CUR_10,CUR_20,CUR_16,FLG_T4,L,K
786 INTEGER ITAGL(NUMNOD),NF,SUM,OFFSET
787C-----------------------------------------------
788
789 nf = face(1)
790 eltag = 0
791
792C--> check of shell elements <---
793 DO l = knod2elc(nf)+1,knod2elc(nf+1)
794 cur_id = nod2elc(l)
795 flg_t4 = 0
796 DO k = 1,4
797 itagl(face(k)) = 0
798 END DO
799 DO k = 2,5
800 itagl(ixc(nixc*(cur_id-1)+k)) = 1
801 IF (tagno(npart+ixc(nixc*(cur_id-1)+k))==2) flg_t4 = 1
802 END DO
803 sum=itagl(face(1))+itagl(face(2))+itagl(face(3))+itagl(face(4))
804 IF ((sum==4).AND.((tagno(ipartc(cur_id))==1).OR.(flg_t4==0))) eltag = 1
805 END DO
806
807C--> check of sh3n elements <---
808 DO l = knod2eltg(nf)+1,knod2eltg(nf+1)
809 cur_id = nod2eltg(l)
810 flg_t4 = 0
811 DO k = 1,4
812 itagl(face(k)) = 0
813 END DO
814 DO k = 2,4
815 itagl(ixtg(nixtg*(cur_id-1)+k)) = 1
816 IF (tagno(npart+ixtg(nixtg*(cur_id-1)+k))==2) flg_t4 = 1
817 END DO
818 sum=itagl(face(1))+itagl(face(2))+itagl(face(3))+itagl(face(4))
819 IF (sum==4) eltag = 1
820 IF ((sum==4).AND.((tagno(ipartg(cur_id))==1).OR.(flg_t4==0))) eltag = 1
821 END DO
822
823C--> check of solid elements <---
824 DO l = knod2els(nf)+1,knod2els(nf+1)
825 cur_id = nod2els(l)
826 flg_t4 = 0
827 DO k = 1,4
828 itagl(face(k)) = 0
829 END DO
830 DO k = 2,9
831 itagl(ixs(nixs*(cur_id-1)+k)) = 1
832 IF (tagno(npart+ixs(nixs*(cur_id-1)+k))==2) flg_t4 = 1
833 END DO
834 IF (isolnod(cur_id)==10) THEN
835 offset = nixs*numels
836 cur_10 = cur_id-numels8
837 DO k=1,6
838 itagl(ixs(offset+6*(cur_10-1)+k)) = 1
839 IF (tagno(npart+ixs(offset+6*(cur_10-1)+k))==2) flg_t4 = 1
840 ENDDO
841 ELSEIF (isolnod(cur_id)==20) THEN
842 offset = nixs*numels+6*numels10
843 cur_20 = cur_id-(numels8+numels10)
844 DO k=1,12
845 itagl(ixs(offset+12*(cur_20-1)+k)) = 1
846 IF (tagno(npart+ixs(offset+12*(cur_20-1)+k))==2) flg_t4 = 1
847 ENDDO
848 ELSEIF (isolnod(cur_id)==16) THEN
849 offset = nixs*numels+6*numels10+12*numels20
850 cur_16 = cur_id-(numels8+numels10+numels20)
851 DO k=1,8
852 itagl(ixs(offset+8*(cur_16-1)+k)) = 1
853 IF (tagno(npart+ixs(offset+8*(cur_16-1)+k))==2) flg_t4 = 1
854 ENDDO
855 ENDIF
856 sum=itagl(face(1))+itagl(face(2))+itagl(face(3))+itagl(face(4))
857 IF (sum==4) eltag = 1
858 IF ((sum==4).AND.((tagno(iparts(cur_id))==1).OR.(flg_t4==0))) eltag = 1
859 END DO
860
861C-----------
862 RETURN
863 END SUBROUTINE r2r_check_seg
my_exit
void my_exit(int *i)
Definition analyse.c:1038
my_real
#define my_real
Definition cppsort.cpp:32
hm_pre_read_link
subroutine hm_pre_read_link(num, igrnod, lsubmodel)
Definition hm_pre_read_rlink.F:39
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
group_mod
Definition group_mod.F:31
group_mod::subsets
type(subset_), dimension(:), allocatable, target subsets
Definition group_mod.F:45
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
nod2el_mod
Definition nod2el_mod.F:36
nod2el_mod::knod2elc
integer, dimension(:), allocatable knod2elc
Definition nod2el_mod.F:58
nod2el_mod::knod2els
integer, dimension(:), allocatable knod2els
Definition nod2el_mod.F:58
nod2el_mod::nod2eltg
integer, dimension(:), allocatable nod2eltg
Definition nod2el_mod.F:58
nod2el_mod::nod2elc
integer, dimension(:), allocatable nod2elc
Definition nod2el_mod.F:58
nod2el_mod::nod2els
integer, dimension(:), allocatable nod2els
Definition nod2el_mod.F:58
nod2el_mod::knod2eltg
integer, dimension(:), allocatable knod2eltg
Definition nod2el_mod.F:58
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tag_els
integer, dimension(:), allocatable tag_els
Definition r2r_mod.F:133
r2r_mod::tagno
integer, dimension(:), allocatable tagno
Definition r2r_mod.F:132
r2r_mod::tagsec
integer, dimension(:), allocatable tagsec
Definition r2r_mod.F:137
r2r_mod::tagrby
integer, dimension(:), allocatable tagrby
Definition r2r_mod.F:132
r2r_mod::tag_part
integer, dimension(:), allocatable tag_part
Definition r2r_mod.F:134
r2r_mod::tagint
integer, dimension(:), allocatable tagint
Definition r2r_mod.F:132
r2r_mod::tagmon
integer, dimension(:), allocatable tagmon
Definition r2r_mod.F:132
r2r_mod::nom_opt_temp
integer, dimension(:), allocatable nom_opt_temp
Definition r2r_mod.F:142
r2r_mod::ipart_r2r
integer, dimension(:,:), allocatable ipart_r2r
Definition r2r_mod.F:144
r2r_mod::taggau
integer, dimension(:), allocatable taggau
Definition r2r_mod.F:142
r2r_mod::tagcyl
integer, dimension(:), allocatable tagcyl
Definition r2r_mod.F:137
restmod::ixs
integer, dimension(:), allocatable, target ixs
Definition restart_mod.F:60
restmod::ipart
integer, dimension(:), allocatable, target ipart
Definition restart_mod.F:60
restmod::ixtg
integer, dimension(:), allocatable, target ixtg
Definition restart_mod.F:60
restmod::ixc
integer, dimension(:), allocatable ixc
Definition restart_mod.F:60
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
nvar
integer function nvar(text)
Definition nvar.F:32
modif_tag
subroutine modif_tag(tag, new_tag, modif)
Definition routines_r2r.F:31
r2r_sys
integer function r2r_sys(iu, itabm1, mess)
Definition routines_r2r.F:67
chk_flg_fsi
subroutine chk_flg_fsi(ixs, pm, iparts, ale_euler, igeo)
Definition routines_r2r.F:705
nodgr_r2r
integer function nodgr_r2r(igu, igs, ibuf, igrnod, itabm1, mess)
Definition routines_r2r.F:174
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:300
sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:242
grsize_r2r
integer function grsize_r2r(igu, igrelem, grlen, typ)
Definition routines_r2r.F:542
r2r_sys2
integer function r2r_sys2(iu, itabm1, mess)
Definition routines_r2r.F:589
r2r_listcnt
integer function r2r_listcnt(nvar, typ)
Definition routines_r2r.F:482
r2r_check_seg
subroutine r2r_check_seg(eltag, face, ipartc, ipartg, iparts, isolnod)
Definition routines_r2r.F:764
r2r_exist
integer function r2r_exist(typ, id)
Definition routines_r2r.F:346
r2r_nin
integer function r2r_nin(iext, ntn, m, n)
Definition routines_r2r.F:137
r2r_nom_opt
subroutine r2r_nom_opt(nom_opt, inom_opt, in10, in20, snom_opt_old)
Definition routines_r2r.F:651
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
nextsla
subroutine nextsla
Definition freform.F:846
freerr
subroutine freerr(it)
Definition freform.F:506
starter
program starter
Definition starter.F:39
groupdef_mod::group_
Definition groupdef_mod.F:700
submodel_mod::submodel_data
Definition submodel_mod.F:723