OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_prop45.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!|| hm_read_prop45 ../starter/source/properties/spring/hm_read_prop45.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_prop_generic ../starter/source/properties/hm_read_prop_generic.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
30!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
31!|| hm_option_is_encrypted ../starter/source/devtools/hm_reader/hm_option_is_encrypted.F
32!|| lec_dof_jnt ../starter/source/properties/spring/hm_read_prop45.f
33!|| set_u_geo ../starter/source/user_interface/uaccess.F
34!|| set_u_pnu ../starter/source/user_interface/uaccess.F
35!||--- uses -----------------------------------------------------
36!|| elbuftag_mod ../starter/share/modules1/elbuftag_mod.F
37!|| message_mod ../starter/share/message_module/message_mod.F
38!|| submodel_mod ../starter/share/modules1/submodel_mod.F
39!||====================================================================
40 SUBROUTINE hm_read_prop45(IOUT,NUVAR ,PARGEO,UNITAB,IGTYP,
41 . ID,PROP_TAG,TITR,LSUBMODEL,IUNIT)
42C-----------------------------------------------
43 USE unitab_mod
44 USE message_mod
45 USE elbuftag_mod
46 USE submodel_mod
47 USE names_and_titles_mod , ONLY : nchartitle
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C A n a l y s e M o d u l e
54C-----------------------------------------------
55#include "tablen_c.inc"
56C----------+---------+---+---+--------------------------------------------
57C VAR | SIZE |TYP| RW| DEFINITION
58C----------+---------+---+---+--------------------------------------------
59C IIN | 1 | I | R | INPUT FILE UNIT (D00 file)
60C IOUT | 1 | I | R | OUTPUT FILE UNIT (L00 file)
61C NUVAR | 1 | I | W | NUMBER OF USER ELEMENT VARIABLES
62C----------+---------+---+---+--------------------------------------------
63C PARGEO | * | F | W | 1)SKEW NUMBER
64C | | | | 2)STIFNESS FOR INTERFACE
65C | | | | 3)FRONT WAVE OPTION
66C | | | | 4)... not yet used
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 IOUT,NUVAR,IGTYP,IUNIT
72 my_real pargeo(*)
73 INTEGER ID
74 TYPE(prop_tag_) , DIMENSION(0:MAXPROP) :: PROP_TAG
75 CHARACTER(LEN=NCHARTITLE) :: TITR
76 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
77C-----------------------------------------------
78C L o c a l V a r i a b l e s
79C-----------------------------------------------
80 INTEGER SENSOR,ZEROI,IERROR,JTYP
81 my_real knn,cr,scf,sensr,skewr
82 my_real xtyp,fac_m,fac_l,fac_t,fac_mm,fac_ff,fac_kt
83 my_real kxx,kyy,kzz,krx,kry,krz
84 my_real cxx,cyy,czz,crx,cry,crz
85 my_real crxx,cryy,crzz,crrx,crry,crrz
86 my_real sdxmi,sdxma,sdymi,sdyma,sdzmi,sdzma
87 my_real saxmi,saxma,saymi,sayma,sazmi,sazma
88 my_real kfx,kfy,kfz,kfrx,kfry,kfrz
89 my_real fmx,fmy,fmz,fmrx,fmry,fmrz,xidsk1,xidsk2
90 my_real fcombx,fcomby,fcombz,fcombrx,fcombry,fcombrz,sumt,sumr,alpha_plus,alpha_moin
91 INTEGER IFUN_XX,IFUN_YY,IFUN_ZZ,IFUN_RX,IFUN_RY,IFUN_RZ
92 INTEGER IFUN_CXX,IFUN_CYY,IFUN_CZZ,IFUN_CRX,IFUN_CRY,IFUN_CRZ
93 INTEGER IFUN_FMX,IFUN_FMY,IFUN_FMZ,IFUN_FMRX,IFUN_FMRY,IFUN_FMRZ
94 INTEGER RED,IDSK1,IDSK2,COMB_ERROR
95 DATA zeroi/0/
96 LOGICAL IS_AVAILABLE, IS_ENCRYPTED
97C-----------------------------------------------
98C E x t e r n a l F u n c t i o n s
99C-----------------------------------------------
100 INTEGER SET_U_PNU,SET_U_GEO,KFUNC
101 parameter(kfunc=29)
102C=======================================================================
103C
104 is_encrypted = .false.
105 is_available = .false.
106C
107C--------------------------------------------------
108C EXTRACT DATA (IS OPTION CRYPTED)
109C--------------------------------------------------
110 CALL hm_option_is_encrypted(is_encrypted)
111C--------------------------------------------------
112C EXTRACT DATAS (INTEGER VALUES)
113C--------------------------------------------------
114 CALL hm_get_intv('type',jtyp,is_available,lsubmodel)
115 CALL hm_get_intv('ISENSOR',sensor,is_available,lsubmodel)
116 CALL hm_get_intv('SKEW1',idsk1,is_available,lsubmodel)
117 CALL hm_get_intv('SKEW2',idsk2,is_available,lsubmodel)
118C--------------------------------------------------
119C EXTRACT DATAS (REAL VALUES)
120C-------------------------------------------------
121 CALL hm_get_floatv('Kn',knn,is_available,lsubmodel,unitab)
122 CALL hm_get_floatv('SCALE',scf,is_available,lsubmodel,unitab)
123 CALL hm_get_floatv('Cr',cr,is_available,lsubmodel,unitab)
124C----------------------
125C
126 IF(.NOT. is_encrypted)THEN
127 WRITE(iout,1400) id
128 ELSE
129 WRITE(iout,1500) id
130 ENDIF
131C
132 nuvar = 39
133C SKEWR - id of local joint - not used for joint type45
134 skewr = 0
135 sensr = sensor
136 fac_m = unitab%FAC_M(iunit)
137 fac_l = unitab%FAC_L(iunit)
138 fac_t = unitab%FAC_T(iunit)
139C
140 fac_ff = fac_m * fac_l / fac_t**2
141 fac_mm = fac_m * fac_l**2 / fac_t**2
142 fac_kt = fac_m / fac_t**2
143C
144 xtyp = jtyp
145 xidsk1 = idsk1
146 xidsk2 = idsk2
147C
148 IF (cr<zero.OR.cr>1.) THEN
149 CALL ancmsg(msgid=388,
150 . msgtype=msgerror,
151 . anmode=aninfo_blind_1,
152 . i1=id,
153 . c1=titr)
154 ENDIF
155 IF (cr==zero) cr = fiveem2
156 IF (scf<zero) THEN
157 CALL ancmsg(msgid=939,
158 . msgtype=msgerror,
159 . anmode=aninfo_blind_1,
160 . i1=id,
161 . c1=titr)
162 ENDIF
163 IF (scf==zero) THEN
164 IF (knn==0) THEN
165 scf = one
166 ELSE
167 scf = 10
168 ENDIF
169 ENDIF
170C
171 knn = knn * fac_kt
172
173C Mise a zero
174 kxx = zero
175 kyy = zero
176 kzz = zero
177 krx = zero
178 kry = zero
179 krz = zero
180 cxx = zero
181 cyy = zero
182 czz = zero
183 crx = zero
184 cry = zero
185 crz = zero
186 crxx = zero
187 cryy = zero
188 crzz = zero
189 crrx = zero
190 crry = zero
191 crrz = zero
192C
193 sdxmi = zero
194 sdxma = zero
195 sdymi = zero
196 sdyma = zero
197 sdzmi = zero
198 sdzma = zero
199 saxmi = zero
200 saxma = zero
201 saymi = zero
202 sayma = zero
203 sazmi = zero
204 sazma = zero
205C
206 fcombx = zero
207 fcomby = zero
208 fcombz = zero
209 fcombrx = zero
210 fcombry = zero
211 fcombrz = zero
212C
213 kfx = zero
214 kfy = zero
215 kfz = zero
216 kfrx = zero
217 kfry = zero
218 kfrz = zero
219 fmx = zero
220 fmy = zero
221 fmz = zero
222 fmrx = zero
223 fmry = zero
224 fmrz = zero
225C
226 ifun_xx = zeroi
227 ifun_yy = zeroi
228 ifun_zz = zeroi
229 ifun_cxx = zeroi
230 ifun_cyy = zeroi
231 ifun_czz = zeroi
232 ifun_rx = zeroi
233 ifun_ry = zeroi
234 ifun_rz = zeroi
235 ifun_crx = zeroi
236 ifun_cry = zeroi
237 ifun_crz = zeroi
238 ifun_fmx = zeroi
239 ifun_fmy = zeroi
240 ifun_fmz = zeroi
241 ifun_fmrx = zeroi
242 ifun_fmry = zeroi
243 ifun_fmrz = zeroi
244C
245 IF (jtyp==1) THEN
246C=======================================================================
247C---- SPHERICAL JOINT
248C=======================================================================
249 IF(.NOT. is_encrypted)THEN
250 WRITE(iout,100)
251 IF ((idsk1==0).AND.(idsk2==0)) THEN
252 IF (knn==0) THEN
253 WRITE(iout,1100) scf,cr,sensor
254 ELSE
255 WRITE(iout,1000) knn,scf,cr,sensor
256 ENDIF
257 ELSE
258 IF (knn==0) THEN
259 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
260 ELSE
261 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
262 ENDIF
263 ENDIF
264 ENDIF
265C
266 red = 0
267 CALL lec_dof_jnt(iout,is_encrypted,unitab,krx,crx,saxmi,
268 . saxma,fcombrx,kfrx,fmrx,ifun_crx,ifun_rx,4,
269 . fac_mm,ifun_fmrx,red,id,titr,
270 . lsubmodel)
271 CALL lec_dof_jnt(iout,is_encrypted,unitab,kry,cry,saymi,
272 . sayma,fcombry,kfry,fmry,ifun_cry,ifun_ry,5,
273 . fac_mm,ifun_fmry,red,id,titr,
274 . lsubmodel)
275 CALL lec_dof_jnt(iout,is_encrypted,unitab,krz,crz,sazmi,
276 . sazma,fcombrz,kfrz,fmrz,ifun_crz,ifun_rz,6,
277 . fac_mm,ifun_fmrz,red,id,titr,
278 . lsubmodel)
279C
280 IF ((red/=0).AND.(red/=3)) THEN
281 CALL ancmsg(msgid=973,
282 . msgtype=msgerror,
283 . anmode=aninfo_blind_2,
284 . i1=id,
285 . c1=titr,
286 . i2=red,
287 . i3=3)
288 ENDIF
289C
290 kxx = knn
291 kyy = knn
292 kzz = knn
293C
294 cxx = zero
295 cyy = zero
296 czz = zero
297C
298 crxx = cr
299 cryy = cr
300 crzz = cr
301 crrx = zero
302 crry = zero
303 crrz = zero
304C
305 sdxmi = zero
306 sdxma = zero
307 sdymi = zero
308 sdyma = zero
309 sdzmi = zero
310 sdzma = zero
311C
312 kfx = zero
313 kfy = zero
314 kfz = zero
315C
316 fmx = zero
317 fmy = zero
318 fmz = zero
319C
320 ifun_xx = zeroi
321 ifun_yy = zeroi
322 ifun_zz = zeroi
323 ifun_cxx = zeroi
324 ifun_cyy = zeroi
325 ifun_czz = zeroi
326 ifun_fmx = zeroi
327 ifun_fmy = zeroi
328 ifun_fmz = zeroi
329C
330 ELSEIF (jtyp==2) THEN
331C=======================================================================
332C---- REVOLUTE JOINT
333C=======================================================================
334 IF(.NOT. is_encrypted)THEN
335 WRITE(iout,200)
336 IF ((idsk1==0).AND.(idsk2==0)) THEN
337 IF (knn==0) THEN
338 WRITE(iout,1100) scf,cr,sensor
339 ELSE
340 WRITE(iout,1000) knn,scf,cr,sensor
341 ENDIF
342 ELSE
343 IF (knn==0) THEN
344 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
345 ELSE
346 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
347 ENDIF
348 ENDIF
349 ENDIF
350C
351 CALL lec_dof_jnt(iout,is_encrypted,unitab,krx,crx,saxmi,
352 . saxma,fcombrx,kfrx,fmrx,ifun_crx,ifun_rx,4,
353 . fac_mm,ifun_fmrx,red,id,titr,
354 . lsubmodel)
355C
356 kxx = knn
357 kyy = knn
358 kzz = knn
359 kry = knn
360 krz = knn
361C
362 cxx = zero
363 cyy = zero
364 czz = zero
365 cry = zero
366 crz = zero
367C
368 crxx = cr
369 cryy = cr
370 crzz = cr
371 crrx = zero
372 crry = cr
373 crrz = cr
374C
375 sdxmi = zero
376 sdxma = zero
377 sdymi = zero
378 sdyma = zero
379 sdzmi = zero
380 sdzma = zero
381C
382 saymi = zero
383 sayma = zero
384 sazmi = zero
385 sazma = zero
386C
387 kfx = zero
388 kfy = zero
389 kfz = zero
390 kfry = zero
391 kfrz = zero
392C
393 fmx = zero
394 fmy = zero
395 fmz = zero
396 fmry = zero
397 fmrz = zero
398C
399 ifun_xx = zeroi
400 ifun_yy = zeroi
401 ifun_zz = zeroi
402 ifun_cxx = zeroi
403 ifun_cyy = zeroi
404 ifun_czz = zeroi
405 ifun_ry = zeroi
406 ifun_rz = zeroi
407 ifun_cry = zeroi
408 ifun_crz = zeroi
409 ifun_fmx = zeroi
410 ifun_fmy = zeroi
411 ifun_fmz = zeroi
412 ifun_fmry = zeroi
413 ifun_fmrz = zeroi
414C
415 ELSEIF (jtyp==3) THEN
416C=======================================================================
417C---- CYLINDRICAL JOINT
418C=======================================================================
419 IF(.NOT. is_encrypted)THEN
420 WRITE(iout,300)
421 IF ((idsk1==0).AND.(idsk2==0)) THEN
422 IF (knn==0) THEN
423 WRITE(iout,1100) scf,cr,sensor
424 ELSE
425 WRITE(iout,1000) knn,scf,cr,sensor
426 ENDIF
427 ELSE
428 IF (knn==0) THEN
429 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
430 ELSE
431 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
432 ENDIF
433 ENDIF
434 ENDIF
435C
436 red = 0
437 CALL lec_dof_jnt(iout,is_encrypted,unitab,kxx,cxx,sdxmi,
438 . sdxma,fcombx,kfx,fmx,ifun_cxx,ifun_xx,1,
439 . fac_ff,ifun_fmx,red,id,titr,
440 . lsubmodel)
441 CALL lec_dof_jnt(iout,is_encrypted,unitab,krx,crx,saxmi,
442 . saxma,fcombrx,kfrx,fmrx,ifun_crx,ifun_rx,4,
443 . fac_mm,ifun_fmrx,red,id,titr,
444 . lsubmodel)
445C
446 IF ((red/=0).AND.(red/=2)) THEN
447 CALL ancmsg(msgid=973,
448 . msgtype=msgerror,
449 . anmode=aninfo_blind_2,
450 . i1=id,
451 . c1=titr,
452 . i2=red,
453 . i3=2)
454 ENDIF
455C
456 kyy = knn
457 kzz = knn
458 kry = knn
459 krz = knn
460C
461 cyy = zero
462 czz = zero
463 cry = zero
464 crz = zero
465C
466 crxx = zero
467 cryy = cr
468 crzz = cr
469 crrx = zero
470 crry = cr
471 crrz = cr
472C
473 sdymi = zero
474 sdyma = zero
475 sdzmi = zero
476 sdzma = zero
477C
478 saymi = zero
479 sayma = zero
480 sazmi = zero
481 sazma = zero
482C
483 kfy = zero
484 kfz = zero
485 kfry = zero
486 kfrz = zero
487C
488 fmy = zero
489 fmz = zero
490 fmry = zero
491 fmrz = zero
492C
493 ifun_yy = zeroi
494 ifun_zz = zeroi
495 ifun_cyy = zeroi
496 ifun_czz = zeroi
497 ifun_ry = zeroi
498 ifun_rz = zeroi
499 ifun_cry = zeroi
500 ifun_crz = zeroi
501 ifun_fmy = zeroi
502 ifun_fmz = zeroi
503 ifun_fmry = zeroi
504 ifun_fmrz = zeroi
505C
506 ELSEIF (jtyp==4) THEN
507C=======================================================================
508C---- PLANAR JOINT
509C=======================================================================
510 IF(.NOT. is_encrypted)THEN
511 WRITE(iout,400)
512 IF ((idsk1==0).AND.(idsk2==0)) THEN
513 IF (knn==0) THEN
514 WRITE(iout,1100) scf,cr,sensor
515 ELSE
516 WRITE(iout,1000) knn,scf,cr,sensor
517 ENDIF
518 ELSE
519 IF (knn==0) THEN
520 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
521 ELSE
522 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
523 ENDIF
524 ENDIF
525 ENDIF
526C
527 red = 0
528 CALL lec_dof_jnt(iout,is_encrypted,unitab,kyy,cyy,sdymi,
529 . sdyma,fcomby,kfy,fmy,ifun_cyy,ifun_yy,2,
530 . fac_ff,ifun_fmy,red,id,titr,
531 . lsubmodel)
532 CALL lec_dof_jnt(iout,is_encrypted,unitab,kzz,czz,sdzmi,
533 . sdzma,fcombz,kfz,fmz,ifun_czz,ifun_zz,3,
534 . fac_ff,ifun_fmz,red,id,titr,
535 . lsubmodel)
536 CALL lec_dof_jnt(iout,is_encrypted,unitab,krx,crx,saxmi,
537 . saxma,fcombrx,kfrx,fmrx,ifun_crx,ifun_rx,4,
538 . fac_mm,ifun_fmrx,red,id,titr,
539 . lsubmodel)
540C
541 IF ((red/=0).AND.(red/=3)) THEN
542 CALL ancmsg(msgid=973,
543 . msgtype=msgerror,
544 . anmode=aninfo_blind_2,
545 . i1=id,
546 . c1=titr,
547 . i2=red,
548 . i3=3)
549 ENDIF
550C
551 kxx = knn
552 kry = knn
553 krz = knn
554C
555 cxx = zero
556 cry = zero
557 crz = zero
558C
559 crxx = cr
560 cryy = zero
561 crzz = zero
562 crrx = zero
563 crry = cr
564 crrz = cr
565C
566 sdxmi = zero
567 sdxma = zero
568C
569 saymi = zero
570 sayma = zero
571 sazmi = zero
572 sazma = zero
573C
574 kfx = zero
575 kfry = zero
576 kfrz = zero
577C
578 fmx = zero
579 fmry = zero
580 fmrz = zero
581C
582 ifun_xx = zeroi
583 ifun_cxx = zeroi
584 ifun_ry = zeroi
585 ifun_rz = zeroi
586 ifun_cry = zeroi
587 ifun_crz = zeroi
588 ifun_fmx = zeroi
589 ifun_fmry = zeroi
590 ifun_fmrz = zeroi
591C
592 ELSEIF (jtyp==5) THEN
593C=======================================================================
594C---- UNIVERSAL JOINT
595C=================================================================
596 IF(.NOT. is_encrypted)THEN
597 WRITE(iout,500)
598 IF ((idsk1==0).AND.(idsk2==0)) THEN
599 IF (knn==0) THEN
600 WRITE(iout,1100) scf,cr,sensor
601 ELSE
602 WRITE(iout,1000) knn,scf,cr,sensor
603 ENDIF
604 ELSE
605 IF (knn==0) THEN
606 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
607 ELSE
608 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
609 ENDIF
610 ENDIF
611 ENDIF
612C
613 red = 0
614 CALL lec_dof_jnt(iout,is_encrypted,unitab,kry,cry,saymi,
615 . sayma,fcombry,kfry,fmry,ifun_cry,ifun_ry,5,
616 . fac_mm,ifun_fmry,red,id,titr,
617 . lsubmodel)
618 CALL lec_dof_jnt(iout,is_encrypted,unitab,krz,crz,sazmi,
619 . sazma,fcombrz,kfrz,fmrz,ifun_crz,ifun_rz,6,
620 . fac_mm,ifun_fmrz,red,id,titr,
621 . lsubmodel)
622C
623 IF ((red/=0).AND.(red/=2)) THEN
624 CALL ancmsg(msgid=973,
625 . msgtype=msgerror,
626 . anmode=aninfo_blind_2,
627 . i1=id,
628 . c1=titr,
629 . i2=red,
630 . i3=3)
631 ENDIF
632C
633 kxx = knn
634 kyy = knn
635 kzz = knn
636 krx = knn
637C
638 cxx = zero
639 cyy = zero
640 czz = zero
641 crx = zero
642C
643 crxx = cr
644 cryy = cr
645 crzz = cr
646 crrx = cr
647 crry = zero
648 crrz = zero
649C
650 sdxmi = zero
651 sdxma = zero
652 sdymi = zero
653 sdyma = zero
654 sdzmi = zero
655 sdzma = zero
656C
657 saxmi = zero
658 saxma = zero
659C
660 kfx = zero
661 kfy = zero
662 kfz = zero
663 kfrx = zero
664C
665 fmx = zero
666 fmy = zero
667 fmz = zero
668 fmrx = zero
669C
670 ifun_xx = zeroi
671 ifun_yy = zeroi
672 ifun_zz = zeroi
673 ifun_rx = zeroi
674 ifun_cxx = zeroi
675 ifun_cyy = zeroi
676 ifun_czz = zeroi
677 ifun_crx = zeroi
678 ifun_fmx = zeroi
679 ifun_fmy = zeroi
680 ifun_fmz = zeroi
681 ifun_fmrx = zeroi
682C
683 ELSEIF (jtyp==6) THEN
684C=======================================================================
685C---- TRANSLATIONAL JOINT
686C=======================================================================
687 IF(.NOT. is_encrypted)THEN
688 WRITE(iout,600)
689 IF ((idsk1==0).AND.(idsk2==0)) THEN
690 IF (knn==0) THEN
691 WRITE(iout,1100) scf,cr,sensor
692 ELSE
693 WRITE(iout,1000) knn,scf,cr,sensor
694 ENDIF
695 ELSE
696 IF (knn==0) THEN
697 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
698 ELSE
699 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
700 ENDIF
701 ENDIF
702 ENDIF
703C
704 CALL lec_dof_jnt(iout,is_encrypted,unitab,kxx,cxx,sdxmi,
705 . sdxma,fcombx,kfx,fmx,ifun_cxx,ifun_xx,1,
706 . fac_ff,ifun_fmx,red,id,titr,
707 . lsubmodel)
708C
709 kyy = knn
710 kzz = knn
711 krx = knn
712 kry = knn
713 krz = knn
714C
715 cyy = zero
716 czz = zero
717 crx = zero
718 cry = zero
719 crz = zero
720C
721 crxx = zero
722 cryy = cr
723 crzz = cr
724 crrx = cr
725 crry = cr
726 crrz = cr
727C
728 sdymi = zero
729 sdyma = zero
730 sdzmi = zero
731 sdzma = zero
732C
733 saxmi = zero
734 saxma = zero
735 saymi = zero
736 sayma = zero
737 sazmi = zero
738 sazma = zero
739C
740 kfy = zero
741 kfz = zero
742 kfrx = zero
743 kfry = zero
744 kfrz = zero
745C
746 fmy = zero
747 fmz = zero
748 fmrx = zero
749 fmry = zero
750 fmrz = zero
751C
752 ifun_yy = zeroi
753 ifun_zz = zeroi
754 ifun_cyy = zeroi
755 ifun_czz = zeroi
756 ifun_rx = zeroi
757 ifun_ry = zeroi
758 ifun_rz = zeroi
759 ifun_crx = zeroi
760 ifun_cry = zeroi
761 ifun_crz = zeroi
762 ifun_fmy = zeroi
763 ifun_fmz = zeroi
764 ifun_fmrx = zeroi
765 ifun_fmry = zeroi
766 ifun_fmrz = zeroi
767C
768 ELSEIF (jtyp==7) THEN
769C=======================================================================
770C---- OLDHAM JOINT
771C=======================================================================
772 IF(.NOT. is_encrypted)THEN
773 WRITE(iout,700)
774 IF ((idsk1==0).AND.(idsk2==0)) THEN
775 IF (knn==0) THEN
776 WRITE(iout,1100) scf,cr,sensor
777 ELSE
778 WRITE(iout,1000) knn,scf,cr,sensor
779 ENDIF
780 ELSE
781 IF (knn==0) THEN
782 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
783 ELSE
784 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
785 ENDIF
786 ENDIF
787 ENDIF
788C
789 red = 0
790 CALL lec_dof_jnt(iout,is_encrypted,unitab,kyy,cyy,sdymi,
791 . sdyma,fcomby,kfy,fmy,ifun_cyy,ifun_yy,2,
792 . fac_ff,ifun_fmy,red,id,titr,
793 . lsubmodel)
794 CALL lec_dof_jnt(iout,is_encrypted,unitab,kzz,czz,sdzmi,
795 . sdzma,fcombz,kfz,fmz,ifun_czz,ifun_zz,3,
796 . fac_ff,ifun_fmz,red,id,titr,
797 . lsubmodel)
798C
799 IF ((red/=0).AND.(red/=2)) THEN
800 CALL ancmsg(msgid=973,
801 . msgtype=msgerror,
802 . anmode=aninfo_blind_2,
803 . i1=id,
804 . c1=titr,
805 . i2=red,
806 . i3=2)
807 ENDIF
808C
809 kxx = knn
810 krx = knn
811 kry = knn
812 krz = knn
813C
814 cxx = zero
815 crx = zero
816 cry = zero
817 crz = zero
818C
819 crxx = cr
820 cryy = zero
821 crzz = zero
822 crrx = cr
823 crry = cr
824 crrz = cr
825C
826 sdxmi = zero
827 sdxma = zero
828C
829 saxmi = zero
830 saxma = zero
831 saymi = zero
832 sayma = zero
833 sazmi = zero
834 sazma = zero
835C
836 kfx = zero
837 kfrx = zero
838 kfry = zero
839 kfrz = zero
840C
841 fmx = zero
842 fmrx = zero
843 fmry = zero
844 fmrz = zero
845C
846 ifun_xx = zeroi
847 ifun_cxx = zeroi
848 ifun_rx = zeroi
849 ifun_ry = zeroi
850 ifun_rz = zeroi
851 ifun_crx = zeroi
852 ifun_cry = zeroi
853 ifun_crz = zeroi
854 ifun_fmx = zeroi
855 ifun_fmrx = zeroi
856 ifun_fmry = zeroi
857 ifun_fmrz = zeroi
858C
859 ELSEIF (jtyp==8) THEN
860C=======================================================================
861C---- RIGID JOINT
862C=======================================================================
863 IF(.NOT. is_encrypted)THEN
864 WRITE(iout,800)
865 IF ((idsk1==0).AND.(idsk2==0)) THEN
866 IF (knn==0) THEN
867 WRITE(iout,1100) scf,cr,sensor
868 ELSE
869 WRITE(iout,1000) knn,scf,cr,sensor
870 ENDIF
871 ELSE
872 IF (knn==0) THEN
873 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
874 ELSE
875 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
876 ENDIF
877 ENDIF
878 ENDIF
879C
880 kxx = knn
881 kyy = knn
882 kzz = knn
883 krx = knn
884 kry = knn
885 krz = knn
886C
887 cxx = zero
888 cyy = zero
889 czz = zero
890 crx = zero
891 cry = zero
892 crz = zero
893C
894 crxx = cr
895 cryy = cr
896 crzz = cr
897 crrx = cr
898 crry = cr
899 crrz = cr
900C
901 sdxmi = zero
902 sdxma = zero
903 sdymi = zero
904 sdyma = zero
905 sdzmi = zero
906 sdzma = zero
907C
908 saxmi = zero
909 saxma = zero
910 saymi = zero
911 sayma = zero
912 sazmi = zero
913 sazma = zero
914C
915 kfx = zero
916 kfy = zero
917 kfz = zero
918 kfrx = zero
919 kfry = zero
920 kfrz = zero
921C
922 fmx = zero
923 fmy = zero
924 fmz = zero
925 fmrx = zero
926 fmry = zero
927 fmrz = zero
928C
929 ifun_xx = zeroi
930 ifun_yy = zeroi
931 ifun_zz = zeroi
932 ifun_cxx = zeroi
933 ifun_cyy = zeroi
934 ifun_czz = zeroi
935 ifun_rx = zeroi
936 ifun_ry = zeroi
937 ifun_rz = zeroi
938 ifun_crx = zeroi
939 ifun_cry = zeroi
940 ifun_crz = zeroi
941 ifun_crz = zeroi
942 ifun_fmx = zeroi
943 ifun_fmy = zeroi
944 ifun_fmz = zeroi
945 ifun_fmrx = zeroi
946 ifun_fmry = zeroi
947 ifun_fmrz = zeroi
948C
949 ELSEIF (jtyp==9) THEN
950C=======================================================================
951C---- FREE JOINT
952C=======================================================================
953 IF(.NOT. is_encrypted)THEN
954 WRITE(iout,900)
955 IF ((idsk1==0).AND.(idsk2==0)) THEN
956 IF (knn==0) THEN
957 WRITE(iout,1100) scf,cr,sensor
958 ELSE
959 WRITE(iout,1000) knn,scf,cr,sensor
960 ENDIF
961 ELSE
962 IF (knn==0) THEN
963 WRITE(iout,1300) scf,cr,sensor,idsk1,idsk2
964 ELSE
965 WRITE(iout,1200) knn,scf,cr,sensor,idsk1,idsk2
966 ENDIF
967 ENDIF
968 ENDIF
969C
970 red = 0
971 CALL lec_dof_jnt(iout,is_encrypted,unitab,kxx,cxx,sdxmi,
972 . sdxma,fcombx,kfx,fmx,ifun_cxx,ifun_xx,1,
973 . fac_ff,ifun_fmx,red,id,titr,
974 . lsubmodel)
975 CALL lec_dof_jnt(iout,is_encrypted,unitab,kyy,cyy,sdymi,
976 . sdyma,fcomby,kfy,fmy,ifun_cyy,ifun_yy,2,
977 . fac_ff,ifun_fmy,red,id,titr,
978 . lsubmodel)
979 CALL lec_dof_jnt(iout,is_encrypted,unitab,kzz,czz,sdzmi,
980 . sdzma,fcombz,kfz,fmz,ifun_czz,ifun_zz,3,
981 . fac_ff,ifun_fmz,red,id,titr,
982 . lsubmodel)
983 CALL lec_dof_jnt(iout,is_encrypted,unitab,krx,crx,saxmi,
984 . saxma,fcombrx,kfrx,fmrx,ifun_crx,ifun_rx,4,
985 . fac_mm,ifun_fmrx,red,id,titr,
986 . lsubmodel)
987 CALL lec_dof_jnt(iout,is_encrypted,unitab,kry,cry,saymi,
988 . sayma,fcombry,kfry,fmry,ifun_cry,ifun_ry,5,
989 . fac_mm,ifun_fmry,red,id,titr,
990 . lsubmodel)
991 CALL lec_dof_jnt(iout,is_encrypted,unitab,krz,crz,sazmi,
992 . sazma,fcombrz,kfrz,fmrz,ifun_crz,ifun_rz,6,
993 . fac_mm,ifun_fmrz,red,id,titr,
994 . lsubmodel)
995C
996 IF ((red/=0).AND.(red/=6)) THEN
997 CALL ancmsg(msgid=973,
998 . msgtype=msgerror,
999 . anmode=aninfo_blind_2,
1000 . i1=id,
1001 . c1=titr,
1002 . i2=red,
1003 . i3=6)
1004 ENDIF
1005C
1006 ELSE
1007C WRITE(IOUT,*)' **ERROR WRONG JOINT TYPE'
1008 CALL ancmsg(msgid=938,
1009 . msgtype=msgerror,
1010 . anmode=aninfo_blind_2,
1011 . i1=id,
1012 . c1=titr,
1013 . i2=jtyp)
1014 END IF
1015
1016C=======================================================================
1017C---- Check of combined stopping displacements / angles
1018C=================================================================
1019C
1020 comb_error = 0
1021 sumt = fcombx+fcomby+fcombz
1022 sumr = fcombrx+fcombry+fcombrz
1023C
1024C--- Check for combined displacements - values must be the same for combined dof
1025C
1026 IF (sumt == one) THEN
1027 CALL ancmsg(msgid=1599,
1028 . msgtype=msgerror,
1029 . anmode=aninfo_blind_2,
1030 . i1=id,
1031 . c1=titr)
1032 ELSEIF (sumt > one) THEN
1033 alpha_plus = (fcombx*sdxma+fcomby*sdyma+fcombz*sdzma)/sumt
1034 alpha_moin = (fcombx*sdxmi+fcomby*sdymi+fcombz*sdzmi)/sumt
1035 IF ((fcombx>em20).AND.(abs(alpha_plus - sdxma)/max(em20,abs(alpha_plus))>em10)) comb_error = 1
1036 IF ((fcomby>em20).AND.(abs(alpha_plus - sdyma)/max(em20,abs(alpha_plus))>em10)) comb_error = 1
1037 IF ((fcombz>em20).AND.(abs(alpha_plus - sdzma)/max(em20,abs(alpha_plus))>em10)) comb_error = 1
1038 IF ((fcombx>em20).AND.(abs(alpha_moin - sdxmi)/max(em20,abs(alpha_moin))>em10)) comb_error = 1
1039 IF ((fcomby>em20).AND.(abs(alpha_moin - sdymi)/max(em20,abs(alpha_moin))>em10)) comb_error = 1
1040 IF ((fcombz>em20).AND.(abs(alpha_moin - sdzmi)/max(em20,abs(alpha_moin))>em10)) comb_error = 1
1041 ENDIF
1042C
1043C--- Check for combined angles - values must be the same for combined dof
1044C
1045 IF (sumr == one) THEN
1046 CALL ancmsg(msgid=1600,
1047 . msgtype=msgerror,
1048 . anmode=aninfo_blind_2,
1049 . i1=id,
1050 . c1=titr)
1051 ELSEIF (sumr > one) THEN
1052 alpha_plus = (fcombrx*saxma+fcombry*sayma+fcombrz*sazma)/sumr
1053 alpha_moin = (fcombrx*saxmi+fcombry*saymi+fcombrz*sazmi)/sumr
1054 IF ((fcombrx>em20).AND.(abs(alpha_plus - saxma)/max(em20,abs(alpha_plus))>em10)) comb_error = 1
1055 IF ((fcombry>em20).AND.(abs(alpha_plus - sayma)/max(em20,abs(alpha_plus))>em10)) comb_error = 1
1056 IF ((fcombrz>em20).AND.(abs(alpha_plus - sazma)/max(em20,abs(alpha_plus))>em10)) comb_error = 1
1057 IF ((fcombrx>em20).AND.(abs(alpha_moin - saxmi)/max(em20,abs(alpha_moin))>em10)) comb_error = 1
1058 IF ((fcombry>em20).AND.(abs(alpha_moin - saymi)/max(em20,abs(alpha_moin))>em10)) comb_error = 1
1059 IF ((fcombrz>em20).AND.(abs(alpha_moin - sazmi)/max(em20,abs(alpha_moin))>em10)) comb_error = 1
1060 ENDIF
1061C
1062 IF (comb_error==1) THEN
1063 CALL ancmsg(msgid=1598,
1064 . msgtype=msgerror,
1065 . anmode=aninfo_blind_2,
1066 . i1=id,
1067 . c1=titr)
1068 ENDIF
1069
1070C=======================================================================
1071C---- Data storage
1072C=================================================================
1073 pargeo(1) = 0
1074 pargeo(2) = 0
1075 pargeo(3) = 0
1076C-----------------------
1077
1078 ierror = set_u_geo(1,xtyp)
1079 ierror = set_u_geo(2,sensr)
1080 ierror = set_u_geo(3,skewr)
1081 ierror = set_u_geo(4,kxx)
1082 ierror = set_u_geo(5,kyy)
1083 ierror = set_u_geo(6,kzz)
1084 ierror = set_u_geo(7,krx)
1085 ierror = set_u_geo(8,kry)
1086 ierror = set_u_geo(9,krz)
1087 ierror = set_u_geo(10,knn)
1088 ierror = set_u_geo(11,scf)
1089C
1090 ierror = set_u_geo(12,cr)
1091 ierror = set_u_geo(13,zero)
1092 ierror = set_u_geo(14,zero)
1093 ierror = set_u_geo(15,crxx)
1094 ierror = set_u_geo(16,cryy)
1095 ierror = set_u_geo(17,crzz)
1096 ierror = set_u_geo(18,crrx)
1097 ierror = set_u_geo(19,crry)
1098 ierror = set_u_geo(20,crrz)
1099 ierror = set_u_geo(21,cxx)
1100 ierror = set_u_geo(22,cyy)
1101 ierror = set_u_geo(23,czz)
1102 ierror = set_u_geo(24,crx)
1103 ierror = set_u_geo(25,cry)
1104 ierror = set_u_geo(26,crz)
1105C IERROR = SET_U_GEO(27,FAC_CTX)
1106C IERROR = SET_U_GEO(28,FAC_CRX)
1107 ierror = set_u_geo(27,fac_l)
1108 ierror = set_u_geo(28,fac_t)
1109C------------Blocking Angles/displacements
1110 ierror = set_u_geo(29,sdxmi)
1111 ierror = set_u_geo(30,sdxma)
1112 ierror = set_u_geo(31,sdymi)
1113 ierror = set_u_geo(32,sdyma)
1114 ierror = set_u_geo(33,sdzmi)
1115 ierror = set_u_geo(34,sdzma)
1116 ierror = set_u_geo(35,saxmi)
1117 ierror = set_u_geo(36,saxma)
1118 ierror = set_u_geo(37,saymi)
1119 ierror = set_u_geo(38,sayma)
1120 ierror = set_u_geo(39,sazmi)
1121 ierror = set_u_geo(40,sazma)
1122C------------Friction parameters
1123 ierror = set_u_geo(41,kfx)
1124 ierror = set_u_geo(42,kfy)
1125 ierror = set_u_geo(43,kfz)
1126 ierror = set_u_geo(44,kfrx)
1127 ierror = set_u_geo(45,kfry)
1128 ierror = set_u_geo(46,kfrz)
1129 ierror = set_u_geo(47,fmx)
1130 ierror = set_u_geo(48,fmy)
1131 ierror = set_u_geo(49,fmz)
1132 ierror = set_u_geo(50,fmrx)
1133 ierror = set_u_geo(51,fmry)
1134 ierror = set_u_geo(52,fmrz)
1135C------------Skews for initial angles
1136 ierror = set_u_geo(53,xidsk1)
1137 ierror = set_u_geo(54,xidsk2)
1138C------------Combination flag for stopping angles / displacements
1139 ierror = set_u_geo(55,fcombx)
1140 ierror = set_u_geo(56,fcomby)
1141 ierror = set_u_geo(57,fcombz)
1142 ierror = set_u_geo(58,fcombrx)
1143 ierror = set_u_geo(59,fcombry)
1144 ierror = set_u_geo(60,fcombrz)
1145C------------Functions
1146 ierror = set_u_pnu(1,ifun_xx,kfunc)
1147 ierror = set_u_pnu(2,ifun_yy,kfunc)
1148 ierror = set_u_pnu(3,ifun_zz,kfunc)
1149 ierror = set_u_pnu(4,ifun_rx,kfunc)
1150 ierror = set_u_pnu(5,ifun_ry,kfunc)
1151 ierror = set_u_pnu(6,ifun_rz,kfunc)
1152 ierror = set_u_pnu(7,ifun_cxx,kfunc)
1153 ierror = set_u_pnu(8,ifun_cyy,kfunc)
1154 ierror = set_u_pnu(9,ifun_czz,kfunc)
1155 ierror = set_u_pnu(10,ifun_crx,kfunc)
1156 ierror = set_u_pnu(11,ifun_cry,kfunc)
1157 ierror = set_u_pnu(12,ifun_crz,kfunc)
1158 ierror = set_u_pnu(13,ifun_fmx,kfunc)
1159 ierror = set_u_pnu(14,ifun_fmy,kfunc)
1160 ierror = set_u_pnu(15,ifun_fmz,kfunc)
1161 ierror = set_u_pnu(16,ifun_fmrx,kfunc)
1162 ierror = set_u_pnu(17,ifun_fmry,kfunc)
1163 ierror = set_u_pnu(18,ifun_fmrz,kfunc)
1164C
1165C-----------------------------
1166C PROPERTY BUFFER
1167C-----------------------------
1168C
1169 prop_tag(igtyp)%G_FOR = 3
1170 prop_tag(igtyp)%G_MOM = 3
1171 prop_tag(igtyp)%G_TOTDEPL = 3
1172 prop_tag(igtyp)%G_TOTROT = 3
1173 prop_tag(igtyp)%G_SKEW = 3
1174 prop_tag(igtyp)%G_MASS = 1
1175 prop_tag(igtyp)%G_NUVAR = nuvar
1176 prop_tag(igtyp)%G_LENGTH_ERR = 3
1177C
1178 RETURN
1179 100 FORMAT(
1180 & 5x,'JOINT TYPE . . . . . . . . SPHERICAL JOINT'/)
1181 200 FORMAT(
1182 & 5x,'JOINT TYPE . . . . . . . . REVOLUTE JOINT'/)
1183 300 FORMAT(
1184 & 5x,'JOINT TYPE . . . . . . . . CYLINDRICAL JOINT'/)
1185 400 FORMAT(
1186 & 5x,'JOINT TYPE . . . . . . . . PLANAR JOINT'/)
1187 500 FORMAT(
1188 & 5x,'JOINT TYPE . . . . . . . . UNIVERSAL JOINT'/)
1189 600 FORMAT(
1190 & 5x,'JOINT TYPE . . . . . . . . TRANSLATIONAL JOINT'/)
1191 700 FORMAT(
1192 & 5x,'JOINT TYPE . . . . . . . . OLDHAM JOINT'/)
1193 800 FORMAT(
1194 & 5x,'JOINT TYPE . . . . . . . . RIGID JOINT'/)
1195 900 FORMAT(
1196 & 5x,'JOINT TYPE . . . . . . . . FREE JOINT'/)
1197
1198 1000 FORMAT(
1199 & 5x,'BLOCKING STIFFNESS KNN . . . . . . . . . . =',1pg20.13/,
1200 & 5x,'SCAL. FACTOR FOR ROT. BLOCKING STIFFNESS . .=',1pg20.13/,
1201 & 5x,'CRITICAL DAMPING COEFFICIENT . . . . . . . =',1pg20.13/,
1202 & 5x,'SENSOR ID . . . . . . . . . . . . . . . . . =',i10/)
1203
1204 1100 FORMAT(
1205 & 5x,'BLOCKING STIFFNESS KNN . . . . . . . . . . =',' AUTO'/,
1206 & 5x,'SCALING FACTOR FOR AUTOMATIC STIFFNESS . =',1pg20.13/,
1207 & 5x,'CRITICAL DAMPING COEFFICIENT . . . . . . . =',1pg20.13/,
1208 & 5x,'SENSOR ID . . . . . . . . . . . . . . . . =',i10/)
1209
1210 1200 FORMAT(
1211 & 5x,'BLOCKING STIFFNESS KNN . . . . . . . . . . =',1pg20.13/,
1212 & 5x,'SCALING FACTOR FOR AUTOMATIC STIFFNESS . =',1pg20.13/,
1213 & 5x,'CRITICAL DAMPING COEFFICIENT . . . . . . . =',1pg20.13/,
1214 & 5x,'SENSOR ID . . . . . . . . . . . . . . . . =',i10/,
1215 & 5x,'SKEW ID 1 . . . . . . . . . . . . . . . . =',i10/,
1216 & 5x,'SKEW ID 2 . . . . . . . . . . . . . . . . =',i10/)
1217
1218 1300 FORMAT(
1219 & 5x,'BLOCKING STIFFNESS KNN . . . . . . . . . . =',' AUTO'/,
1220 & 5x,'scaling factor for automatic stiffness . =',1PG20.13/,
1221 & 5X,'critical damping coefficient . . . . . . . =',1PG20.13/,
1222 & 5X,'sensor id . . . . . . . . . . . . . . . . =',I10/,
1223 & 5X,'skew id 1 . . . . . . . . . . . . . . . . =',I10/,
1224 & 5X,'skew id 2 . . . . . . . . . . . . . . . . =',I10/)
1225
1226 1400 FORMAT(
1227 & 5X,'user property set'/,
1228 & 5X,'property set number . . . . . . . . . .=',I10)
1229
1230 1500 FORMAT(
1231 & 5X,'user property set'/,
1232 & 5X,'property set number . . . . . . . . . .=',I10,
1233 & 5X,'confidential data'//)
1234
1235 RETURN
1236 END
1237
1238!||====================================================================
1239!|| lec_dof_jnt ../starter/source/properties/spring/hm_read_prop45.F
1240!||--- called by ------------------------------------------------------
1241!|| hm_read_prop45 ../starter/source/properties/spring/hm_read_prop45.F
1242!||--- calls -----------------------------------------------------
1243!|| ancmsg ../starter/source/output/message/message.F
1244!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
1245!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
1246!|| set_u_geo ../starter/source/user_interface/uaccess.F
1247!|| set_u_pnu ../starter/source/user_interface/uaccess.F
1248!||--- uses -----------------------------------------------------
1249!|| message_mod ../starter/share/message_module/message_mod.F
1250!|| submodel_mod ../starter/share/modules1/submodel_mod.F
1251!||====================================================================
1252 SUBROUTINE LEC_DOF_JNT(IOUT,IS_ENCRYPTED,UNITAB,KRX,CRX,SAMI,
1253 . SAMA,FCOMB,KFR,FM,IFUN_CRX,IFUN_RX,IDOF,
1254 . FAC3,IFUN_FM,RED,ID,TITR,LSUBMODEL)
1255C-----------------------------------------------
1256 USE UNITAB_MOD
1257 USE MESSAGE_MOD
1258 USE SUBMODEL_MOD
1259 USE NAMES_AND_TITLES_MOD , ONLY : NCHARTITLE
1260C-----------------------------------------------
1261C I m p l i c i t T y p e s
1262C-----------------------------------------------
1263#include "implicit_f.inc"
1264C-----------------------------------------------
1265C A n a l y s e M o d u l e
1266C-----------------------------------------------
1267C----------+---------+---+---+--------------------------------------------
1268C VAR | SIZE |TYP| RW| DEFINITION
1269C----------+---------+---+---+--------------------------------------------
1270C IIN | 1 | I | R | INPUT FILE UNIT (D00 file)
1271C IOUT | 1 | I | R | OUTPUT FILE UNIT (L00 file)
1272C----------+---------+---+---+--------------------------------------------
1273C PARGEO | * | F | W | 1)SKEW NUMBER
1274C | | | | 2)STIFNESS FOR INTERFACE
1275C | | | | 3)FRONT WAVE OPTION
1276C | | | | 4)... not yet used
1277C----------+---------+---+---+------------------------------------------|
1278C D u m m y A r g u m e n t s
1279C-----------------------------------------------
1280 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
1281 INTEGER IOUT,IFUN_CRX,IFUN_RX,IDOF,RED,IFUN_FM
1282 my_real KRX,CRX,SAMI,SAMA,KFR,FM,FAC3,FCOMB
1283 INTEGER ID
1284 CHARACTER(LEN=NCHARTITLE) :: TITR
1285 LOGICAL IS_ENCRYPTED
1286 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
1287C=======================================================================
1288C L o c a l V a r i a b l e s
1289C-----------------------------------------------
1290 INTEGER SET_U_PNU,SET_U_GEO,ICOMB,READ_BLOCK,I
1291 EXTERNAL SET_U_PNU,SET_U_GEO
1292 LOGICAL IS_AVAILABLE(10)
1293C=======================================================================
1294C---- READING OF THE DATA BLOCK FOR FREE DOF
1295C=======================================================================
1296C
1297 IF (IDOF == 1) THEN
1298C--------------------------------------------------
1299C EXTRACT DATAS (INTEGER VALUES)
1300C--------------------------------------------------
1301 CALL HM_GET_INTV('xt_fun',IFUN_RX,IS_AVAILABLE(1),LSUBMODEL)
1302 CALL HM_GET_INTV('ctx_fun',IFUN_CRX,IS_AVAILABLE(2),LSUBMODEL)
1303 CALL HM_GET_INTV('fun_a1',IFUN_FM,IS_AVAILABLE(3),LSUBMODEL)
1304 CALL HM_GET_INTV('icomb_tx',ICOMB,IS_AVAILABLE(4),LSUBMODEL)
1305C--------------------------------------------------
1306C EXTRACT DATAS (REAL VALUES)
1307C-------------------------------------------------
1308 CALL HM_GET_FLOATV('ktx',KRX,IS_AVAILABLE(5),LSUBMODEL,UNITAB)
1309 CALL HM_GET_FLOATV('type12_xn',SAMI,IS_AVAILABLE(6),LSUBMODEL,UNITAB)
1310 CALL HM_GET_FLOATV('type12_xc',SAMA,IS_AVAILABLE(7),LSUBMODEL,UNITAB)
1311 CALL HM_GET_FLOATV('ctx',CRX,IS_AVAILABLE(8),LSUBMODEL,UNITAB)
1312 CALL HM_GET_FLOATV('vx',KFR,IS_AVAILABLE(9),LSUBMODEL,UNITAB)
1313 CALL HM_GET_FLOATV('prop_x_f',FM,IS_AVAILABLE(10),LSUBMODEL,UNITAB)
1314C-------------------------
1315 ELSEIF (IDOF == 2) THEN
1316C--------------------------------------------------
1317C EXTRACT DATAS (INTEGER VALUES)
1318C--------------------------------------------------
1319 CALL HM_GET_INTV('yt_fun',IFUN_RX,IS_AVAILABLE(1),LSUBMODEL)
1320 CALL HM_GET_INTV('cty_fun',IFUN_CRX,IS_AVAILABLE(2),LSUBMODEL)
1321 CALL HM_GET_INTV('fun_a2',IFUN_FM,IS_AVAILABLE(3),LSUBMODEL)
1322 CALL HM_GET_INTV('icomb_ty',ICOMB,IS_AVAILABLE(4),LSUBMODEL)
1323C--------------------------------------------------
1324C EXTRACT DATAS (REAL VALUES)
1325C-------------------------------------------------
1326 CALL HM_GET_FLOATV('kty',KRX,IS_AVAILABLE(5),LSUBMODEL,UNITAB)
1327 CALL HM_GET_FLOATV('type12_yn',SAMI,IS_AVAILABLE(6),LSUBMODEL,UNITAB)
1328 CALL HM_GET_FLOATV('type12_yc',SAMA,IS_AVAILABLE(7),LSUBMODEL,UNITAB)
1329 CALL HM_GET_FLOATV('cty',CRX,IS_AVAILABLE(8),LSUBMODEL,UNITAB)
1330 CALL HM_GET_FLOATV('vy',KFR,IS_AVAILABLE(9),LSUBMODEL,UNITAB)
1331 CALL HM_GET_FLOATV('prop_y_f',FM,IS_AVAILABLE(10),LSUBMODEL,UNITAB)
1332C-------------------------
1333 ELSEIF (IDOF == 3) THEN
1334C--------------------------------------------------
1335C EXTRACT DATAS (INTEGER VALUES)
1336C--------------------------------------------------
1337 CALL HM_GET_INTV('zt_fun',IFUN_RX,IS_AVAILABLE(1),LSUBMODEL)
1338 CALL HM_GET_INTV('ctz_fun',IFUN_CRX,IS_AVAILABLE(2),LSUBMODEL)
1339 CALL HM_GET_INTV('fun_a3',IFUN_FM,IS_AVAILABLE(3),LSUBMODEL)
1340 CALL HM_GET_INTV('icomb_tz',ICOMB,IS_AVAILABLE(4),LSUBMODEL)
1341C--------------------------------------------------
1342C EXTRACT DATAS (REAL VALUES)
1343C-------------------------------------------------
1344 CALL HM_GET_FLOATV('ktz',KRX,IS_AVAILABLE(5),LSUBMODEL,UNITAB)
1345 CALL HM_GET_FLOATV('type12_zn',SAMI,IS_AVAILABLE(6),LSUBMODEL,UNITAB)
1346 CALL HM_GET_FLOATV('type12_zc',SAMA,IS_AVAILABLE(7),LSUBMODEL,UNITAB)
1347 CALL HM_GET_FLOATV('ctz',CRX,IS_AVAILABLE(8),LSUBMODEL,UNITAB)
1348 CALL HM_GET_FLOATV('vz',KFR,IS_AVAILABLE(9),LSUBMODEL,UNITAB)
1349 CALL HM_GET_FLOATV('prop_z_f',FM,IS_AVAILABLE(10),LSUBMODEL,UNITAB)
1350C-------------------------
1351 ELSEIF (IDOF == 4) THEN
1352C--------------------------------------------------
1353C EXTRACT DATAS (INTEGER VALUES)
1354C--------------------------------------------------
1355 CALL HM_GET_INTV('xr_fun',IFUN_RX,IS_AVAILABLE(1),LSUBMODEL)
1356 CALL HM_GET_INTV('crx_fun',IFUN_CRX,IS_AVAILABLE(2),LSUBMODEL)
1357 CALL HM_GET_INTV('fun_b1',IFUN_FM,IS_AVAILABLE(3),LSUBMODEL)
1358 CALL HM_GET_INTV('icomb_rx',ICOMB,IS_AVAILABLE(4),LSUBMODEL)
1359C--------------------------------------------------
1360C EXTRACT DATAS (REAL VALUES)
1361C-------------------------------------------------
1362 CALL HM_GET_FLOATV('krx',KRX,IS_AVAILABLE(5),LSUBMODEL,UNITAB)
1363 CALL HM_GET_FLOATV('x_a',SAMI,IS_AVAILABLE(6),LSUBMODEL,UNITAB)
1364 CALL HM_GET_FLOATV('x_b',SAMA,IS_AVAILABLE(7),LSUBMODEL,UNITAB)
1365 CALL HM_GET_FLOATV('crx',CRX,IS_AVAILABLE(8),LSUBMODEL,UNITAB)
1366 CALL HM_GET_FLOATV('vx1',KFR,IS_AVAILABLE(9),LSUBMODEL,UNITAB)
1367 CALL HM_GET_FLOATV('n_x',FM,IS_AVAILABLE(10),LSUBMODEL,UNITAB)
1368C-------------------------
1369 ELSEIF (IDOF == 5) THEN
1370C--------------------------------------------------
1371C EXTRACT DATAS (INTEGER VALUES)
1372C--------------------------------------------------
1373 CALL HM_GET_INTV('yr_fun',IFUN_RX,IS_AVAILABLE(1),LSUBMODEL)
1374 CALL HM_GET_INTV('cry_fun',IFUN_CRX,IS_AVAILABLE(2),LSUBMODEL)
1375 CALL HM_GET_INTV('fun_b2',IFUN_FM,IS_AVAILABLE(3),LSUBMODEL)
1376 CALL HM_GET_INTV('icomb_ry',ICOMB,IS_AVAILABLE(4),LSUBMODEL)
1377C--------------------------------------------------
1378C EXTRACT DATAS (REAL VALUES)
1379C-------------------------------------------------
1380 CALL HM_GET_FLOATV('kry',KRX,IS_AVAILABLE(5),LSUBMODEL,UNITAB)
1381 CALL HM_GET_FLOATV('y_a',SAMI,IS_AVAILABLE(6),LSUBMODEL,UNITAB)
1382 CALL HM_GET_FLOATV('y_b',SAMA,IS_AVAILABLE(7),LSUBMODEL,UNITAB)
1383 CALL HM_GET_FLOATV('cry',CRX,IS_AVAILABLE(8),LSUBMODEL,UNITAB)
1384 CALL HM_GET_FLOATV('vy1',KFR,IS_AVAILABLE(9),LSUBMODEL,UNITAB)
1385 CALL HM_GET_FLOATV('n_y',FM,IS_AVAILABLE(10),LSUBMODEL,UNITAB)
1386C-------------------------
1387 ELSEIF (IDOF == 6) THEN
1388C--------------------------------------------------
1389C EXTRACT DATAS (INTEGER VALUES)
1390C--------------------------------------------------
1391 CALL HM_GET_INTV('zr_fun',IFUN_RX,IS_AVAILABLE(1),LSUBMODEL)
1392 CALL HM_GET_INTV('crz_fun',IFUN_CRX,IS_AVAILABLE(2),LSUBMODEL)
1393 CALL HM_GET_INTV('fun_b3',IFUN_FM,IS_AVAILABLE(3),LSUBMODEL)
1394 CALL HM_GET_INTV('icomb_rz',ICOMB,IS_AVAILABLE(4),LSUBMODEL)
1395C--------------------------------------------------
1396C EXTRACT DATAS (REAL VALUES)
1397C-------------------------------------------------
1398 CALL HM_GET_FLOATV('krz',KRX,IS_AVAILABLE(5),LSUBMODEL,UNITAB)
1399 CALL HM_GET_FLOATV('z_a',SAMI,IS_AVAILABLE(6),LSUBMODEL,UNITAB)
1400 CALL HM_GET_FLOATV('z_b',SAMA,IS_AVAILABLE(7),LSUBMODEL,UNITAB)
1401 CALL HM_GET_FLOATV('crz',CRX,IS_AVAILABLE(8),LSUBMODEL,UNITAB)
1402 CALL HM_GET_FLOATV('vz1',KFR,IS_AVAILABLE(9),LSUBMODEL,UNITAB)
1403 CALL HM_GET_FLOATV('n_z',FM,IS_AVAILABLE(10),LSUBMODEL,UNITAB)
1404C-------------------------
1405 ENDIF
1406C
1407 READ_BLOCK = 0
1408 DO I=1,10
1409 IF (IS_AVAILABLE(I)) READ_BLOCK = READ_BLOCK + 1
1410 ENDDO
1411C
1412 IF (READ_BLOCK > 0) THEN
1413 FCOMB = ICOMB
1414 RED = RED +1
1415 ELSE
1416 GOTO 350
1417 ENDIF
1418C
1419.AND. IF(CRX==ZEROIFUN_CRX/=0) CRX = ONE * FAC3
1420.AND. IF(KRX==ZEROIFUN_RX/=0) KRX = ONE * FAC3
1421.AND. IF(FM==ZEROIFUN_FM/=0) FM = ONE * FAC3
1422C
1423C-----------------------
1424.NOT. IF( IS_ENCRYPTED)THEN
1425 IF (IDOF==1) THEN
1426 WRITE(IOUT,100)
1427 ELSEIF (IDOF==2) THEN
1428 WRITE(IOUT,200)
1429 ELSEIF (IDOF==2) THEN
1430 WRITE(IOUT,300)
1431 ELSEIF (IDOF==4) THEN
1432 WRITE(IOUT,400)
1433 ELSEIF (IDOF==5) THEN
1434 WRITE(IOUT,500)
1435 ELSE
1436 WRITE(IOUT,600)
1437 ENDIF
1438 ENDIF
1439C
1440 IF (SAMI>ZERO) THEN
1441 CALL ANCMSG(MSGID=943,
1442 . MSGTYPE=MSGERROR,
1443 . ANMODE=ANINFO_BLIND_2,
1444 . I1=ID,
1445 . C1=TITR)
1446 ELSEIF (SAMA<ZERO) THEN
1447 CALL ANCMSG(MSGID=944,
1448 . MSGTYPE=MSGERROR,
1449 . ANMODE=ANINFO_BLIND_2,
1450 . I1=ID,
1451 . C1=TITR)
1452 ENDIF
1453C
1454.NOT. IF( IS_ENCRYPTED)THEN
1455 IF (IDOF<4) THEN
1456 IF (IFUN_FM==0) THEN
1457 WRITE(IOUT,1000) KRX,IFUN_RX,CRX,IFUN_CRX,SAMI,SAMA,ICOMB,KFR,FM
1458 ELSE
1459 WRITE(IOUT,3000) KRX,IFUN_RX,CRX,IFUN_CRX,SAMI,SAMA,ICOMB,KFR,IFUN_FM
1460 ENDIF
1461 ELSE
1462 IF (IFUN_FM==0) THEN
1463 WRITE(IOUT,2000) KRX,IFUN_RX,CRX,IFUN_CRX,SAMI,SAMA,ICOMB,KFR,FM
1464 ELSE
1465 WRITE(IOUT,4000) KRX,IFUN_RX,CRX,IFUN_CRX,SAMI,SAMA,ICOMB,KFR,IFUN_FM
1466 ENDIF
1467 ENDIF
1468 ENDIF
1469C
1470350 CONTINUE
1471
1472C-----------------------
1473 RETURN
1474 100 FORMAT(
1475 & 5X,'parameters for free translation along x axis'/)
1476 200 FORMAT(
1477 & 5X,'parameters for free translation along y axis'/)
1478 300 FORMAT(
1479 & 5X,'parameters for free translation along z axis'/)
1480 400 FORMAT(
1481 & 5X,'parameters for free rotation around x axis'/)
1482 500 FORMAT(
1483 & 5X,'parameters for free rotation around y axis'/)
1484 600 FORMAT(
1485 & 5X,'parameters for free rotation around z axis'/)
1486 1000 FORMAT(
1487 & 5X,'translational linear stiffness . . . . =',1PG20.13/,
1488 & 5X,'translational FUNCTION id . . . . . . .=',I10/,
1489 & 5X,'linear damping . . . . . . . . . . . . =',1PG20.13/,
1490 & 5X,'user damping function. . . . . . . . . =',I10/,
1491 & 5X,'negative stop displacement . . . . . . =',1PG20.13/,
1492 & 5X,'positive stop displacement . . . . . . =',1PG20.13/,
1493 & 5X,'combined stop displacement . . . . . . =',I10/,
1494 & 5X,'stiff. for friction and stop displ. . .=',1PG20.13/,
1495 & 5X,'frictional force. . . . . . . . . . . .=',1PG20.13//)
1496 2000 FORMAT(
1497 & 5X,'linear rotational stiffness . . . . . .=',1PG20.13/,
1498 & 5X,'rotational function id . . . . . . . =',I10/,
1499 & 5X,'linear damping . . . . . . . . . . . . =',1PG20.13/,
1500 & 5X,'user damping function. . . . . . . . . =',I10/,
1501 & 5X,'negative stop angle . . . . . .. . . . =',1PG20.13/,
1502 & 5X,'positive stop angle . . . . . .. . . . =',1PG20.13/,
1503 & 5X,'combined stop angle . . . . . .. . . . =',I10/,
1504 & 5X,'stiff. for friction and stop angles. . =',1PG20.13/,
1505 & 5X,'frictional moment. . . . . . . . . . . =',1PG20.13//)
1506 3000 FORMAT(
1507 & 5X,'translational linear stiffness . . . . =',1PG20.13/,
1508 & 5X,'translational function id . . . . . . .=',I10/,
1509 & 5X,'linear damping . . . . . . . . . . . . =',1PG20.13/,
1510 & 5X,'user damping function. . . . . . . . . =',I10/,
1511 & 5X,'negative stop displacement . . . . . . =',1PG20.13/,
1512 & 5X,'positive stop displacement . . . . . . =',1PG20.13/,
1513 & 5X,'combined stop displacement . . . . . . =',I10/,
1514 & 5X,'stiff. for friction and stop displ. . .=',1PG20.13/,
1515 & 5X,'frictional force function. . .. . . . .=',I10//)
1516 4000 FORMAT(
1517 & 5X,'linear rotational stiffness . . . . . .=',1PG20.13/,
1518 & 5X,'rotational function id . . . . . . . =',I10/,
1519 & 5X,'linear damping . . . . . . . . . . . . =',1PG20.13/,
1520 & 5X,'user damping function. . . . . . . . . =',I10/,
1521 & 5X,'negative stop angle . . . . . .. . . . =',1PG20.13/,
1522 & 5X,'positive stop angle . . . . . .. . . . =',1PG20.13/,
1523 & 5X,'combined stop angle . . . . . .. . . . =',I10/,
1524 & 5X,'stiff. for friction and stop angles. . =',1PG20.13/,
1525 & 5X,'frictional moment function. . .. . . . =',I10//)
1526
1527 RETURN
1528 END
1529
my_real
#define my_real
Definition cppsort.cpp:32
damping
subroutine damping(nodft, nodlt, v, vr, a, ar, damp, ms, in, igrnod, dim, itask, weight, tagslv_rby, wfext)
Definition damping.F:882
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_is_encrypted
subroutine hm_option_is_encrypted(is_encrypted)
Definition hm_option_is_encrypted.F:288
lec_dof_jnt
subroutine lec_dof_jnt(iout, is_encrypted, unitab, krx, crx, sami, sama, fcomb, kfr, fm, ifun_crx, ifun_rx, idof, fac3, ifun_fm, red, id, titr, lsubmodel)
Definition hm_read_prop45.F:1255
hm_read_prop45
subroutine hm_read_prop45(iout, nuvar, pargeo, unitab, igtyp, id, prop_tag, titr, lsubmodel, iunit)
Definition hm_read_prop45.F:42
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
elbuftag_mod
Definition elbuftag_mod.F:230
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
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
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
starter
program starter
Definition starter.F:39
elbuftag_mod::prop_tag_
Definition elbuftag_mod.F:377
submodel_mod::submodel_data
Definition submodel_mod.F:728