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

Go to the source code of this file.

Functions/Subroutines

subroutine lectranssub (x, igrnod, itab, itabm1, unitab, rtrans, lsubmodel, is_dyna)

Function/Subroutine Documentation

◆ lectranssub()

subroutine lectranssub ( x,
type (group_), dimension(ngrnod), target igrnod,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
type (unit_type_), intent(in) unitab,
rtrans,
type(submodel_data), dimension(*) lsubmodel,
integer is_dyna )

Definition at line 44 of file lectranssub.F.

46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE unitab_mod
50 USE message_mod
51 USE groupdef_mod
52 USE submodel_mod
53 USE hm_option_read_mod
54 USE names_and_titles_mod , ONLY : nchartitle, ncharline, ncharfield
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "com04_c.inc"
63#include "units_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
68 INTEGER ITAB(*),ITABM1(*)
69 my_real
70 . x(3,*),rtrans(ntransf,*)
71 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
72 INTEGER IS_DYNA
73C-----------------------------------------------
74 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER I,I0,I1,I2,I3,I4,I5,I6,
79 . N0,N1,N2,N3,N4,N5,N6,IERROR,
80 . J,IS,ID,UID,IGU,IGS,NN,NTRANS,STAT,ITRANSSUB,IBID,
81 . NTAG,CTAG,ISU,IDU,IDNOD,
82 . INUM,K,CPT,ID_TRANSSUB,NUMNUSR
83 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGNODSUB !NUMNOD
84 INTEGER :: WORK(70000)
85 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX,INDEX1,TAGNODSUB_TMP,IDNODSUB
86!! INTEGER, ALLOCATABLE, DIMENSION(:) :: ITG
87 my_real
88 . lx,ly,lz,tx,ty,tz,r,s,rx,ry,rz,sx,sy,sz,angle,at,fac_l
89 my_real
90 . vr(3),x0(3),x1(3),x2(3),x3(3),x4(3),x5(3),x6(3),
91 . rot(9),pp(3,3),qq(3,3),p(3),norm1, norm2, norm3, scal1,
92 . scal2, scal3, eps,xc(3)
93 CHARACTER KEY*10
94 CHARACTER(LEN=NCHARLINE) ::CART,SOLVERKEYWORD
95 CHARACTER(LEN=NCHARTITLE) :: TITR
96 CHARACTER(LEN=NCHARFIELD) ::VERS_IN,STRING
97!
98 INTEGER, DIMENSION(:), POINTER :: INGR2USR
99 LOGICAL IS_AVAILABLE
100C-----------------------------------------------
101C E x t e r n a l F u n c t i o n s
102C-----------------------------------------------
103 INTEGER NGR2USR,USRTOS
104 EXTERNAL ngr2usr,usrtos
105C=======================================================================
106 ALLOCATE(tagnodsub(numnod))
107 isu = 0
108 tagnodsub = 0
109 numnusr = 0
110
111 IF(is_dyna /= 0)THEN
112 CALL cpp_node_count(numnusr)
113 ALLOCATE( index(2*numnusr) )
114 DO i=1,2*numnusr
115 index(i)=i
116 ENDDO
117 ALLOCATE( index1(2*numnod) )
118 DO i=1,2*numnod
119 index1(i)=i
120 ENDDO
121 ALLOCATE( tagnodsub_tmp(numnusr) )
122 DO i=1,numnusr
123 tagnodsub_tmp(i)=i
124 ENDDO
125 ALLOCATE( idnodsub(numnusr) )
126 DO i=1,numnusr
127 idnodsub(i)=i
128 ENDDO
129 ENDIF
130
131 fac_l = one
132 is_available = .false.
133C--------------------------------------------------
134C TAG SUBMODEL NODES DYNA
135C--------------------------------------------------
136 IF(is_dyna /= 0)THEN
137 CALL cpp_node_sub_tag_dyna(tagnodsub_tmp,idnodsub)
138
139 CALL my_orders( 0, work, idnodsub, index, numnusr , 1)
140 CALL my_orders( 0, work, itab, index1, numnod , 1)
141
142 DO i=1,numnusr
143 tagnodsub(index1(i)) = tagnodsub_tmp(index(i))
144 ENDDO
145C--------------------------------------------------
146C TAG SUBMODEL NODES RADIOSS
147C--------------------------------------------------
148 ELSE
149 CALL cpp_node_sub_tag(tagnodsub)
150 ENDIF
151C--------------------------------------------------
152C COUNT NUMBER TRANSFORM OPTIONS
153C--------------------------------------------------
154 CALL hm_option_count('TRANSFORM',ntrans)
155C--------------------------------------------------
156 IF (ntrans > 0) WRITE (iout,100)
157C--------------------------------------------------
158C START READING TRANSFORM OPTIONS
159C--------------------------------------------------
160 CALL hm_option_start('TRANSFORM')
161C--------------------------------------------------
162C BROWSING MODEL TRANSFORM 1->NTRANS
163C--------------------------------------------------
164 DO i=1,ntrans
165C--------------------------------------------------
166C EXTRACT DATAS OF /TRANSFORM/... LINE
167C--------------------------------------------------
168 CALL hm_option_read_key(lsubmodel,
169 . option_id = id,
170 . unit_id = uid,
171 . option_titr = titr,
172 . keyword2 = key)
173 rtrans(i,19) = id
174C--------------------------------------------------
175 CALL hm_get_intv('GR_NODE',igu,is_available,lsubmodel)
176 CALL hm_get_intv('SUBMODEL',id_transsub,is_available,lsubmodel)
177c---------------------
178 itranssub = 0
179 IF(id_transsub/=0)THEN
180 DO j=1,nsubmod
181 IF (lsubmodel(j)%NOSUBMOD == id_transsub) THEN
182 itranssub = j
183 EXIT
184 ENDIF
185 ENDDO
186 IF(itranssub==0)THEN
187 CALL ancmsg(msgid=1824,
188 . msgtype=msgerror,
189 . anmode=aninfo,
190 . i1=id,
191 . c1=titr)
192 END IF
193 END IF
194 rtrans(i,1) = itranssub
195c---------------------
196 IF(igu /= 0 .AND. id_transsub /= 0) THEN
197 CALL ancmsg(msgid=914,
198 . msgtype=msgerror,
199 . anmode=aninfo,
200 . i1=id,
201 . c1=titr)
202 ENDIF
203c---------------------
204 IF (itranssub == 0) cycle
205c---------------------
206 rtrans(i,1) = itranssub
207 IF (key(1:3) == 'TRA') THEN
208C
209 rtrans(i,2) = 1
210C
211 CALL hm_get_intv('node1',n0,is_available,lsubmodel)
212 CALL hm_get_intv('node2',n1,is_available,lsubmodel)
213C
214 CALL hm_get_floatv('translation_x',tx,is_available,lsubmodel,unitab)
215 CALL hm_get_floatv('translation_y',ty,is_available,lsubmodel,unitab)
216 CALL hm_get_floatv('translation_z',tz,is_available,lsubmodel,unitab)
217c
218 IF (n0 > 0 .OR. n1 > 0) THEN
219 i0 = usrtos(n0,itabm1)
220 i1 = usrtos(n1,itabm1)
221 IF (i0 == 0) THEN
222 CALL ancmsg(msgid=694,
223 . msgtype=msgerror,
224 . anmode=aninfo,
225 . i1=id,
226 . c1=titr,
227 . i2=n0)
228 END IF
229 IF (i1 == 0) THEN
230 CALL ancmsg(msgid=694,
231 . msgtype=msgerror,
232 . anmode=aninfo,
233 . i1=id,
234 . c1=titr,
235 . i2=n1)
236 END IF
237C
238C TRANSFORMATION OF COORDS OF NODES N0 & N1
239 IF(tagnodsub(i0) == itranssub) THEN
240 DO j=1,i-1
241 IF(rtrans(j,1) == itranssub) CALL rtranspos(x0,j,rtrans)
242 END DO
243 END IF
244 IF(tagnodsub(i1) == itranssub) THEN
245 DO j=1,i-1
246 IF(rtrans(j,1) == itranssub) CALL rtranspos(x1,j,rtrans)
247 END DO
248 END IF
249 tx = x1(1) - x0(1)
250 ty = x1(2) - x0(2)
251 tz = x1(3) - x0(3)
252 ELSE
253 tx = tx * fac_l
254 ty = ty * fac_l
255 tz = tz * fac_l
256 ENDIF
257 rtrans(i,15) = tx
258 rtrans(i,16) = ty
259 rtrans(i,17) = tz
260 s = sqrt(tx*tx + ty*ty + tz*tz)
261C
262 rot(1:9)=zero
263 rot(1) = one
264 rot(5) = one
265 rot(9) = one
266C
267 WRITE(iout,500) id,id_transsub
268 IF (n0 > 0 .AND. n1 > 0) WRITE(iout,200) n0,n1
269 WRITE(iout,510) s,tx,ty,tz
270C----
271 ELSEIF (key(1:3) == 'ROT') THEN
272C
273 rtrans(i,2) = 2
274C
275 CALL hm_get_intv('node1',n0,is_available,lsubmodel)
276 CALL hm_get_intv('node2',n1,is_available,lsubmodel)
277C
278 CALL hm_get_floatv('rotation_point1_x',x0(1),is_available,lsubmodel,unitab)
279 CALL hm_get_floatv('rotation_point1_y',x0(2),is_available,lsubmodel,unitab)
280 CALL hm_get_floatv('rotation_point1_z',x0(3),is_available,lsubmodel,unitab)
281 CALL hm_get_floatv('rotation_point2_x',x1(1),is_available,lsubmodel,unitab)
282 CALL hm_get_floatv('rotation_point2_y',x1(2),is_available,lsubmodel,unitab)
283 CALL hm_get_floatv('rotation_point2_z',x1(3),is_available,lsubmodel,unitab)
284 CALL hm_get_floatv('rotation_angle',angle,is_available,lsubmodel,unitab)
285c---------------------
286 IF (n0 > 0 .OR. n1 > 0) THEN
287 i0 = usrtos(n0,itabm1)
288 i1 = usrtos(n1,itabm1)
289 IF (i0 == 0) THEN
290 CALL ancmsg(msgid=694,
291 . msgtype=msgerror,
292 . anmode=aninfo,
293 . i1=id,
294 . c1=titr,
295 . i2=n0)
296 END IF
297 IF (i1 == 0) THEN
298 CALL ancmsg(msgid=694,
299 . msgtype=msgerror,
300 . anmode=aninfo,
301 . i1=id,
302 . c1=titr,
303 . i2=n1)
304 END IF
305 x0(1) = x(1,i0)
306 x0(2) = x(2,i0)
307 x0(3) = x(3,i0)
308 x1(1) = x(1,i1)
309 x1(2) = x(2,i1)
310 x1(3) = x(3,i1)
311C
312C TRANSFORMATION OF COORDS OF NODES N0 & N1
313 IF(tagnodsub(i0) == itranssub) THEN
314 DO j=1,i-1
315 IF(rtrans(j,1) == itranssub) CALL rtranspos(x0,j,rtrans)
316 END DO
317 END IF
318 IF(tagnodsub(i1) == itranssub) THEN
319 DO j=1,i-1
320 IF(rtrans(j,1) == itranssub) CALL rtranspos(x1,j,rtrans)
321 END DO
322 END IF
323c
324 ELSE
325 x0(1) = x0(1) * fac_l
326 x0(2) = x0(2) * fac_l
327 x0(3) = x0(3) * fac_l
328 x1(1) = x1(1) * fac_l
329 x1(2) = x1(2) * fac_l
330 x1(3) = x1(3) * fac_l
331 ENDIF
332 tx = x1(1) - x0(1)
333 ty = x1(2) - x0(2)
334 tz = x1(3) - x0(3)
335 s = sqrt(tx*tx + ty*ty + tz*tz)
336 at = angle * pi/hundred80 /max(em20,s)
337 tx = tx * at
338 ty = ty * at
339 tz = tz * at
340 CALL euler_mrot (tx,ty,tz,rot)
341 DO j=1,9
342 rtrans(i,j+2) = rot(j)
343 ENDDO
344 DO j=1,3
345 rtrans(i,j+11) = x0(j)
346 ENDDO
347 DO j=1,3
348 rtrans(i,j+14) = x0(j)
349 ENDDO
350C
351 WRITE(iout,600) id,id_transsub
352 IF (n0 > 0 .AND. n1 > 0) WRITE(iout,200) n0,n1
353 WRITE(iout,610) x0(1),x0(2),x0(3),tx,ty,tz,angle
354C----
355 ELSEIF (key(1:6) == 'MATRIX') THEN
356C
357 rtrans(i,2) = 3
358C
359 CALL hm_get_floatv('vector_1_x',rtrans(i,3),is_available,lsubmodel,unitab)
360 CALL hm_get_floatv('vector_1_y',rtrans(i,6),is_available,lsubmodel,unitab)
361 CALL hm_get_floatv('vector_1_z',rtrans(i,9),is_available,lsubmodel,unitab)
362 CALL hm_get_floatv('vector_2_x',rtrans(i,4),is_available,lsubmodel,unitab)
363 CALL hm_get_floatv('vector_2_y',rtrans(i,7),is_available,lsubmodel,unitab)
364 CALL hm_get_floatv('vector_2_z',rtrans(i,10),is_available,lsubmodel,unitab)
365 CALL hm_get_floatv('vector_3_x',rtrans(i,5),is_available,lsubmodel,unitab)
366 CALL hm_get_floatv('vector_3_y',rtrans(i,8),is_available,lsubmodel,unitab)
367 CALL hm_get_floatv('vector_3_z',rtrans(i,11),is_available,lsubmodel,unitab)
368 CALL hm_get_floatv('position_x',rtrans(i,15),is_available,lsubmodel,unitab)
369 CALL hm_get_floatv('position_y',rtrans(i,16),is_available,lsubmodel,unitab)
370 CALL hm_get_floatv('position_z',rtrans(i,17),is_available,lsubmodel,unitab)
371C
372 eps = em3
373 norm1 = sqrt(rtrans(i,3)**2+rtrans(i,6)**2+rtrans(i,9)**2)
374 norm2 = sqrt(rtrans(i,4)**2+rtrans(i,7)**2+rtrans(i,10)**2)
375 norm3 = sqrt(rtrans(i,5)**2+rtrans(i,8)**2+rtrans(i,11)**2)
376 scal1 = rtrans(i,3)*rtrans(i,4)+rtrans(i,6)*rtrans(i,7)+
377 . rtrans(i,9)*rtrans(i,10)
378 scal2 = rtrans(i,3)*rtrans(i,5)+rtrans(i,6)*rtrans(i,8)+
379 . rtrans(i,9)*rtrans(i,11)
380 scal3 = rtrans(i,4)*rtrans(i,5)+rtrans(i,7)*rtrans(i,8)+
381 . rtrans(i,10)*rtrans(i,11)
382 IF(abs(one-norm1) > eps .OR. abs(one-norm2) > eps .OR.
383 . abs(one-norm3) > eps .OR.
384 . scal1 > (eps * norm1*norm2) .OR. scal2 > (eps * norm1*norm3)
385 . .OR. scal3 > (eps * norm2*norm3))THEN
386 CALL ancmsg(msgid=986,
387 . msgtype=msgerror,
388 . anmode=aninfo)
389 ENDIF
390c
391 WRITE(iout,700) id,id_transsub
392c
393 WRITE(iout,710)
394 . rtrans(i,3),rtrans(i,6),rtrans(i,9),rtrans(i,15),
395 . rtrans(i,4),rtrans(i,7),rtrans(i,10),rtrans(i,16),
396 . rtrans(i,5),rtrans(i,8),rtrans(i,11),rtrans(i,17)
397C----
398 ELSEIF (key(1:8) == 'POSITION') THEN
399C
400 rtrans(i,2) = 4
401C
402 CALL hm_get_intv('node1',n1,is_available,lsubmodel)
403 CALL hm_get_intv('node2',n2,is_available,lsubmodel)
404 CALL hm_get_intv('node3',n3,is_available,lsubmodel)
405 CALL hm_get_intv('node4',n4,is_available,lsubmodel)
406 CALL hm_get_intv('node5',n5,is_available,lsubmodel)
407 CALL hm_get_intv('node6',n6,is_available,lsubmodel)
408C
409 CALL hm_get_floatv('X_Point_1',x1(1),is_available,lsubmodel,unitab)
410 CALL hm_get_floatv('Y_Point_1',x1(2),is_available,lsubmodel,unitab)
411 CALL hm_get_floatv('Z_Point_1',x1(3),is_available,lsubmodel,unitab)
412 CALL hm_get_floatv('X_Point_2',x2(1),is_available,lsubmodel,unitab)
413 CALL hm_get_floatv('Y_Point_2',x2(2),is_available,lsubmodel,unitab)
414 CALL hm_get_floatv('Z_Point_2',x2(3),is_available,lsubmodel,unitab)
415 CALL hm_get_floatv('X_Point_3',x3(1),is_available,lsubmodel,unitab)
416 CALL hm_get_floatv('Y_Point_3',x3(2),is_available,lsubmodel,unitab)
417 CALL hm_get_floatv('Z_Point_3',x3(3),is_available,lsubmodel,unitab)
418 CALL hm_get_floatv('X_Point_4',x4(1),is_available,lsubmodel,unitab)
419 CALL hm_get_floatv('Y_Point_4',x4(2),is_available,lsubmodel,unitab)
420 CALL hm_get_floatv('Z_Point_4',x4(3),is_available,lsubmodel,unitab)
421 CALL hm_get_floatv('X_Point_5',x5(1),is_available,lsubmodel,unitab)
422 CALL hm_get_floatv('Y_Point_5',x5(2),is_available,lsubmodel,unitab)
423 CALL hm_get_floatv('Z_Point_5',x5(3),is_available,lsubmodel,unitab)
424 CALL hm_get_floatv('X_Point_6',x6(1),is_available,lsubmodel,unitab)
425 CALL hm_get_floatv('Y_Point_6',x6(2),is_available,lsubmodel,unitab)
426 CALL hm_get_floatv('Z_Point_6',x6(3),is_available,lsubmodel,unitab)
427C
428 IF (n1 > 0 .OR. n2 > 0 .OR. n3 > 0 .OR.
429 . n4 > 0 .OR. n5 > 0 .OR. n6 > 0) THEN
430 i1 = usrtos(n1,itabm1)
431 i2 = usrtos(n2,itabm1)
432 i3 = usrtos(n3,itabm1)
433 i4 = usrtos(n4,itabm1)
434 i5 = usrtos(n5,itabm1)
435 i6 = usrtos(n6,itabm1)
436 IF (i1 == 0) THEN
437 CALL ancmsg(msgid=694,
438 . msgtype=msgerror,
439 . anmode=anstop,
440 . i1=id,
441 . c1=titr,
442 . i2=n1)
443 END IF
444 x1(1) = x(1,i1)
445 x1(2) = x(2,i1)
446 x1(3) = x(3,i1)
447 IF (i2 == 0) THEN
448 CALL ancmsg(msgid=694,
449 . msgtype=msgerror,
450 . anmode=anstop,
451 . i1=id,
452 . c1=titr,
453 . i2=n2)
454 END IF
455 x2(1) = x(1,i2)
456 x2(2) = x(2,i2)
457 x2(3) = x(3,i2)
458 IF (i3 == 0) THEN
459 CALL ancmsg(msgid=694,
460 . msgtype=msgerror,
461 . anmode=anstop,
462 . i1=id,
463 . c1=titr,
464 . i2=n3)
465 END IF
466 x3(1) = x(1,i3)
467 x3(2) = x(2,i3)
468 x3(3) = x(3,i3)
469 IF (i4 == 0) THEN
470 CALL ancmsg(msgid=694,
471 . msgtype=msgerror,
472 . anmode=anstop,
473 . i1=id,
474 . c1=titr,
475 . i2=n4)
476 END IF
477 x4(1) = x(1,i4)
478 x4(2) = x(2,i4)
479 x4(3) = x(3,i4)
480 IF (i5 == 0) THEN
481 CALL ancmsg(msgid=694,
482 . msgtype=msgerror,
483 . anmode=anstop,
484 . i1=id,
485 . c1=titr,
486 . i2=n5)
487 END IF
488 x5(1) = x(1,i5)
489 x5(2) = x(2,i5)
490 x5(3) = x(3,i5)
491 IF (i6 == 0) THEN
492 CALL ancmsg(msgid=694,
493 . msgtype=msgerror,
494 . anmode=anstop,
495 . i1=id,
496 . c1=titr,
497 . i2=n6)
498 END IF
499 x6(1) = x(1,i6)
500 x6(2) = x(2,i6)
501 x6(3) = x(3,i6)
502C
503C TRANSFORMATION OF COORDS OF NODES N0 & N1
504 IF(tagnodsub(i1) == itranssub) THEN
505 DO j=1,i-1
506 IF(rtrans(j,1) == itranssub) CALL rtranspos(x1,j,rtrans)
507 END DO
508 END IF
509 IF(tagnodsub(i2) == itranssub) THEN
510 DO j=1,i-1
511 IF(rtrans(j,1) == itranssub) CALL rtranspos(x2,j,rtrans)
512 END DO
513 END IF
514 IF(tagnodsub(i3) == itranssub) THEN
515 DO j=1,i-1
516 IF(rtrans(j,1) == itranssub) CALL rtranspos(x3,j,rtrans)
517 END DO
518 END IF
519 IF(tagnodsub(i4) == itranssub) THEN
520 DO j=1,i-1
521 IF(rtrans(j,1) == itranssub) CALL rtranspos(x4,j,rtrans)
522 END DO
523 END IF
524 IF(tagnodsub(i5) == itranssub) THEN
525 DO j=1,i-1
526 IF(rtrans(j,1) == itranssub) CALL rtranspos(x5,j,rtrans)
527 END DO
528 END IF
529 IF(tagnodsub(i6) == itranssub) THEN
530 DO j=1,i-1
531 IF(rtrans(j,1) == itranssub) CALL rtranspos(x6,j,rtrans)
532 END DO
533 END IF
534 ELSE
535 x1(1) = x1(1) * fac_l
536 x1(2) = x1(2) * fac_l
537 x1(3) = x1(3) * fac_l
538 x2(1) = x2(1) * fac_l
539 x2(2) = x2(2) * fac_l
540 x2(3) = x2(3) * fac_l
541 x3(1) = x3(1) * fac_l
542 x3(2) = x3(2) * fac_l
543 x3(3) = x3(3) * fac_l
544 x4(1) = x4(1) * fac_l
545 x4(2) = x4(2) * fac_l
546 x4(3) = x4(3) * fac_l
547 x5(1) = x5(1) * fac_l
548 x5(2) = x5(2) * fac_l
549 x5(3) = x5(3) * fac_l
550 x6(1) = x6(1) * fac_l
551 x6(2) = x6(2) * fac_l
552 x6(3) = x6(3) * fac_l
553 ENDIF
554C
555 CALL points_to_frame(x1,x2,x3,pp,ierror)
556 IF(ierror==1.OR.ierror==3)THEN
557 CALL ancmsg(msgid=1866,
558 . msgtype=msgerror,
559 . anmode=aninfo_blind_1,
560 . i1=id,c1=titr)
561 END IF
562 IF(ierror >= 2)THEN
563 CALL ancmsg(msgid=1867,
564 . msgtype=msgwarning,
565 . anmode=aninfo_blind_1,
566 . i1=id,c1=titr)
567 END IF
568 CALL points_to_frame(x4,x5,x6,qq,ierror)
569 IF(ierror == 1)THEN
570 CALL ancmsg(msgid=1868,
571 . msgtype=msgerror,
572 . anmode=aninfo_blind_1,
573 . i1=id,c1=titr)
574C
575 rot(1:9)=zero
576 rot(1) = one
577 rot(5) = one
578 rot(9) = one
579 DO j=1,9
580 rtrans(i,j+2) = rot(j)
581 ENDDO
582 rtrans(i,12:14) = zero
583 rtrans(i,15:17) = zero
584C
585 ELSE
586C
587 IF(ierror == 2)THEN
588 CALL ancmsg(msgid=1869,
589 . msgtype=msgwarning,
590 . anmode=aninfo_blind_1,
591 . i1=id,c1=titr)
592 END IF
593C
594 rot(1)=qq(1,1)*pp(1,1)+qq(1,2)*pp(1,2)+qq(1,3)*pp(1,3) ! QQ . Transpose(PP)
595 rot(4)=qq(1,1)*pp(2,1)+qq(1,2)*pp(2,2)+qq(1,3)*pp(2,3)
596 rot(7)=qq(1,1)*pp(3,1)+qq(1,2)*pp(3,2)+qq(1,3)*pp(3,3)
597 rot(2)=qq(2,1)*pp(1,1)+qq(2,2)*pp(1,2)+qq(2,3)*pp(1,3)
598 rot(5)=qq(2,1)*pp(2,1)+qq(2,2)*pp(2,2)+qq(2,3)*pp(2,3)
599 rot(8)=qq(2,1)*pp(3,1)+qq(2,2)*pp(3,2)+qq(2,3)*pp(3,3)
600 rot(3)=qq(3,1)*pp(1,1)+qq(3,2)*pp(1,2)+qq(3,3)*pp(1,3)
601 rot(6)=qq(3,1)*pp(2,1)+qq(3,2)*pp(2,2)+qq(3,3)*pp(2,3)
602 rot(9)=qq(3,1)*pp(3,1)+qq(3,2)*pp(3,2)+qq(3,3)*pp(3,3)
603C
604 DO j=1,9
605 rtrans(i,j+2) = rot(j)
606 ENDDO
607 DO j=1,3
608 rtrans(i,j+11) = x1(j)
609 ENDDO
610 DO j=1,3
611 rtrans(i,j+14) = x4(j) ! Xnew = X4 + ROT(Xold-X1)
612 ENDDO
613C
614 END IF
615C
616 WRITE(iout,800) id,id_transsub
617c
618 WRITE(iout,810)
619 . (rtrans(i,k+11) , k=1,3),
620 . (rtrans(i,k+14) , k=1,3),
621 . rtrans(i,3),rtrans(i,6), rtrans(i,9),
622 . rtrans(i,4),rtrans(i,7),rtrans(i,10),
623 . rtrans(i,5),rtrans(i,8),rtrans(i,11)
624
625 ELSE IF (key(1:3) == 'SYM') THEN
626C
627 rtrans(i,2) = 5
628
629 CALL hm_get_intv('GR_NODE',igu,is_available,lsubmodel)
630 CALL hm_get_intv('node1',n0,is_available,lsubmodel)
631 CALL hm_get_intv('node2',n1,is_available,lsubmodel)
632 CALL hm_get_intv('SUBMODEL',itranssub,is_available,lsubmodel)
633C
634 CALL hm_get_floatv('reflect_point1_x',x0(1),is_available,lsubmodel,unitab)
635 CALL hm_get_floatv('reflect_point1_y',x0(2),is_available,lsubmodel,unitab)
636 CALL hm_get_floatv('reflect_point1_z',x0(3),is_available,lsubmodel,unitab)
637 CALL hm_get_floatv('reflect_point2_x',x1(1),is_available,lsubmodel,unitab)
638 CALL hm_get_floatv('reflect_point2_y',x1(2),is_available,lsubmodel,unitab)
639 CALL hm_get_floatv('reflect_point2_z',x1(3),is_available,lsubmodel,unitab)
640C--------------------------------------------------
641 ingr2usr => igrnod(1:ngrnod)%ID
642 igs = ngr2usr(igu,ingr2usr,ngrnod)
643
644 IF (n0 > 0 .OR. n1 > 0) THEN
645 i0 = usrtos(n0,itabm1)
646 i1 = usrtos(n1,itabm1)
647 IF (i0 == 0) THEN
648 CALL ancmsg(msgid=694,
649 . msgtype=msgerror,
650 . anmode=aninfo,
651 . i1=id,
652 . c1=titr,
653 . i2=n0)
654 END IF
655 IF (i1 == 0) THEN
656 CALL ancmsg(msgid=694,
657 . msgtype=msgerror,
658 . anmode=aninfo,
659 . i1=id,
660 . c1=titr,
661 . i2=n1)
662 END IF
663 x0(1) = x(1,i0)
664 x0(2) = x(2,i0)
665 x0(3) = x(3,i0)
666 x1(1) = x(1,i1)
667 x1(2) = x(2,i1)
668 x1(3) = x(3,i1)
669 ELSE
670 x0(1) = x0(1) * fac_l
671 x0(2) = x0(2) * fac_l
672 x0(3) = x0(3) * fac_l
673 x1(1) = x1(1) * fac_l
674 x1(2) = x1(2) * fac_l
675 x1(3) = x1(3) * fac_l
676 ENDIF
677C
678 IF(tagnodsub(i0) == itranssub) THEN
679 DO j=1,i-1
680 IF(rtrans(j,1) == itranssub) CALL rtranspos(x0,j,rtrans)
681 END DO
682 END IF
683C
684 IF(tagnodsub(i1) == itranssub) THEN
685 DO j=1,i-1
686 IF(rtrans(j,1) == itranssub) CALL rtranspos(x1,j,rtrans)
687 END DO
688 END IF
689C
690 DO j=1,3
691 rtrans(i,j+11) = x0(j)
692 ENDDO
693C
694 DO j=1,3
695 rtrans(i,j+14) = x1(j)
696 ENDDO
697C
698 WRITE(iout,900) id,igu
699 IF (n0 > 0 .AND. n1 > 0) WRITE(iout,200) n0,n1
700 WRITE(iout,910) x0(1),x0(2),x0(3),tx,ty,tz
701
702 ELSE IF (key(1:3) == 'SCA') THEN
703C
704 rtrans(i,2) = 6
705C
706 CALL hm_get_intv('node1',n0,is_available,lsubmodel)
707C
708 CALL hm_get_floatv('scalefactor_x',rtrans(i,20),is_available,lsubmodel,unitab)
709 CALL hm_get_floatv('scalefactor_y',rtrans(i,21),is_available,lsubmodel,unitab)
710 CALL hm_get_floatv('scalefactor_z',rtrans(i,22),is_available,lsubmodel,unitab)
711c
712 IF (n0 > 0) THEN
713 i0 = usrtos(n0,itabm1)
714 IF (i0 == 0) THEN
715 CALL ancmsg(msgid=694,
716 . msgtype=msgerror,
717 . anmode=aninfo,
718 . i1=id,
719 . c1=titr,
720 . i2=n1)
721 x0(1) = zero
722 x0(2) = zero
723 x0(3) = zero
724 ELSE
725 x0(1) = x(1,i0)
726 x0(2) = x(2,i0)
727 x0(3) = x(3,i0)
728 ENDIF
729 ENDIF
730C
731 DO j=1,3
732 rtrans(i,j+11) = x0(j)
733 ENDDO
734C
735 IF(tagnodsub(i0) == itranssub) THEN
736 DO j=1,i-1
737 IF(rtrans(j,1) == itranssub) CALL rtranspos(x0,j,rtrans)
738 END DO
739 END IF
740C
741 WRITE(iout,1000) id,id_transsub
742 WRITE(iout,1010) rtrans(i,12),rtrans(i,13),rtrans(i,14),rtrans(i,20),rtrans(i,21),rtrans(i,22)
743C----
744 ENDIF
745 ENDDO
746C-------------------------
747 IF(is_dyna /= 0)THEN
748 IF (ALLOCATED(index)) DEALLOCATE(index)
749 IF (ALLOCATED(index1)) DEALLOCATE(index1)
750 IF (ALLOCATED(tagnodsub_tmp)) DEALLOCATE(tagnodsub_tmp)
751 IF (ALLOCATED(idnodsub)) DEALLOCATE(idnodsub)
752 ENDIF
753C-----------------------
754 DEALLOCATE(tagnodsub)
755 RETURN
756C-----------------------
757 100 FORMAT(//
758 .' NODAL TRANSFORMATIONS '/,
759 .' ---------------------- ')
760 200 FORMAT(10x,' NODES N0 . . . . .= ',i10/,
761 . 10x,' N1 . . . . .= ',i10)
762 300 FORMAT(10x,' CENTER NODE N0 . . . . .= ',i10)
763 500 FORMAT(/
764 . ' SUBMODEL TRANSLATION, TRANSFORMATION ID = ',i10/,
765 . ' SUBMODEL ID. . . . . . . . . . . .= ',i10/,
766 . ' TRANSLATION VECTOR :')
767 510 FORMAT(10x,' VALUE. . . . . . . . . . . . .= ',e20.13/,
768 . ' COORDINATES X. . . . . . .= ',e20.13/,
769 . ' Y. . . . . . .= ',e20.13/,
770 . ' Z. . . . . . .= ',e20.13)
771 600 FORMAT(/
772 . ' SUBMODEL ROTATION, TRANSFORMATION ID. = ',i10/,
773 . ' SUBMODEL ID. . . . . . . . . . . .= ',i10/,
774 . ' ROTATION VECTOR: ')
775 610 FORMAT(10x,' CENTER X. . . . . . .= ',e20.13/,
776 . ' Y. . . . . . .= ',e20.13/,
777 . ' Z. . . . . . .= ',e20.13/,
778 . ' DIRECTION X. . . . . . .= ',e20.13/,
779 . ' y. . . . . . .= ',E20.13/,
780 . ' z. . . . . . .= ',E20.13/,
781 . ' angle . . . . . . .= ',E20.13)
782 700 FORMAT(/
783 . ' submodel matrix transformation, transformation id.= ',I10/,
784 . ' submodel id. . . . . . . . . . . .= ',I10/)
785 710 FORMAT(4X,'matrix '/,
786 .' '/,
787 . 17X,'m11',17X,'m12',17X,'m13',18X,'tx' /,
788 . 4E20.13/,
789 . 17X,'m21',17X,'m22',17X,'m23',18X,'ty' /,
790 . 4e20.13/,
791 . 17x,'M31',17x,'M32',17x,'M33',18x,'TZ' /,
792 . 4e20.13/)
793 800 FORMAT(/
794 . ' SUBMODEL TRANSFORMATION WRT 6 POSITIONS',/,
795 . ' TRANSFORMATION ID. . . . . . . . . . . = ',i10/,
796 . ' SUBMODEL ID. . . . . . . . . . . . . . = ',i10/)
797 810 FORMAT(
798 . ' CENTER N1 X1 . . . . . .= ',e20.13/,
799 . ' Y1 . . . . . .= ',e20.13/,
800 . ' Z1 . . . . . .= ',e20.13/,
801 . ' CENTER N4 X4 . . . . . .= ',e20.13/,
802 . ' Y4 . . . . . .= ',e20.13/,
803 . ' Z4 . . . . . .= ',e20.13/,
804 . ' ROTATION MATRIX . . . . . . . = ',/,
805 . ' . . . . . . . . M11 . . . . . . . . M12 . . . . . . . . M13',/,
806 . 3e20.13/,
807 . ' . . . . . . . . M21 . . . . . . . . M22 . . . . . . . . M23',/,
808 . 3e20.13/,
809 . ' . . . . . . . . M31 . . . . . . . . M32 . . . . . . . . M33',/,
810 . 3e20.13/)
811 900 FORMAT(/
812 . ' SUBMODEL TRANSFORMATION PLANE SYMMETRY',/,
813 . ' TRANSFORMATION ID. . . . . . . . . . . = ',i10/,
814 . ' SUBMODEL ID. . . . . . . . . . . . . . = ',i10/)
815 910 FORMAT(10x,' CENTER X. . . . . . .= ',e20.13/,
816 . ' Y. . . . . . .= ',e20.13/,
817 . ' Z. . . . . . .= ',e20.13/,
818 . ' DIRECTION X. . . . . . .= ',e20.13/,
819 . ' Y. . . . . . .= ',e20.13/,
820 . ' Z. . . . . . .= ',e20.13)
821
822 1000 FORMAT(/
823 . ' SUBMODEL SCALE',/,
824 . ' TRANSFORMATION ID. . . . . . . . . . . = ',i10/,
825 . ' SUBMODEL ID. . . . . . . . . . . . . . = ',i10/)
826 1010 FORMAT(10x,' CENTER X. . . . . . .= ',e20.13/,
827 . ' Y. . . . . . .= ',e20.13/,
828 . ' Z. . . . . . .= ',e20.13/,
829 . ' SCALE X . . . . . .= ',e20.13/,
830 . ' Y . . . . . .= ',e20.13/,
831 . ' Z . . . . . .= ',e20.13)
832
833 3000 FORMAT(/10x,'NEW NODE COORDINATES',14x,'X',24x,'Y',24x,'Z')
834 3500 FORMAT( 17x,i10,3(5x,e20.13))
835C-----------------------
836 RETURN
points_to_frame
subroutine points_to_frame(x1, x2, x3, pp, ierror)
Definition 3points_to_frame.F:32
my_real
#define my_real
Definition cppsort.cpp:32
euler_mrot
subroutine euler_mrot(rx, ry, rz, rot)
Definition euler_mrot.F:34
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
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
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::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
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:325
rtranspos
subroutine rtranspos(point, mytrans, rtrans)
Definition rtranspos.F:29
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