OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_general_controls.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "scr03_c.inc"
#include "scr05_c.inc"
#include "scr06_c.inc"
#include "scr12_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "scr17_c.inc"
#include "tabsiz_c.inc"
#include "random_c.inc"
#include "sphcom.inc"
#include "sms_c.inc"
#include "eigcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine st_qaprint_general_controls (nom_opt, inom_opt, dampr, irand, alea, xseed, unitab, qp_iperturb, qp_rperturb, eigipm, eigrpm, defaults, damp_range_part)

Function/Subroutine Documentation

◆ st_qaprint_general_controls()

subroutine st_qaprint_general_controls ( integer, dimension(lnopt1,snom_opt1), intent(in) nom_opt,
integer, dimension(sinom_opt), intent(in) inom_opt,
dimension(nrdamp,*), intent(in) dampr,
integer, dimension(*), intent(in) irand,
dimension(*), intent(in) alea,
dimension(*), intent(in) xseed,
type (unit_type_) unitab,
integer, dimension(nperturb,6), intent(in) qp_iperturb,
dimension(nperturb,4), intent(in) qp_rperturb,
integer, dimension(neipm,*), intent(in) eigipm,
dimension(nerpm,*), intent(in) eigrpm,
type(defaults_), intent(in) defaults,
integer, dimension(npart), intent(in) damp_range_part )
Parameters
[in]damp_range_partflag to compute the damping range

Definition at line 31 of file st_qaprint_general_controls.F.

34C============================================================================
35C M o d u l e s
36C-----------------------------------------------
37 USE qa_out_mod
38 USE unitab_mod
39 USE ale_mod
40 USE defaults_mod
41 USE names_and_titles_mod , ONLY : nchartitle
42C-----------------------------------------------
43C I m p l i c i t T y p e s
44C-----------------------------------------------
45#include "implicit_f.inc"
46C-----------------------------------------------
47C C o m m o n B l o c k s
48C-----------------------------------------------
49#include "com01_c.inc"
50#include "com04_c.inc"
51#include "param_c.inc"
52#include "scr03_c.inc"
53#include "scr05_c.inc"
54#include "scr06_c.inc"
55#include "scr12_c.inc"
56#include "scr14_c.inc"
57#include "scr16_c.inc"
58#include "scr17_c.inc"
59#include "tabsiz_c.inc"
60#include "random_c.inc"
61#include "sphcom.inc"
62#include "sms_c.inc"
63#include "eigcom.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER, INTENT(IN) :: NOM_OPT(LNOPT1,SNOM_OPT1), INOM_OPT(SINOM_OPT),
68 . IRAND(*),QP_IPERTURB(NPERTURB,6),EIGIPM(NEIPM,*)
69 my_real, INTENT(IN) :: dampr(nrdamp,*),alea(*),xseed(*),eigrpm(nerpm,*)
70 my_real, INTENT(IN) :: qp_rperturb(nperturb,4)
71 INTEGER, INTENT(IN) :: DAMP_RANGE_PART(NPART) !< flag to compute the damping range
72 TYPE (UNIT_TYPE_) ::UNITAB
73 TYPE(DEFAULTS_) , INTENT(IN) :: DEFAULTS
74C--------------------------------------------------
75C L o c a l V a r i a b l e s
76C-----------------------------------------------
77 INTEGER I,II,J,IPERT,MY_ID, MY_DAMP, MY_CONSTRAINT,TEMP_INT,
78 . MY_RAND, MY_UNIT, MY_DEFAULTINTER,LENRNOISE,
79 . IDS(NPERTURB),IDX(NPERTURB),IDSEIG(NEIG),IDXEIG(NEIG),MY_EIG
80 CHARACTER(LEN=NCHARTITLE) :: TITR
81 INTEGER IHBE_DS,ISST_DS,IPLA_DS,IFRAME_DS,ITET4_D,ITET10_D,ICPRE_D,IMAS_DS,
82 . IHBE_D,IPLA_D,ISTR_D,ITHK_D,ISHEA_D,ISST_D,
83 . ISH3N_D, ISTRA_D,NPTS_D,IDRIL_D,IOFFSET,DEF_INTER(100)
84 CHARACTER (LEN=255) :: VARNAME
85 DOUBLE PRECISION TEMP_DOUBLE
86 LOGICAL :: OK_QA
87C-----------------------------------------------
88!--- defaults values
89C-----------------------------------------------
90 ihbe_ds= defaults%SOLID%ISOLID
91 isst_ds= defaults%SOLID%ISMSTR
92 icpre_d= defaults%SOLID%ICPRE
93 itet4_d= defaults%SOLID%ITETRA4
94 itet10_d= defaults%SOLID%ITETRA10
95 imas_ds= defaults%SOLID%IMAS
96 iframe_ds= defaults%SOLID%IFRAME
97 istra_d = 1
98 ihbe_d = defaults%SHELL%ishell
99 ish3n_d= defaults%SHELL%ish3n
100 isst_d = defaults%SHELL%ismstr
101 ipla_d = defaults%SHELL%iplas
102 ithk_d = defaults%SHELL%ithick
103 idril_d= defaults%SHELL%idrill
104 ishea_d = 0
105 npts_d = 0
106!
107C-----------------------------------------------
108C /DAMP
109C-----------------------------------------------
110 IF (myqakey('/DAMP')) THEN
111 DO my_damp=1,ndamp
112C
113 titr(1:nchartitle)=''
114 my_id = nint(dampr(1,my_damp))
115 IF(len_trim(titr)/=0)THEN
116 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
117 ELSE
118 CALL qaprint('A_DAMP_FAKE_NAME', my_id,0.0_8)
119 END IF
120C
121 DO i=1,nrdamp
122 IF(dampr(i,my_damp)/=zero)THEN
123C
124C VARNAME: variable name in ref.extract (without blanks)
125 WRITE(varname,'(A,I0)') 'DAMPR_',i
126 temp_double = dampr(i,my_damp)
127 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
128 END IF
129 END DO
130C
131 END DO ! MY_DAMP=1,NDAMP
132 END IF
133C-----------------------------------------------
134C /DAMP/INTER
135C-----------------------------------------------
136 IF (myqakey('/DAMP/INTER')) THEN
137 DO my_damp=1,ndamp
138C
139 titr(1:nchartitle)=''
140 my_id = nint(dampr(1,my_damp))
141 IF(len_trim(titr)/=0)THEN
142 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
143 ELSE
144 CALL qaprint('A_DAMP_INTER_FAKE_NAME', my_id,0.0_8)
145 END IF
146C
147 DO i=1,nrdamp
148 IF(dampr(i,my_damp)/=zero)THEN
149C
150C VARNAME: variable name in ref.extract (without blanks)
151 WRITE(varname,'(A,I0)') 'DAMPR_',i
152 temp_double = dampr(i,my_damp)
153 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
154 END IF
155 END DO
156C
157 IF(idamp_rdof/=zero)THEN
158 WRITE(varname,'(A)') 'IDAMP_RDOF_'
159 temp_double = idamp_rdof
160 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
161 ENDIF
162C
163 END DO ! MY_DAMP=1,NDAMP
164 END IF
165C-----------------------------------------------
166C /DAMP/FREQ_RANGE
167C-----------------------------------------------
168 IF (myqakey('/DAMP/FREQ_RANGE')) THEN
169 DO my_damp=1,ndamp
170C
171 IF (nint(dampr(31,my_damp))==1) THEN
172 titr(1:nchartitle)=''
173 my_id = nint(dampr(1,my_damp))
174 IF(len_trim(titr)/=0)THEN
175 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
176 ELSE
177 CALL qaprint('A_DAMP_INTER_FAKE_NAME', my_id,0.0_8)
178 END IF
179C
180 DO i=1,nrdamp
181 IF(dampr(i,my_damp)/=zero)THEN
182C
183C VARNAME: variable name in ref.extract (without blanks)
184 WRITE(varname,'(A,I0)') 'DAMPR_',i
185 temp_double = dampr(i,my_damp)
186 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
187 END IF
188 END DO
189C
190 DO i=1,npart
191 IF (damp_range_part(i) == my_damp) THEN
192 WRITE(varname,'(A)') 'PART_'
193 temp_int = i
194 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
195 ENDIF
196 ENDDO
197C
198 ENDIF
199C
200 END DO ! MY_DAMP=1,NDAMP
201 END IF
202C-----------------------------------------------
203C /ANALY
204C-----------------------------------------------
205 IF (myqakey('/ANALY')) THEN
206C
207 CALL qaprint('ANALY', 0,0.0_8)
208C
209 WRITE(varname,'(A)') 'NANALY'
210 temp_int = nanaly
211 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
212C
213 WRITE(varname,'(A)') 'IPARI0'
214 temp_int = ipari0
215 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
216C
217 END IF
218C-----------------------------------------------
219C /DEF_SOLID
220C-----------------------------------------------
221 IF (myqakey('/DEF_SOLID')) THEN
222C
223 CALL qaprint('DEF_SOLID', 0,0.0_8)
224C
225 WRITE(varname,'(A)') 'Isolid'
226 temp_int = ihbe_ds
227 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
228C
229 WRITE(varname,'(A)') 'ismstr'
230 TEMP_INT = ISST_DS
231 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
232C
233 WRITE(VARNAME,'(a)') 'icpre'
234 TEMP_INT = ICPRE_D
235 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
236C
237 WRITE(VARNAME,'(a)') 'istrain'
238 TEMP_INT = ISTRA_D
239 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
240C
241 WRITE(VARNAME,'(a)') 'itetra4'
242 TEMP_INT = ITET4_D
243 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
244C
245 WRITE(VARNAME,'(a)') 'itetra10'
246 TEMP_INT = ITET10_D
247 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
248C
249 WRITE(VARNAME,'(a)') 'imas'
250 TEMP_INT = IMAS_DS
251 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
252C
253 WRITE(VARNAME,'(a)') 'iframe'
254 TEMP_INT = IFRAME_DS
255 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
256 END IF
257C-----------------------------------------------
258C /DEF_SHELL
259C-----------------------------------------------
260 IF (MYQAKEY('/def_shell')) THEN
261C
262 CALL QAPRINT('def_shell', 0,0.0_8)
263C
264 WRITE(VARNAME,'(a)') 'ishell'
265 TEMP_INT = IHBE_D
266 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
267C
268 WRITE(VARNAME,'(a)') 'ismstr'
269 TEMP_INT = ISST_D
270 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
271C
272 WRITE(VARNAME,'(a)') 'ithick'
273 TEMP_INT = ITHK_D
274 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
275C
276 WRITE(VARNAME,'(a)') 'iplas'
277 TEMP_INT = IPLA_D
278 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
279C
280 WRITE(VARNAME,'(a)') 'istrain'
281 TEMP_INT = ISTRA_D
282 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
283C
284 WRITE(VARNAME,'(a)') 'ish3n'
285 TEMP_INT = ISH3N_D
286 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
287C
288 WRITE(VARNAME,'(a)') 'idrill'
289 TEMP_INT = IDRIL_D
290 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
291 END IF
292C-----------------------------------------------
293C /RANDOM
294C-----------------------------------------------
295 IF (MYQAKEY('/random')) THEN
296C
297 CALL QAPRINT('random',0,0.0_8)
298
299 DO MY_RAND=1,NRAND
300C
301 WRITE(VARNAME,'(a,i0)') 'irand_',MY_RAND
302 TEMP_INT = IRAND(MY_RAND)
303 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
304C
305 IF(ALEA(MY_RAND)/=ZERO)THEN
306C VARNAME: variable name in ref.extract (without blanks)
307 WRITE(VARNAME,'(a,i0)') 'alea_',MY_RAND
308 TEMP_DOUBLE = ALEA(MY_RAND)
309 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
310 END IF
311C
312 IF(XSEED(MY_RAND)/=ZERO)THEN
313C VARNAME: variable name in ref.extract (without blanks)
314 WRITE(VARNAME,'(a,i0)') 'xseed_',MY_RAND
315 TEMP_DOUBLE = XSEED(MY_RAND)
316 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
317 END IF
318C
319 END DO ! MY_RAND=1,NRAND
320C
321 END IF
322C-----------------------------------------------
323C /IMPLICIT
324C-----------------------------------------------
325 IF (MYQAKEY('/IMPLICIT')) THEN
326C
327 CALL QAPRINT('IMPLICIT',0,0.0_8)
328
329 WRITE(VARNAME,'(a,i0)') 'iimplicit'
330 TEMP_INT = IIMPLICIT
331 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
332C
333 WRITE(VARNAME,'(a,i0)') 'ipla_d'
334 TEMP_INT = IPLA_D
335 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
336C
337 WRITE(VARNAME,'(a,i0)') 'ihbe_ds'
338 TEMP_INT = IHBE_DS
339 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
340C
341 WRITE(VARNAME,'(a,i0)') 'ihbe_d'
342 TEMP_INT = IHBE_D
343 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
344C
345 WRITE(VARNAME,'(a,i0)') 'idril_d'
346 TEMP_INT = IDRIL_D
347 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
348C
349 END IF
350C-----------------------------------------------
351C /SPMD
352C-----------------------------------------------
353 IF (MYQAKEY('/spmd')) THEN
354C
355 CALL QAPRINT('spmd',0,0.0_8)
356
357 WRITE(VARNAME,'(a,i0)') 'dectyp'
358 TEMP_INT = DECTYP
359 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
360C
361 WRITE(VARNAME,'(a,i0)') 'nspmd'
362 TEMP_INT = NSPMD
363 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
364C
365 WRITE(VARNAME,'(a,i0)') 'decani'
366 TEMP_INT = DECANI
367 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
368C
369 WRITE(VARNAME,'(a,i0)') 'decmot'
370 TEMP_INT = DECMOT
371 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
372C
373 WRITE(VARNAME,'(a,i0)') 'decneq'
374 TEMP_INT = DECNEQ
375 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
376C
377 WRITE(VARNAME,'(a,i0)') 'nthread'
378 TEMP_INT = NTHREAD
379 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
380C
381 END IF
382C-----------------------------------------------
383C /SPHGLO
384C-----------------------------------------------
385 IF (MYQAKEY('/sphglo')) THEN
386C
387 CALL QAPRINT('sphglo',0,0.0_8)
388
389 IF(SPASORT/=ZERO)THEN
390C VARNAME: variable name in ref.extract (without blanks)
391 WRITE(VARNAME,'(a,i0)') 'spasort'
392 TEMP_DOUBLE = SPASORT
393 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
394 END IF
395C
396 WRITE(VARNAME,'(a,i0)') 'lvoisph'
397 TEMP_INT = LVOISPH
398 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
399C
400 WRITE(VARNAME,'(a,i0)') 'kvoisph'
401 TEMP_INT = KVOISPH
402 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
403C
404 WRITE(VARNAME,'(a,i0)') 'itsol2sph'
405 TEMP_INT = ITSOL2SPH
406 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
407C
408 END IF
409C-----------------------------------------------
410C /CAA
411C-----------------------------------------------
412 IF (MYQAKEY('/caa')) THEN
413C
414 CALL QAPRINT('caa',0,0.0_8)
415
416 WRITE(VARNAME,'(a,i0)') 'icaa'
417 TEMP_INT = ALE%GLOBAL%ICAA
418 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
419C
420 END IF
421C-----------------------------------------------
422C /IOFLAG
423C-----------------------------------------------
424 IF (MYQAKEY('/ioflag')) THEN
425C
426 CALL QAPRINT('ioflag',0,0.0_8)
427C
428 WRITE(VARNAME,'(a,i0)') 'ipri'
429 TEMP_INT = IPRI
430 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
431C
432 WRITE(VARNAME,'(a,i0)') 'ioutput'
433 TEMP_INT = IOUTPUT
434 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
435C
436 WRITE(VARNAME,'(a,i0)') 'outyy_fmt'
437 TEMP_INT = OUTYY_FMT
438 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
439C
440 WRITE(VARNAME,'(a,i0)') 'irootyy'
441 TEMP_INT = IROOTYY
442 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
443C
444 WRITE(VARNAME,'(a,i0)') 'idrot'
445 TEMP_INT = IDROT
446 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
447C
448 WRITE(VARNAME,'(a,i0)') 'irform'
449 TEMP_INT = IRFORM
450 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
451C
452 END IF
453C-----------------------------------------------
454C /AMS
455C-----------------------------------------------
456 IF (MYQAKEY('/ams')) THEN
457C
458 CALL QAPRINT('ams',0,0.0_8)
459C
460 WRITE(VARNAME,'(a,i0)') 'isms'
461 TEMP_INT = ISMS
462 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
463C
464 WRITE(VARNAME,'(a,i0)') 'idtgrs'
465 TEMP_INT = IDTGRS
466 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
467C
468 WRITE(VARNAME,'(a,i0)') 'isms_selec'
469 TEMP_INT = ISMS_SELEC
470 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
471C
472 WRITE(VARNAME,'(a,i0)') 'irest_mselt'
473 TEMP_INT = IREST_MSELT
474 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
475C
476 IF(DT_SMS_SWITCH/=ZERO)THEN
477C VARNAME: variable name in ref.extract (without blanks)
478 WRITE(VARNAME,'(a,i0)') 'dt_sms_switch'
479 TEMP_DOUBLE = DT_SMS_SWITCH
480 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
481 END IF
482C
483 END IF
484C-----------------------------------------------
485C /UNIT
486C-----------------------------------------------
487 IF (MYQAKEY('/unit')) THEN
488C
489 DO MY_UNIT=1,UNITAB%NUNITS
490C
491 TITR(1:nchartitle)=''
492 MY_ID = UNITAB%UNIT_ID(MY_UNIT)
493 IF(LEN_TRIM(TITR)/=0)THEN
494 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
495 ELSE
496 CALL QAPRINT('a_unit_fake_name', MY_ID,0.0_8)
497 END IF
498C
499 IF(UNITAB%FAC_M(MY_UNIT)/=ZERO)THEN
500C VARNAME: variable name in ref.extract (without blanks)
501 WRITE(VARNAME,'(a,i0)') 'fac_m_',MY_UNIT
502 TEMP_DOUBLE = UNITAB%FAC_M(MY_UNIT)
503 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
504 END IF
505C
506 IF(UNITAB%FAC_L(MY_UNIT)/=ZERO)THEN
507C VARNAME: variable name in ref.extract (without blanks)
508 WRITE(VARNAME,'(a,i0)') 'fac_l_',MY_UNIT
509 TEMP_DOUBLE = UNITAB%FAC_L(MY_UNIT)
510 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
511 END IF
512
513 IF(UNITAB%FAC_T(MY_UNIT)/=ZERO)THEN
514C VARNAME: variable name in ref.extract (without blanks)
515 WRITE(VARNAME,'(a,i0)') 'fac_t_',MY_UNIT
516 TEMP_DOUBLE = UNITAB%FAC_T(MY_UNIT)
517 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
518 END IF
519C
520 END DO ! MY_UNIT=1,UNITAB%NUNITS
521C
522 END IF
523C-----------------------------------------------
524C /DEFAULT/INTER
525C----------------------------------------------
526 IF (MYQAKEY('/default/inter')) THEN
527C
528 DEF_INTER(1:100) = DEFAULTS%interface%DEF_INTER(1:100)
529 CALL QAPRINT('/default/inter', 0,0.0_8)
530
531 DO MY_DEFAULTINTER=1,100
532C
533 IF(DEF_INTER(MY_DEFAULTINTER) /= 0) THEN
534 WRITE(VARNAME,'(a,i0)') 'def_inter_',MY_DEFAULTINTER
535 TEMP_INT = DEF_INTER(MY_DEFAULTINTER)
536 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
537 ENDIF
538C
539 ENDDO ! MY_DEFAULTINTER=1,100
540
541 END IF
542C-----------------------------------------------
543C /INTTHICK
544C----------------------------------------------
545 IF (MYQAKEY('/intthick')) THEN
546C
547 IF (IINTTHICK > 0) THEN
548 CALL QAPRINT('/intthick',0,0.0_8)
549 WRITE(VARNAME,'(a)') 'intthick_'
550 TEMP_INT = IINTTHICK
551 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INT,0.0_8)
552 ENDIF
553
554 END IF
555C-----------------------------------------------
556C /ALE/GRID/ *
557C----------------------------------------------
558 OK_QA = MYQAKEY('/ale/grid')
559 IF (OK_QA) THEN
560 TEMP_DOUBLE = ALE%GRID%ALPHA
561 WRITE(VARNAME,'(a)') 'alpha_'
562 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
563 temp_double = ale%GRID%GAMMA
564 WRITE(varname,'(A)') 'GAMMA_'
565 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
566 temp_double = ale%GRID%VGX
567 WRITE(varname,'(A)') 'VGX_'
568 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
569 temp_double = ale%GRID%VGY
570 WRITE(varname,'(A)') 'VGY_'
571 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
572 temp_double = ale%GRID%VGZ
573 WRITE(varname,'(A)') 'VGZ_'
574 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
575 ENDIF
576C-----------------------------------------------
577C /SHFRA
578C----------------------------------------------
579 IF (myqakey('/SHFRA')) THEN
580C
581 IF (ishfram > 0) THEN
582 CALL qaprint('/ISHFRA',0,0.0_8)
583 WRITE(varname,'(A)') 'ISHFRAM_'
584 temp_int = ishfram
585 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
586 ENDIF
587
588 END IF
589C-----------------------------------------------
590C /UPWIND
591C----------------------------------------------
592 ok_qa = myqakey('/UPWIND')
593 IF (ok_qa) THEN
594 temp_double = ale%UPWIND%UPWMG
595 WRITE(varname,'(A)') 'UPCOEF1_'
596 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
597 temp_double = ale%UPWIND%UPWOG
598 WRITE(varname,'(A)') 'UPCOEF2_'
599 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
600 temp_double = ale%UPWIND%UPWSM
601 WRITE(varname,'(A)') 'UPCOEF3_'
602 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
603 ENDIF
604C-----------------------------------------------
605C /PERTURB
606C----------------------------------------------
607
608 IF (myqakey('/PERTURB')) THEN
609C
610 IF (nperturb > 0) THEN
611C
612! Sort by ID to ensure internal order independent output
613 DO i = 1,nperturb
614 ids(i) = qp_iperturb(i,1)
615 idx(i) = i
616 ENDDO
617 CALL quicksort_i2(ids, idx, 1, nperturb)
618C
619! Loop over INIGRAVs
620 DO ii = 1, nperturb
621C
622 my_id = idx(ii)
623 CALL qaprint('/PERTURB_FAKE_NAME',ii,0.0_8)
624C
625 DO i = 1,6
626 WRITE(varname,'(A,I0)') 'QP_IPERTURB_',i
627 temp_int = qp_iperturb(my_id,i)
628 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
629 ENDDO
630C
631 DO i = 1,4
632 WRITE(varname,'(A,I0)') 'QP_RPERTURB_',i
633 temp_double = qp_rperturb(my_id,i)
634 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
635 ENDDO
636C
637 ENDDO
638C
639 ENDIF
640C
641 END IF
642C-----------------------------------------------
643C /STAMPING
644C-----------------------------------------------
645 IF (myqakey('/STAMPING')) THEN
646C
647 CALL qaprint('STAMPING',0,0.0_8)
648
649 WRITE(varname,'(A,I0)') 'ISTAMPING'
650 temp_int = istamping
651 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
652 ENDIF
653C-----------------------------------------------
654C /EIG
655C-----------------------------------------------
656 IF (myqakey('/EIG')) THEN
657C
658! Sort by ID to ensure internal order independent output
659 DO i = 1, neig
660 idseig(i) = eigipm(1,i)
661 idxeig(i) = i
662 ENDDO
663 IF (neig>0) CALL quicksort_i2(idseig, idxeig, 1, neig)
664
665 DO ii=1,neig
666C
667 my_eig = idxeig(ii)
668 WRITE(varname,'(A,I0)') 'EIGID_',my_eig
669 temp_int = eigipm(1,my_eig)
670 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
671C
672 DO i=1,neipm
673 IF(eigipm(i,my_eig) /=0)THEN
674C VARNAME: variable name in ref.extract (without blanks)
675 WRITE(varname,'(A,I0)') 'EIGIPM_',i
676 CALL qaprint(varname(1:len_trim(varname)),eigipm(i,my_eig),0.0_8)
677 END IF
678 END DO
679C
680 DO i=1,nerpm
681 IF(eigrpm(i,my_eig) /=zero)THEN
682 WRITE(varname,'(A,I0)') 'EIGRPM_',i
683 temp_double = eigrpm(i,my_eig)
684 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
685 END IF
686 END DO
687C
688 END DO ! II=1,NEIG
689C
690 END IF
691C-----------------------------------------------
692C /ANIM/VERS
693C-----------------------------------------------
694 IF (myqakey('/ANIM/VERS')) THEN
695C
696 WRITE(varname,'(A)') 'ANIM_VERS'
697 temp_int = anim_vers
698 CALL qaprint(varname(1:len_trim(varname)),temp_int,0.0_8)
699C
700 END IF
701c----------------------------------------------------------------------
702 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
ale_mod
Definition ale_mod.F:149
ale_mod::ale
type(ale_) ale
Definition ale_mod.F:249
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
unitab_mod
Definition unitab_mod.F:513
quicksort_i2
recursive subroutine quicksort_i2(a, idx, first, last)
Definition quicksort.F:153