OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_element.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "scr17_c.inc"
#include "scr23_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine st_qaprint_element (ixs, ixs10, ipm, igeo, itab, isolnod, ixr, r_skew, iskwn, ixp, ixt, x, ixc, ixtg, thke, sh4ang, thkec, sh3ang, kxsp, ipartsp, ipart, ixr_kj, kxx, ixx, ipartx, ixri, ixs16, ixq, ibeam_vector, rbeam_vector)

Function/Subroutine Documentation

◆ st_qaprint_element()

subroutine st_qaprint_element ( integer, dimension(nixs,*), intent(in) ixs,
integer, dimension(6,*), intent(in) ixs10,
integer, dimension(npropmi,*), intent(in) ipm,
integer, dimension(npropgi,*), intent(in) igeo,
integer, dimension(*), intent(in) itab,
integer, dimension(*), intent(in) isolnod,
integer, dimension(nixr,*), intent(in) ixr,
integer, dimension(*), intent(in) r_skew,
integer, dimension(liskn,*), intent(in) iskwn,
integer, dimension(nixp,*), intent(in) ixp,
integer, dimension(nixt,*), intent(in) ixt,
dimension(3,numnod), intent(in) x,
integer, dimension(nixc,*), intent(in) ixc,
integer, dimension(nixtg,*), intent(in) ixtg,
dimension(*), intent(in) thke,
dimension(*), intent(in) sh4ang,
dimension(*), intent(in) thkec,
dimension(*), intent(in) sh3ang,
integer, dimension(nisp,*), intent(in) kxsp,
integer, dimension(*), intent(in) ipartsp,
integer, dimension(lipart1,*), intent(in) ipart,
integer, dimension(5,*), intent(in) ixr_kj,
integer, dimension(nixx,*), intent(in) kxx,
integer, dimension(*), intent(in) ixx,
integer, dimension(*), intent(in) ipartx,
integer, dimension(4,*), intent(in) ixri,
integer, dimension(8,*), intent(in) ixs16,
integer, dimension(nixq,*), intent(in) ixq,
integer, dimension(numelp), intent(in) ibeam_vector,
dimension(3,numelp), intent(in) rbeam_vector )

Definition at line 31 of file st_qaprint_element.F.

37C============================================================================
38C M o d u l e s
39C-----------------------------------------------
40 USE qa_out_mod
41 USE message_mod
42 USE my_alloc_mod
43 USE names_and_titles_mod , ONLY : nchartitle
44C-----------------------------------------------
45C I m p l i c i t T y p e s
46C-----------------------------------------------
47#include "implicit_f.inc"
48C-----------------------------------------------
49C C o m m o n B l o c k s
50C-----------------------------------------------
51#include "com04_c.inc"
52#include "param_c.inc"
53#include "scr17_c.inc"
54#include "scr23_c.inc"
55#include "sphcom.inc"
56C-----------------------------------------------
57C D u m m y A r g u m e n t s
58C-----------------------------------------------
59 INTEGER, INTENT(IN) :: IXS(NIXS,*), IXS10(6,*), IPM(NPROPMI,*), IGEO(NPROPGI,*)
60 INTEGER, INTENT(IN) :: ITAB(*), ISOLNOD(*),IXR_KJ(5,*)
61 INTEGER, INTENT(IN) :: IXR(NIXR,*), R_SKEW(*), ISKWN(LISKN,*), IXP(NIXP,*), IXT(NIXT,*),
62 . IXC(NIXC,*),IXTG(NIXTG,*),KXSP(NISP,*),IPARTSP(*),IPART(LIPART1,*),
63 . KXX(NIXX,*),IXX(*),IPARTX(*),IXRI(4,*),IXS16(8,*),IXQ(NIXQ,*)
64 INTEGER, INTENT(IN) :: IBEAM_VECTOR(NUMELP)
65 my_real, INTENT(IN) ::
66 . x(3,numnod),
67 . thke(*),thkec(*),sh4ang(*),sh3ang(*)
68 my_real, INTENT(IN) :: rbeam_vector(3,numelp)
69C--------------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I, J, MY_ID, TEMP_INT, NS, MY_MID, MY_PID, MY_NOD, MY_SKEW,NC
73 INTEGER :: WORK(70000),NUMEL_KJ
74 INTEGER, ALLOCATABLE, DIMENSION(:) :: INDEX,ITR1
75 CHARACTER(LEN=NCHARTITLE)::TITR
76 CHARACTER (LEN=255) :: VARNAME
77 DOUBLE PRECISION TEMP_DOUBLE
78 INTEGER ITETRA4(4),IPENTA6(6)
79 DATA itetra4/2,4,7,6/,ipenta6/2,3,4,6,7,8/
80C-----------------------------------------------
81C Elements
82C-----------------------------------------------
83
84 IF (myqakey('ELEMENTS')) THEN
85C
86C-----------------------------------------------
87C Solid elements
88C-----------------------------------------------
89C
90 CALL my_alloc(index,2*numels)
91 CALL my_alloc(itr1,numels)
92C
93 DO i=1,numels8
94 itr1(i)=ixs(nixs,i)
95 ENDDO
96 CALL my_orders(0,work,itr1,index,numels8,1)
97 DO i=1,numels8
98 ns=index(i)
99C
100 my_id = ixs(nixs,ns)
101 CALL qaprint('A_SOLID_ELEMENT_ID', my_id,0.0_8)
102C
103 my_mid = ipm(1,ixs(1,ns))
104 CALL qaprint('A_SOLID_ELEMENT_MID', my_mid,0.0_8)
105C
106 my_pid = igeo(1,ixs(10,ns))
107 CALL qaprint('A_SOLID_ELEMENT_PID', my_pid,0.0_8)
108C
109 IF(isolnod(ns)==4)THEN
110 DO j=1,4
111 IF(ixs(itetra4(j),ns)/=0)THEN
112C
113C VARNAME: variable name in ref.extract (without blanks)
114C
115 my_nod = itab(ixs(itetra4(j),ns))
116 WRITE(varname,'(A,I0)') 'NODE_',j
117 CALL qaprint(varname(1:len_trim(varname)), my_nod,0.0_8)
118 END IF
119 END DO
120 ELSEIF(isolnod(ns)==6)THEN
121 DO j=1,6
122 IF(ixs(ipenta6(j),ns)/=0)THEN
123C
124C VARNAME: variable name in ref.extract (without blanks)
125C
126 my_nod = itab(ixs(ipenta6(j),ns))
127 WRITE(varname,'(A,I0)') 'NODE_',j
128 CALL qaprint(varname(1:len_trim(varname)), my_nod,0.0_8)
129 END IF
130 END DO
131 ELSEIF(isolnod(ns)==8)THEN
132 DO j=2,9
133 IF(ixs(j,ns)/=0)THEN
134C
135C VARNAME: variable name in ref.extract (without blanks)
136C
137 my_nod = itab(ixs(j,ns))
138 WRITE(varname,'(A,I0)') 'NODE_',j-1
139 CALL qaprint(varname(1:len_trim(varname)), my_nod,0.0_8)
140 END IF
141 END DO
142 END IF
143C
144 END DO ! DO I=1,NUMELS8
145C
146C-----------------------------------------------
147C Tetra10 Elements
148C-----------------------------------------------
149 DO i=1,numels10
150 itr1(i)=ixs(nixs,numels8+i)
151 ENDDO
152 CALL my_orders(0,work,itr1,index,numels10,1)
153C
154 DO i=1,numels10
155 ns=index(i)
156C
157 my_id = ixs(nixs,numels8+ns)
158 CALL qaprint('A_TETRA10_ELEMENT_ID', my_id,0.0_8)
159C
160 my_mid = ipm(1,ixs(1,numels8+ns))
161 CALL qaprint('A_TETRA10_ELEMENT_MID', my_mid,0.0_8)
162C
163 my_pid = igeo(1,ixs(10,numels8+ns))
164 CALL qaprint('A_TETRA10_ELEMENT_PID', my_pid,0.0_8)
165C
166 DO j=1,4
167 IF(ixs(itetra4(j),numels8+ns)/=0)THEN
168C
169C VARNAME: variable name in ref.extract (without blanks)
170C
171 my_nod = itab(ixs(itetra4(j),numels8+ns))
172 WRITE(varname,'(A,I0)') 'NODE_',j
173 CALL qaprint(varname(1:len_trim(varname)), my_nod,0.0_8)
174 END IF
175 END DO
176C
177 DO j=1,6
178 IF(ixs10(j,ns)/=0)THEN
179C
180C VARNAME: variable name in ref.extract (without blanks)
181C
182 my_nod = itab(ixs10(j,ns))
183 WRITE(varname,'(A,I0)') 'NODE_',j+4
184 CALL qaprint(varname(1:len_trim(varname)), my_nod,0.0_8)
185 END IF
186 END DO
187C
188 END DO ! DO I=1,NUMELS10
189C-----------------------------------------------
190C Shell16 elements
191C-----------------------------------------------
192 DO i=1,numels16
193 itr1(i)=ixs(nixs,numels8+numels10+numels20+i)
194 ENDDO
195 CALL my_orders(0,work,itr1,index,numels16,1)
196C
197 DO i=1,numels16
198 ns=index(i)
199C
200 my_id = ixs(nixs,numels8+numels10+numels20+ns)
201 CALL qaprint('A_SHEL16_ELEMENT_ID', my_id,0.0_8)
202C
203 my_mid = ipm(1,ixs(1,numels8+numels10+numels20+ns))
204 CALL qaprint('A_SHEL16_ELEMENT_MID', my_mid,0.0_8)
205C
206 my_pid = igeo(1,ixs(10,numels8+numels10+numels20+ns))
207 CALL qaprint('A_SHEL16_ELEMENT_PID', my_pid,0.0_8)
208C
209 DO j=2,9
210 IF(ixs(j,numels8+numels10+numels20+ns)/=0)THEN
211C
212C VARNAME: variable name in ref.extract (without blanks)
213C
214 my_nod = itab(ixs(j,numels8+numels10+numels20+ns))
215 WRITE(varname,'(A,I0)') 'NODE_',j
216 CALL qaprint(varname(1:len_trim(varname)), my_nod,0.0_8)
217 END IF
218 END DO
219C
220 DO j=1,8
221 IF(ixs16(j,ns)/=0)THEN
222C
223C VARNAME: variable name in ref.extract (without blanks)
224C
225 my_nod = itab(ixs16(j,ns))
226 WRITE(varname,'(A,I0)') 'node_',J+8
227 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
228 END IF
229 END DO
230C
231 END DO ! DO I=1,NUMELS16
232
233 DEALLOCATE(INDEX,ITR1)
234C
235C-----------------------------------------------
236C Spring elements
237C-----------------------------------------------
238C
239 CALL MY_ALLOC(INDEX,2*NUMELR)
240 CALL MY_ALLOC(ITR1,NUMELR)
241C
242 DO I=1,NUMELR
243 ITR1(I)=IXR(NIXR,I)
244 ENDDO
245 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELR,1)
246C
247 DO I=1,NUMELR
248 NS=INDEX(I)
249C
250 MY_ID = IXR(NIXR,NS)
251 CALL QAPRINT('a_spring_element_id', MY_ID,0.0_8)
252C
253 MY_MID = 0
254 IF (IXR(5,NS) > 0) MY_MID = IPM(1,IXR(5,NS))
255 CALL QAPRINT('a_spring_element_mid', MY_MID,0.0_8)
256C
257 MY_PID = IGEO(1,IXR(1,NS))
258 CALL QAPRINT('a_spring_element_pid', MY_PID,0.0_8)
259C
260 DO J=2,3
261 IF(IXR(J,NS)/=0)THEN
262 MY_NOD = ITAB(IXR(J,NS))
263 WRITE(VARNAME,'(a,i0)') 'node_',J-1
264 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
265 END IF
266 END DO
267C
268 IF(IXR(4,NS)/=0)THEN
269 MY_NOD = ITAB(IXR(4,NS))
270 WRITE(VARNAME,'(a,i0)') 'node_',3
271 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
272C
273 TEMP_DOUBLE = X(1,IXR(4,NS))-X(1,IXR(2,NS))
274 CALL QAPRINT('--> vec_n1n3_x', 0,TEMP_DOUBLE)
275 TEMP_DOUBLE = X(2,IXR(4,NS))-X(2,IXR(2,NS))
276 CALL QAPRINT('--> vec_n1n3_y', 0,TEMP_DOUBLE)
277 TEMP_DOUBLE = X(3,IXR(4,NS))-X(3,IXR(2,NS))
278 CALL QAPRINT('--> vec_n1n3_z', 0,TEMP_DOUBLE)
279 END IF
280C
281 IF(R_SKEW(NS)/=0)THEN
282 MY_SKEW = ISKWN(4,R_SKEW(NS))
283 WRITE(VARNAME,'(a,i0)') 'skew_',J-1
284 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_SKEW,0.0_8)
285 END IF
286C
287 END DO ! DO I=1,NUMELR
288C
289 DEALLOCATE(INDEX,ITR1)
290C
291C----- Additional output of IXR_KJ for kjoints
292C
293 IF (NUMELR > 0) THEN
294C
295 NUMEL_KJ = IXR_KJ(1,NUMELR+1)
296 CALL MY_ALLOC(INDEX,2*NUMEL_KJ)
297 CALL MY_ALLOC(ITR1,NUMEL_KJ)
298C
299 DO I=1,NUMEL_KJ
300 ITR1(I)=IXR_KJ(4,I)
301 ENDDO
302 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMEL_KJ,1)
303C
304 DO I=1,NUMEL_KJ
305 NS=INDEX(I)
306C
307 DO J=1,3
308 IF(IXR_KJ(J,NS)/=0)THEN
309 MY_NOD = ITAB(IXR_KJ(J,NS))
310 WRITE(VARNAME,'(a,x,i0,x,a,i0)') 'kjoint_id',IXR_KJ(4,NS),'additional_node_',3+J
311 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
312 END IF
313 END DO
314C
315 ENDDO
316C
317 DEALLOCATE(INDEX,ITR1)
318C
319 ENDIF
320C
321C-----------------------------------------------
322C Beam elements
323C-----------------------------------------------
324C
325 CALL MY_ALLOC(INDEX,2*NUMELP)
326 CALL MY_ALLOC(ITR1,NUMELP)
327C
328 DO I=1,NUMELP
329 ITR1(I)=IXP(NIXP,I)
330 ENDDO
331 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELP,1)
332C
333 DO I=1,NUMELP
334 NS=INDEX(I)
335C
336 MY_ID = IXP(NIXP,NS)
337 CALL QAPRINT('a_beam_element_id', MY_ID,0.0_8)
338C
339 MY_MID = IPM(1,IXP(1,NS))
340 CALL QAPRINT('a_beam_element_mid', MY_MID,0.0_8)
341C
342 MY_PID = IGEO(1,IXP(5,NS))
343 CALL QAPRINT('a_beam_element_pid', MY_PID,0.0_8)
344C
345 DO J=2,3
346 IF(IXP(J,NS)/=0)THEN
347 MY_NOD = ITAB(IXP(J,NS))
348 WRITE(VARNAME,'(a,i0)') 'node_',J-1
349 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
350 END IF
351 END DO
352C
353 IF (IBEAM_VECTOR(NS) == 1) THEN
354 TEMP_DOUBLE = RBEAM_VECTOR(1,NS)
355 CALL QAPRINT('--> input_vec_x', 0,TEMP_DOUBLE)
356 TEMP_DOUBLE = RBEAM_VECTOR(2,NS)
357 CALL QAPRINT('--> input_vec_y', 0,TEMP_DOUBLE)
358 TEMP_DOUBLE = RBEAM_VECTOR(3,NS)
359 CALL QAPRINT('--> input_vec_z', 0,TEMP_DOUBLE)
360 ELSEIF(IXP(4,NS)/=0)THEN
361 MY_NOD = ITAB(IXP(4,NS))
362 WRITE(VARNAME,'(a,i0)') 'node_',J-1
363 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
364C
365 TEMP_DOUBLE = X(1,IXP(4,NS))-X(1,IXP(2,NS))
366 CALL QAPRINT('--> vec_n1n3_x', 0,TEMP_DOUBLE)
367 TEMP_DOUBLE = X(2,IXP(4,NS))-X(2,IXP(2,NS))
368 CALL QAPRINT('--> vec_n1n3_y', 0,TEMP_DOUBLE)
369 TEMP_DOUBLE = X(3,IXP(4,NS))-X(3,IXP(2,NS))
370 CALL QAPRINT('--> vec_n1n3_z', 0,TEMP_DOUBLE)
371 END IF
372C
373 END DO ! DO I=1,NUMELP
374C
375 DEALLOCATE(INDEX,ITR1)
376C
377C-----------------------------------------------
378C Truss elements
379C-----------------------------------------------
380C
381 CALL MY_ALLOC(INDEX,2*NUMELT)
382 CALL MY_ALLOC(ITR1,NUMELT)
383C
384 DO I=1,NUMELT
385 ITR1(I)=IXT(NIXT,I)
386 ENDDO
387 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELT,1)
388C
389 DO I=1,NUMELT
390 NS=INDEX(I)
391C
392 MY_ID = IXT(NIXT,NS)
393 CALL QAPRINT('a_truss_element_id', MY_ID,0.0_8)
394C
395 MY_MID = IPM(1,IXT(1,NS))
396 CALL QAPRINT('a_truss_element_mid', MY_MID,0.0_8)
397C
398 MY_PID = IGEO(1,IXT(4,NS))
399 CALL QAPRINT('a_truss_element_pid', MY_PID,0.0_8)
400C
401 DO J=2,3
402 IF(IXT(J,NS)/=0)THEN
403 MY_NOD = ITAB(IXT(J,NS))
404 WRITE(VARNAME,'(a,i0)') 'node_',J-1
405 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
406 END IF
407 END DO
408C
409 END DO ! DO I=1,NUMELT
410C
411 DEALLOCATE(INDEX,ITR1)
412C
413C-----------------------------------------------
414C SHELL elements
415C-----------------------------------------------
416 CALL MY_ALLOC(INDEX,2*NUMELC)
417 CALL MY_ALLOC(ITR1,NUMELC)
418C
419 DO I=1,NUMELC
420 ITR1(I)=IXC(NIXC,I)
421 ENDDO
422
423 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELC,1)
424 DO I=1,NUMELC
425 NC=INDEX(I)
426C
427 MY_ID = IXC(NIXC,NC)
428 CALL QAPRINT('a_shell_element_id', MY_ID,0.0_8)
429C
430 MY_MID = IPM(1,IXC(1,NC))
431 CALL QAPRINT('a_shell_element_mid', MY_MID,0.0_8)
432C
433 MY_PID = IGEO(1,IXC(6,NC))
434 CALL QAPRINT('a_shell_element_pid', MY_PID,0.0_8)
435C
436 DO J=1,4
437 MY_NOD = ITAB(IXC(J+1,NC))
438 WRITE(VARNAME,'(a,i0)') 'node_',J
439 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
440 END DO
441C
442 WRITE(VARNAME,'(a,i0)') 'thk_'
443 TEMP_DOUBLE = THKE(NC)
444 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
445C
446 WRITE(VARNAME,'(a,i0)') 'angle_'
447 TEMP_DOUBLE = SH4ANG(NC)
448 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
449
450 ENDDO
451 DEALLOCATE(INDEX,ITR1)
452C-----------------------------------------------
453C QUAD elements
454C-----------------------------------------------
455 CALL MY_ALLOC(INDEX,2*NUMELQ)
456 CALL MY_ALLOC(ITR1,NUMELQ)
457C
458 DO I=1,NUMELQ
459 ITR1(I)=IXQ(NIXQ,I)
460 ENDDO
461
462 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELQ,1)
463 DO I=1,NUMELQ
464 NC=INDEX(I)
465C
466 MY_ID = IXQ(NIXQ,NC)
467 CALL QAPRINT('a_quad_element_id', MY_ID,0.0_8)
468C
469 MY_MID = IPM(1,IXQ(1,NC))
470 CALL QAPRINT('a_quad_element_mid', MY_MID,0.0_8)
471C
472 MY_PID = IGEO(1,IXQ(6,NC))
473 CALL QAPRINT('a_quad_element_pid', MY_PID,0.0_8)
474C
475 DO J=1,4
476 MY_NOD = ITAB(IXQ(J+1,NC))
477 WRITE(VARNAME,'(a,i0)') 'node_',J
478 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
479 END DO
480C
481 ENDDO
482 DEALLOCATE(INDEX,ITR1)
483C-----------------------------------------------
484C SH3N elements
485C-----------------------------------------------
486 CALL MY_ALLOC(INDEX,2*NUMELTG)
487 CALL MY_ALLOC(ITR1,NUMELTG)
488C
489 DO I=1,NUMELTG
490 ITR1(I)=IXTG(NIXTG,I)
491 ENDDO
492
493 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELTG,1)
494 DO I=1,NUMELTG
495 NC=INDEX(I)
496C
497 MY_ID = IXTG(NIXTG,NC)
498 CALL QAPRINT('a_sh3n_element_id', MY_ID,0.0_8)
499C
500 MY_MID = IPM(1,IXTG(1,NC))
501 CALL QAPRINT('a_sh3n_element_mid', MY_MID,0.0_8)
502C
503 MY_PID = IGEO(1,IXTG(5,NC))
504 CALL QAPRINT('a_sh3n_element_pid', MY_PID,0.0_8)
505C
506 DO J=1,3
507 MY_NOD = ITAB(IXTG(J+1,NC))
508 WRITE(VARNAME,'(a,i0)') 'node_',J
509 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_NOD,0.0_8)
510 END DO
511C
512 WRITE(VARNAME,'(a,i0)') 'thk_'
513 TEMP_DOUBLE = THKEC(NC)
514 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
515C
516 WRITE(VARNAME,'(a,i0)') 'angle_'
517 TEMP_DOUBLE = SH3ANG(NC)
518 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
519
520 ENDDO
521 DEALLOCATE(INDEX,ITR1)
522C
523C-----------------------------------------------
524C Sph elements
525C-----------------------------------------------
526 CALL MY_ALLOC(INDEX,2*NUMSPH)
527 CALL MY_ALLOC(ITR1,NUMSPH)
528C
529 DO I=1,NUMSPH
530 ITR1(I)=KXSP(NISP,I)
531 ENDDO
532 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMSPH,1)
533C
534 DO I=1,NUMSPH
535C
536 NS=INDEX(I)
537C
538 MY_ID = KXSP(NISP,NS)
539 CALL QAPRINT('a_sph_cell_element_id', MY_ID,0.0_8)
540C
541 MY_ID = IPARTSP(NS)
542 CALL QAPRINT('a_sph_cell_part_id', MY_ID,0.0_8)
543
544 MY_MID = IPART(1,IPARTSP(NS))
545 CALL QAPRINT('a_sph_cell_mid', MY_MID,0.0_8)
546C
547 MY_PID = IGEO(1,IPART(2,IPARTSP(NS)))
548 CALL QAPRINT('a_sph_cell_pid', MY_PID,0.0_8)
549C
550 DO J=2,7
551 MY_ID = KXSP(J,NS)
552 IF (MY_ID /= 0) THEN
553 WRITE(VARNAME,'(a,i0)') 'kxsp_',J
554 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), MY_ID,0.0_8)
555 ENDIF
556 ENDDO
557C
558 ENDDO
559 DEALLOCATE(INDEX,ITR1)
560C-----------------------------------------------
561C Xelem elements
562C-----------------------------------------------
563 CALL MY_ALLOC(INDEX,2*NUMELX)
564 CALL MY_ALLOC(ITR1,NUMELX)
565C
566 DO I=1,NUMELX
567 ITR1(I)=KXX(NIXX,I)
568 ENDDO
569 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMELX,1)
570C
571 DO I=1,NUMELX
572C
573 NS=INDEX(I)
574C
575 MY_ID = KXX(NIXX,NS)
576 CALL QAPRINT('a_xelem_element_id', MY_ID,0.0_8)
577C
578 MY_ID = IPARTX(NS)
579 CALL QAPRINT('a_xelem_part_id', MY_ID,0.0_8)
580C
581 DO J=1,KXX(3,NS)
582 MY_ID = ITAB(IXX(KXX(4,NS)+J-1))
583 IF (MY_ID /= 0) THEN
584 WRITE(VARNAME,'(a,i0)') 'ixx_',kxx(4,ns)+j
585 CALL qaprint(varname(1:len_trim(varname)), my_id,0.0_8)
586 ENDIF
587 ENDDO
588C
589 ENDDO
590 DEALLOCATE(index,itr1)
591C-----------------------------------------------
592C Rivet elements
593C-----------------------------------------------
594 CALL my_alloc(index,2*nrivet)
595 CALL my_alloc(itr1,nrivet)
596C
597 DO i=1,nrivet
598 itr1(i)=ixri(4,i)
599 ENDDO
600 CALL my_orders(0,work,itr1,index,nrivet,1)
601C
602 DO i=1,nrivet
603C
604 ns=index(i)
605C
606 my_id = ixri(4,ns)
607 CALL qaprint('A_RIVET_ELEMENT_ID', my_id,0.0_8)
608C
609 my_id = igeo(1,ixri(1,ns))
610 CALL qaprint('A_RIVET_PID', my_id,0.0_8)
611C
612 DO j=1,2
613 my_id = itab(ixri(j+1,ns))
614 IF (my_id /= 0) THEN
615 WRITE(varname,'(A,I0)') 'IXRI_',j
616 CALL qaprint(varname(1:len_trim(varname)), my_id,0.0_8)
617 ENDIF
618 ENDDO
619C
620 ENDDO
621 DEALLOCATE(index,itr1)
622C-----------------------------------------------
623 END IF
624C-----------------------------------------------
625 RETURN
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
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
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