OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_rlink.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!|| hm_read_link ../starter/source/constraints/rigidlink/hm_read_rlink.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.f
29!|| fretitl ../starter/source/starter/freform.F
30!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
31!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
32!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.f
33!|| kinset ../starter/source/constraints/general/kinset.F
34!|| ngr2usr ../starter/source/system/nintrr.F
35!|| sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
36!|| udouble ../starter/source/system/sysfus.F
37!|| usr2sys ../starter/source/system/sysfus.F
38!||--- uses -----------------------------------------------------
39!|| format_mod ../starter/share/modules1/format_mod.f90
40!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
41!|| message_mod ../starter/share/message_module/message_mod.F
42!|| r2r_mod ../starter/share/modules1/r2r_mod.F
43!|| submodel_mod ../starter/share/modules1/submodel_mod.F
44!||====================================================================
45 SUBROUTINE hm_read_link(NNLINK ,LLLINK ,ITAB ,ITABM1 ,IKINE ,
46 . IGRNOD ,ISKN ,IFRAME ,NOM_OPT ,LSUBMODEL )
47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE r2r_mod
51 USE message_mod
52 USE groupdef_mod
53 USE hm_option_read_mod
54 USE submodel_mod
55 USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
56 USE format_mod , ONLY : fmw_10i
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "com01_c.inc"
65#include "com04_c.inc"
66#include "units_c.inc"
67#include "scr03_c.inc"
68#include "scr17_c.inc"
69#include "param_c.inc"
70#include "r2r_c.inc"
71#include "sphcom.inc"
72C-----------------------------------------------
73C D u m m y A r g u m e n t s
74C-----------------------------------------------
75 INTEGER NNLINK(10,*), LLLINK(*), ITAB(*), ITABM1(*),
76 . ikine(*),iskn(liskn,*),iframe(liskn,*)
77 INTEGER NOM_OPT(LNOPT1,*)
78 TYPE(submodel_data) LSUBMODEL(*)
79C-----------------------------------------------
80 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER K, N, NSL, NUSER, J, I, IGU,IC,ICR,J10(10),
85 . igrs, nosys,j6(6),is,ipol,idir,isl,ikine1(3*numnod),nlk
86 CHARACTER MESS*40,CODE*7
87 CHARACTER(LEN=NCHARKEY) :: KEY
88 CHARACTER(LEN=NCHARTITLE) :: TITR
89 CHARACTER(LEN=NCHARFIELD) :: STRING
90 my_real bid
91C-----------------------------------------------
92C E x t e r n a l F u n c t i o n s
93C-----------------------------------------------
94 INTEGER USR2SYS, NGR2USR
95!
96 INTEGER, DIMENSION(:), POINTER :: INGR2USR
97C
98 DATA mess/'STANDARD RIGID LINK DEFINITION '/
99C-----------------------------------------------
100 LOGICAL IS_AVAILABLE
101C=======================================================================
102 is_available = .false.
103C-----------------------------------------------
104 nsl = 0
105 k=0
106 WRITE(iout,1000)
107 nlk = 0
108C
109C-----------------------------------------------
110 CALL hm_option_start('/RLINK')
111C-----------------------------------------------
112C
113 DO i=1,3*numnod
114 ikine1(i) = 0
115 ENDDO
116C
117 DO n=1,nlink
118C
119C LECTURE DES CARTES D'INPUT
120C
121 nlk=nlk+1
122C----------Multidomaines --> on ignore les rlink non tages--------
123 IF(nsubdom > 0)THEN
124 IF(taglnk(nlk) == 0)CALL sz_r2r(taglnk,nlk)
125 END IF
126C-----------------------------------------------------------------
127 CALL hm_option_read_key(lsubmodel,
128 . option_id = nuser,
129 . option_titr = titr)
130 nom_opt(1,n) = nuser
131 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
132!Tx, Ty, Tz, OmegaX, OmegaY, OmegaZ, SKEW_CSID, dependentnodeset, RLINK_IPOL);
133C--------------------read card-------------------------------------
134 CALL hm_get_intv('Tx' ,j6(1) ,is_available,lsubmodel)
135 CALL hm_get_intv('Ty' ,j6(2) ,is_available,lsubmodel)
136 CALL hm_get_intv('Tz' ,j6(3) ,is_available,lsubmodel)
137 CALL hm_get_intv('OmegaX' ,j6(4) ,is_available,lsubmodel)
138 CALL hm_get_intv('OmegaY' ,j6(5) ,is_available,lsubmodel)
139 CALL hm_get_intv('OmegaZ' ,j6(6) ,is_available,lsubmodel)
140
141 CALL hm_get_intv('SKEW_CSID' ,is ,is_available,lsubmodel)
142 CALL hm_get_intv('dependentnodeset' ,igu ,is_available,lsubmodel)
143 CALL hm_get_intv('RLINK_IPOL' ,ipol,is_available,lsubmodel)
144C-----------------------------------------------------------------
145 ic =j6(1)*4 +j6(2)*2 +j6(3)
146 icr=j6(4)*4 +j6(5)*2 +j6(6)
147 IF (icr > 0.AND.iroddl==0) THEN
148 CALL ancmsg(msgid=844,
149 . msgtype=msgwarning,
150 . anmode=aninfo_blind_1,
151 . i1=nuser,
152 . c1=titr)
153 END IF
154C------------------------------------------------------------------
155C RECHERCHE DES NOEUDS SECONDARY
156C------------------------------------------------------------------
157C GROUPE DE NOEUDS
158C------------------------------------------------------------------
159 nsl = 0
160 ingr2usr => igrnod(1:ngrnod)%ID
161 igrs=ngr2usr(igu,ingr2usr,ngrnod)
162 IF(igrs /= 0)THEN
163 DO j=1,igrnod(igrs)%NENTITY
164 nsl = nsl + 1
165 lllink(k+nsl)=igrnod(igrs)%ENTITY(j)
166 ENDDO
167 ENDIF
168
169C------------------------------------------------------------
170C Condition cinematique incompatible
171C------------------------------------------------------------
172 DO j=1,nsl
173 DO idir=1,6
174 CALL kinset(1024,itab(lllink(j+k)),ikine(lllink(j+k)),
175 . idir,0,ikine1(lllink(j+k)))
176 ENDDO
177 ENDDO
178C------------------------------------------------------------------
179C IMPRESSIONS
180C------------------------------------------------------------------
181 IF(ipol == 0)THEN
182 WRITE(iout,1100) nuser,trim(titr),j6,is,nsl
183 ELSE
184 WRITE(iout,1200) nuser,trim(titr),j6,is,nsl
185 ENDIF
186C
187 IF(ipri >= 1) THEN
188 WRITE(iout,'(/10X,A)')'SECONDARY NODES : '
189 WRITE(iout,fmt=fmw_10i) (itab(lllink(i+k)),i=1,nsl)
190 WRITE(iout,'(//)')
191 ENDIF
192 IF(ipol == 0)THEN
193 DO 640 j=0,numskw+min(1,nspcond)*numsph+nsubmod
194 IF(is == iskn(4,j+1)) THEN
195 is=j+1
196 GO TO 660
197 ENDIF
198 640 CONTINUE
199C
200 CALL ancmsg(msgid=184,
201 . msgtype=msgerror,
202 . anmode=aninfo,
203 . c1='RIGID LINK',
204 . i1=nuser,
205 . c2='RIGID LINK',
206 . c3=titr,
207 . i2=is)
208 660 CONTINUE
209 ELSE
210 DO j=0,numfram
211 IF(is==iframe(4,j+1)) THEN
212 is=j+1
213 GO TO 661
214 ENDIF
215 ENDDO
216 WRITE(istdo,*)' ** ERROR WRONG FRAME NUMBER'
217 WRITE(iout,*)' ** ERROR WRONG FRAME NUMBER'
218 ierr=ierr+1
219 661 CONTINUE
220 ENDIF
221 nnlink(1,n)=nsl
222 nnlink(2,n)=nuser
223 nnlink(3,n)=ic
224 nnlink(4,n)=icr
225 nnlink(5,n)=is
226 nnlink(6,n)=ipol
227C
228 k = k+nsl
229 ENDDO
230C-------------------------------------
231C Recherche des ID doubles
232C-------------------------------------
233 CALL udouble(nom_opt,lnopt1,nlink,mess,0,bid)
234 RETURN
235C
236 1000 FORMAT(
237 . ' RIGID LINK DEFINITIONS '/
238 . ' ---------------------- '/)
239 1100 FORMAT(/10x,'RIGID LINK NUMBER . . . .',i10,/,a,
240 . /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . ',3i1,2x,3i1
241 . /10x,'SKEW FRAME. . . . . . . .',i10
242 . /10x,'NUMBER OF NODES . . . . .',i10,//)
243 1200 FORMAT(/10x,'POLAR RIGID LINK NUMBER .',i10,/,a,
244 . /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . ',3i1,2x,3i1
245 . /10x,'POLAR FRAME . . . . . . .',i10
246 . /10x,'NUMBER OF NODES . . . . .',i10,//)
247 END
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_read_link
subroutine hm_read_link(nnlink, lllink, itab, itabm1, ikine, igrnod, iskn, iframe, nom_opt, lsubmodel)
Definition hm_read_rlink.F:47
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
min
#define min(a, b)
Definition macros.h:20
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
r2r_mod
Definition r2r_mod.F:125
r2r_mod::taglnk
integer, dimension(:), allocatable taglnk
Definition r2r_mod.F:138
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:242
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589
starter
program starter
Definition starter.F:39
submodel_mod::submodel_data
Definition submodel_mod.F:723