OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_frm.F File Reference
#include "implicit_f.inc"
#include "analyse_name.inc"
#include "scr17_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "sphcom.inc"
#include "units_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_frm (iskn, x, itab, itabm1, xframe, lsubmodel, rtrans, nom_opt, unitab)

Function/Subroutine Documentation

◆ hm_read_frm()

subroutine hm_read_frm ( integer, dimension(liskn,*) iskn,
x,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
xframe,
type(submodel_data), dimension(*) lsubmodel,
rtrans,
integer, dimension(lnopt1,*) nom_opt,
type (unit_type_), intent(in) unitab )

Definition at line 48 of file hm_read_frm.F.

50C-----------------------------------------------
51C M o d u l e s
52C-----------------------------------------------
53 USE unitab_mod
54 USE submodel_mod
55 USE message_mod
56 USE hm_option_read_mod
57 USE names_and_titles_mod , ONLY : nchartitle, ncharfield, ncharkey
58 USE format_mod , ONLY : lfield
59C-----------------------------------------------
60C I m p l i c i t T y p e s
61C-----------------------------------------------
62#include "implicit_f.inc"
63C-----------------------------------------------
64C A n a l y s e M o d u l e
65C-----------------------------------------------
66#include "analyse_name.inc"
67C-----------------------------------------------
68C C o m m o n B l o c k s
69C-----------------------------------------------
70#include "scr17_c.inc"
71#include "com01_c.inc"
72#include "com04_c.inc"
73#include "sphcom.inc"
74#include "units_c.inc"
75#include "param_c.inc"
76C-----------------------------------------------
77C D u m m y A r g u m e n t s
78C-----------------------------------------------
79 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
80 INTEGER ISKN(LISKN,*), ITAB(*), ITABM1(*)
81 my_real x(3,*), xframe(nxframe,*),rtrans(ntransf,*)
82 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
83 INTEGER NOM_OPT(LNOPT1,*)
84C-----------------------------------------------
85C L o c a l V a r i a b l e s
86C-----------------------------------------------
87 INTEGER I, IMOV, INOD, J, N1, N2, N3, K, NSK,
88 . IUN, JJ, SUB_ID,
89 . IDIR,IFLAGUNIT,ID,UID,CPT
90 my_real p(12), pnor1, pnor2, pnorm1, det1, det2, det3, det, pp,bid
91 CHARACTER(LEN=NCHARTITLE) :: NOMFG
92 CHARACTER(LEN=NCHARTITLE) :: TITR
93 CHARACTER :: MESS*40,MESSF*40
94 CHARACTER(LEN=NCHARKEY) :: KEY
95 CHARACTER(LEN=NCHARFIELD) :: DIR
96 LOGICAL IS_AVAILABLE
97C-----------------------------------------------
98C E x t e r n a l F u n c t i o n s
99C-----------------------------------------------
100 INTEGER USR2SYS
101 DATA iun/1/
102 DATA messf/'MOVING FRAME '/
103 DATA nomfg/'global reference frame '/
104C=======================================================================
105C
106 DO i=1,9
107 xframe(i,1) =zero
108 ENDDO
109 xframe(1,1) =one
110 xframe(5,1) =one
111 xframe(9,1) =one
112 DO i=1,9
113 xframe(18+i,1) =zero
114 ENDDO
115 xframe(18+1,1) =one
116 xframe(18+5,1) =one
117 xframe(18+9,1) =one
118C
119 jj=(numskw+1)+min(iun,nspcond)*numsph+1+nsubmod
120 iskn(1,jj)=0
121 iskn(2,jj)=0
122 iskn(3,jj)=0
123 iskn(5,jj)=0
124C Global Frame ID is set to -1
125 iskn(4,jj)=-1
126 nom_opt(1,numskw+2)=-1
127 CALL fretitl(nomfg,nom_opt(lnopt1-ltitr+1,numskw+2),ltitr)
128C
129 IF(numfram==0)GOTO 900
130C--------------------------------------------------
131C START BROWSING MODEL PROPERTIES
132C--------------------------------------------------
133 CALL hm_option_start('/FRAME')
134 i = 0
135C--------------------------------------------------
136C BROWSING MODEL PROPERTIES 1->HM_NUMGEO
137C--------------------------------------------------
138 DO cpt=1,numfram
139 i = i + 1
140 jj=(numskw+1)+min(iun,nspcond)*numsph+i+1+nsubmod
141C--------------------------------------------------
142C EXTRACT DATAS OF /FRAME/... LINE
143C--------------------------------------------------
144 CALL hm_option_read_key(lsubmodel,
145 . option_id = id,
146 . unit_id = uid,
147 . submodel_id = sub_id,
148 . option_titr = titr,
149 . keyword2 = key)
150C
151 nom_opt(1,numskw+2+i)=id
152 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,
153 . numskw+2+i),ltitr)
154C
155 iflagunit = 0
156 DO j=1,unitab%NUNITS
157 IF (unitab%UNIT_ID(j) == uid) THEN
158 iflagunit = 1
159 EXIT
160 ENDIF
161 ENDDO
162 IF (uid/=0.AND.iflagunit==0) THEN
163 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
164 . i2=uid,i1=id,c1='REFERENCE FRAME',
165 . c2='REFERENCE FRAME',
166 . c3=titr)
167 ENDIF
168C
169 inod =0
170 imov =0
171C
172 IF (key(1:3)=='FIX') THEN
173C--------------------------------------------------
174C EXTRACT DATAS (REAL VALUES)
175C--------------------------------------------------
176 CALL hm_get_floatv('globaloriginx',p(10),is_available,lsubmodel,unitab)
177 CALL hm_get_floatv('globaloriginy',p(11),is_available,lsubmodel,unitab)
178 CALL hm_get_floatv('globaloriginz',p(12),is_available,lsubmodel,unitab)
179
180 CALL hm_get_floatv('globalyaxisx',p(4),is_available,lsubmodel,unitab)
181 CALL hm_get_floatv('globalyaxisy',p(5),is_available,lsubmodel,unitab)
182 CALL hm_get_floatv('globalyaxisz',p(6),is_available,lsubmodel,unitab)
183
184 CALL hm_get_floatv('globalzaxisx',p(7),is_available,lsubmodel,unitab)
185 CALL hm_get_floatv('globalzaxisy',p(8),is_available,lsubmodel,unitab)
186 CALL hm_get_floatv('globalzaxisz',p(9),is_available,lsubmodel,unitab)
187C
188 ELSEIF (key(1:4)=='MOV2') THEN
189 imov=2
190C--------------------------------------------------
191C EXTRACT DATAS (INTEGER VALUES)
192C--------------------------------------------------
193 CALL hm_get_intv('originnodeid',n1,is_available,lsubmodel)
194 CALL hm_get_intv('axisnodeid',n2,is_available,lsubmodel)
195 CALL hm_get_intv('planenodeid',n3,is_available,lsubmodel)
196C
197 ELSEIF (key(1:3)=='MOV') THEN
198 imov=1
199 idir = 1
200C--------------------------------------------------
201C EXTRACT DATAS (INTEGER VALUES)
202C--------------------------------------------------
203 CALL hm_get_intv('originnodeid',n1,is_available,lsubmodel)
204 CALL hm_get_intv('axisnodeid',n2,is_available,lsubmodel)
205 CALL hm_get_intv('planenodeid',n3,is_available,lsubmodel)
206C--------------------------------------------------
207C EXTRACT DATAS (STRING)
208C--------------------------------------------------
209 CALL hm_get_string('DIR',dir,ncharfield,is_available)
210 DO k = 1,lfield
211 IF(dir(k:k) == 'X'.OR.dir(k:k) == 'x')idir = 1
212 IF(dir(k:k) == 'Y'.OR.dir(k:k) == 'y')idir = 2
213 IF(dir(k:k) == 'Z'.OR.dir(k:k) == 'z')idir = 3
214 ENDDO
215 iskn(6,jj)=idir
216C
217 ELSEIF (key(1:3)=='NOD') THEN
218C Node defined moving frame
219 inod=1
220C--------------------------------------------------
221C EXTRACT DATAS (INTEGER VALUES)
222C--------------------------------------------------
223 CALL hm_get_intv('originnodeid',n1,is_available,lsubmodel)
224 CALL hm_get_intv('axisnodeid',n2,is_available,lsubmodel)
225 CALL hm_get_intv('planenodeid',n3,is_available,lsubmodel)
226 IF (n2==0 .OR. n3==0) THEN
227 inod=2
228C--------------------------------------------------
229C EXTRACT DATAS (REAL VALUES)
230C--------------------------------------------------
231 CALL hm_get_floatv('globalyaxisx',p(4),is_available,lsubmodel,unitab)
232 CALL hm_get_floatv('globalyaxisy',p(5),is_available,lsubmodel,unitab)
233 CALL hm_get_floatv('globalyaxisz',p(6),is_available,lsubmodel,unitab)
234C
235 CALL hm_get_floatv('globalzaxisx',p(7),is_available,lsubmodel,unitab)
236 CALL hm_get_floatv('globalzaxisy',p(8),is_available,lsubmodel,unitab)
237 CALL hm_get_floatv('globalzaxisz',p(9),is_available,lsubmodel,unitab)
238C
239 IF(sub_id /= 0)
240 . CALL subrotvect(p(4),p(5),p(6),rtrans,sub_id,lsubmodel)
241 IF(sub_id /= 0)
242 . CALL subrotvect(p(7),p(8),p(9),rtrans,sub_id,lsubmodel)
243 ENDIF
244 ENDIF
245 iskn(4,jj)=id
246C----------------
247C FRAME MOBILE (CALCUL DE LA POSITION INITIALE)
248C----------------
249 IF(imov==1)THEN
250 n1=usr2sys(n1,itabm1,messf,id)
251 n2=usr2sys(n2,itabm1,messf,id)
252 CALL anodset(n1, check_used)
253 CALL anodset(n2, check_used)
254 CALL ifrontplus(n1,1)
255 CALL ifrontplus(n2,1)
256 iskn(1,jj)=n1
257 iskn(2,jj)=n2
258 iskn(5,jj)=imov
259C-----------------
260C CALCUL DE X' et Y0'
261C-----------------
262 IF(n2d==0)THEN
263c
264 IF (idir == 1) THEN
265 p(1)=x(1,n2)-x(1,n1)
266 p(2)=x(2,n2)-x(2,n1)
267 p(3)=x(3,n2)-x(3,n1)
268 ELSEIF(idir == 2) THEN
269 p(4)=x(1,n2)-x(1,n1)
270 p(5)=x(2,n2)-x(2,n1)
271 p(6)=x(3,n2)-x(3,n1)
272 ELSEIF(idir == 3) THEN
273 p(7)=x(1,n2)-x(1,n1)
274 p(8)=x(2,n2)-x(2,n1)
275 p(9)=x(3,n2)-x(3,n1)
276 ENDIF
277c
278 n3=usr2sys(n3,itabm1,messf,id)
279 CALL anodset(n3, check_used)
280 CALL ifrontplus(n3,1)
281 iskn(3,jj)=n3
282C
283 IF (idir == 1) THEN
284 p(4)=x(1,n3)-x(1,n1)
285 p(5)=x(2,n3)-x(2,n1)
286 p(6)=x(3,n3)-x(3,n1)
287 ELSEIF (idir == 2) THEN
288 p(7)=x(1,n3)-x(1,n1)
289 p(8)=x(2,n3)-x(2,n1)
290 p(9)=x(3,n3)-x(3,n1)
291 ELSEIF (idir == 3) THEN
292 p(1)=x(1,n3)-x(1,n1)
293 p(2)=x(2,n3)-x(2,n1)
294 p(3)=x(3,n3)-x(3,n1)
295 ENDIF
296C
297 p(10)=x(1,n1)
298 p(11)=x(2,n1)
299 p(12)=x(3,n1)
300 ELSE
301 p(1)=one
302 p(2)=zero
303 p(3)=zero
304C
305 p(4)=x(1,n2)-x(1,n1)
306 p(5)=x(2,n2)-x(2,n1)
307 p(6)=x(3,n2)-x(3,n1)
308C
309 p(10)=x(1,n1)
310 p(11)=x(2,n1)
311 p(12)=x(3,n1)
312 ENDIF
313C----------------
314C TESTS DE CONSISTANCE
315C----------------
316 IF (idir == 1) pnor1=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
317 IF (idir == 2) pnor1=sqrt(p(4)*p(4)+p(5)*p(5)+p(6)*p(6))
318 IF (idir == 3) pnor1=sqrt(p(7)*p(7)+p(8)*p(8)+p(9)*p(9))
319 IF(pnor1<1.e-20) THEN
320 CALL ancmsg(msgid=162,
321 . msgtype=msgerror,
322 . anmode=aninfo_blind_1,
323 . i2=itab(n1),
324 . i1=id,c1=titr,
325 . i3=itab(n2))
326 RETURN
327 ENDIF
328C CALCUL DE COLINEARITE DES VECTEURS N1N2 ET N1N3
329 IF (idir == 1) THEN
330 pnor2=sqrt(p(4)*p(4)+p(5)*p(5)+p(6)*p(6))
331 IF(pnor2>em20) THEN
332 pnorm1=one/(pnor1*pnor2)
333 det1=abs((p(1)*p(5)-p(2)*p(4))*pnorm1)
334 det2=abs((p(1)*p(6)-p(3)*p(4))*pnorm1)
335 det3=abs((p(2)*p(6)-p(3)*p(5))*pnorm1)
336 det= max(det1,det2,det3)
337 ELSE
338 det=zero
339 ENDIF
340 IF(det<em5) THEN
341 CALL ancmsg(msgid=163,
342 . msgtype=msgwarning,
343 . anmode=aninfo_blind_1,
344 . i1=id,c1=titr)
345 IF(abs(p(2))>em5) THEN
346 p(4)=abs(p(1))+ten
347 ELSE
348 p(5)=ten
349 ENDIF
350 ENDIF
351 ELSEIF (idir == 2) THEN
352 pnor2=sqrt(p(7)*p(7)+p(8)*p(8)+p(9)*p(9))
353 IF(pnor2>em20) THEN
354 pnorm1=one/(pnor1*pnor2)
355 det1=abs((p(4)*p(8)-p(5)*p(7))*pnorm1)
356 det2=abs((p(4)*p(9)-p(6)*p(7))*pnorm1)
357 det3=abs((p(5)*p(9)-p(6)*p(8))*pnorm1)
358 det= max(det1,det2,det3)
359 ELSE
360 det=zero
361 ENDIF
362 IF(det<em5) THEN
363 CALL ancmsg(msgid=163,
364 . msgtype=msgwarning,
365 . anmode=aninfo_blind_1,
366 . i1=id,c1=titr)
367 IF(abs(p(5))>em5) THEN
368 p(7)=abs(p(4))+ten
369 ELSE
370 p(8)=ten
371 ENDIF
372 ENDIF
373 ELSEIF (idir == 3) THEN
374 pnor2=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
375 IF(pnor2>em20) THEN
376 pnorm1=one/(pnor1*pnor2)
377 det1=abs((p(7)*p(2)-p(8)*p(1))*pnorm1)
378 det2=abs((p(7)*p(3)-p(9)*p(1))*pnorm1)
379 det3=abs((p(8)*p(3)-p(9)*p(2))*pnorm1)
380 det= max(det1,det2,det3)
381 ELSE
382 det=zero
383 ENDIF
384 IF(det<em5) THEN
385 CALL ancmsg(msgid=163,
386 . msgtype=msgwarning,
387 . anmode=aninfo_blind_1,
388 . i1=id,c1=titr)
389 IF(abs(p(5))>em5) THEN
390 p(1)=abs(p(7))+ten
391 ELSE
392 p(2)=ten
393 ENDIF
394 ENDIF
395 ENDIF
396C-----------------
397C CALCUL DE Z'
398C-----------------
399 IF (idir == 1) THEN
400 p(7)=p(2)*p(6)-p(3)*p(5)
401 p(8)=p(3)*p(4)-p(1)*p(6)
402 p(9)=p(1)*p(5)-p(2)*p(4)
403 ELSEIF (idir == 2) THEN
404 p(1)=p(5)*p(9)-p(6)*p(8)
405 p(2)=p(6)*p(7)-p(4)*p(9)
406 p(3)=p(4)*p(8)-p(5)*p(7)
407 ELSEIF (idir == 3) THEN
408 p(4)=p(8)*p(3)-p(9)*p(2)
409 p(5)=p(9)*p(1)-p(7)*p(3)
410 p(6)=p(7)*p(2)-p(8)*p(1)
411 ENDIF
412C-----------------
413C CALCUL DE Y'
414C-----------------
415 IF (idir == 1) THEN
416 p(4)=p(8)*p(3)-p(9)*p(2)
417 p(5)=p(9)*p(1)-p(7)*p(3)
418 p(6)=p(7)*p(2)-p(8)*p(1)
419 ELSEIF (idir == 2) THEN
420 p(7)=p(2)*p(6)-p(3)*p(5)
421 p(8)=p(3)*p(4)-p(1)*p(6)
422 p(9)=p(1)*p(5)-p(2)*p(4)
423 ELSEIF (idir == 3) THEN
424 p(1)=p(5)*p(9)-p(6)*p(8)
425 p(2)=p(6)*p(7)-p(4)*p(9)
426 p(3)=p(4)*p(8)-p(5)*p(7)
427 ENDIF
428C----------------
429C FRAME MOV2
430C----------------
431 ELSEIF (imov == 2) THEN
432 n1=usr2sys(n1,itabm1,mess,id)
433 n2=usr2sys(n2,itabm1,mess,id)
434 n3=usr2sys(n3,itabm1,mess,id)
435 CALL anodset(n1, check_used)
436 CALL anodset(n2, check_used)
437 CALL anodset(n3, check_used)
438 CALL ifrontplus(n1,1)
439 CALL ifrontplus(n2,1)
440 CALL ifrontplus(n3,1)
441 iskn(1,jj)=n1
442 iskn(2,jj)=n2
443 iskn(3,jj)=n3
444 iskn(5,jj)=imov
445 p(7)=x(1,n2)-x(1,n1)
446 p(8)=x(2,n2)-x(2,n1)
447 p(9)=x(3,n2)-x(3,n1)
448 p(1)=x(1,n3)-x(1,n1)
449 p(2)=x(2,n3)-x(2,n1)
450 p(3)=x(3,n3)-x(3,n1)
451C-----------------
452C CALCUL DE Y = Z x X'
453C-----------------
454 p(4)=p(8)*p(3)-p(9)*p(2)
455 p(5)=p(9)*p(1)-p(7)*p(3)
456 p(6)=p(7)*p(2)-p(8)*p(1)
457C-----------------
458C CALCUL DE X = Y x Z
459C-----------------
460 p(1)=p(5)*p(9)-p(6)*p(8)
461 p(2)=p(6)*p(7)-p(4)*p(9)
462 p(3)=p(4)*p(8)-p(5)*p(7)
463C-----------------
464C ORIGINE
465C-----------------
466 p(10)=x(1,n1)
467 p(11)=x(2,n1)
468 p(12)=x(3,n1)
469C----------------
470C TESTS DE CONSISTANCE
471C----------------
472 pnor1=sqrt(p(7)*p(7)+p(8)*p(8)+p(9)*p(9))
473 IF (pnor1 < em20) THEN
474 CALL ancmsg(msgid=162,
475 . msgtype=msgerror,
476 . anmode=aninfo_blind_1,
477 . i2=itab(n1),
478 . i1=id,c1=titr,
479 . i3=itab(n2))
480 ENDIF
481C CALCUL DE COLINEARITE DES VECTEURS N1N2 ET N1N3
482 pnor2=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
483 IF (pnor2 > em20) THEN
484 pnorm1=one/(pnor1*pnor2)
485 det1=abs((p(8)*p(3)-p(9)*p(2))*pnorm1)
486 det2=abs((p(9)*p(1)-p(7)*p(3))*pnorm1)
487 det3=abs((p(7)*p(2)-p(8)*p(1))*pnorm1)
488 det= max(det1,det2,det3)
489 ELSE
490 det=zero
491 ENDIF
492 IF (det < em5) THEN
493 CALL ancmsg(msgid=163,
494 . msgtype=msgwarning,
495 . anmode=aninfo_blind_1,
496 . i1=id,c1=titr)
497 IF(abs(p(2)) < em5) THEN
498 p(4)=abs(p(1))+ten
499 ELSE
500 p(5)=ten
501 ENDIF
502 ENDIF
503C----------------
504C MOVING FRAME ATTACHED TO A NODE
505C----------------
506 ELSEIF (inod>=1) THEN
507 IF (n1<=0) THEN
508 CALL ancmsg(msgid=900,
509 . msgtype=msgerror,
510 . anmode=aninfo_blind_1,
511 . i1=sub_id,
512 . c1=titr,
513 . i2=n1)
514 ENDIF
515 IF (n1/=0) THEN
516 n1=usr2sys(n1,itabm1,messf,id)
517 CALL anodset(n1, check_used)
518 CALL ifrontplus(n1,1)
519 ENDIF
520 IF (n2/=0) THEN
521 n2=usr2sys(n2,itabm1,messf,id)
522 CALL anodset(n2, check_used)
523 CALL ifrontplus(n2,1)
524 ENDIF
525 iskn(1,jj)=n1
526 iskn(2,jj)=0
527 iskn(3,jj)=0
528 IF (inod==1) THEN
529C defined with 3 nodes
530C--- CALCUL DE X' et Y0'
531 IF(n2d==0)THEN
532 p(1)=x(1,n2)-x(1,n1)
533 p(2)=x(2,n2)-x(2,n1)
534 p(3)=x(3,n2)-x(3,n1)
535 IF (n3/=0) THEN
536 n3=usr2sys(n3,itabm1,messf,id)
537 CALL anodset(n3, check_used)
538 CALL ifrontplus(n3,1)
539 ENDIF
540 p(4)=x(1,n3)-x(1,n1)
541 p(5)=x(2,n3)-x(2,n1)
542 p(6)=x(3,n3)-x(3,n1)
543 p(10)=x(1,n1)
544 p(11)=x(2,n1)
545 p(12)=x(3,n1)
546 ELSE
547 p(1)=one
548 p(2)=zero
549 p(3)=zero
550 p(4)=x(1,n2)-x(1,n1)
551 p(5)=x(2,n2)-x(2,n1)
552 p(6)=x(3,n2)-x(3,n1)
553 p(10)=x(1,n1)
554 p(11)=x(2,n1)
555 p(12)=x(3,n1)
556 ENDIF
557C--- TESTS DE CONSISTANCE
558 pnor1=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
559 IF(pnor1<em20) THEN
560 CALL ancmsg(msgid=162,
561 . msgtype=msgerror,
562 . anmode=aninfo_blind_1,
563 . i2=itab(n1),
564 . i1=id,c1=titr,
565 . i3=itab(n2))
566 RETURN
567 ENDIF
568C--- CALCUL DE COLINEARITE DES VECTEURS N1N2 ET N1N3
569 pnor2=sqrt(p(4)*p(4)+p(5)*p(5)+p(6)*p(6))
570 IF(pnor2>em20) THEN
571 pnorm1=1./(pnor1*pnor2)
572 det1=abs((p(1)*p(5)-p(2)*p(4))*pnorm1)
573 det2=abs((p(1)*p(6)-p(3)*p(4))*pnorm1)
574 det3=abs((p(2)*p(6)-p(3)*p(5))*pnorm1)
575 det= max(det1,det2,det3)
576 ELSE
577 det=zero
578 ENDIF
579 IF(det<em5) THEN
580 CALL ancmsg(msgid=163,
581 . msgtype=msgwarning,
582 . anmode=aninfo_blind_1,
583 . i1=id,c1=titr)
584 IF(abs(p(2))>em5) THEN
585 p(4)=abs(p(1))+ten
586 ELSE
587 p(5)=ten
588 ENDIF
589 ENDIF
590C--- CALCUL DE Z'
591 p(7)=p(2)*p(6)-p(3)*p(5)
592 p(8)=p(3)*p(4)-p(1)*p(6)
593 p(9)=p(1)*p(5)-p(2)*p(4)
594C--- CALCUL DE Y'
595 p(4)=p(8)*p(3)-p(9)*p(2)
596 p(5)=p(9)*p(1)-p(7)*p(3)
597 p(6)=p(7)*p(2)-p(8)*p(1)
598 ELSE
599C defined with 1 node and 2 vectors
600C--- CALCUL DE X'
601 p(10)=x(1,n1)
602 p(11)=x(2,n1)
603 p(12)=x(3,n1)
604 p(1)=p(5)*p(9)-p(6)*p(8)
605 p(2)=p(6)*p(7)-p(4)*p(9)
606 p(3)=p(4)*p(8)-p(5)*p(7)
607C--- CALCUL DE Y'
608 p(4)=p(8)*p(3)-p(9)*p(2)
609 p(5)=p(9)*p(1)-p(7)*p(3)
610 p(6)=p(7)*p(2)-p(8)*p(1)
611 ENDIF
612 ELSE
613C----------------
614C FRAME FIXE
615C----------------
616 iskn(1,jj)=0
617 iskn(2,jj)=0
618 iskn(3,jj)=0
619 iskn(5,jj)=0
620C-----------------
621C CALCUL DE X'
622C-----------------
623 p(1)=p(5)*p(9)-p(6)*p(8)
624 p(2)=p(6)*p(7)-p(4)*p(9)
625 p(3)=p(4)*p(8)-p(5)*p(7)
626C-----------------
627C CALCUL DE Y'
628C-----------------
629 p(4)=p(8)*p(3)-p(9)*p(2)
630 p(5)=p(9)*p(1)-p(7)*p(3)
631 p(6)=p(7)*p(2)-p(8)*p(1)
632 IF(sub_id /= 0)
633 . CALL subrotpoint(p(10),p(11),p(12),rtrans,sub_id,lsubmodel)
634 IF(sub_id /= 0)
635 . CALL subrotvect(p(1),p(2),p(3),rtrans,sub_id,lsubmodel)
636 IF(sub_id /= 0)
637 . CALL subrotvect(p(4),p(5),p(6),rtrans,sub_id,lsubmodel)
638 IF(sub_id /= 0)
639 . CALL subrotvect(p(7),p(8),p(9),rtrans,sub_id,lsubmodel)
640 ENDIF
641C-----------
642C NORME
643C-----------
644 pp=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
645 IF(pp/=zero)THEN
646 p(1)=p(1)/pp
647 p(2)=p(2)/pp
648 p(3)=p(3)/pp
649 ENDIF
650 pp=sqrt(p(4)*p(4)+p(5)*p(5)+p(6)*p(6))
651 IF(pp/=zero)THEN
652 p(4)=p(4)/pp
653 p(5)=p(5)/pp
654 p(6)=p(6)/pp
655 ENDIF
656 pp=sqrt(p(7)*p(7)+p(8)*p(8)+p(9)*p(9))
657 IF(pp/=zero)THEN
658 p(7)=p(7)/pp
659 p(8)=p(8)/pp
660 p(9)=p(9)/pp
661 ENDIF
662C
663C-----------
664 DO k=1,12
665 xframe(k,i+1)=p(k)
666 ENDDO
667 DO k=1,9
668 xframe(18+k,i+1)=p(k)
669 ENDDO
670C-----------
671 ENDDO
672C------------------------------------------------
673 WRITE (iout,'(A)')' REFERENCE FRAME SETS '
674 WRITE (iout,'(A)')' -------------------- '
675 DO i=1,numfram
676 j=i+1
677 jj=(numskw+1)+min(iun,nspcond)*numsph+i+nsubmod+1
678 nsk = iskn(4,jj)
679C
680 n1=iskn(1,jj)
681 n2=iskn(2,jj)
682 n3=iskn(3,jj)
683 IF(n1/=0)n1=itab(n1)
684 IF(n2/=0)n2=itab(n2)
685 IF(n3/=0)n3=itab(n3)
686 WRITE(iout,1000)
687 WRITE(iout,'(1X,4I10,1X,3F16.7,3F16.7)')nsk,n1,n2,n3,
688 & (xframe(k,j),k=1,3),(xframe(k,j),k=10,12)
689 WRITE(iout,'(2(42X,3F16.7/))') (xframe(k,j),k=4,9)
690 ENDDO
691C-----
692 900 CONTINUE
693C-------------------------------------
694C Recherche des ID doubles
695C-------------------------------------
696 IF (numfram+numskw/=0)
697 . CALL udouble(iskn(4,1),liskn,
698 . numskw+1+min(iun,nspcond)*numsph+numfram+1+nsubmod,
699 . mess,0,bid)
700C-----
701 RETURN
702
703 1000 FORMAT(5x,'NUMBER',8x,'N1',8x,'N2',8x,'N3',10x,'VECTORS',42x,
704 . 'ORIGIN')
705! 1001 FORMAT(5X,'NUMBER',10X,'VECTORS',42X,'ORIGIN')
706 RETURN
anodset
void anodset(int *id, int *type)
Definition analyse_node.c:321
my_real
#define my_real
Definition cppsort.cpp:32
ifrontplus
subroutine ifrontplus(n, p)
Definition frontplus.F:100
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_get_string
subroutine hm_get_string(name, sval, size, is_available)
Definition hm_get_string.F:76
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
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
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
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589
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