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