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, iskwn, liskn, nspcond, numsph, siskwn)

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,
integer, dimension(liskn,siskwn/liskn), intent(in) iskwn,
integer, intent(in) liskn,
integer, intent(in) nspcond,
integer, intent(in) numsph,
integer, intent(in) siskwn )

Definition at line 44 of file lectranssub.F.

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