OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_reference_state.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!|| st_qaprint_reference_state ../starter/source/output/qaprint/st_qaprint_reference_state.F
25!||--- called by ------------------------------------------------------
26!|| st_qaprint_driver ../starter/source/output/qaprint/st_qaprint_driver.F
27!||--- calls -----------------------------------------------------
28!||--- uses -----------------------------------------------------
29!|| message_mod ../starter/share/message_module/message_mod.F
30!||====================================================================
31 SUBROUTINE st_qaprint_reference_state(XREFC ,XREFTG ,XREFS ,TAGXREF,
32 . IXS ,IXC ,IXTG )
33C-----------------------------------------------
34C M o d u l e s
35C-----------------------------------------------
36 USE my_alloc_mod
37 USE qa_out_mod
38 USE message_mod
39 use element_mod , only : nixs,nixc,nixtg
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com04_c.inc"
48#include "scr03_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER, INTENT(IN) :: TAGXREF(NUMNOD),IXC(NIXC,*),IXTG(NIXTG,*),IXS(NIXS,*)
53 my_real, INTENT(IN) ::
54 . xrefc(4,3,numelc),xreftg(3,3,numeltg),xrefs(8,3,numels8)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER IE,IN,NN,TEMP_INT,NC,ELEM_ID,WORK(70000)
59 CHARACTER (LEN=255) :: VARNAME
60 DOUBLE PRECISION TEMP_DOUBLE
61 INTEGER, ALLOCATABLE, DIMENSION(:) :: INDEX,ITR1
62C-----------------------------------------------
63C S o u r c e L i n e s
64C-----------------------------------------------
65C
66C-----------------------------------------------
67C XREF
68C-----------------------------------------------
69
70 IF (myqakey('/XREF')) THEN
71C
72 WRITE(varname,'(A)') 'NXREF'
73 temp_int = nxref
74 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
75C
76 IF (nxref > 0) THEN
77C
78 DO ie = 1,numelc
79 DO in = 1,4
80 nn = ixc(in+1,ie)
81 IF (tagxref(nn) == 1) THEN
82 ! Number of the node
83 WRITE(varname,'(A)') 'XREFC_NODE'
84 temp_int = nn
85 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
86 ! Coordinate X of the node
87 WRITE(varname,'(A)') 'XREFC_X'
88 temp_double = xrefc(in,1,ie)
89 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
90 ! Coordinate Y of the node
91 WRITE(varname,'(A)') 'XREFC_Y'
92 temp_double = xrefc(in,2,ie)
93 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
94 ! Coordinate Z of the node
95 WRITE(varname,'(a)') 'xrefc_z'
96 TEMP_DOUBLE = XREFC(IN,3,IE)
97 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
98 ENDIF
99 ENDDO
100 ENDDO
101C
102 DO IE = 1,NUMELTG
103 DO IN = 1,3
104 NN = IXTG(IN+1,IE)
105 IF (TAGXREF(NN) == 1) THEN
106 ! Number of the node
107 WRITE(VARNAME,'(a)') 'xreftg_node'
108 TEMP_INT = NN
109 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
110 ! Coordinate X of the node
111 WRITE(VARNAME,'(a)') 'xreftg_x'
112 TEMP_DOUBLE = XREFTG(IN,1,IE)
113 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
114 ! Coordinate Y of the node
115 WRITE(VARNAME,'(a)') 'xreftg_y'
116 TEMP_DOUBLE = XREFTG(IN,2,IE)
117 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
118 ! Coordinate Z of the node
119 WRITE(VARNAME,'(a)') 'xreftg_z'
120 TEMP_DOUBLE = XREFTG(IN,3,IE)
121 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
122 ENDIF
123 ENDDO
124 ENDDO
125C
126 DO IE = 1,NUMELS8
127 DO IN = 1,8
128 NN = IXS(IN+1,IE)
129 IF (TAGXREF(NN) == 1) THEN
130 ! Number of the node
131 WRITE(VARNAME,'(a)') 'xrefs_node'
132 TEMP_INT = NN
133 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
134 ! Coordinate X of the node
135 WRITE(VARNAME,'(a)') 'xrefs_x'
136 TEMP_DOUBLE = XREFS(IN,1,IE)
137 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
138 ! Coordinate Y of the node
139 WRITE(VARNAME,'(a)') 'xrefs_y'
140 TEMP_DOUBLE = XREFS(IN,2,IE)
141 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
142 ! Coordinate Z of the node
143 WRITE(VARNAME,'(a)') 'xrefs_z'
144 TEMP_DOUBLE = XREFS(IN,3,IE)
145 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
146 ENDIF
147 ENDDO
148 ENDDO
149C
150 ENDIF
151C
152 ENDIF
153
154C-----------------------------------------------
155C EREF
156C-----------------------------------------------
157 IF (MYQAKEY('/eref')) THEN
158C
159 WRITE(VARNAME,'(a)') 'neref'
160 TEMP_INT = NEREF
161 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
162C
163 IF (NEREF > 0) THEN
164C
165 CALL MY_ALLOC(INDEX,2*NUMELC)
166 CALL MY_ALLOC(ITR1,NUMELC)
167C
168 DO IE=1,NUMELC
169 ITR1(IE)=IXC(NIXC,IE)
170 ENDDO
171 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELC,1)
172C
173 DO IE = 1,NUMELC
174 NC=INDEX(IE)
175 ELEM_ID = IXC(NIXC,NC)
176C
177 DO IN = 1,4
178 NN = IXC(IN+1,NC)
179 IF (TAGXREF(NN) /= 1) THEN
180 ! Id of the element
181 WRITE(VARNAME,'(a,i0)') 'eref_shell_element_node ',IN
182 TEMP_INT = ELEM_ID
183 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
184 IF (XREFC(IN,1,NC) > 0) THEN
185 ! Coordinate X of the node
186 WRITE(VARNAME,'(a)') 'erefc_x'
187 TEMP_DOUBLE = XREFC(IN,1,NC)
188 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
189 ENDIF
190 IF (XREFC(IN,2,NC) > 0) THEN
191 ! Coordinate Y of the node
192 WRITE(VARNAME,'(a)') 'erefc_y'
193 TEMP_DOUBLE = XREFC(IN,2,NC)
194 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
195 ENDIF
196 IF (XREFC(IN,3,NC) > 0) THEN
197 ! Coordinate Z of the node
198 WRITE(VARNAME,'(a)') 'erefc_z'
199 TEMP_DOUBLE = XREFC(IN,3,NC)
200 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
201 ENDIF
202 ENDIF
203 ENDDO
204C
205 ENDDO
206 DEALLOCATE(INDEX,ITR1)
207C
208 CALL MY_ALLOC(INDEX,2*NUMELTG)
209 CALL MY_ALLOC(ITR1,NUMELTG)
210C
211 DO IE=1,NUMELTG
212 ITR1(IE)=IXTG(NIXTG,IE)
213 ENDDO
214 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELTG,1)
215C
216 DO IE = 1,NUMELTG
217 NC=INDEX(IE)
218 ELEM_ID = IXTG(NIXTG,NC)
219C
220 DO IN = 1,3
221 NN = IXTG(IN+1,NC)
222 IF (TAGXREF(NN) /= 1) THEN
223 ! Id of the element
224 WRITE(VARNAME,'(a,i0)') 'eref_sh3n_element_node ',IN
225 TEMP_INT = ELEM_ID
226 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
227 IF (XREFTG(IN,1,NC) > 0) THEN
228 ! Coordinate X of the node
229 WRITE(VARNAME,'(a)') 'ereftg_x'
230 TEMP_DOUBLE = XREFTG(IN,1,NC)
231 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
232 ENDIF
233 IF (XREFTG(IN,2,NC) > 0) THEN
234 ! Coordinate Y of the node
235 WRITE(VARNAME,'(a)') 'ereftg_y'
236 TEMP_DOUBLE = XREFTG(IN,2,NC)
237 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
238 ENDIF
239 IF (XREFTG(IN,3,NC) > 0) THEN
240 ! Coordinate Z of the node
241 WRITE(VARNAME,'(a)') 'ereftg_z'
242 TEMP_DOUBLE = XREFTG(IN,3,NC)
243 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
244 ENDIF
245 ENDIF
246 ENDDO
247C
248 ENDDO
249 DEALLOCATE(INDEX,ITR1)
250C
251 CALL MY_ALLOC(INDEX,2*NUMELS8)
252 CALL MY_ALLOC(ITR1,NUMELS8)
253C
254 DO IE=1,NUMELS8
255 ITR1(IE)=IXS(NIXS,IE)
256 ENDDO
257 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELS8,1)
258C
259 DO IE = 1,NUMELS8
260 NC=INDEX(IE)
261 ELEM_ID = IXS(NIXS,NC)
262C
263 DO IN = 1,8
264 NN = IXS(IN+1,NC)
265 IF (TAGXREF(NN) /= 1) THEN
266 ! Id of the element
267 WRITE(VARNAME,'(a,i0)') 'eref_solid_element_node ',IN
268 TEMP_INT = ELEM_ID
269 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
270 IF (XREFS(IN,1,NC) > 0) THEN
271 ! Coordinate X of the node
272 WRITE(VARNAME,'(a)') 'erefs_x'
273 TEMP_DOUBLE = XREFS(IN,1,NC)
274 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
275 ENDIF
276 IF (XREFS(IN,2,NC) > 0) THEN
277 ! Coordinate Y of the node
278 WRITE(VARNAME,'(a)') 'erefs_y'
279 TEMP_DOUBLE = XREFS(IN,2,NC)
280 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
281 ENDIF
282 IF (XREFS(IN,3,NC) > 0) THEN
283 ! Coordinate Z of the node
284 WRITE(VARNAME,'(a)') 'erefs_z'
285 TEMP_DOUBLE = XREFS(IN,3,NC)
286 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
287 ENDIF
288 ENDIF
289 ENDDO
290C
291 ENDDO
292 DEALLOCATE(INDEX,ITR1)
293C
294 ENDIF
295
296 ENDIF
297
298
299 END SUBROUTINE
my_real
#define my_real
Definition cppsort.cpp:32
message_mod
Definition message_mod.F:1257
qa_out_mod
Definition qa_out_mod.F:78
qa_out_mod::myqakey
logical function myqakey(value)
@purpose Check if a given value is part of the values set by env variable Useful to make a condition ...
Definition qa_out_mod.F:694
qa_out_mod::qaprint
subroutine qaprint(name, idin, value)
@purpose print one entry to QA extract file example of call for real print CALL QAPRINT('MY_LABEL',...
Definition qa_out_mod.F:390
st_qaprint_reference_state
subroutine st_qaprint_reference_state(xrefc, xreftg, xrefs, tagxref, ixs, ixc, ixtg)
Definition st_qaprint_reference_state.F:33