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

Go to the source code of this file.

Functions/Subroutines

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)

Function/Subroutine Documentation

◆ st_qaprint_model_tools()

subroutine st_qaprint_model_tools ( integer, dimension(lnopt1,snom_opt1), intent(in) nom_opt,
integer, dimension(sinom_opt), intent(in) inom_opt,
type (box_), dimension(nbbox), intent(in) ibox,
type (admas_), dimension(nodmas), intent(in) ipmas,
integer, dimension(snom_sect), intent(in) nom_sect,
integer, dimension(snstrf), intent(in) nstrf,
dimension(ssecbuf), intent(in) secbuf,
dimension(lskew,*), intent(in) skew,
integer, dimension(liskn,*), intent(in) iskwn,
dimension(nxframe,*), intent(in) xframe,
integer, dimension(*), intent(in) npc,
dimension(*), intent(in) pld,
type(ttable), dimension(*) table,
integer, intent(in) npts,
integer, dimension(lactiv,*), intent(in) iactiv,
dimension(lractiv,*), intent(in) factiv,
type (sensors_), intent(in) sensors,
type(func2d_struct), dimension(nfunc2d), intent(in) func2d )

Definition at line 34 of file st_qaprint_model_tools.F.

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 ok_qa = ok_qa .OR. 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 IF (lentitr /= 0 .AND. 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
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
id
initmumps id
Definition multiplerhs_example.m:4
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
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
quicksort_i
recursive subroutine quicksort_i(a, first, last)
Definition quicksort.F:92
quicksort_i2
recursive subroutine quicksort_i2(a, idx, first, last)
Definition quicksort.F:153
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804