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

Go to the source code of this file.

Functions/Subroutines

subroutine modif_tag (tag, new_tag, modif)
integer function r2r_sys (iu, itabm1, mess)
integer function r2r_nin (iext, ntn, m, n)
integer function nodgr_r2r (igu, igs, ibuf, igrnod, itabm1, mess)
subroutine sz_r2r (tag, val)
subroutine hm_sz_r2r (tag, val, lsubmodel)
integer function r2r_exist (typ, id)
integer function r2r_listcnt (nvar, typ)
integer function grsize_r2r (igu, igrelem, grlen, typ)
integer function r2r_sys2 (iu, itabm1, mess)
subroutine r2r_nom_opt (nom_opt, inom_opt, in10, in20, snom_opt_old)
subroutine chk_flg_fsi (ixs, pm, iparts, ale_euler, igeo)
subroutine r2r_check_seg (eltag, face, ipartc, ipartg, iparts, isolnod)

Function/Subroutine Documentation

◆ chk_flg_fsi()

subroutine chk_flg_fsi ( integer, dimension(nixs,sixs/nixs) ixs,
pm,
integer, dimension(*) iparts,
integer ale_euler,
integer, dimension(npropgi,numgeo), intent(in) igeo )

Definition at line 704 of file routines_r2r.F.

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
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
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::ipart_r2r
integer, dimension(:,:), allocatable ipart_r2r
Definition r2r_mod.F:144

◆ grsize_r2r()

integer function grsize_r2r ( integer igu,
type (group_), dimension(grlen) igrelem,
integer grlen,
integer typ )

Definition at line 541 of file routines_r2r.F.

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
groupdef_mod
Definition groupdef_mod.F:662
grsize_r2r
integer function grsize_r2r(igu, igrelem, grlen, typ)
Definition routines_r2r.F:542

◆ hm_sz_r2r()

subroutine hm_sz_r2r ( integer, dimension(*) tag,
integer val,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 299 of file routines_r2r.F.

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
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
hm_option_read_mod
Definition hm_option_read_mod.F:408
submodel_mod
Definition submodel_mod.F:712

◆ modif_tag()

subroutine modif_tag ( integer tag,
integer new_tag,
integer modif )

Definition at line 30 of file routines_r2r.F.

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

◆ nodgr_r2r()

integer function nodgr_r2r ( integer igu,
integer igs,
integer, dimension(*) ibuf,
type (group_), dimension(ngrnod) igrnod,
integer, dimension(*) itabm1,
character mess )

Definition at line 172 of file routines_r2r.F.

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
message_mod
Definition message_mod.F:1249
nodgr_r2r
integer function nodgr_r2r(igu, igs, ibuf, igrnod, itabm1, mess)
Definition routines_r2r.F:174
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

◆ r2r_check_seg()

subroutine r2r_check_seg ( integer eltag,
integer, dimension(4) face,
integer, dimension(*) ipartc,
integer, dimension(*) ipartg,
integer, dimension(*) iparts,
integer, dimension(*) isolnod )

Definition at line 763 of file routines_r2r.F.

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
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
restmod::ixs
integer, dimension(:), allocatable, target ixs
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

◆ r2r_exist()

integer function r2r_exist ( integer typ,
integer id )

Definition at line 345 of file routines_r2r.F.

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
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
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::taggau
integer, dimension(:), allocatable taggau
Definition r2r_mod.F:142
r2r_mod::tagcyl
integer, dimension(:), allocatable tagcyl
Definition r2r_mod.F:137
restmod::ipart
integer, dimension(:), allocatable, target ipart
Definition restart_mod.F:60
r2r_exist
integer function r2r_exist(typ, id)
Definition routines_r2r.F:346

◆ r2r_listcnt()

integer function r2r_listcnt ( integer nvar,
integer typ )

Definition at line 481 of file routines_r2r.F.

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)
my_exit
void my_exit(int *i)
Definition analyse.c:1038
nvar
integer function nvar(text)
Definition nvar.F:32
r2r_listcnt
integer function r2r_listcnt(nvar, typ)
Definition routines_r2r.F:482
freerr
subroutine freerr(it)
Definition freform.F:506

◆ r2r_nin()

integer function r2r_nin ( integer iext,
integer, dimension(m,n) ntn,
integer m,
integer n )

Definition at line 136 of file routines_r2r.F.

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
r2r_nin
integer function r2r_nin(iext, ntn, m, n)
Definition routines_r2r.F:137

◆ r2r_nom_opt()

subroutine r2r_nom_opt ( integer, dimension(*) nom_opt,
integer, dimension(*) inom_opt,
integer in10,
integer in20,
integer snom_opt_old )

Definition at line 650 of file routines_r2r.F.

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
r2r_mod::nom_opt_temp
integer, dimension(:), allocatable nom_opt_temp
Definition r2r_mod.F:142
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720

◆ r2r_sys()

integer function r2r_sys ( integer iu,
integer, dimension(*), target itabm1,
character mess )

Definition at line 66 of file routines_r2r.F.

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
r2r_sys
integer function r2r_sys(iu, itabm1, mess)
Definition routines_r2r.F:67
r2r_sys2
integer function r2r_sys2(iu, itabm1, mess)
Definition routines_r2r.F:589

◆ r2r_sys2()

integer function r2r_sys2 ( integer iu,
integer, dimension(*) itabm1,
character mess )

Definition at line 588 of file routines_r2r.F.

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

◆ sz_r2r()

subroutine sz_r2r ( integer, dimension(*) tag,
integer val )

Definition at line 241 of file routines_r2r.F.

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
nextsla
subroutine nextsla
Definition freform.F:846