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_thgrne ../starter/source/output/th/hm_read_thgrne.F
58!|| hm_read_xref ../starter/source/loads/reference_state/xref/hm_read_xref.F
59!|| lecrefsta ../starter/source/loads/reference_state/refsta/lecrefsta.F
60!|| usr2sys ../starter/source/system/sysfus.F
61!|| usr2sys2 ../starter/source/system/sysfus.F
62!||--- calls -----------------------------------------------------
63!|| r2r_sys2 ../starter/source/coupling/rad2rad/routines_r2r.F
64!||====================================================================
65 INTEGER FUNCTION r2r_sys(IU,ITABM1,MESS)
66C-----------------------------------------------
67C I m p l i c i t T y p e s
68C-----------------------------------------------
69#include "implicit_f.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73 INTEGER iu
74 CHARACTER mess*40
75 INTEGER itabm1(*)
76C-----------------------------------------------
77C C o m m o n B l o c k s
78C-----------------------------------------------
79#include "com04_c.inc"
80#include "r2r_c.inc"
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER jinf, jsup, j,sauv,nn
85 INTEGER, DIMENSION(:), POINTER :: itabm2
86 TARGET :: itabm1
87C-----------------------------------------------
88C E x t e r n a l F u n c t i o n s
89C-----------------------------------------------
90 INTEGER r2r_sys2
91C-----------------------------------------------
92
93 jinf=1
94 jsup=numnod
95 j=max(1,numnod/2)
96
97 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
98 r2r_sys=0
99C------------Check of the list of removed nodes-------------
100 itabm2 => itabm1(2*numnod+1:2*(numnod+nodsupr))
101 sauv = numnod
102 numnod = nodsupr
103 nn=r2r_sys2(iu,itabm2,mess)
104 IF (nn==0) r2r_sys=-1
105 numnod = sauv
106C-----------------------------------------------------------
107 RETURN
108 ENDIF
109
110 IF((iu-itabm1(j))==0)THEN
111C >IU=TABM - end of the search
112 r2r_sys=itabm1(j+numnod)
113 RETURN
114 ELSE IF (iu-itabm1(j)<0) THEN
115C >IU<TABM
116 jsup=j-1
117 ELSE
118C >IU>TABM
119 jinf=j+1
120 ENDIF
121 j=(jsup+jinf)/2
122 IF (j > 0) THEN
123 GO TO 10
124 ELSE
125 r2r_sys=0
126 ENDIF
127C
128 end function r2r_sys
129
130!||====================================================================
131!|| r2r_nin ../starter/source/coupling/rad2rad/routines_r2r.F
132!||--- called by ------------------------------------------------------
133!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
134!||====================================================================
135 INTEGER FUNCTION r2r_nin(IEXT,NTN,M,N)
136C-----------------------------------------------
137C I m p l i c i t T y p e s
138C-----------------------------------------------
139#include "implicit_f.inc"
140C-----------------------------------------------
141C D u m m y A r g u m e n t s
142C-----------------------------------------------
143 INTEGER iext, m, n
144 INTEGER ntn(m,n)
145C-----------------------------------------------
146C L o c a l V a r i a b l e s
147C-----------------------------------------------
148 INTEGER i
149C-----------------------------------------------
150 DO i=1,n
151 IF(ntn(m,i)==iext)THEN
152 r2r_nin=i
153 RETURN
154 ENDIF
155 ENDDO
156 r2r_nin=0
157C-------------------------------------------
158 RETURN
159 end function r2r_nin
160
161!||====================================================================
162!|| nodgr_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
163!||--- called by ------------------------------------------------------
164!|| hm_read_cload ../starter/source/loads/general/cload/hm_read_cload.F
165!||--- calls -----------------------------------------------------
166!|| ancmsg ../starter/source/output/message/message.F
167!||--- uses -----------------------------------------------------
168!|| message_mod ../starter/share/message_module/message_mod.F
169!|| r2r_mod ../starter/share/modules1/r2r_mod.F
170!||====================================================================
171 INTEGER FUNCTION nodgr_r2r(IGU,IGS,IBUF,IGRNOD,
172 . ITABM1 ,MESS )
173C-----------------------------------------------
174C M o d u l e s
175C-----------------------------------------------
176 USE groupdef_mod
177 USE message_mod
178 USE r2r_mod
179C-----------------------------------------------
180C I m p l i c i t T y p e s
181C-----------------------------------------------
182#include "implicit_f.inc"
183C-----------------------------------------------
184C C o m m o n B l o c k s
185C-----------------------------------------------
186#include "com04_c.inc"
187C-----------------------------------------------
188 INTEGER igu,igs,ibuf(*),itabm1(*)
189 CHARACTER mess*40
190C-----------------------------------------------
191 TYPE (group_) , DIMENSION(NGRNOD) :: igrnod
192C-----------------------------------------------
193 INTEGER i,compt
194C=======================================================================
195 nodgr_r2r = 0
196 IF (igu > 0) THEN
197 igs=0
198 DO i=1,ngrnod
199 IF(igrnod(i)%ID == igu) THEN
200 igs=i
201 nodgr_r2r = igrnod(igs)%NENTITY
202 EXIT
203 ENDIF
204 ENDDO
205C
206 IF (igs == 0)THEN
207 CALL ancmsg(msgid=53,
208 . msgtype=msgerror,
209 . anmode=aninfo,
210 . c1= mess,
211 . i1=igu)
212 RETURN
213 ENDIF
214C
215 compt = 0
216 DO i=1,nodgr_r2r
217 IF (tagno(igrnod(igs)%ENTITY(i)+npart)/=2) THEN
218 compt = compt + 1
219 ibuf(compt)=igrnod(igs)%ENTITY(i)
220 ENDIF
221 ENDDO
222!
223 nodgr_r2r = nodgr_r2r - igrnod(igs)%R2R_SHARE
224 ENDIF
225C---
226 RETURN
227 end function nodgr_r2r
228
229!||====================================================================
230!|| sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
231!||--- called by ------------------------------------------------------
232!|| hm_pre_read_link ../starter/source/constraints/rigidlink/hm_pre_read_rlink.F
233!|| hm_read_gauge ../starter/source/output/gauge/hm_read_gauge.F
234!|| hm_read_link ../starter/source/constraints/rigidlink/hm_read_rlink.F
235!||--- calls -----------------------------------------------------
236!|| nextsla ../starter/source/starter/freform.F
237!||--- uses -----------------------------------------------------
238!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
239!||====================================================================
240 SUBROUTINE sz_r2r(TAG,VAL)
241C-----------------------------------------------
242C M o d u l e s
243C-----------------------------------------------
244 USE reader_old_mod , ONLY : irec, nslash
245C-----------------------------------------------
246C I m p l i c i t T y p e s
247C-----------------------------------------------
248#include "implicit_f.inc"
249C-----------------------------------------------
250C C o m m o n B l o c k s
251C-----------------------------------------------
252#include "scr17_c.inc"
253C-----------------------------------------------
254C D u m m y A r g u m e n t s
255C-----------------------------------------------
256 INTEGER VAL,TAG(*)
257C-----------------------------------------------
258
259 CALL nextsla
260 DO WHILE (tag(val) == 0)
261 val=val+1
262 irec=irec+1
263 CALL nextsla
264 END DO
265
266 RETURN
267 END SUBROUTINE sz_r2r
268
269!||====================================================================
270!|| hm_sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
271!||--- called by ------------------------------------------------------
272!|| hm_prelecjoi ../starter/source/constraints/general/cyl_joint/hm_prelecjoi.F
273!|| hm_preread_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
274!|| hm_preread_rbe3 ../starter/source/constraints/general/rbe3/hm_preread_rbe3.F
275!|| hm_preread_rbody ../starter/source/constraints/general/rbody/hm_preread_rbody.F
276!|| hm_read_cyljoint ../starter/source/constraints/general/cyl_joint/hm_read_cyljoint.F
277!|| hm_read_gjoint ../starter/source/constraints/general/gjoint/hm_read_gjoint.F
278!|| hm_read_inivol ../starter/source/initial_conditions/inivol/hm_read_inivol.F90
279!|| hm_read_interfaces ../starter/source/interfaces/reader/hm_read_interfaces.F
280!|| hm_read_intsub ../starter/source/output/subinterface/hm_read_intsub.F
281!|| hm_read_mpc ../starter/source/constraints/general/mpc/hm_read_mpc.F
282!|| hm_read_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
283!|| hm_read_rbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
284!|| hm_read_rbody ../starter/source/constraints/general/rbody/hm_read_rbody.F
285!|| hm_read_rbody_lagmul ../starter/source/constraints/general/rbody/hm_read_rbody_lagmul.F
286!|| hm_read_spcnd ../starter/source/constraints/sph/hm_read_spcnd.F
287!|| lecsec42 ../starter/source/tools/sect/hm_read_sect.F
288!|| prelecsec ../starter/source/tools/sect/prelecsec.F
289!|| preread_rbody_lagmul ../starter/source/constraints/general/rbody/preread_rbody_lagmul.F
290!|| read_monvol ../starter/source/airbag/read_monvol.F
291!|| setrbyon ../starter/source/constraints/general/rbody/hm_read_rbody.F
292!||--- calls -----------------------------------------------------
293!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
294!||--- uses -----------------------------------------------------
295!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
296!|| submodel_mod ../starter/share/modules1/submodel_mod.F
297!||====================================================================
298 SUBROUTINE hm_sz_r2r(TAG,VAL,LSUBMODEL)
299C-----------------------------------------------
300C M o d u l e s
301C-----------------------------------------------
302 USE submodel_mod
303 USE hm_option_read_mod
304C-----------------------------------------------
305C I m p l i c i t T y p e s
306C-----------------------------------------------
307#include "implicit_f.inc"
308C-----------------------------------------------
309C D u m m y A r g u m e n t s
310C-----------------------------------------------
311 INTEGER VAL,TAG(*)
312 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
313C-----------------------------------------------
314C
315 DO WHILE (tag(val) == 0)
316 CALL hm_option_read_key(lsubmodel)
317 val=val+1
318 END DO
319C
320 RETURN
321 END SUBROUTINE hm_sz_r2r
322
323!||====================================================================
324!|| r2r_exist ../starter/source/coupling/rad2rad/routines_r2r.F
325!||--- called by ------------------------------------------------------
326!|| hm_read_thchecksum ../starter/source/output/th/hm_read_thchecksum.F90
327!|| hm_read_thgrki ../starter/source/output/th/hm_read_thgrki.F
328!|| hm_read_thgrki_rbody ../starter/source/output/th/hm_read_thgrki_rbody.F
329!|| hm_read_thgrpa ../starter/source/output/th/hm_read_thgrpa.F
330!|| hm_read_thgrpa_sub ../starter/source/output/th/hm_read_thgrpa.F
331!|| hm_read_thgrsens ../starter/source/output/th/hm_read_thgrsens.F
332!|| hm_read_thgrsurf ../starter/source/output/th/hm_read_thgrsurf.F
333!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
334!|| r2r_listcnt ../starter/source/coupling/rad2rad/routines_r2r.F
335!||--- calls -----------------------------------------------------
336!|| ancmsg ../starter/source/output/message/message.F
337!||--- uses -----------------------------------------------------
338!|| group_mod ../starter/share/modules1/group_mod.F
339!|| message_mod ../starter/share/message_module/message_mod.F
340!|| r2r_mod ../starter/share/modules1/r2r_mod.F
341!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
342!|| restmod ../starter/share/modules1/restart_mod.F
343!||====================================================================
344 INTEGER FUNCTION r2r_exist(TYP,ID)
345C-----------------------------------------------
346C M o d u l e s
347C-----------------------------------------------
348 USE r2r_mod
349 USE restmod
350 USE message_mod
351 USE groupdef_mod
352 USE group_mod
353 USE reader_old_mod , ONLY : kinter, nslash
354C-----------------------------------------------
355C I m p l i c i t T y p e s
356C-----------------------------------------------
357#include "implicit_f.inc"
358C-----------------------------------------------
359C C o m m o n B l o c k s
360C-----------------------------------------------
361#include "scr17_c.inc"
362#include "com04_c.inc"
363C-----------------------------------------------
364 INTEGER id,typ
365 INTEGER i,curs
366C--------------------------------------------------------
367C------ --> TH : check if corresponding option is kept---
368C--------------------------------------------------------
369
370 r2r_exist=0
371 curs = 0
372
373 IF (typ==107) THEN
374C-----------MONVOL------------------
375 DO i=1,nvolu
376 curs=curs+1
377 DO WHILE (tagmon(curs)==0)
378 curs=curs+1
379 END DO
380 IF (tagmon(curs)==id) r2r_exist=1
381 END DO
382 ELSEIF (typ==101) THEN
383C-----------INTER------------------
384 DO i=1,hm_ninter+nslash(kinter)
385 curs=curs+1
386 DO WHILE (tagint(curs)==0)
387 curs=curs+1
388 END DO
389 IF (tagint(curs)==id) r2r_exist=1
390 END DO
391 ELSEIF (typ==103) THEN
392C-----------RBY------------------
393 DO i=1,nrbody
394 curs=curs+1
395 DO WHILE (tagrby(curs)==0)
396 curs=curs+1
397 END DO
398 IF (tagrby(curs)==id) r2r_exist=1
399 END DO
400 ELSEIF (typ==105) THEN
401C-----------CYL_JOIN--------------
402 DO i=1,njoint
403 curs=curs+1
404 DO WHILE (tagcyl(curs)==0)
405 curs=curs+1
406 END DO
407 IF (tagcyl(curs)==id) r2r_exist=1
408 END DO
409 ELSEIF (typ==1001) THEN
410C-----------PART------------------
411 DO i=1,npart
412 IF (ipart(lipart1*(i-1)+4)==id) curs = i
413 END DO
414 IF (curs == 0) THEN
415 CALL ancmsg(msgid=258,
416 . msgtype=msgerror,
417 . anmode=aninfo_blind_1,
418 . c1="PART",
419 . i1=id)
420 ENDIF
421 IF (tag_part(curs)>0) r2r_exist=1
422 ELSEIF (typ==1002) THEN
423C-----------SUBSET------------------
424 DO i=1,nsubs
425 IF (subsets(i)%ID==id) curs = i
426 END DO
427 IF (curs == 0) THEN
428 CALL ancmsg(msgid=258,
429 . msgtype=msgerror,
430 . anmode=aninfo_blind_1,
431 . c1="SUBSET",
432 . i1=id)
433 ENDIF
434 r2r_exist=1
435 ELSEIF (typ==102) THEN
436C-----------RWALL-------------------
437 r2r_exist=1
438 ELSEIF (typ==104) THEN
439C-----------SECTION-----------------
440 DO i=1,nsect
441 curs=curs+1
442 DO WHILE (tagsec(curs)==0)
443 curs=curs+1
444 END DO
445 IF (tagsec(curs)==id) r2r_exist=1
446 END DO
447 ELSEIF (typ==108) THEN
448C-----------ACCELEROMETER-----------
449 r2r_exist=1
450 ELSEIF (typ==110) THEN
451C-----------FRAMES------------------
452 r2r_exist=1
453 ELSEIF (typ==113) THEN
454C-----------GAUGES------------------
455 DO i=1,nbgauge
456 curs=curs+1
457 DO WHILE (taggau(curs)==0)
458 curs=curs+1
459 END DO
460 IF (taggau(curs)==id) r2r_exist=1
461 END DO
462 ENDIF
463
464 RETURN
465 end function r2r_exist
466
467!||====================================================================
468!|| r2r_listcnt ../starter/source/coupling/rad2rad/routines_r2r.F
469!||--- called by ------------------------------------------------------
470!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
471!||--- calls -----------------------------------------------------
472!|| my_exit ../starter/source/output/analyse/analyse.c
473!|| r2r_exist ../starter/source/coupling/rad2rad/routines_r2r.F
474!||--- uses -----------------------------------------------------
475!|| format_mod ../starter/share/modules1/format_mod.F90
476!|| r2r_mod ../starter/share/modules1/r2r_mod.F
477!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
478!||====================================================================
479 INTEGER FUNCTION r2r_listcnt(NVAR,TYP)
480C-----------------------------------------------
481C M o d u l e s
482C-----------------------------------------------
483 USE r2r_mod
484 USE format_mod , ONLY : fmt_10i
485 USE reader_old_mod , ONLY : line, irec
486C-----------------------------------------------
487C I m p l i c i t T y p e s
488C-----------------------------------------------
489#include "implicit_f.inc"
490C-----------------------------------------------
491C C o m m o n B l o c k s
492C-----------------------------------------------
493#include "scr17_c.inc"
494#include "units_c.inc"
495C-----------------------------------------------
496 INTEGER nvar,typ
497C-----------------------------------------------
498C E x t e r n a l F u n c t i o n s
499C-----------------------------------------------
500 INTEGER r2r_exist
501C-----------------------------------------------
502 INTEGER i,jrec,j10(10),nvar_tmp
503C-----------------------------------------------------------
504C------ --> TH : re-count of nb of entities in TH groups----
505C-----------------------------------------------------------
506
507 r2r_listcnt=0
508 nvar=0
509 jrec=irec
510 jrec=jrec+1
511 READ(iin,rec=jrec,err=999,fmt='(A)')line
512 DO WHILE(line(1:1)/='/')
513 nvar_tmp = nvar
514 READ(line,err=999,fmt=fmt_10i) j10
515 DO i=1,10
516 IF(j10(i)/=0) THEN
517C-----------entity is counted if it is kept-------------------
518 IF (r2r_exist(typ,j10(i))==1) nvar=nvar+1
519C-------------------------------------------------------------
520 ENDIF
521 ENDDO
522 r2r_listcnt=r2r_listcnt+1
523 jrec=jrec+1
524 READ(iin,rec=jrec,err=999,fmt='(A)')line
525 ENDDO
526 RETURN
527 999 CALL freerr(1)
528 CALL my_exit(2)
529 end function r2r_listcnt
530
531C
532!||====================================================================
533!|| grsize_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
534!||--- called by ------------------------------------------------------
535!|| prelecsec ../starter/source/tools/sect/prelecsec.F
536!|| prelecsec4bolt ../starter/source/tools/sect/prelecsec4bolt.F
537!||--- uses -----------------------------------------------------
538!||====================================================================
539 INTEGER FUNCTION grsize_r2r(IGU,IGRELEM,GRLEN,TYP)
540C-----------------------------------------------
541C M o d u l e s
542C-----------------------------------------------
543 USE groupdef_mod
544C-----------------------------------------------
545C I m p l i c i t T y p e s
546C-----------------------------------------------
547#include "implicit_f.inc"
548C-----------------------------------------------
549C D u m m y A r g u m e n t s
550C-----------------------------------------------
551 INTEGER IGU,grlen,typ
552C-----------------------------------------------
553 TYPE (group_) , DIMENSION(GRLEN) :: igrelem
554C-----------------------------------------------
555C L o c a l V a r i a b l e s
556C-----------------------------------------------
557 INTEGER I,igs
558C-----------------------------------------------
559 grsize_r2r = 0
560 IF (igu > 0) THEN
561 DO i=1,grlen
562 IF (igu == igrelem(i)%ID) THEN
563 IF (typ == 8) THEN ! before split
564 grsize_r2r = igrelem(i)%R2R_ALL
565 ELSEIF (typ == 9) THEN ! shared
566 grsize_r2r = igrelem(i)%R2R_SHARE
567 ENDIF
568 igs = i
569 EXIT
570 ENDIF
571 ENDDO
572 ENDIF
573C-----------
574 RETURN
575 end function grsize_r2r
576
577!||====================================================================
578!|| r2r_sys2 ../starter/source/coupling/rad2rad/routines_r2r.F
579!||--- called by ------------------------------------------------------
580!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.F
581!||--- calls -----------------------------------------------------
582!|| ancmsg ../starter/source/output/message/message.F
583!||--- uses -----------------------------------------------------
584!|| message_mod ../starter/share/message_module/message_mod.F
585!||====================================================================
586 INTEGER FUNCTION r2r_sys2(IU,ITABM1,MESS)
587 USE message_mod
588C-----------------------------------------------
589C I m p l i c i t T y p e s
590C-----------------------------------------------
591#include "implicit_f.inc"
592C-----------------------------------------------
593C D u m m y A r g u m e n t s
594C-----------------------------------------------
595 INTEGER iu
596 CHARACTER mess*40
597 INTEGER itabm1(*)
598C-----------------------------------------------
599C C o m m o n B l o c k s
600C-----------------------------------------------
601#include "com04_c.inc"
602C-----------------------------------------------
603C L o c a l V a r i a b l e s
604C-----------------------------------------------
605 INTEGER jinf, jsup, j
606C-----------------------------------------------
607C-- Same routine as USR2SYS -> used to avoid infinite loop in R2R_SYS
608
609 jinf=1
610 jsup=numnod
611 j=max(1,numnod/2)
612 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
613 CALL ancmsg(msgid=78,
614 . msgtype=msgerror,
615 . anmode=aninfo,
616 . c1=mess,
617 . i1=iu)
618 r2r_sys2=0
619 RETURN
620 ENDIF
621 IF((iu-itabm1(j))==0)THEN
622C >IU=TABM - end of search
623 r2r_sys2=itabm1(j+numnod)
624 RETURN
625 ELSE IF (iu-itabm1(j)<0) THEN
626C >IU<TABM
627 jsup=j-1
628 ELSE
629C >IU>TABM
630 jinf=j+1
631 ENDIF
632 j=(jsup+jinf)/2
633 IF (j > 0) THEN
634 GO TO 10
635 ELSE
636 r2r_sys2=0
637 ENDIF
638 end function r2r_sys2
639
640!||====================================================================
641!|| r2r_nom_opt ../starter/source/coupling/rad2rad/routines_r2r.F
642!||--- called by ------------------------------------------------------
643!|| lectur ../starter/source/starter/lectur.F
644!||--- uses -----------------------------------------------------
645!|| r2r_mod ../starter/share/modules1/r2r_mod.F
646!|| submodel_mod ../starter/share/modules1/submodel_mod.F
647!||====================================================================
648 SUBROUTINE r2r_nom_opt(NOM_OPT,INOM_OPT,IN10,IN20,SNOM_OPT_OLD)
649C-----------------------------------------------
650C M o d u l e s
651C-----------------------------------------------
652 USE r2r_mod
653 USE submodel_mod , ONLY : nsubmod
654C-----------------------------------------------
655C I m p l i c i t T y p e s
656C-----------------------------------------------
657#include "implicit_f.inc"
658C-----------------------------------------------
659C C o m m o n B l o c k s
660C-----------------------------------------------
661#include "scr17_c.inc"
662#include "com04_c.inc"
663C-----------------------------------------------
664C D u m m y A r g u m e n t s
665C-----------------------------------------------
666 INTEGER NOM_OPT(*),INOM_OPT(*),IN10,IN20,SNOM_OPT_OLD
667C-----------------------------------------------
668C L o c a l V a r i a b l e s
669C-----------------------------------------------
670 INTEGER I
671C=======================================================================
672C-- Split of NOM_OPT
673
674 ALLOCATE (nom_opt_temp(snom_opt_old))
675 DO i=1,snom_opt_old
676 nom_opt_temp(i) = nom_opt(i)
677 nom_opt(i) = 0
678 ENDDO
679
680C--- FUNCTIONS / TABLES --
681 DO i=1,lnopt1*nfunct
682 nom_opt(lnopt1*inom_opt(20)+i)=nom_opt_temp(lnopt1*in20+i)
683 END DO
684C--- FRAMES --
685 DO i=1,lnopt1*(numskw+1+numfram+1+nsubmod)
686 nom_opt(lnopt1*inom_opt(10)+i)=nom_opt_temp(lnopt1*in10+i)
687 END DO
688
689 DEALLOCATE (nom_opt_temp)
690
691C-----------
692 RETURN
693 END SUBROUTINE r2r_nom_opt
694
695!||====================================================================
696!|| chk_flg_fsi ../starter/source/coupling/rad2rad/routines_r2r.F
697!||--- called by ------------------------------------------------------
698!|| r2r_group ../starter/source/coupling/rad2rad/r2r_group.F
699!||--- uses -----------------------------------------------------
700!|| r2r_mod ../starter/share/modules1/r2r_mod.F
701!||====================================================================
702 SUBROUTINE chk_flg_fsi(IXS,PM,IPARTS,ALE_EULER,IGEO)
703C-----------------------------------------------
704C M o d u l e s
705C-----------------------------------------------
706 USE r2r_mod
707 use element_mod , only : nixs
708C-----------------------------------------------
709C I m p l i c i t T y p e s
710C-----------------------------------------------
711#include "implicit_f.inc"
712C-----------------------------------------------
713C C o m m o n B l o c k s
714C-----------------------------------------------
715#include "com04_c.inc"
716#include "param_c.inc"
717#include "r2r_c.inc"
718#include "tabsiz_c.inc"
719C-----------------------------------------------
720C D u m m y A r g u m e n t s
721C-----------------------------------------------
722 INTEGER IXS(NIXS,SIXS/NIXS),IPARTS(*),ALE_EULER
723 INTEGER,INTENT(IN) :: IGEO(NPROPGI,NUMGEO)
724 my_real pm(npropm,nummat)
725C-----------------------------------------------
726C L o c a l V a r i a b l e s
727C-----------------------------------------------
728 INTEGER M,JALE,ID_PART,IMAT0,IPROP0,ELEM_VOID,JALE_FROM_MAT, JALE_FROM_PROP
729C-----------------------------------------------
730C S o u r c e L i n e s
731C-----------------------------------------------
732 flg_fsi = 0
733 ale_euler = 0
734 DO m=1,numels
735 id_part=iparts(m)
736C---------------id of the original material -----------C
737 imat0=ipart_r2r(1,id_part) !original mat_id
738 iprop0=ipart_r2r(4,id_part) !original prop_id
739 jale_from_mat = nint(pm(72,imat0))
740 jale_from_prop = igeo(62,iprop0)
741 jale= max(jale_from_mat, jale_from_prop)
742C
743 elem_void = 0
744 IF ((tagno(id_part)==0).AND.(tag_els(m)>0)) elem_void=1
745 IF ((jale > 0).AND.(tagno(id_part) > 0)) ale_euler = 1
746 IF ((jale == 0).OR.(elem_void == 0)) cycle
747 flg_fsi = 1
748 END DO
749C-------------------------------------------
750 RETURN
751 END SUBROUTINE chk_flg_fsi
752
753!||====================================================================
754!|| r2r_check_seg ../starter/source/coupling/rad2rad/routines_r2r.F
755!||--- called by ------------------------------------------------------
756!|| r2r_clean_inter ../starter/source/coupling/rad2rad/r2r_clean_inter.F
757!||--- uses -----------------------------------------------------
758!|| nod2el_mod ../starter/share/modules1/nod2el_mod.F
759!|| r2r_mod ../starter/share/modules1/r2r_mod.F
760!|| restmod ../starter/share/modules1/restart_mod.F
761!||====================================================================
762 SUBROUTINE r2r_check_seg(ELTAG,FACE,IPARTC,IPARTG,IPARTS,ISOLNOD)
763C-----------------------------------------------
764C M o d u l e s
765C-----------------------------------------------
766 USE restmod
767 USE nod2el_mod
768 USE r2r_mod
769 use element_mod , only : nixs,nixc,nixtg
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_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
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:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
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:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
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:66
chk_flg_fsi
subroutine chk_flg_fsi(ixs, pm, iparts, ale_euler, igeo)
Definition routines_r2r.F:703
nodgr_r2r
integer function nodgr_r2r(igu, igs, ibuf, igrnod, itabm1, mess)
Definition routines_r2r.F:173
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:299
sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:241
grsize_r2r
integer function grsize_r2r(igu, igrelem, grlen, typ)
Definition routines_r2r.F:540
r2r_sys2
integer function r2r_sys2(iu, itabm1, mess)
Definition routines_r2r.F:587
r2r_listcnt
integer function r2r_listcnt(nvar, typ)
Definition routines_r2r.F:480
r2r_check_seg
subroutine r2r_check_seg(eltag, face, ipartc, ipartg, iparts, isolnod)
Definition routines_r2r.F:763
r2r_exist
integer function r2r_exist(typ, id)
Definition routines_r2r.F:345
r2r_nin
integer function r2r_nin(iext, ntn, m, n)
Definition routines_r2r.F:136
r2r_nom_opt
subroutine r2r_nom_opt(nom_opt, inom_opt, in10, in20, snom_opt_old)
Definition routines_r2r.F:649
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
nextsla
subroutine nextsla
Definition freform.F:841
freerr
subroutine freerr(it)
Definition freform.F:501
groupdef_mod::group_
Definition groupdef_mod.F:706
submodel_mod::submodel_data
Definition submodel_mod.F:728