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
39C-----------------------------------------------
40C I m p l i c i t T y p e s
41C-----------------------------------------------
42#include "implicit_f.inc"
43C-----------------------------------------------
44C C o m m o n B l o c k s
45C-----------------------------------------------
46#include "com04_c.inc"
47#include "scr03_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 INTEGER, INTENT(IN) :: TAGXREF(NUMNOD),IXC(NIXC,*),IXTG(NIXTG,*),IXS(NIXS,*)
52 my_real, INTENT(IN) ::
53 . xrefc(4,3,numelc),xreftg(3,3,numeltg),xrefs(8,3,numels8)
54C-----------------------------------------------
55C L o c a l V a r i a b l e s
56C-----------------------------------------------
57 INTEGER IE,IN,NN,TEMP_INT,NC,ELEM_ID,WORK(70000)
58 CHARACTER (LEN=255) :: VARNAME
59 DOUBLE PRECISION TEMP_DOUBLE
60 INTEGER, ALLOCATABLE, DIMENSION(:) :: INDEX,ITR1
61C-----------------------------------------------
62C S o u r c e L i n e s
63C-----------------------------------------------
64C
65C-----------------------------------------------
66C XREF
67C-----------------------------------------------
68
69 IF (myqakey('/XREF')) THEN
70C
71 WRITE(varname,'(A)') 'NXREF'
72 temp_int = nxref
73 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
74C
75 IF (nxref > 0) THEN
76C
77 DO ie = 1,numelc
78 DO in = 1,4
79 nn = ixc(in+1,ie)
80 IF (tagxref(nn) == 1) THEN
81 ! Number of the node
82 WRITE(varname,'(A)') 'XREFC_NODE'
83 temp_int = nn
84 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
85 ! Coordinate X of the node
86 WRITE(varname,'(A)') 'XREFC_X'
87 temp_double = xrefc(in,1,ie)
88 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
89 ! Coordinate Y of the node
90 WRITE(varname,'(A)') 'XREFC_Y'
91 temp_double = xrefc(in,2,ie)
92 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
93 ! Coordinate Z of the node
94 WRITE(varname,'(A)') 'XREFC_Z'
95 temp_double = xrefc(in,3,ie)
96 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
97 ENDIF
98 ENDDO
99 ENDDO
100C
101 DO ie = 1,numeltg
102 DO in = 1,3
103 nn = ixtg(in+1,ie)
104 IF (tagxref(nn) == 1) THEN
105 ! Number of the node
106 WRITE(varname,'(A)') 'XREFTG_NODE'
107 temp_int = nn
108 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
109 ! Coordinate X of the node
110 WRITE(varname,'(A)') 'XREFTG_X'
111 temp_double = xreftg(in,1,ie)
112 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
113 ! Coordinate Y of the node
114 WRITE(varname,'(A)') 'XREFTG_Y'
115 temp_double = xreftg(in,2,ie)
116 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
117 ! Coordinate Z of the node
118 WRITE(varname,'(A)') 'XREFTG_Z'
119 temp_double = xreftg(in,3,ie)
120 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
121 ENDIF
122 ENDDO
123 ENDDO
124C
125 DO ie = 1,numels8
126 DO in = 1,8
127 nn = ixs(in+1,ie)
128 IF (tagxref(nn) == 1) THEN
129 ! Number of the node
130 WRITE(varname,'(A)') 'XREFS_NODE'
131 temp_int = nn
132 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
133 ! Coordinate X of the node
134 WRITE(varname,'(A)') 'XREFS_X'
135 temp_double = xrefs(in,1,ie)
136 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
137 ! Coordinate Y of the node
138 WRITE(varname,'(A)') 'XREFS_Y'
139 temp_double = xrefs(in,2,ie)
140 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
141 ! Coordinate Z of the node
142 WRITE(varname,'(A)') 'XREFS_Z'
143 temp_double = xrefs(in,3,ie)
144 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
145 ENDIF
146 ENDDO
147 ENDDO
148C
149 ENDIF
150C
151 ENDIF
152
153C-----------------------------------------------
154C EREF
155C-----------------------------------------------
156 IF (myqakey('/EREF')) THEN
157C
158 WRITE(varname,'(A)') 'NEREF'
159 temp_int = neref
160 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
161C
162 IF (neref > 0) THEN
163C
164 CALL my_alloc(index,2*numelc)
165 CALL my_alloc(itr1,numelc)
166C
167 DO ie=1,numelc
168 itr1(ie)=ixc(nixc,ie)
169 ENDDO
170 CALL my_orders(0,work,itr1,index,numelc,1)
171C
172 DO ie = 1,numelc
173 nc=index(ie)
174 elem_id = ixc(nixc,nc)
175C
176 DO in = 1,4
177 nn = ixc(in+1,nc)
178 IF (tagxref(nn) /= 1) THEN
179 ! Id of the element
180 WRITE(varname,'(A,I0)') 'EREF_SHELL_ELEMENT_NODE ',in
181 temp_int = elem_id
182 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
183 IF (xrefc(in,1,nc) > 0) THEN
184 ! Coordinate X of the node
185 WRITE(varname,'(A)') 'EREFC_X'
186 temp_double = xrefc(in,1,nc)
187 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
188 ENDIF
189 IF (xrefc(in,2,nc) > 0) THEN
190 ! Coordinate Y of the node
191 WRITE(varname,'(A)') 'EREFC_Y'
192 temp_double = xrefc(in,2,nc)
193 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
194 ENDIF
195 IF (xrefc(in,3,nc) > 0) THEN
196 ! Coordinate Z of the node
197 WRITE(varname,'(A)') 'EREFC_Z'
198 temp_double = xrefc(in,3,nc)
199 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
200 ENDIF
201 ENDIF
202 ENDDO
203C
204 ENDDO
205 DEALLOCATE(index,itr1)
206C
207 CALL my_alloc(index,2*numeltg)
208 CALL my_alloc(itr1,numeltg)
209C
210 DO ie=1,numeltg
211 itr1(ie)=ixtg(nixtg,ie)
212 ENDDO
213 CALL my_orders(0,work,itr1,index,numeltg,1)
214C
215 DO ie = 1,numeltg
216 nc=index(ie)
217 elem_id = ixtg(nixtg,nc)
218C
219 DO in = 1,3
220 nn = ixtg(in+1,nc)
221 IF (tagxref(nn) /= 1) THEN
222 ! Id of the element
223 WRITE(varname,'(A,I0)') 'EREF_SH3N_ELEMENT_NODE ',in
224 temp_int = elem_id
225 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
226 IF (xreftg(in,1,nc) > 0) THEN
227 ! Coordinate X of the node
228 WRITE(varname,'(A)') 'EREFTG_X'
229 temp_double = xreftg(in,1,nc)
230 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
231 ENDIF
232 IF (xreftg(in,2,nc) > 0) THEN
233 ! Coordinate Y of the node
234 WRITE(varname,'(A)') 'EREFTG_Y'
235 temp_double = xreftg(in,2,nc)
236 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
237 ENDIF
238 IF (xreftg(in,3,nc) > 0) THEN
239 ! Coordinate Z of the node
240 WRITE(varname,'(A)') 'EREFTG_Z'
241 temp_double = xreftg(in,3,nc)
242 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
243 ENDIF
244 ENDIF
245 ENDDO
246C
247 ENDDO
248 DEALLOCATE(index,itr1)
249C
250 CALL my_alloc(index,2*numels8)
251 CALL my_alloc(itr1,numels8)
252C
253 DO ie=1,numels8
254 itr1(ie)=ixs(nixs,ie)
255 ENDDO
256 CALL my_orders(0,work,itr1,index,numels8,1)
257C
258 DO ie = 1,numels8
259 nc=index(ie)
260 elem_id = ixs(nixs,nc)
261C
262 DO in = 1,8
263 nn = ixs(in+1,nc)
264 IF (tagxref(nn) /= 1) THEN
265 ! Id of the element
266 WRITE(varname,'(A,I0)') 'EREF_SOLID_ELEMENT_NODE ',in
267 temp_int = elem_id
268 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
269 IF (xrefs(in,1,nc) > 0) THEN
270 ! Coordinate X of the node
271 WRITE(varname,'(A)') 'EREFS_X'
272 temp_double = xrefs(in,1,nc)
273 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
274 ENDIF
275 IF (xrefs(in,2,nc) > 0) THEN
276 ! Coordinate Y of the node
277 WRITE(varname,'(A)') 'EREFS_Y'
278 temp_double = xrefs(in,2,nc)
279 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
280 ENDIF
281 IF (xrefs(in,3,nc) > 0) THEN
282 ! Coordinate Z of the node
283 WRITE(varname,'(A)') 'EREFS_Z'
284 temp_double = xrefs(in,3,nc)
285 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
286 ENDIF
287 ENDIF
288 ENDDO
289C
290 ENDDO
291 DEALLOCATE(index,itr1)
292C
293 ENDIF
294
295 ENDIF
296
297
298 END SUBROUTINE
my_real
#define my_real
Definition cppsort.cpp:32
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
message_mod
Definition message_mod.F:1249
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