OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
read_impvel_lagmul.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!|| read_impvel_lagmul ../starter/source/constraints/general/impvel/read_impvel_lagmul.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_impvel ../starter/source/constraints/general/impvel/hm_read_impvel.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl ../starter/source/starter/freform.F
30!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
31!|| hm_get_floatv_dim ../starter/source/devtools/hm_reader/hm_get_floatv_dim.F
32!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
33!|| hm_get_string ../starter/source/devtools/hm_reader/hm_get_string.F
34!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.f
35!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
36!|| kinset ../starter/source/constraints/general/kinset.F
37!|| nodgrnr5 ../starter/source/starter/freform.F
38!|| usr2sys ../starter/source/system/sysfus.F
39!||--- uses -----------------------------------------------------
40!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
41!|| message_mod ../starter/share/message_module/message_mod.F
42!|| submodel_mod ../starter/share/modules1/submodel_mod.F
43!||====================================================================
44 SUBROUTINE read_impvel_lagmul(
45 . NLAGMUL ,INUM ,IOPT ,FBFVEL ,IBFVEL ,
46 . ITAB ,ITABM1 ,IGRNOD ,NOM_OPT ,X0 ,
47 . IXR ,IPART ,IPARTR ,ISKN ,IKINE ,
48 . UNITAB ,LSUBMODEL )
49C============================================================================
50C M o d u l e s
51C-----------------------------------------------
52 USE message_mod
53 USE groupdef_mod
54 USE submodel_mod
55 USE hm_option_read_mod
56 USE unitab_mod
57 USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C C o m m o n B l o c k s
64C-----------------------------------------------
65#include "sphcom.inc"
66#include "lagmult.inc"
67#include "com04_c.inc"
68#include "scr17_c.inc"
69#include "param_c.inc"
70#include "units_c.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER ,INTENT(IN ) :: NLAGMUL
75 INTEGER ,INTENT(INOUT) :: INUM,IOPT
76 INTEGER ,DIMENSION(*) :: ITAB,ITABM1,IPARTR,IKINE
77 INTEGER ,DIMENSION(LIPART1,*) :: IPART
78 INTEGER ,DIMENSION(NIXR,*) :: IXR
79 INTEGER ,DIMENSION(NIFV,NFXVEL) :: IBFVEL
80 INTEGER ,DIMENSION(LISKN,*),INTENT(IN) :: ISKN
81 INTEGER ,DIMENSION(LNOPT1,*) ,INTENT(OUT) :: NOM_OPT
82 my_real ,DIMENSION(LFXVELR,NFXVEL) :: fbfvel
83 my_real ,DIMENSION(3,NUMNOD) ,INTENT(IN):: x0
84 TYPE (UNIT_TYPE_) ,INTENT(IN) :: UNITAB
85 TYPE (group_) ,DIMENSION(NGRNOD) ,INTENT(IN) :: igrnod
86 TYPE(submodel_data),DIMENSION(*) ,INTENT(IN) :: LSUBMODEL
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90 INTEGER I,J,K,N,N1,N2,NOD,NUM0,ILAGMUL,IUN,JPART,NNOD,NOFRAME,INOD,NOSKEW,
91 . SENS_ID,PART_ID,OPTID,UID,FCT1_ID,FCT2_ID,ILAGM,GRNOD_ID,IGS,LEN,
92 . LAGMUL,IDIS,ICOOR,DISTRIBUTION,SKEW_ID
93 INTEGER ,DIMENSION(NUMNOD) :: NOD1,NOD2,NWORK
94 INTEGER ,DIMENSION(3*NUMNOD) :: IKINE1
95 my_real :: XSCALE,YSCALE,FSCAL_T,FSCAL_V,T0,DMIN,DIST,
96 . XI,YI,ZI,XF,YF,ZF,TSTART,TSTOP
97 CHARACTER(LEN=NCHARKEY) :: KEY
98 CHARACTER(LEN=NCHARFIELD) :: XYZ
99 CHARACTER(LEN=NCHARTITLE) :: TITR,MESS
100 CHARACTER(LEN=2) :: X,Y,Z,XX,YY,ZZ
101 LOGICAL IS_AVAILABLE
102C-----------------------------------------------
103C E x t e r n a l F u n c t i o n s
104C-----------------------------------------------
105 INTEGER NODGRNR5,USR2SYS
106 EXTERNAL NODGRNR5,USR2SYS
107C-----------------------------------------------
108C D a t a
109C-----------------------------------------------
110 DATA x /'X'/
111 DATA y /'Y'/
112 DATA z /'Z'/
113 DATA xx /'XX'/
114 DATA yy /'YY'/
115 DATA zz /'ZZ'/
116
117 DATA iun/1/
118 DATA mess/'IMPOSED VELOCITY DEFINITION '/
119C======================================================================|
120 is_available = .false.
121
122 num0 = inum+1
123c
124 ikine1(:) = 0
125c--------------------------------------------------
126c
127 CALL hm_option_start('/impvel/lagmul')
128c
129c--------------------------------------------------
130 DO ILAGMUL = 1,NLAGMUL
131c--------------------------------------------------
132 CALL HM_OPTION_READ_KEY(LSUBMODEL,
133 . OPTION_ID = OPTID,
134 . UNIT_ID = UID,
135 . OPTION_TITR = TITR,
136 . KEYWORD2 = KEY)
137c
138 IOPT = IOPT + 1
139 NOM_OPT(1,IOPT) = OPTID
140 CALL FRETITL(TITR,NOM_OPT(LNOPT1-LTITR+1,IOPT),LTITR)
141c
142c--------------------------------------------------
143 ICOOR = 0
144 IDIS = 1
145 ILAGM = 1
146 NOFRAME = 0
147 SENS_ID = 0
148 LEN = 1
149 TSTART = ZERO
150 TSTOP = INFINITY
151c--------------------------------------------------
152c READ STRING VALUES from /IMPVEL/LAGMUL
153c--------------------------------------------------
154 CALL HM_GET_INTV ('curveid' ,FCT1_ID,IS_AVAILABLE,LSUBMODEL)
155 CALL HM_GET_STRING('rad_dir' ,XYZ ,ncharfield,IS_AVAILABLE)
156 CALL HM_GET_INTV ('inputsystem' ,SKEW_ID,IS_AVAILABLE,LSUBMODEL)
157 CALL HM_GET_INTV ('entityid' ,GRNOD_ID ,IS_AVAILABLE,LSUBMODEL)
158c
159 CALL HM_GET_FLOATV('xscale' ,XSCALE ,IS_AVAILABLE,LSUBMODEL,UNITAB)
160 CALL HM_GET_FLOATV('magnitude' ,YSCALE ,IS_AVAILABLE,LSUBMODEL,UNITAB)
161c--------------------------------------------------
162c
163c--------------------------------------------------
164 DO J=0,NUMSKW+MIN(1,NSPCOND)*NUMSPH+NSUBMOD
165 IF (SKEW_ID == ISKN(4,J+1)) THEN
166 NOSKEW = J+1
167 EXIT
168 ENDIF
169 ENDDO
170.and. IF (SKEW_ID > 0 NOSKEW == 0)
171 . CALL ANCMSG(MSGID=137,ANMODE=ANINFO,MSGTYPE=MSGERROR,
172 . I1= OPTID,
173 . I2= SKEW_ID,
174 . C1='imposed velocity',
175 . C2='imposed velocity',
176 . C3= TITR)
177
178
179c--------------------------------------------------
180 IF (XSCALE == ZERO) THEN
181 CALL HM_GET_FLOATV_DIM('xscale' ,FSCAL_T ,IS_AVAILABLE,LSUBMODEL,UNITAB)
182 XSCALE = FSCAL_T
183 ENDIF
184 IF (YSCALE == ZERO) THEN
185 CALL HM_GET_FLOATV_DIM('magnitude' ,fscal_v ,is_available,lsubmodel,unitab)
186 yscale = fscal_v
187 ENDIF
188c
189 IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
190 len = 2
191 ENDIF
192 WRITE (iout,1000)
193c Read NODE numbers from the group
194 nnod = nodgrnr5(grnod_id ,igs ,nwork,igrnod ,itabm1 ,mess )
195
196
197 nfvlag = nfvlag+nnod
198 lag_ncf = lag_ncf + nnod
199 lag_nhf = lag_nhf + nnod
200 IF(noskew == 0) THEN
201 lag_nkf = lag_nkf + nnod
202 ELSE
203 lag_nkf = lag_nkf + nnod*3
204 ENDIF
205c--------------------------------------------------
206c Treatment of explicitly defined nodes
207c--------------------------------------------------
208 DO j=1,nnod
209 inum = inum + 1
210 inod = iabs(nwork(j))
211 nod = itab(inod)
212c
213 ibfvel(1 ,inum) = nwork(j)
214 ibfvel(2 ,inum) = 0
215 ibfvel(3 ,inum) = fct1_id
216 ibfvel(4 ,inum) = sens_id
217 ibfvel(5 ,inum) = 0
218 ibfvel(6 ,inum) = 0
219 ibfvel(7 ,inum) = idis
220 ibfvel(8 ,inum) = ilagm
221 ibfvel(9 ,inum) = noframe
222 ibfvel(10,inum) = icoor
223 ibfvel(11,inum) = 0
224 ibfvel(12,inum) = iopt
225 ibfvel(13,inum) = 0
226 ibfvel(14,inum) = 0
227c
228
229c
230 fbfvel(1,inum) = yscale
231 fbfvel(2,inum) = tstart
232 fbfvel(3,inum) = tstop
233 fbfvel(4,inum) = zero
234 fbfvel(5,inum) = one/xscale
235 fbfvel(6,inum) = zero
236
237 IF(xyz(1:2) == xx)THEN
238 ibfvel(2,inum) = 4 + noskew*10
239 CALL kinset(16,nod,ikine(inod),4,noskew,ikine1(inod))
240 ELSEIF(xyz(1:2) == yy)THEN
241 ibfvel(2,inum) = 5 + noskew*10
242 CALL kinset(16,nod,ikine(inod),5,noskew,ikine1(inod))
243 ELSEIF(xyz(1:2) == zz)THEN
244 ibfvel(2,inum) = 6 + noskew*10
245 CALL kinset(16,nod,ikine(inod),6,noskew,ikine1(inod))
246 ELSEIF (xyz(1:1) == x)THEN
247 ibfvel(2,inum)=1 + noskew*10
248 CALL kinset(16,nod,ikine(inod),1,noskew,ikine1(inod))
249 ELSEIF(xyz(1:1) == y)THEN
250 ibfvel(2,inum) = 2 + noskew*10
251 CALL kinset(16,nod,ikine(inod),2,noskew,ikine1(inod))
252 ELSEIF(xyz(1:1) == z)THEN
253 ibfvel(2,inum) = 3 + noskew*10
254 CALL kinset(16,nod,ikine(inod),3,noskew,ikine1(inod))
255 ELSE
256 CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
257 . i1=optid,
258 . c1=titr,
259 . c2=xyz)
260 ENDIF
261c
262
263 WRITE (iout,4000) nod,iskn(4,noskew),0,xyz(1:len),fct1_id,sens_id,
264 . yscale,xscale,tstart,tstop,0
265 END DO
266c-----------
267 END DO !
268c----------------------------------------------------------------------
269 1000 FORMAT(//
270 .' IMPOSED VELOCITIES BY LAGRANGE MULTIPLIERS'/
271 .' ------------------------------------------'/
272 .' NODE SKEW FRAME DIRECTION LOAD_CURVE',
273 .' SENSOR FSCALE ASCALE')
274
275 4000 FORMAT(3x,i10,3x,i10,3x,i10,9x,a2,3x,i10,3x,i10,
276 . 2x,1pg20.13,2x,1pg20.13,2x,g20.13,2x,g20.13,16x,i10)
277c----------------------------------------------------------------------
278 RETURN
279 END
my_real
#define my_real
Definition cppsort.cpp:32
hm_option_read_key
subroutine hm_option_read_key(lsubmodel, option_id, unit_id, submodel_index, submodel_id, option_titr, keyword1, keyword2, keyword3, keyword4, opt_pos)
Definition hm_option_read_key.F:249
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
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
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
read_impvel_lagmul
subroutine read_impvel_lagmul(nlagmul, inum, iopt, fbfvel, ibfvel, itab, itabm1, igrnod, nom_opt, x0, ixr, ipart, ipartr, iskn, ikine, unitab, lsubmodel)
Definition read_impvel_lagmul.F:49
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
starter
program starter
Definition starter.F:39
groupdef_mod::group_
Definition groupdef_mod.F:700
submodel_mod::submodel_data
Definition submodel_mod.F:723