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!||--- uses -----------------------------------------------------
38!|| format_mod ../starter/share/modules1/format_mod.F90
39!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
40!|| message_mod ../starter/share/message_module/message_mod.F
41!|| r2r_mod ../starter/share/modules1/r2r_mod.F
42!|| submodel_mod ../starter/share/modules1/submodel_mod.F
43!||====================================================================
44 SUBROUTINE hm_read_link(NNLINK ,LLLINK ,ITAB ,ITABM1 ,IKINE ,
45 . IGRNOD ,ISKN ,IFRAME ,NOM_OPT ,LSUBMODEL )
46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE r2r_mod
50 USE message_mod
51 USE groupdef_mod
52 USE hm_option_read_mod
53 USE submodel_mod
54 USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
55 USE format_mod , ONLY : fmw_10i
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "com01_c.inc"
64#include "com04_c.inc"
65#include "units_c.inc"
66#include "scr03_c.inc"
67#include "scr17_c.inc"
68#include "param_c.inc"
69#include "r2r_c.inc"
70#include "sphcom.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER NNLINK(10,*), LLLINK(*), ITAB(*), ITABM1(*),
75 . ikine(*),iskn(liskn,*),iframe(liskn,*)
76 INTEGER NOM_OPT(LNOPT1,*)
77 TYPE(submodel_data) LSUBMODEL(*)
78C-----------------------------------------------
79 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
80C-----------------------------------------------
81C L o c a l V a r i a b l e s
82C-----------------------------------------------
83 INTEGER K, N, NSL, NUSER, J, I, IGU,IC,ICR,J10(10),
84 . igrs, nosys,j6(6),is,ipol,idir,isl,ikine1(3*numnod),nlk
85 CHARACTER MESS*40,CODE*7
86 CHARACTER(LEN=NCHARKEY) :: KEY
87 CHARACTER(LEN=NCHARTITLE) :: TITR
88 CHARACTER(LEN=NCHARFIELD) :: STRING
89 my_real bid
90C-----------------------------------------------
91C E x t e r n a l F u n c t i o n s
92C-----------------------------------------------
93 INTEGER NGR2USR
94!
95 INTEGER, DIMENSION(:), POINTER :: INGR2USR
96C
97 DATA mess/'STANDARD RIGID LINK DEFINITION '/
98C-----------------------------------------------
99 LOGICAL IS_AVAILABLE
100C=======================================================================
101 is_available = .false.
102C-----------------------------------------------
103 nsl = 0
104 k=0
105 WRITE(iout,1000)
106 nlk = 0
107C
108C-----------------------------------------------
109 CALL hm_option_start('/RLINK')
110C-----------------------------------------------
111C
112 DO i=1,3*numnod
113 ikine1(i) = 0
114 ENDDO
115C
116 DO n=1,nlink
117C
118C READING DES CARTES D'INPUT
119C
120 nlk=nlk+1
121C----------Multidomaines --> on ignore les rlink non tages--------
122 IF(nsubdom > 0)THEN
123 IF(taglnk(nlk) == 0)CALL sz_r2r(taglnk,nlk)
124 END IF
125C-----------------------------------------------------------------
126 CALL hm_option_read_key(lsubmodel,
127 . option_id = nuser,
128 . option_titr = titr)
129 nom_opt(1,n) = nuser
130 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
131!Tx, Ty, Tz, OmegaX, OmegaY, OmegaZ, SKEW_CSID, dependentnodeset, RLINK_IPOL);
132C--------------------read card-------------------------------------
133 CALL hm_get_intv('Tx' ,j6(1) ,is_available,lsubmodel)
134 CALL hm_get_intv('Ty' ,j6(2) ,is_available,lsubmodel)
135 CALL hm_get_intv('Tz' ,j6(3) ,is_available,lsubmodel)
136 CALL hm_get_intv('OmegaX' ,j6(4) ,is_available,lsubmodel)
137 CALL hm_get_intv('OmegaY' ,j6(5) ,is_available,lsubmodel)
138 CALL hm_get_intv('OmegaZ' ,j6(6) ,is_available,lsubmodel)
139
140 CALL hm_get_intv('SKEW_CSID' ,is ,is_available,lsubmodel)
141 CALL hm_get_intv('dependentnodeset' ,igu ,is_available,lsubmodel)
142 CALL hm_get_intv('RLINK_IPOL' ,ipol,is_available,lsubmodel)
143C-----------------------------------------------------------------
144 ic =j6(1)*4 +j6(2)*2 +j6(3)
145 icr=j6(4)*4 +j6(5)*2 +j6(6)
146 IF (icr > 0.AND.iroddl==0) THEN
147 CALL ancmsg(msgid=844,
148 . msgtype=msgwarning,
149 . anmode=aninfo_blind_1,
150 . i1=nuser,
151 . c1=titr)
152 END IF
153C------------------------------------------------------------------
154C SEARCH FOR SECONDARY NODES
155C------------------------------------------------------------------
156C NODE GROUP
157C------------------------------------------------------------------
158 nsl = 0
159 ingr2usr => igrnod(1:ngrnod)%ID
160 igrs=ngr2usr(igu,ingr2usr,ngrnod)
161 IF(igrs /= 0)THEN
162 DO j=1,igrnod(igrs)%NENTITY
163 nsl = nsl + 1
164 lllink(k+nsl)=igrnod(igrs)%ENTITY(j)
165 ENDDO
166 ENDIF
167
168C------------------------------------------------------------
169C Condition cinematique incompatible
170C------------------------------------------------------------
171 DO j=1,nsl
172 DO idir=1,6
173 CALL kinset(1024,itab(lllink(j+k)),ikine(lllink(j+k)),
174 . idir,0,ikine1(lllink(j+k)))
175 ENDDO
176 ENDDO
177C------------------------------------------------------------------
178C IMPRESSIONS
179C------------------------------------------------------------------
180 IF(ipol == 0)THEN
181 WRITE(iout,1100) nuser,trim(titr),j6,is,nsl
182 ELSE
183 WRITE(iout,1200) nuser,trim(titr),j6,is,nsl
184 ENDIF
185C
186 IF(ipri >= 1) THEN
187 WRITE(iout,'(/10X,A)')'SECONDARY NODES : '
188 WRITE(iout,fmt=fmw_10i) (itab(lllink(i+k)),i=1,nsl)
189 WRITE(iout,'(//)')
190 ENDIF
191 IF(ipol == 0)THEN
192 DO 640 j=0,numskw+min(1,nspcond)*numsph+nsubmod
193 IF(is == iskn(4,j+1)) THEN
194 is=j+1
195 GO TO 660
196 ENDIF
197 640 CONTINUE
198C
199 CALL ancmsg(msgid=184,
200 . msgtype=msgerror,
201 . anmode=aninfo,
202 . c1='RIGID LINK',
203 . i1=nuser,
204 . c2='RIGID LINK',
205 . c3=titr,
206 . i2=is)
207 660 CONTINUE
208 ELSE
209 DO j=0,numfram
210 IF(is==iframe(4,j+1)) THEN
211 is=j+1
212 GO TO 661
213 ENDIF
214 ENDDO
215 WRITE(istdo,*)' ** ERROR WRONG FRAME NUMBER'
216 WRITE(iout,*)' ** ERROR WRONG FRAME NUMBER'
217 ierr=ierr+1
218 661 CONTINUE
219 ENDIF
220 nnlink(1,n)=nsl
221 nnlink(2,n)=nuser
222 nnlink(3,n)=ic
223 nnlink(4,n)=icr
224 nnlink(5,n)=is
225 nnlink(6,n)=ipol
226C
227 k = k+nsl
228 ENDDO
229C-------------------------------------
230C Search for double IDs
231C-------------------------------------
232 CALL udouble(nom_opt,lnopt1,nlink,mess,0,bid)
233 RETURN
234C
235 1000 FORMAT(
236 . ' RIGID LINK DEFINITIONS '/
237 . ' ---------------------- '/)
238 1100 FORMAT(/10x,'RIGID LINK NUMBER . . . .',i10,/,a,
239 . /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . ',3i1,2x,3i1
240 . /10x,'SKEW FRAME. . . . . . . .',i10
241 . /10x,'NUMBER OF NODES . . . . .',i10,//)
242 1200 FORMAT(/10x,'POLAR RIGID LINK NUMBER .',i10,/,a,
243 . /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . ',3i1,2x,3i1
244 . /10x,'POLAR FRAME . . . . . . .',i10
245 . /10x,'NUMBER OF NODES . . . . .',i10,//)
246 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:528
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_read_link
subroutine hm_read_link(nnlink, lllink, itab, itabm1, ikine, igrnod, iskn, iframe, nom_opt, lsubmodel)
Definition hm_read_rlink.F:46
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
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:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
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:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:241
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:573
submodel_mod::submodel_data
Definition submodel_mod.F:728