OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_model_tools.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_model_tools ../starter/source/output/qaprint/st_qaprint_model_tools.F
25!||--- called by ------------------------------------------------------
26!|| st_qaprint_driver ../starter/source/output/qaprint/st_qaprint_driver.f
27!||--- calls -----------------------------------------------------
28!|| fretitl2 ../starter/source/starter/freform.F
29!||--- uses -----------------------------------------------------
30!|| func2d_mod ../starter/share/modules1/func2d_mod.F
31!|| submodel_mod ../starter/share/modules1/submodel_mod.F
32!|| table_mod ../starter/share/modules1/table_mod.F
33!||====================================================================
34 SUBROUTINE st_qaprint_model_tools(NOM_OPT ,INOM_OPT ,
35 . IBOX ,IPMAS ,NOM_SECT ,NSTRF ,SECBUF ,
36 . SKEW ,ISKWN ,XFRAME ,NPC ,PLD ,
37 . TABLE ,NPTS ,IACTIV ,FACTIV,SENSORS ,
38 . FUNC2D)
39C============================================================================
40C M o d u l e s
41C-----------------------------------------------
42 USE qa_out_mod
43 USE optiondef_mod
44 USE table_mod
45 USE sensor_mod
46 USE func2d_mod
47 USE submodel_mod , ONLY : nsubmod
48 USE names_and_titles_mod , ONLY : nchartitle, ncharline
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com04_c.inc"
57#include "param_c.inc"
58#include "scr17_c.inc"
59#include "tabsiz_c.inc"
60#include "sphcom.inc"
61#include "lagmult.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 INTEGER, INTENT(IN) :: NOM_OPT(LNOPT1,SNOM_OPT1), INOM_OPT(SINOM_OPT)
66 TYPE (BOX_) ,DIMENSION(NBBOX) ,INTENT(IN) :: IBOX
67 TYPE (ADMAS_) ,DIMENSION(NODMAS) ,INTENT(IN) :: IPMAS
68 INTEGER, INTENT(IN) :: NPTS,NPC(*)
69 INTEGER,INTENT(IN) :: NOM_SECT(SNOM_SECT),NSTRF(SNSTRF)
70 my_real,INTENT(IN) :: secbuf(ssecbuf)
71 INTEGER, INTENT(IN) :: ISKWN(LISKN,*)
72 my_real, INTENT(IN) :: skew(lskew,*)
73 my_real, INTENT(IN) :: xframe(nxframe,*)
74 my_real, INTENT(IN) :: pld(*)
75 INTEGER, INTENT(IN) :: IACTIV(LACTIV,*)
76 my_real, INTENT(IN) :: factiv(lractiv,*)
77 TYPE(ttable) TABLE(*)
78 TYPE (SENSORS_) ,INTENT(IN) :: SENSORS
79 TYPE(func2d_struct), DIMENSION(NFUNC2D), INTENT(IN) :: FUNC2D
80C-----------------------------------------------
81C NOM_OPT(LNOPT1,SNOM_OPT1)
82C * Possibly, NOM_OPT(1) = ID
83C NOM_OPT(LNOPT1-LTITL+1:LTITL) <=> TITLES of the OPTIONS
84C--------------------------------------------------
85C SNOM_OPT1= NRBODY+NACCELM+NVOLU+NINTER+NINTSUB+
86C + NRWALL+NJOINT+NSECT+NLINK+
87C + NUMSKW+1+NUMFRAM+1+NFXBODY+NFLOW+NRBE2+
88C + NRBE3+NSUBMOD+NFXVEL+NUMBCS+NUMMPC+
89C + NGJOINT+NUNIT0+NFUNCT+NADMESH+
90C + NSPHIO+NSPCOND+NRBYKIN+NEBCS+
91C + NINICRACK+NODMAS+NBGAUGE+NCLUSTER+NINTERFRIC+
92C + NRBMERGE
93C-----------------------------------------------
94C INOM_OPT(SINOM_OPT)
95C--------------------------------------------------
96C INOM_OPT(1) = NRBODY
97C INOM_OPT(2) = INOM_OPT(1) + NACCELM
98C INOM_OPT(3) = INOM_OPT(2) + NVOLU
99C INOM_OPT(4) = INOM_OPT(3) + NINTER
100C INOM_OPT(5) = INOM_OPT(4) + NINTSUB
101C INOM_OPT(6) = INOM_OPT(5) + NRWALL
102C INOM_OPT(7) = INOM_OPT(6)
103C INOM_OPT(8) = INOM_OPT(7) + NJOINT
104C INOM_OPT(9) = INOM_OPT(8) + NSECT
105C INOM_OPT(10)= INOM_OPT(9) + NLINK
106C INOM_OPT(11)= INOM_OPT(10)+ NUMSKW+1+NUMFRAM+1+NSUBMOD
107C INOM_OPT(12)= INOM_OPT(11)+ NFXBODY
108C INOM_OPT(13)= INOM_OPT(12)+ NFLOW
109C INOM_OPT(14)= INOM_OPT(13)+ NRBE2
110C INOM_OPT(15)= INOM_OPT(14)+ NRBE3
111C INOM_OPT(16)= INOM_OPT(15)+ NFXVEL
112C INOM_OPT(17)= INOM_OPT(16)+ NUMBCS
113C INOM_OPT(18)= INOM_OPT(17)+ NUMMPC
114C INOM_OPT(19)= INOM_OPT(18)+ NGJOINT
115C INOM_OPT(20)= INOM_OPT(19)+ NUNIT0
116C INOM_OPT(21)= INOM_OPT(20)+ NFUNCT
117C INOM_OPT(22)= INOM_OPT(21)+ NADMESH
118C INOM_OPT(23)= INOM_OPT(22)+ NSPHIO
119C INOM_OPT(24)= INOM_OPT(23)+ NSPCOND
120C INOM_OPT(25)= INOM_OPT(24)+ NEBCS
121C INOM_OPT(26)= INOM_OPT(25)+ NINICRACK
122C INOM_OPT(27)= INOM_OPT(26)+ NODMAS
123C INOM_OPT(28)= INOM_OPT(27)+ NBGAUGE
124C INOM_OPT(29)= INOM_OPT(28)+ NCLUSTER
125C INOM_OPT(30)= INOM_OPT(29)+ NINTERFRIC
126C INOM_OPT(31)= INOM_OPT(30)+ NRBMERGE
127C .. TO BE MAINTAINED (cf doc/inom_opt.txt) ..
128C-----------------------------------------------
129C L o c a l V a r i a b l e s
130C-----------------------------------------------
131 INTEGER I,J,IAD,OPT_ID,NDIM,NY,NOTABLE
132 CHARACTER(LEN=255) :: VARNAME
133 CHARACTER(LEN=nchartitle) :: TITR, TEMP_STRING
134 DOUBLE PRECISION TEMP_DOUBLE
135 INTEGER :: TEMP_INTEGER
136 INTEGER :: ISECT, K0, K1, K2, K3, K4, K5, K6, K7, K8, K9, K10, KR0
137 INTEGER :: NNOD,NSEGS,NSEGQ,NSEGC,NSEGT,NSEGP,NSEGR,NSEGTG,NBINTER,
138 . isen,intval
139 INTEGER :: WORK(70000),INDEX(2*(NUMFRAM+1)),IFRAME,ITR1(NUMFRAM+1)
140 INTEGER :: INDEXS(2*(SENSORS%NSENSOR+1)),ITRS(SENSORS%NSENSOR+1)
141 LOGICAL :: OK_QA
142 DOUBLE PRECISION :: TIME, FVAL, XX, YY, ZZ
143 INTEGER :: NPT, ID, II, LENTITR, ICODE
144 INTEGER, DIMENSION(NTABLE + NFUNC2D) :: IDX, IDS
145C-----------------------------------------------
146C /BOX/...
147C-----------------------------------------------
148 IF (myqakey('/BOX')) THEN
149 DO iad = 1,nbbox
150 !Title of the option was not stored in NOM_OPT ... TBD
151 titr = ibox(iad)%TITLE
152 opt_id = ibox(iad)%ID
153 IF (len_trim(titr)/=0) THEN
154 CALL qaprint(titr(1:len_trim(titr)),opt_id,0.0_8)
155 ELSE
156 CALL qaprint('BOX_FAKE_NAME',opt_id,0.0_8)
157 END IF
158c---
159 WRITE(varname,'(A)') 'TYPE'
160 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%TYPE,0.0_8)
161c
162 WRITE(varname,'(A)') 'NBOXBOX'
163 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%NBOXBOX,0.0_8)
164c
165 WRITE(varname,'(A)') 'NOD1'
166 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%NOD1,0.0_8)
167c
168 WRITE(varname,'(A)') 'ISKBOX'
169 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%ISKBOX,0.0_8)
170c
171 WRITE(varname,'(A)') 'NOD2'
172 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%NOD2,0.0_8)
173c
174 WRITE(varname,'(A)') 'NBLEVELS'
175 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%NBLEVELS,0.0_8)
176c
177 WRITE(varname,'(A)') 'LEVEL'
178 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%LEVEL,0.0_8)
179c
180 WRITE(varname,'(A)') 'ACTIBOX'
181 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%ACTIBOX,0.0_8)
182c
183 WRITE(varname,'(A)') 'NENTITY'
184 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%NENTITY,0.0_8)
185c
186 WRITE(varname,'(A)') 'SURFIAD'
187 CALL qaprint(varname(1:len_trim(varname)),ibox(iad)%SURFIAD,0.0_8)
188c
189 WRITE(varname,'(A)') 'DIAM'
190 temp_double = ibox(iad)%DIAM
191 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
192c
193 WRITE(varname,'(A)') 'X1'
194 temp_double = ibox(iad)%X1
195 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
196 WRITE(varname,'(A)') 'Y1'
197 temp_double = ibox(iad)%Y1
198 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
199c
200 WRITE(varname,'(A)') 'Z1'
201 temp_double = ibox(iad)%Z1
202 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
203c
204 WRITE(varname,'(A)') 'x2'
205 TEMP_DOUBLE = IBOX(IAD)%X2
206 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
207c
208 WRITE(VARNAME,'(a)') 'y2'
209 TEMP_DOUBLE = IBOX(IAD)%Y2
210 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
211c
212 WRITE(VARNAME,'(a)') 'z2'
213 TEMP_DOUBLE = IBOX(IAD)%Z2
214 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
215c
216 IF (IBOX(IAD)%NBOXBOX > 0) THEN
217 DO I=1,IBOX(IAD)%NBOXBOX
218 WRITE(VARNAME,'(a,i0)') 'boxid_',I
219 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),IBOX(IAD)%IBOXBOX(I),0.0_8)
220 ENDDO
221 ENDIF
222
223 END DO
224 END IF ! /BOX/
225
226c-----------------------------------------------
227c /ADMAS
228c-----------------------------------------------
229 IF (MYQAKEY('/admas')) THEN
230 DO IAD = 1,NODMAS
231 TITR = IPMAS(IAD)%TITLE
232 OPT_ID = IPMAS(IAD)%ID
233 IF (LEN_TRIM(TITR)/=0) THEN
234 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),OPT_ID,0.0_8)
235 ELSE
236 CALL QAPRINT('box_fake_name',OPT_ID,0.0_8)
237 END IF
238c
239 WRITE(VARNAME,'(a)') 'TYPE'
240 CALL qaprint(varname(1:len_trim(varname)),ipmas(iad)%TYPE,0.0_8)
241c
242 WRITE(varname,'(A)') 'WEIGHT_FLAG'
243 CALL qaprint(varname(1:len_trim(varname)),ipmas(iad)%WEIGHT_FLAG,0.0_8)
244c
245 WRITE(varname,'(A)') 'NPART'
246 CALL qaprint(varname(1:len_trim(varname)),ipmas(iad)%NPART,0.0_8)
247c
248 IF (ipmas(iad)%NPART > 0) THEN
249 DO i=1,ipmas(iad)%NPART
250 WRITE(varname,'(A,I0)') 'PARTID_',i
251 CALL qaprint(varname(1:len_trim(varname)),ipmas(iad)%PARTID(i),0.0_8)
252 temp_double = ipmas(iad)%PART(i)%RPMAS
253 WRITE(varname,'(A,I0)') 'MAS_',i
254 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
255 ENDDO
256 ENDIF
257 END DO
258 END IF ! /ADMAS
259
260C-----------------------------------------------
261C SECTIONS : /SECT, /SECT/CIRCLE, /SECT/PARAL
262C-----------------------------------------------
263 IF ( myqakey('SECTIONS') ) THEN
264 DO i=1,min(30,snstrf)
265 IF(nstrf(i) /= 0)THEN
266 WRITE(varname,'(A,I0)') 'SECTIONS__NSTRF_',i
267 temp_integer = nstrf(i)
268 CALL qaprint(varname(1:len_trim(varname)),temp_integer,0.0_8)
269 END IF
270 END DO
271 DO i=1,min(10,ssecbuf)
272 IF(secbuf(i) /= 0)THEN
273 WRITE(varname,'(A,I0)') 'SECTIONS__SECBUF_',i
274 temp_double = secbuf(i)
275 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
276 END IF
277 END DO
278 k0=31
279 kr0=11
280 DO isect = 1,nsect
281 CALL fretitl2(titr, nom_opt(lnopt1-ltitr+1, inom_opt(8) + isect), ltitr)
282 opt_id = nom_opt(1,inom_opt(8)+isect)
283 IF (len_trim(titr)/=0) THEN
284 CALL qaprint(titr(1:len_trim(titr)),opt_id,0.0_8)
285 ELSE
286 CALL qaprint('SECTION_NO_NAME',opt_id,0.0_8)
287 END IF
288 DO j=1,ncharline
289 temp_string(j:j)=char( nom_sect( (isect-1)*ncharline+j ))
290 ENDDO
291 IF (len_trim(temp_string) > 0) THEN
292 CALL qaprint( trim(temp_string), 0 , 0.0_8)
293 ELSE
294 CALL qaprint( "NO_FILE_NAME", 0 , 0.0_8)
295 ENDIF
296 nnod=nstrf(k0+6)
297 nsegs=nstrf(k0+7)
298 nsegq=nstrf(k0+8)
299 nsegc=nstrf(k0+9)
300 nsegt=nstrf(k0+10)
301 nsegp=nstrf(k0+11)
302 nsegr=nstrf(k0+12)
303 nsegtg=nstrf(k0+13)
304 nbinter=nstrf(k0+14)
305 k1=k0+30
306 k2=k1+nnod
307 k3=k2+nbinter
308 k4=k3+2*nsegs
309 k5=k4+2*nsegq
310 k6=k5+2*nsegc
311 k7=k6+2*nsegt
312 k8=k7+2*nsegp
313 k9=k8+2*nsegr
314 DO i=k0,min(nstrf(k0+24)-1,snstrf)
315 IF(nstrf(i) /= 0)THEN
316 WRITE(varname,'(A,I0,A,I0)') 'SECTIONS__',opt_id,"_NSTRF_",i
317 temp_integer = nstrf(i)
318 CALL qaprint(varname(1:len_trim(varname)),temp_integer,0.0_8)
319 END IF
320 END DO
321 DO i=kr0,min(ssecbuf,nstrf(k0+25))
322 IF(secbuf(i) /= 0)THEN
323 WRITE(varname,'(A,I0,A,I0)') 'SECTIONS__',opt_id,"_SECBUF_",i
324 temp_double = secbuf(i)
325 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
326 END IF
327 END DO
328 IF(k0+24 <= snstrf) k0 = nstrf(k0+24)
329 if(k0+25 <= snstrf) kr0 = nstrf(k0+25)
330 ENDDO !next ISECT
331c-----------
332 END IF ! SECTIONS
333C-----------------------------------------------
334C SKEWS : /SKEW/FIX, /SKEW/MOV, /SKEW/MOV2
335C-----------------------------------------------
336 IF ( myqakey('SKEWS') ) THEN
337
338 DO iad=1,numskw+1
339
340 CALL fretitl2(titr, nom_opt(lnopt1-ltitr+1,inom_opt(10)+iad), ltitr)
341C
342 IF(len_trim(titr)/=0)THEN
343 CALL qaprint(titr(1:len_trim(titr)),iskwn(4,iad),0.0_8)
344 ELSE
345 CALL qaprint('A_SKEW_FAKE_NAME',iskwn(4,iad),0.0_8)
346 END IF
347C
348 DO i=1,liskn
349 IF(iskwn(i,iad)/=0)THEN
350C VARNAME: variable name in ref.extract (without blanks)
351 WRITE(varname,'(A,I0)') 'ISKWN_',i
352 CALL qaprint(varname(1:len_trim(varname)),iskwn(i,iad),0.0_8)
353 END IF
354 END DO
355C
356 DO i=1,lskew
357 IF(skew(i,iad)/=zero)THEN
358C VARNAME: variable name in ref.extract (without blanks)
359 WRITE(varname,'(A,I0)') 'SKEW_',i
360 temp_double = skew(i,iad)
361 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
362 END IF
363 END DO
364C
365 ENDDO
366
367 DO iad=numskw+2,numskw+1+min(1,nspcond)*numsph
368C
369 CALL qaprint('A_SPH_SKEW_FAKE_NAME',iskwn(4,iad),0.0_8)
370C
371 DO i=1,liskn
372 IF(iskwn(i,iad)/=0)THEN
373C VARNAME: variable name in ref.extract (without blanks)
374 WRITE(varname,'(A,I0)') 'ISKWN_',i
375 CALL qaprint(varname(1:len_trim(varname)),iskwn(i,iad),0.0_8)
376 END IF
377 END DO
378C
379 DO i=1,lskew
380 IF(skew(i,iad)/=zero)THEN
381C VARNAME: variable name in ref.extract (without blanks)
382 WRITE(varname,'(A,I0)') 'SKEW_',i
383 temp_double = skew(i,iad)
384 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
385 END IF
386 END DO
387C
388 ENDDO
389C
390 DO iad=numskw+1+min(1,nspcond)*numsph+1,numskw+1+min(1,nspcond)*numsph+nsubmod
391C
392 CALL qaprint('A_SUBMODEL_SKEW_FAKE_NAME',iskwn(4,iad),0.0_8)
393C
394 DO i=1,liskn
395 IF(iskwn(i,iad)/=0)THEN
396C VARNAME: variable name in ref.extract (without blanks)
397 WRITE(varname,'(A,I0)') 'ISKWN_',i
398 CALL qaprint(varname(1:len_trim(varname)),iskwn(i,iad),0.0_8)
399 END IF
400 END DO
401C
402 DO i=1,lskew
403 IF(skew(i,iad)/=zero)THEN
404C VARNAME: variable name in ref.extract (without blanks)
405 WRITE(varname,'(A,I0)') 'skew_',I
406 TEMP_DOUBLE = SKEW(I,IAD)
407 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
408 END IF
409 END DO
410C
411 ENDDO
412C
413 END IF ! SKEWS
414C
415C-----------------------------------------------
416C FRAMES : /FRAME/FIX, /FRAME/MOV, /FRAME/MOV2, /FRAME/NODE
417C-----------------------------------------------
418 IF ( MYQAKEY('frames') ) THEN
419C
420 DO IFRAME=1,NUMFRAM+1
421 ITR1(IFRAME)=ISKWN(4,NUMSKW+1+MIN(1,NSPCOND)*NUMSPH+NSUBMOD+IFRAME)+2
422 ENDDO
423 CALL MY_ORDERS(0,WORK,ITR1,INDEX,NUMFRAM+1,1)
424C
425 DO IFRAME=1,NUMFRAM+1
426 IAD = INDEX(IFRAME)
427 CALL FRETITL2(TITR, NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(10)+NUMSKW+1+IAD), LTITR)
428C
429 IF(LEN_TRIM(TITR)/=0)THEN
430 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),ISKWN(4,NUMSKW+1+MIN(1,NSPCOND)*NUMSPH+NSUBMOD+IAD),0.0_8)
431 ELSE
432 CALL QAPRINT('a_frame_fake_name',ISKWN(4,NUMSKW+1+MIN(1,NSPCOND)*NUMSPH+NSUBMOD+IAD),0.0_8)
433 END IF
434C
435 DO I=1,LISKN
436 IF(ISKWN(I,NUMSKW+1+MIN(1,NSPCOND)*NUMSPH+NSUBMOD+IAD)/=0)THEN
437C VARNAME: variable name in ref.extract (without blanks)
438 WRITE(VARNAME,'(a,i0)') 'iskwn_',I
439 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),ISKWN(I,NUMSKW+1+MIN(1,NSPCOND)*NUMSPH+NSUBMOD+IAD),0.0_8)
440 END IF
441 END DO
442C
443 DO I=1,NXFRAME
444 IF(XFRAME(I,IAD)/=ZERO)THEN
445C VARNAME: variable name in ref.extract (without blanks)
446 WRITE(VARNAME,'(a,i0)') 'xframe_',I
447 TEMP_DOUBLE = XFRAME(I,IAD)
448 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
449 END IF
450 END DO
451C
452 ENDDO
453C
454 END IF ! FRAMES
455c-----------
456C-----------------------------------------------
457C /TABLE
458C-----------------------------------------------
459 IF ( MYQAKEY('table') ) THEN
460 DO IAD = 1, NTABLE
461 IDX(IAD) = IAD
462 ENDDO
463 CALL QUICKSORT_I(IDX, 1,NTABLE )
464C
465C Title of the option was not stored in NOM_OPT FOR TABLES ONLY FOR FUNCTIONS OR 1D TABLES
466 !CALL FRETITL2(TITR, NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(20)+IAD), LTITR)
467 !OPT_ID = NOM_OPT(1,INOM_OPT(20)+IAD)
468 !IF (LEN_TRIM(TITR)/=0) THEN
469 ! CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),OPT_ID,0.0_8)
470 !ELSE
471 ! CALL QAPRINT('table_no_name',OPT_ID,0.0_8)
472 !END IF
473
474 DO II=1, NTABLE
475 IAD = IDX(II)
476 TITR(1:nchartitle)=''
477 IF(LEN_TRIM(TITR)/=0)THEN
478 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),IAD,0.0_8)
479 ELSE
480 CALL QAPRINT('table_no_name',IAD,0.0_8)
481 END IF
482
483 WRITE(VARNAME,'(a)') 'notable'
484 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TABLE(IAD)%NOTABLE,0.0_8)
485 NOTABLE = TABLE(IAD)%NOTABLE
486
487 WRITE(VARNAME,'(a)') 'ndim'
488 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TABLE(IAD)%NDIM,0.0_8)
489 NDIM = TABLE(IAD)%NDIM
490
491 DO I=1,NDIM
492 NY=SIZE(TABLE(IAD)%X(I)%VALUES)
493 DO J=1,NY
494 WRITE(VARNAME,'(a,i0,a,i0)') 'x',I,' ',J
495 TEMP_DOUBLE = TABLE(IAD)%X(I)%VALUES(J)
496 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
497 ENDDO
498 END DO
499 NY=SIZE(TABLE(IAD)%Y%VALUES)
500 DO J=1,NY
501 WRITE(VARNAME,'(a,i0)') 'y',J
502 TEMP_DOUBLE = TABLE(IAD)%Y%VALUES(J)
503 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
504 ENDDO
505 ENDDO
506C
507 END IF ! TABLES
508c-----------
509C-----------------------------------------------
510C /FUNCT
511C-----------------------------------------------
512 OK_QA = MYQAKEY('/funct')
513.OR. OK_QA = OK_QA MYQAKEY('/move_funct')
514 IF (OK_QA) THEN
515 DO IAD = 1, NFUNCT
516 IDS(IAD) = NOM_OPT(1, INOM_OPT(20) + IAD)
517 IDX(IAD) = IAD
518 ENDDO
519 CALL QUICKSORT_I2(IDS, IDX, 1, NFUNCT)
520 DO II = 1, NFUNCT
521 IAD = IDX(II)
522 TITR(1:nchartitle) = ''
523 ID = NOM_OPT(1, INOM_OPT(20) + IAD)
524 CALL FRETITL2(TITR, NOM_OPT(LNOPT1-LTITR+1, INOM_OPT(20) + IAD), LTITR)
525 LENTITR=LEN_TRIM(TITR)
526 ICODE=0
527 IF(LENTITR>0)ICODE=iachar(TITR(1:1))
528.AND. IF (LENTITR /= 0 ICODE /= 0) THEN
529 CALL QAPRINT(TITR(1:LENTITR), ID, 0.0_8)
530 ELSE
531 CALL QAPRINT('funct_no_name', ID, 0.0_8)
532 ENDIF
533! Number of points
534 NPT = (NPC(IAD + 1) - NPC(IAD)) / 2
535 WRITE(VARNAME,'(a,i0)') 'nb_points_',ID
536 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),NPT,0.0_8)
537 DO I = NPC(IAD), NPC(IAD + 1) - 1, 2
538 TIME = PLD(I)
539 FVAL = PLD(I + 1)
540 WRITE(VARNAME,'(a,i0)') 'time_', (I - NPC(IAD) + 2) / 2
541 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), 0, TIME)
542 WRITE(VARNAME,'(a,i0)') 'funct_value_', (I - NPC(IAD) + 2) / 2
543 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), 0, FVAL)
544 ENDDO
545 ENDDO
546 END IF ! /FUNCT
547C-----------------------------------------------
548C /FUNC_2D
549C-----------------------------------------------
550 IF (OK_QA) THEN
551 DO II = 1, NFUNC2D
552 IDS(II) = FUNC2D(II)%ID
553 IDX(II) = II
554 ENDDO
555 CALL QUICKSORT_I2(IDS, IDX, 1, NFUNC2D)
556 DO II = 1, NFUNC2D
557 IAD = IDX(II)
558 ID = FUNC2D(IAD)%ID
559 CALL QAPRINT("FUNC2D_", ID, 0.0_8)
560 DO I = 1, FUNC2D(IAD)%NPT
561 XX = FUNC2D(IAD)%XVAL(1, I)
562 YY = FUNC2D(IAD)%XVAL(2, I)
563 WRITE(VARNAME,'(a,i0)') 'x_', I
564 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), 0, XX)
565 WRITE(VARNAME,'(a,i0)') 'y_', I
566 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), 0, YY)
567 DO J = 1, FUNC2D(IAD)%DIM
568 ZZ = FUNC2D(IAD)%FVAL(J, I)
569 WRITE(VARNAME,'(a,i0,a,i0)') 'f_', J, '_', I
570 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)), 0, ZZ)
571 ENDDO
572 ENDDO
573 ENDDO
574 ENDIF
575C-----------------------------------------------
576C /ACTIV
577C-----------------------------------------------
578 IF ( MYQAKEY('/activ') ) THEN
579 DO IAD=1,NACTIV
580C
581 CALL QAPRINT('activ',IAD,0.0_8)
582
583 DO I=1,LACTIV
584 IF(IACTIV(I,IAD)/=0)THEN
585C VARNAME: variable name in ref.extract (without blanks)
586 WRITE(VARNAME,'(a,i0)') 'iactiv_',I
587 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),IACTIV(I,IAD),0.0_8)
588 END IF
589 END DO
590
591 DO I=1,LRACTIV
592 IF(FACTIV(I,IAD)/=0)THEN
593 WRITE(VARNAME,'(a,i0)') 'factiv_',I
594 TEMP_DOUBLE = FACTIV(I,IAD)
595 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
596 END IF
597 END DO
598 ENDDO
599 END IF ! /ACTIV
600C-----------------------------------------------
601C SENSORS
602C-----------------------------------------------
603 IF (MYQAKEY('sensor') ) THEN
604C
605 DO ISEN=1,SENSORS%NSENSOR
606 ITRS(ISEN) = SENSORS%SENSOR_TAB(ISEN)%SENS_ID
607 ENDDO
608 CALL MY_ORDERS(0,WORK,ITRS,INDEXS,SENSORS%NSENSOR,1)
609C
610 DO ISEN=1,SENSORS%NSENSOR
611 IAD = INDEXS(ISEN)
612 OPT_ID = SENSORS%SENSOR_TAB(IAD)%SENS_ID
613.and. IF (OPT_ID > 0 SENSORS%SENSOR_TAB(IAD)%TYPE >= 0) THEN
614 CALL QAPRINT('new sensor_no_name', OPT_ID, 0.0_8)
615c
616 WRITE(VARNAME,'(a)') 'sensor_id'
617 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),SENSORS%SENSOR_TAB(IAD)%SENS_ID,0.0_8)
618 WRITE(VARNAME,'(a)') 'sensor_type'
619 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),SENSORS%SENSOR_TAB(IAD)%TYPE,0.0_8)
620 WRITE(VARNAME,'(a)') 'tdelay'
621 TEMP_DOUBLE = SENSORS%SENSOR_TAB(IAD)%TDELAY
622 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
623 WRITE(VARNAME,'(a)') 'tmin'
624 TEMP_DOUBLE = SENSORS%SENSOR_TAB(IAD)%TMIN
625 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
626 WRITE(VARNAME,'(a)') 'tcrit'
627 TEMP_DOUBLE = SENSORS%SENSOR_TAB(IAD)%TCRIT
628 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
629 WRITE(VARNAME,'(a)') 'tstart'
630 TEMP_DOUBLE = SENSORS%SENSOR_TAB(IAD)%TSTART
631 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
632 WRITE(VARNAME,'(a)') 'VALUE'
633 TEMP_DOUBLE = SENSORS%SENSOR_TAB(IAD)%VALUE
634 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
635 WRITE(VARNAME,'(a)') 'status'
636 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),SENSORS%SENSOR_TAB(IAD)%STATUS,0.0_8)
637 WRITE(VARNAME,'(a)') 'npari'
638 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),SENSORS%SENSOR_TAB(IAD)%NPARI,0.0_8)
639 WRITE(VARNAME,'(a)') 'nparr'
640 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),SENSORS%SENSOR_TAB(IAD)%NPARR,0.0_8)
641 WRITE(VARNAME,'(a)') 'nvar'
642 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),SENSORS%SENSOR_TAB(IAD)%NVAR,0.0_8)
643c
644 DO I = 1,SENSORS%SENSOR_TAB(IAD)%NPARI
645 INTVAL = SENSORS%SENSOR_TAB(IAD)%IPARAM(I)
646 WRITE(VARNAME,'(a,i0)') 'iparam_',I
647 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),INTVAL,0.0_8)
648 END DO
649c
650 DO I=1,SENSORS%SENSOR_TAB(IAD)%NPARR
651 FVAL = SENSORS%SENSOR_TAB(IAD)%RPARAM(I)
652 WRITE(VARNAME,'(a,i0)') 'rparam_',I
653 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,FVAL)
654 END DO
655 END IF
656c
657 ENDDO
658c
659 END IF ! /SENSOR
660C-----------------------------------------------
661C /LAGMUL
662C-----------------------------------------------
663 IF (MYQAKEY('/lagmul')) THEN
664
665 CALL QAPRINT('lagmul', 0,0.0_8)
666C
667 WRITE(VARNAME,'(a)') 'lagmod'
668 TEMP_INTEGER = LAGMOD
669 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
670c
671 WRITE(VARNAME,'(a)') 'lagopt'
672 TEMP_INTEGER = LAGOPT
673 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
674c
675 WRITE(VARNAME,'(a)') 'lagm_tol'
676 TEMP_DOUBLE = LAGM_TOL
677 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
678c
679 WRITE(VARNAME,'(a)') 'lag_alph'
680 TEMP_DOUBLE = LAG_ALPH
681 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
682c
683 WRITE(VARNAME,'(a)') 'lag_alphs'
684 TEMP_DOUBLE = LAG_ALPHS
685 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
686C
687 END IF ! /LAGMUL
688c-----------
689 RETURN
690 END
691c
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
func2d_mod
Definition func2d_mod.F:35
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
names_and_titles_mod::ncharline
integer, parameter ncharline
Definition names_and_titles_mod.F:1001
optiondef_mod
Definition optiondef_mod.F:90
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
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
table_mod
Definition table_mod.F:112
nvar
integer function nvar(text)
Definition nvar.F:32
st_qaprint_driver
subroutine st_qaprint_driver(igeo, geo, bufgeo, ipm, pm, bufmat, nom_opt, inom_opt, numloadp, iloadp, lloadp, loadp, ibcl, forc, ipres, pres, npby, lpby, rby, ibcr, fradia, ibcv, fconv, ibftemp, fbftemp, igrv, lgrv, agrv, ibfflux, fbfflux, itab, v, vr, w, icode, iskew, icfield, lcfield, cfield, dampr, temp, ibcslag, ipari, intbuf_tab, clusters, ibox, ipmas, ibfvel, fbfvel, nimpacc, laccelm, accelm, nom_sect, nstrf, secbuf, skew, iskwn, xframe, t_monvol, t_monvol_metadata, i2rupt, areasl, intbuf_fric_tab, npfricorth, mat_elem, pfricorth, irepforth, phiforth, vforth, xrefc, xreftg, xrefs, tagxref, ixs, ixc, ixtg, rwbuf, nprw, lprw, ithvar, ipart, subsets, ipartth, nthgrpmx, nimpdisp, nimpvel, detonators, ibcscyc, npc, pld, table, npts, irbe3, lrbe3, frbe3, mgrby, ixs10, isolnod, ixr, r_skew, ixp, ixt, x, thke, sh4ang, thkec, sh3ang, set, lsubmodel, igrnod, igrpart, igrbric, igrsh4n, igrsh3n, igrquad, igrbeam, igrtruss, igrspring, igrsurf, igrslin, ixq, ispcond, rtrans, irand, alea, xseed, xlas, las, irbe2, lrbe2, kxsp, ipartsp, drape, ixr_kj, iactiv, factiv, unitab, npbyl, lpbyl, rbyl, xyzref, sensors, func2d, inicrack, ipreload, preload, iflag_bpreload, ibmpc, ibmpc2, ibmpc3, ibmpc4, rbmpc, ljoint, nnlink, lnlink, bufsf, sbufsf_, pm_stack, geo_stack, igeo_stack, iparg, ipadmesh, padmesh, liflow, lrflow, iflow, rflow, sh4tree, sh3tree, sh4trim, sh3trim, qp_iperturb, qp_rperturb, llinal, linale, fvm_inivel, gjbufi, gjbufr, ms, in, lgauge, gauge, kxx, ixx, ipartx, ixri, ixs16, iexmad, fxbipm, fxbfile_tab, eigipm, eigrpm, isphio, vsphio, ebcs_tab, inimap1d, inimap2d, nsigsh, sigsh, nsigi, sigsp, nsigs, sigi, nsigbeam, sigbeam, nsigtruss, sigtruss, nsigrs, sigrs, merge_node_tab, merge_node_tol, imerge, nmerge_tot, iexlnk, drapeg, user_windows, output, defaults, glob_therm, pblast, ibeam_vector, rbeam_vector, damp_range_part)
Definition st_qaprint_driver.F:120
st_qaprint_model_tools
subroutine st_qaprint_model_tools(nom_opt, inom_opt, ibox, ipmas, nom_sect, nstrf, secbuf, skew, iskwn, xframe, npc, pld, table, npts, iactiv, factiv, sensors, func2d)
Definition st_qaprint_model_tools.F:39
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
starter
program starter
Definition starter.F:39
func2d_mod::func2d_struct
Definition func2d_mod.F:37
table_mod::ttable
Definition table_mod.F:125