OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
lecsubmod.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine lecsubmod (isubmod, x, unitab, itabm1, rtrans, itab, lsubmodel, is_dyna, iskwn, liskn, skew, lskew, siskwn, sskew)

Function/Subroutine Documentation

◆ lecsubmod()

subroutine lecsubmod ( integer, dimension(*) isubmod,
x,
type (unit_type_), intent(in) unitab,
integer, dimension(*) itabm1,
rtrans,
integer, dimension(*) itab,
type(submodel_data), dimension(*) lsubmodel,
integer is_dyna,
integer, dimension(liskn,siskwn/liskn), intent(in) iskwn,
integer, intent(in) liskn,
dimension(lskew,sskew/lskew), intent(in) skew,
integer, intent(in) lskew,
integer, intent(in) siskwn,
integer, intent(in) sskew )

Definition at line 42 of file lecsubmod.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE unitab_mod
49 USE submodel_mod
50 USE message_mod
51 USE hm_option_read_mod
52 USE names_and_titles_mod , ONLY : nchartitle, ncharline, ncharkey, ncharfield
53 USE transform_translate_in_local_skew_mod, ONLY : transform_translate_in_local_skew
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "com04_c.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
66 INTEGER ITABM1(*),ISUBMOD(*),ITAB(*)
67 my_real
68 . x(3,*),rtrans(ntransf,*)
69 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
70 INTEGER IS_DYNA
71 INTEGER, INTENT(IN) :: LISKN,LSKEW,SISKWN,SSKEW
72 INTEGER, INTENT(IN) :: ISKWN(LISKN,SISKWN/LISKN)
73 my_real, INTENT(IN) :: skew(lskew,sskew/lskew)
74C-----------------------------------------------
75C L o c a l V a r i a b l e s
76C-----------------------------------------------
77 INTEGER I,J,ID,IDU,ISU,NTRANS,UID,
78 . ITRANSSUB,IDSUBOK(NSUBMOD),ISUBOK,IGU,I0,
79 . I1,N0,N1,IFLAGUNIT,IDNOD,NTAG,CTAG,INUM,SIDTRANS,
80 . IDSUB,ITY,K,
81 . CUR_SUBMOD,SUB_LEVEL,NUMNUSR,NUMNUSR2,ISK,CNT
82 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGNODSUB,NODESSUB ! NUMNOD
83 INTEGER :: WORK(70000)
84 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX,INDEX1,TAGNODSUB_TMP,IDNODSUB
85 CHARACTER(LEN=NCHARKEY) :: KEY
86 CHARACTER(LEN=NCHARLINE) ::CART,MESS
87 CHARACTER(LEN=NCHARTITLE) :: TITR
88 CHARACTER(LEN=NCHARFIELD) ::VERS_IN,STRING
89 my_real
90 . bid
91 my_real
92 . tx,ty,tz,angle,fac_l,x0(3),x1(3),rot(9),s,xp,yp,zp,
93 . xcold(3), xcnew(3), sx, sy, sz
94 DATA mess/'SUBMODEL DEFINITION '/
95 LOGICAL IS_AVAILABLE
96C-----------------------------------------------
97C E x t e r n a l F u n c t i o n s
98C-----------------------------------------------
99 INTEGER USRTOS
100 EXTERNAL usrtos
101C=======================================================================
102 ALLOCATE(tagnodsub(numnod))
103 isu = 0
104 is_available = .false.
105 uid = 0
106 tagnodsub = 0
107 numnusr = 0
108
109 ALLOCATE(nodessub(numnod))
110 nodessub = 0
111
112 IF(is_dyna /= 0)THEN
113 CALL cpp_nodes_count(numnusr,numnusr2)
114 ALLOCATE( index(2*numnusr))
115 DO i=1,2*numnusr
116 index(i)=i
117 ENDDO
118 ALLOCATE( index1(2*numnod) )
119 DO i=1,2*numnod
120 index1(i)=i
121 ENDDO
122 ALLOCATE( tagnodsub_tmp(numnusr) )
123 DO i=1,numnusr
124 tagnodsub_tmp(i)=i
125 ENDDO
126 ALLOCATE( idnodsub(numnusr) )
127 DO i=1,numnusr
128 idnodsub(i)=i
129 ENDDO
130 ENDIF
131C--------------------------------------------------
132C TAG SUBMODEL NODES DYNA
133C--------------------------------------------------
134 IF(is_dyna /= 0)THEN
135 CALL cpp_node_sub_tag_dyna(tagnodsub_tmp,idnodsub)
136
137C Considering that nodes with the same coordinated duplicated over multiple include files have the SAME USER ID
138C we have IDNODSUB(1:NUMNUSR) => 1:NUMNOD
139
140 CALL my_orders( 0, work, idnodsub, index, numnusr , 1)
141 CALL my_orders( 0, work, itab, index1, numnod , 1)
142
143 i = 1
144 j = 1
145 DO WHILE(j <= numnusr .AND. i <= numnod)
146C TAGNODSUB(1:NUMNOD) TAGNODSUB_TMP(1:NUMNUSR)
147 IF(itab(index1(i)) == idnodsub(index(j))) THEN
148 tagnodsub(index1(i)) = tagnodsub_tmp(index(j))
149 i = i + 1
150 j = j + 1
151 ELSE IF(itab(index1(i)) < idnodsub(index(j))) THEN
152 i = i + 1
153 ELSE
154 j = j + 1
155 ENDIF
156 ENDDO
157C--------------------------------------------------
158C TAG SUBMODEL NODES RADIOSS
159C--------------------------------------------------
160 ELSE
161 CALL cpp_node_sub_tag(tagnodsub)
162 ENDIF
163C-------------------------------------
164C Search for double IDs
165C-------------------------------------
166c CALL UDOUBLE(ISUBMOD,LSUBMOD,NSUBMOD,MESS,0,BID)
167C-------------------------
168c dim LSUBMODEL(I)%IDTRANS()
169C-------------------------
170 CALL hm_option_count('TRANSFORM',ntrans)
171 CALL hm_option_start('TRANSFORM')
172 DO i=1,ntrans
173 titr = ''
174 CALL hm_option_read_key(lsubmodel,
175 . option_id = id,
176 . unit_id = uid,
177 . option_titr = titr)
178
179 CALL hm_get_intv('SUBMODEL',itranssub,is_available,lsubmodel)
180
181 IF (itranssub /= 0) THEN
182 isubok = 0
183 DO j=1,nsubmod
184 IF (lsubmodel(j)%NOSUBMOD == itranssub) THEN
185 lsubmodel(j)%NBTRANS = lsubmodel(j)%NBTRANS + 1
186 EXIT
187 ENDIF
188 ENDDO
189 ENDIF
190 ENDDO
191 DO i=1,nsubmod
192 sidtrans = lsubmodel(i)%NBTRANS
193 ALLOCATE(lsubmodel(i)%IDTRANS(sidtrans))
194 lsubmodel(i)%IDTRANS = 0
195 ENDDO
196C----
197C-------------------------
198c build LSUBMODEL(I)%IDTRANS()
199C-------------------------
200 idsubok = 0
201 CALL hm_option_start('TRANSFORM')
202 DO i=1,ntrans
203 titr = ''
204 CALL hm_option_read_key(lsubmodel,
205 . option_id = id,
206 . unit_id = uid,
207 . option_titr = titr)
208C----
209 CALL hm_get_intv('SUBMODEL',itranssub,is_available,lsubmodel)
210 IF (itranssub /= 0) THEN
211 isubok = 0
212 DO j=1,nsubmod
213 IF (lsubmodel(j)%NOSUBMOD == itranssub) THEN
214 idsubok(j) = idsubok(j)+1
215 lsubmodel(j)%IDTRANS(idsubok(j)) = i
216 isubok = 1
217 EXIT
218 ENDIF
219 ENDDO
220 ENDIF
221 IF (itranssub /= 0 .AND. isubok == 0) THEN
222 CALL ancmsg(msgid=915,
223 . msgtype=msgerror,
224 . anmode=aninfo,
225 . i1=id,
226 . c1=titr,
227 . i2=itranssub)
228 ENDIF
229C----
230 ENDDO
231C-------------------------
232c MAKE TRANSFORMATION ON SUBMODEL NODES
233C-------------------------
234 DO i=1,nsubmod
235 cur_submod = i
236 sub_level = lsubmodel(i)%LEVEL
237 DO WHILE (sub_level /= 0)
238 IF (lsubmodel(cur_submod)%NBTRANS /= 0) THEN
239 DO j = 1,lsubmodel(cur_submod)%NBTRANS
240 ity = rtrans(lsubmodel(cur_submod)%IDTRANS(j),2)
241 IF(ity == 1)THEN
242 tx=rtrans(lsubmodel(cur_submod)%IDTRANS(j),15)
243 ty=rtrans(lsubmodel(cur_submod)%IDTRANS(j),16)
244 tz=rtrans(lsubmodel(cur_submod)%IDTRANS(j),17)
245 isk = int(rtrans(lsubmodel(cur_submod)%IDTRANS(j),23))
246 !DO K=1,NUMNOD
247 ! IF(TAGNODSUB(K) == I) THEN
248 ! X(1,K)=X(1,K)+TX
249 ! X(2,K)=X(2,K)+TY
250 ! X(3,K)=X(3,K)+TZ
251 ! ENDIF
252 !ENDDO
253 cnt = 0
254 DO k=1,numnod
255 IF(tagnodsub(k) == i) THEN
256 cnt = cnt + 1
257 nodessub(cnt) = k
258 ENDIF
259 ENDDO
260 CALL transform_translate_in_local_skew(
261 . nodessub ,cnt ,x ,numnod , isk ,
262 . tx ,ty ,tz ,skew , lskew,
263 . sskew )
264 ELSEIF(ity == 2)THEN
265 DO k=1,9
266 rot(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+2)
267 ENDDO
268 DO k=1,3
269 x0(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+11)
270 ENDDO
271
272 DO k=1,numnod
273 IF(tagnodsub(k) == i) CALL euler_vrot(x0,x(1,k),rot)
274 ENDDO
275 ELSEIF(ity == 3)THEN
276 tx = rtrans(lsubmodel(cur_submod)%IDTRANS(j),15)
277 ty = rtrans(lsubmodel(cur_submod)%IDTRANS(j),16)
278 tz = rtrans(lsubmodel(cur_submod)%IDTRANS(j),17)
279 DO k=1,9
280 rot(k) = rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+2)
281 ENDDO
282 DO k=1,numnod
283 IF(tagnodsub(k) == i) THEN
284 xp = rot(1)*x(1,k) + rot(4)*x(2,k) + rot(7)*x(3,k) + tx
285 yp = rot(2)*x(1,k) + rot(5)*x(2,k) + rot(8)*x(3,k) + ty
286 zp = rot(3)*x(1,k) + rot(6)*x(2,k) + rot(9)*x(3,k) + tz
287 x(1,k) = xp
288 x(2,k) = yp
289 x(3,k) = zp
290 ENDIF
291 ENDDO
292 ELSEIF(ity == 4)THEN
293 DO k=1,9
294 rot(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+2)
295 ENDDO
296 DO k=1,3
297 xcold(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+11)
298 ENDDO
299 DO k=1,3
300 xcnew(k) = rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+14)
301 ENDDO
302 DO k=1,numnod
303 IF(tagnodsub(k) == i) THEN
304 xp = x(1,k) - xcold(1)
305 yp = x(2,k) - xcold(2)
306 zp = x(3,k) - xcold(3)
307 x(1,k) = xcnew(1) + rot(1)*xp + rot(4)*yp + rot(7)*zp
308 x(2,k) = xcnew(2) + rot(2)*xp + rot(5)*yp + rot(8)*zp
309 x(3,k) = xcnew(3) + rot(3)*xp + rot(6)*yp + rot(9)*zp
310 END IF
311 ENDDO
312 ELSEIF(ity == 5)THEN
313 DO k=1,3
314 x0(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+11)
315 ENDDO
316 DO k=1,3
317 x1(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+14)
318 ENDDO
319 tx = x1(1) - x0(1)
320 ty = x1(2) - x0(2)
321 tz = x1(3) - x0(3)
322 s = one/max(sqrt(tx*tx + ty*ty + tz*tz),em20)
323 tx = tx*s
324 ty = ty*s
325 tz = tz*s
326 DO k=1,numnod
327 IF(tagnodsub(k) == i) THEN
328 sx = x(1,k) - x0(1)
329 sy = x(2,k) - x0(2)
330 sz = x(3,k) - x0(3)
331 s = sx*tx + sy*ty + sz*tz
332 x(1,k) = x(1,k) - two*tx*s
333 x(2,k) = x(2,k) - two*ty*s
334 x(3,k) = x(3,k) - two*tz*s
335 ENDIF
336 ENDDO
337 ELSEIF(ity == 6)THEN
338 sx = rtrans(lsubmodel(cur_submod)%IDTRANS(j),20)
339 sy = rtrans(lsubmodel(cur_submod)%IDTRANS(j),21)
340 sz = rtrans(lsubmodel(cur_submod)%IDTRANS(j),22)
341 DO k=1,3
342 x0(k)=rtrans(lsubmodel(cur_submod)%IDTRANS(j),k+11)
343 ENDDO
344 DO k=1,numnod
345 IF(tagnodsub(k) == i) THEN
346 x(1,k) = x0(1) + x(1,k) * sx
347 x(2,k) = x0(2) + x(2,k) * sy
348 x(3,k) = x0(3) + x(3,k) * sz
349 ENDIF
350 ENDDO
351 ENDIF
352 ENDDO
353 ENDIF
354 sub_level = sub_level - 1
355 cur_submod = lsubmodel(cur_submod)%IFATHER
356 ENDDO
357 ENDDO
358C-------------------------
359 IF(is_dyna /= 0)THEN
360 IF (ALLOCATED(index)) DEALLOCATE(index)
361 IF (ALLOCATED(index1)) DEALLOCATE(index1)
362 IF (ALLOCATED(tagnodsub_tmp)) DEALLOCATE(tagnodsub_tmp)
363 IF (ALLOCATED(idnodsub)) DEALLOCATE(idnodsub)
364 ENDIF
365 DEALLOCATE(tagnodsub)
366 IF(ALLOCATED(nodessub)) DEALLOCATE(nodessub)
367C-------------------------
368c MAKE TRANSFORMATION ON SUBMODEL NODES
369C-------------------------
370c IF (IPRI > 5) THEN
371c IF (ITRANSSUB > 0) WRITE (IOUT,100)
372c WRITE (IOUT,1000)
373c DO K=1,NUMNOD
374c WRITE(IOUT,1500) ITAB(K),X(1,K),X(2,K),X(3,K)
375c ENDDO
376c ENDIF
377C-------------------------
378c 100 FORMAT(//
379c .' NODAL TRANSFORMATIONS '/,
380c .' ---------------------- ')
381c 1000 FORMAT(/10X,'NEW NODE COORDINATES',14X,'X',24X,'Y',24X,'Z')
382c 1500 FORMAT( 17X,I10,3(5X,E20.13))
383 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
euler_vrot
subroutine euler_vrot(x0, x, rot)
Definition euler_vrot.F:35
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
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
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
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
names_and_titles_mod::ncharline
integer, parameter ncharline
Definition names_and_titles_mod.F:1006
submodel_mod
Definition submodel_mod.F:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
unitab_mod
Definition unitab_mod.F:517
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
usrtos
integer function usrtos(iu, itabm1)
Definition sysfus.F:240