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)

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 )

Definition at line 40 of file lecsubmod.F.

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