OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
create_ellipse_clause.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!|| create_ellipse_clause ../starter/source/model/sets/create_ellipse_clause.F
25!||--- called by ------------------------------------------------------
26!|| hm_set ../starter/source/model/sets/hm_set.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!|| subrotpoint ../starter/source/model/submodel/subrot.F
32!||--- uses -----------------------------------------------------
33!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
34!|| message_mod ../starter/share/message_module/message_mod.F
35!|| submodel_mod ../starter/share/modules1/submodel_mod.f
36!||====================================================================
37 SUBROUTINE create_ellipse_clause(ID ,TITLE ,SUB_ID ,SKEW ,RTRANS,
38 . CLAUSE ,NRTRANS ,LSUBMODEL,UNITAB ,ISKN ,
39 . IAD ,NTRANSF ,NUMSKW ,LISKN ,LSKEW ,
40 . SSKEW ,SISKWN ,NSPCOND ,NUMSPH )
41C-----------------------------------------------
42C ROUTINE DESCRIPTION :
43C ===================
44C Create PART Clause from LIST
45C------------------------------------------------------------------
46C DUMMY ARGUMENTS DESCRIPTION:
47C ===================,
48C JCLAUSE parameter with HM_READER (current clause read)
49C IS_AVAILABLE Bool / Result of HM_interface
50C LSUBMODEL SUBMODEL Structure.
51C============================================================================
52C-----------------------------------------------
53C M o d u l e s
54C-----------------------------------------------
55 USE setdef_mod
56 USE submodel_mod
57 USE message_mod
58 USE hm_option_read_mod
59 USE unitab_mod
60 USE my_alloc_mod
61 USE names_and_titles_mod
62C-----------------------------------------------
63C I m p l i c i t T y p e s
64C-----------------------------------------------
65#include "implicit_f.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER, INTENT(INOUT) :: IAD
70 INTEGER, INTENT(IN) :: NTRANSF,NUMSKW,LISKN,LSKEW,NRTRANS,
71 . SSKEW,SISKWN,NSPCOND,NUMSPH
72 INTEGER, INTENT(IN) :: ID,SUB_ID,ISKN(LISKN,SISKWN/LISKN)
73 my_real, INTENT(IN) :: skew(lskew,sskew/lskew),rtrans(ntransf,nrtrans)
74 CHARACTER(LEN=NCHARTITLE), INTENT(IN) :: TITLE
75!
76 TYPE (SET_), INTENT(INOUT) :: CLAUSE
77 TYPE (UNIT_TYPE_),INTENT(IN) :: UNITAB
78 TYPE (SUBMODEL_DATA),INTENT(IN) :: LSUBMODEL(NSUBMOD)
79C-----------------------------------------------
80C L o c a l V a r i a b l e s
81C-----------------------------------------------
82 INTEGER I,J,DGR1,DGR,ISKEW
83!
84 MY_REAL XG,YG,ZG,S_A,S_B,S_C
85 LOGICAL :: lFOUND
86 LOGICAL :: IS_AVAILABLE
87C=======================================================================
88 dgr1=0
89
90 CALL hm_get_intv('Skew_ID' ,iskew,is_available,lsubmodel)
91 CALL hm_get_intv('n' ,dgr1,is_available,lsubmodel)
92
93 clause%ELLIPSE_ID_MADYMO=iskew ! No de l'entite qui impose le mvt de la surface.
94 ! --> No systeme Radioss ou MaDyMO.
95 !skew:temporary storage of user id
96 !get internal id from user id
97
98 lfound=.false.
99 DO j=0,numskw+min(1,nspcond)*numsph+nsubmod
100 IF (iskew==iskn(4,j+1)) THEN
101 iskew=j+1
102 lfound=.true.
103 EXIT
104 ENDIF
105 END DO
106
107 IF(.NOT.lfound)THEN
108 CALL ancmsg(msgid=184,
109 . msgtype=msgerror,
110 . anmode=aninfo,
111 . c1='SURFACE',
112 . i1=id,
113 . c2='SURFACE',
114 . c3=title,
115 . i2=iskew)
116 ELSE
117 ! Init surface rotation
118 !DO J=1,9
119 !!BUFSF(IAD+7+J-1)=SKEW(J,ISKEW)
120 !END DO
121 ENDIF
122
123 CALL hm_get_floatv('Xc' ,xg,is_available,lsubmodel,unitab)
124 CALL hm_get_floatv('Yc' ,yg,is_available,lsubmodel,unitab)
125 CALL hm_get_floatv('Zc' ,zg,is_available,lsubmodel,unitab)
126 IF(sub_id /= 0)CALL subrotpoint(xg,yg,zg,rtrans,sub_id,lsubmodel)
127
128 !BUFSF(IAD+4)=XG
129 !BUFSF(IAD+5)=YG
130 !BUFSF(IAD+6)=ZG
131 !Init application point for force and momentum
132 !/* ellipsoides : defining center ! */
133 !BUFSF(IAD+16)=XG
134 !BUFSF(IAD+17)=YG
135 !BUFSF(IAD+18)=ZG
136
137 CALL hm_get_floatv('a' ,s_a,is_available,lsubmodel,unitab)
138 CALL hm_get_floatv('b' ,s_b,is_available,lsubmodel,unitab)
139 CALL hm_get_floatv('c' ,s_c,is_available,lsubmodel,unitab)
140 dgr = 0
141 IF ( s_a==0. .OR. s_b==0. .OR. s_c==0.) THEN
142 CALL ancmsg(msgid=185,
143 . msgtype=msgerror,
144 . anmode=aninfo,
145 . i1=id,
146 . c1=title)
147 ENDIF
148
149 IF (dgr==0.AND.dgr1==0) THEN
150 dgr1=2
151 ELSEIF (dgr1==0) THEN
152 dgr1=dgr
153 ENDIF
154
155 !BUFSF(IAD+1)=S_A
156 !BUFSF(IAD+2)=S_B
157 !BUFSF(IAD+3)=S_C
158 !BUFSF(IAD+36)=DGR1
159
160
161 ! Copy in final SET
162 ! ------------------
163
164 !------------------------------------!
165 ! create SURF clause !
166 !------------------------------------! print*,"clause ELLIPSE_SECOND", ISKEW
167 clause%NB_ELLIPSE=1 ! only one ellipsoid per /SET
168 CALL my_alloc(clause%ELLIPSE_SKEW,9)
169
170 clause%ELLIPSE_IAD_BUFR= iad ! Analytical Surfaces address (reals BUFSF - temp)
171
172 clause%ELLIPSE_N=dgr1
173 clause%ELLIPSE_XC=xg
174 clause%ELLIPSE_YC=yg
175 clause%ELLIPSE_ZC=zg
176 clause%ELLIPSE_A=s_a
177 clause%ELLIPSE_B=s_b
178 clause%ELLIPSE_C=s_c
179 clause%ELLIPSE_SKEW(1:9)=skew(1:9,iskew)
180
181 iad=iad+36
182!
183 RETURN
184 END
my_real
#define my_real
Definition cppsort.cpp:32
create_ellipse_clause
subroutine create_ellipse_clause(id, title, sub_id, skew, rtrans, clause, nrtrans, lsubmodel, unitab, iskn, iad, ntransf, numskw, liskn, lskew, sskew, siskwn, nspcond, numsph)
Definition create_ellipse_clause.F:41
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
min
#define min(a, b)
Definition macros.h:20
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
setdef_mod
Definition setdef_mod.F:107
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
starter
program starter
Definition starter.F:39
subrotpoint
subroutine subrotpoint(x, y, z, rtrans, sub_id, lsubmodel)
Definition subrot.F:180