OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
qa_out_mod.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!|| qa_out_mod ../common_source/qa/qa_out_mod.F
25!||--- called by ------------------------------------------------------
26!|| arret ../engine/source/system/arret.F
27!|| cgrtails ../starter/source/elements/shell/coque/cgrtails.F
28!|| eng_qaprint_animinput ../engine/source/output/qaprint/eng_qaprint_animinput.F
29!|| eng_qaprint_driver ../engine/source/output/qaprint/eng_qaprint_driver.F
30!|| eng_qaprint_dtinput ../engine/source/output/qaprint/eng_qaprint_dtinput.F
31!|| eng_qaprint_generalcontrolsinput ../engine/source/output/qaprint/eng_qaprint_generalcontrolsinput.F
32!|| fill_igr ../starter/source/model/sets/fill_igr.F
33!|| fill_surf ../starter/source/model/sets/fill_gr.F
34!|| fill_surf_ellipse ../starter/source/model/sets/fill_gr_surf_ellipse.F
35!|| qa_print_groups ../starter/source/output/qaprint/st_qaprint_groups.F
36!|| qa_print_surf ../starter/source/output/qaprint/st_qaprint_surf.F
37!|| r2r_fork ../starter/source/coupling/rad2rad/r2r_fork.F
38!|| radioss2 ../engine/source/engine/radioss2.F
39!|| sgrtails ../starter/source/elements/solid/solide/sgrtails.F
40!|| st_qaprint_admesh ../starter/source/output/qaprint/st_qaprint_admesh.F
41!|| st_qaprint_ale_options_driver ../starter/source/output/qaprint/st_qaprint_ale_options_driver.F
42!|| st_qaprint_clusters ../starter/source/output/qaprint/st_qaprint_clusters.F
43!|| st_qaprint_composite_options ../starter/source/output/qaprint/st_qaprint_composite_options.F
44!|| st_qaprint_constraints ../starter/source/output/qaprint/st_qaprint_constraints.F
45!|| st_qaprint_dfs_detonators ../starter/source/output/qaprint/st_qaprint_dfs_detonators.F
46!|| st_qaprint_dfs_lasers ../starter/source/output/qaprint/st_qaprint_dfs_lasers.F
47!|| st_qaprint_driver ../starter/source/output/qaprint/st_qaprint_driver.F
48!|| st_qaprint_ebcs ../starter/source/output/qaprint/st_qaprint_ebcs.F
49!|| st_qaprint_element ../starter/source/output/qaprint/st_qaprint_element.F
50!|| st_qaprint_friction ../starter/source/output/qaprint/st_qaprint_friction.F
51!|| st_qaprint_general_controls ../starter/source/output/qaprint/st_qaprint_general_controls.F
52!|| st_qaprint_groups ../starter/source/output/qaprint/st_qaprint_groups.F
53!|| st_qaprint_initial_conditions ../starter/source/output/qaprint/st_qaprint_initial_conditions.F
54!|| st_qaprint_initial_state ../starter/source/output/qaprint/st_qaprint_initial_state.F
55!|| st_qaprint_inivol ../starter/source/output/qaprint/st_qaprint_inivol.F
56!|| st_qaprint_interfaces ../starter/source/output/qaprint/st_qaprint_interfaces.F
57!|| st_qaprint_internal_groups ../starter/source/output/qaprint/st_qaprint_internal_groups.F
58!|| st_qaprint_loads ../starter/source/output/qaprint/st_qaprint_loads.F
59!|| st_qaprint_madymo ../starter/source/output/qaprint/st_qaprint_madymo.F
60!|| st_qaprint_materials ../starter/source/output/qaprint/st_qaprint_materials.F
61!|| st_qaprint_model_tools ../starter/source/output/qaprint/st_qaprint_model_tools.F
62!|| st_qaprint_monvol ../starter/source/output/qaprint/st_qaprint_monvol.F
63!|| st_qaprint_multidomains ../starter/source/output/qaprint/st_qaprint_multidomains.F
64!|| st_qaprint_nodes ../starter/source/output/qaprint/st_qaprint_nodes.F
65!|| st_qaprint_output_databases ../starter/source/output/qaprint/st_qaprint_output_databases.F
66!|| st_qaprint_properties ../starter/source/output/qaprint/st_qaprint_properties.F
67!|| st_qaprint_reference_state ../starter/source/output/qaprint/st_qaprint_reference_state.F
68!|| st_qaprint_refsta ../starter/source/output/qaprint/st_qaprint_refsta.F
69!|| st_qaprint_seatbelts ../starter/source/output/qaprint/st_qaprint_seatbelts.F
70!|| st_qaprint_set ../starter/source/output/qaprint/st_qaprint_set.F
71!|| st_qaprint_surf ../starter/source/output/qaprint/st_qaprint_surf.F
72!|| st_qaprint_thgrou ../starter/source/output/qaprint/st_qaprint_time_histories.F
73!|| st_qaprint_time_histories ../starter/source/output/qaprint/st_qaprint_time_histories.F
74!|| st_qaprint_transformations ../starter/source/output/qaprint/st_qaprint_transformations.F
75!|| st_qaprint_userwi ../starter/source/output/qaprint/st_qaprint_userwi.F
76!|| starter ../starter/source/starter/starter.F
77!||====================================================================
78 module qa_out_mod
79
80!#if CPP_mach == CPP_p4win64
81! USE IFPORT
82!#endif
83
84 integer doqa, lunitqa, qaid, next_index
85 integer lqa_storage
86 parameter(lqa_storage=5000)
87 integer,parameter :: qaprint_limit_default = 10000
88 integer,parameter :: qaprint_limit_maxx = 500000
89 integer qaprint_limit
90
91 type tqa_value
92 integer itype
93 character*50 title
94 integer valuei
95 double precision valuer
96 end type tqa_value
97
98 type(tqa_value), dimension(:), allocatable :: qa_storage
99
100 character*12 qa_format
101 common /qa_blk/ doqa, lunitqa, qaid, qa_format
102
103 save /qa_blk/
104
105 data lunitqa /91/, doqa /0/, qaid /0/
106
107 integer emax_index
108
109C Array that contains the predefined list of available qakeys
110C A WARNING is displayed if user asks for a non available qakey
111 INTEGER nqakeylist_avail
112#include "qaprint_c.inc"
113C Array that contain keywords given by the QAKEY env variable
114C At least one card is one char, so we do 1039 / 2 (one char one comma...)
115 CHARACTER(len=64), DIMENSION(520) :: split_qakey_env
116
117 contains
118
119! ----------------------------------------------------------------------
120!> @purpose
121!> open QA extract file
122!> @ingroup utl_qa
123!||====================================================================
124!|| qaopen ../common_source/qa/qa_out_mod.F
125!||--- called by ------------------------------------------------------
126!|| radioss2 ../engine/source/engine/radioss2.F
127!|| starter ../starter/source/starter/starter.F
128!||--- calls -----------------------------------------------------
129!|| qagetqakeyenv ../common_source/qa/qa_out_mod.F
130!||====================================================================
131 subroutine qaopen (step)
132#include "implicit_f.inc"
133 integer preci
134 integer i
135 logical RD_extract_file
136 character *100 env
137 character(len=*) :: step
138
139 rd_extract_file=.false.
140
141 call getenv ( 'DO_QA', env )
142 doqa = 0
143
144 if ( env /= 'ON' ) then
145 return
146 endif
147
148
149 allocate(qa_storage(lqa_storage))
150 do i=1,lqa_storage
151 qa_storage(i)%itype=0
152 qa_storage(i)%title=''
153 qa_storage(i)%valuer=0.0_8
154 qa_storage(i)%valuei=0
155 end do
156
157! open the file
158 open ( lunitqa, file='RD-qa.extract', err=9010 )
159
160C In engine step we append print in the extract file, in starter we
161C create the file from scratch
162
163 if (step(1:len_trim(step)) == "engine") then
164
165C We get the next index value (in the case we are in engine, we want
166C to continue the id at the following, so read the RD.extract file
167C to get the value and set qaid for next qaprint
168
169 next_index=0
170 1001 read ( lunitqa, 2001, end=3001 ) next_index
171 2001 format(i10)
172 goto 1001
173 3001 continue
174
175#ifdef __GFORTRAN__
176 ! Only Gfortran / Intel compiler works fine
177 ! -----------------------------------------
178 ! Gfortran cannot write after EOF
179 ! Needs to do a Backspace to place just before EOF.
180 backspace lunitqa
181#endif
182
183 qaid = next_index
184 endif
185 qa_format = '(g16.9)'
186 preci = 9
187
188 write( qa_format, 1200 ) 7+preci, preci
189 1200 format('(g',i2,'.',i1,')')
190
191 doqa = 1
192
193
194C Get possible defined env variable QAKEY
195 call qagetqakeyenv()
196
197
198 return
199
200 9010 continue
201
202 write(*,*) 'Error opening extract file'
203 doqa = 2
204 RETURN
205 end subroutine qaopen
206
207! ----------------------------------------------------------------------
208!> @purpose
209!> get and store the possible values of the QAKEY env variable
210!> @ingroup utl_qa
211!||====================================================================
212!|| qagetqakeyenv ../common_source/qa/qa_out_mod.F
213!||--- called by ------------------------------------------------------
214!|| qaopen ../common_source/qa/qa_out_mod.F
215!||--- calls -----------------------------------------------------
216!|| is_value_in_qakeylist_avail ../common_source/qa/qa_out_mod.F
217!|| myqakey ../common_source/qa/qa_out_mod.F
218!||====================================================================
219 subroutine qagetqakeyenv ()
220#include "implicit_f.inc"
221 integer QAKEY_ENV_len, QAKEY_ENV_status, QAKEY_SPECIFIC_len, QAKEY_SPECIFIC_status, i, j, k
222C length is (64 chars + 1 comma)*16 occurrence - last comma (no comma at the end) = 1039
223 character(LEN=1039) QAKEY_ENV, QAKEY_SPECIFIC
224 character(64) temp_qakey
225 integer QAPRINT_LIMIT_ENV_len, QAPRINT_LIMIT_ENV_status
226 character(LEN=12) QAPRINT_LIMIT_ENV
227
228C Initializing qaprint_limit with its default value
229 qaprint_limit = qaprint_limit_default
230C If the env variable QAPRINT_LIMIT is defined, we replace the limit
231 qaprint_limit_env = ''
232 call get_environment_variable("QAPRINT_LIMIT",qaprint_limit_env,qaprint_limit_env_len,qaprint_limit_env_status,.true.)
233 if (qaprint_limit_env /= '') then
234 read(qaprint_limit_env,'(i12)') qaprint_limit
235 endif
236
237 if (qaprint_limit > qaprint_limit_maxx) then
238 qaprint_limit = qaprint_limit_maxx
239 endif
240
241C WRITE(*,'(a,i12)') "TRACE qaprint_limit is ",qaprint_limit,"END"
242
243 qakey_env = ''
244 call get_environment_variable("QAKEY",qakey_env,qakey_env_len,qakey_env_status,.true.)
245
246 temp_qakey=''
247 j=1
248 k=1
249 do i=1,len_trim(qakey_env)+1
250 if (qakey_env(i:i) == ',' .OR. i == len_trim(qakey_env)+1) then
251 if (temp_qakey /= '') then
252
253 ! Checking if the found keyword is allowed, if not => error reading input
254 IF (is_value_in_qakeylist_avail(temp_qakey)) THEN
255 IF (.NOT. myqakey(temp_qakey)) THEN
256 split_qakey_env(j)=temp_qakey
257 j=j+1
258 ENDIF
259 ELSE
260 print*,"ERROR : THE QAKEY ", temp_qakey(1:len_trim(temp_qakey)), " IS NOT AVAILABLE, ABORTING"
261 close ( lunitqa )
262 stop
263 ENDIF
264 temp_qakey=''
265 endif
266 k=1
267 else
268 temp_qakey(k:k)=qakey_env(i:i)
269 k=k+1
270 endif
271 end do
272
273 call get_environment_variable("QAKEY_SPECIFIC",qakey_specific,qakey_specific_len,qakey_specific_status,.true.)
274
275 temp_qakey=''
276 k=1
277 do i=1,len_trim(qakey_specific)+1
278 if (qakey_specific(i:i) == ',' .OR. i == len_trim(qakey_specific)+1) then
279 if (temp_qakey /= '') then
280
281 ! Checking if the found keyword is allowed, if not => error reading input
282 IF (is_value_in_qakeylist_avail(temp_qakey)) THEN
283 IF (.NOT. myqakey(temp_qakey)) THEN
284 split_qakey_env(j)=temp_qakey
285 j=j+1
286 ENDIF
287 ELSE
288 print*,"ERROR : THE QAKEY ", temp_qakey(1:len_trim(temp_qakey)), " IS NOT AVAILABLE, ABORTING"
289 close ( lunitqa )
290 stop
291 ENDIF
292 temp_qakey=''
293 endif
294 k=1
295 else
296 temp_qakey(k:k)=qakey_specific(i:i)
297 k=k+1
298 endif
299 end do
300
301C TRACE
302C do i=1,size(split_qakey_env)
303C PRINT*,"QAKEY TRACE : ",split_qakey_env(i)
304C enddo
305
306
307 RETURN
308 end subroutine qagetqakeyenv
309
310
311! ----------------------------------------------------------------------
312!> @purpose
313!> replace blank char with _ for a given string
314!||====================================================================
315!|| blank2underscore ../common_source/qa/qa_out_mod.F
316!||--- called by ------------------------------------------------------
317!|| qaprint ../common_source/qa/qa_out_mod.F
318!||====================================================================
319 subroutine blank2underscore(textin,textout)
320#include "implicit_f.inc"
321 character(len=*), intent(in) :: textin
322 character(len=LEN_TRIM(textin)), intent(out) :: textout
323 integer i
324
325 textout=textin
326
327 do i=1,len_trim(textout)
328 if (textout(i:i) == ' ') then
329 textout(i:i)='_';
330 endif
331 enddo
332
333 end subroutine blank2underscore
334
335! ----------------------------------------------------------------------
336!> @purpose
337!> print one entry to QA extract file
338!> example of call for real print
339!> CALL QAPRINT('MY_LABEL',0,12345.6_8) (2nd argument is 0, 3rd is the real value to be printed followed with '_8')
340!> example of call for integer print
341!> CALL QAPRINT('MY_LABEL',123456,0.0_8) (2nd argument is the integer value to be printed, 3rd must be 0.0_8)
342!> @ingroup utl_qa
343!||====================================================================
344!|| qaprint ../common_source/qa/qa_out_mod.F
345!||--- called by ------------------------------------------------------
346!|| eng_qaprint_animinput ../engine/source/output/qaprint/eng_qaprint_animinput.F
347!|| eng_qaprint_dtinput ../engine/source/output/qaprint/eng_qaprint_dtinput.F
348!|| eng_qaprint_generalcontrolsinput ../engine/source/output/qaprint/eng_qaprint_generalcontrolsinput.F
349!|| qa_print_groups ../starter/source/output/qaprint/st_qaprint_groups.F
350!|| qa_print_surf ../starter/source/output/qaprint/st_qaprint_surf.F
351!|| qaclose ../common_source/qa/qa_out_mod.F
352!|| st_qaprint_admesh ../starter/source/output/qaprint/st_qaprint_admesh.F
353!|| st_qaprint_ale_options_driver ../starter/source/output/qaprint/st_qaprint_ale_options_driver.F
354!|| st_qaprint_clusters ../starter/source/output/qaprint/st_qaprint_clusters.F
355!|| st_qaprint_composite_options ../starter/source/output/qaprint/st_qaprint_composite_options.F
356!|| st_qaprint_constraints ../starter/source/output/qaprint/st_qaprint_constraints.F
357!|| st_qaprint_dfs_detonators ../starter/source/output/qaprint/st_qaprint_dfs_detonators.F
358!|| st_qaprint_dfs_lasers ../starter/source/output/qaprint/st_qaprint_dfs_lasers.F
359!|| st_qaprint_ebcs ../starter/source/output/qaprint/st_qaprint_ebcs.F
360!|| st_qaprint_element ../starter/source/output/qaprint/st_qaprint_element.F
361!|| st_qaprint_friction ../starter/source/output/qaprint/st_qaprint_friction.F
362!|| st_qaprint_general_controls ../starter/source/output/qaprint/st_qaprint_general_controls.F
363!|| st_qaprint_initial_conditions ../starter/source/output/qaprint/st_qaprint_initial_conditions.F
364!|| st_qaprint_initial_state ../starter/source/output/qaprint/st_qaprint_initial_state.F
365!|| st_qaprint_inivol ../starter/source/output/qaprint/st_qaprint_inivol.F
366!|| st_qaprint_interfaces ../starter/source/output/qaprint/st_qaprint_interfaces.F
367!|| st_qaprint_internal_groups ../starter/source/output/qaprint/st_qaprint_internal_groups.F
368!|| st_qaprint_loads ../starter/source/output/qaprint/st_qaprint_loads.F
369!|| st_qaprint_madymo ../starter/source/output/qaprint/st_qaprint_madymo.F
370!|| st_qaprint_materials ../starter/source/output/qaprint/st_qaprint_materials.F
371!|| st_qaprint_model_tools ../starter/source/output/qaprint/st_qaprint_model_tools.F
372!|| st_qaprint_monvol ../starter/source/output/qaprint/st_qaprint_monvol.F
373!|| st_qaprint_multidomains ../starter/source/output/qaprint/st_qaprint_multidomains.F
374!|| st_qaprint_nodes ../starter/source/output/qaprint/st_qaprint_nodes.F
375!|| st_qaprint_output_databases ../starter/source/output/qaprint/st_qaprint_output_databases.F
376!|| st_qaprint_properties ../starter/source/output/qaprint/st_qaprint_properties.F
377!|| st_qaprint_reference_state ../starter/source/output/qaprint/st_qaprint_reference_state.F
378!|| st_qaprint_refsta ../starter/source/output/qaprint/st_qaprint_refsta.F
379!|| st_qaprint_seatbelts ../starter/source/output/qaprint/st_qaprint_seatbelts.F
380!|| st_qaprint_set ../starter/source/output/qaprint/st_qaprint_set.F
381!|| st_qaprint_thgrou ../starter/source/output/qaprint/st_qaprint_time_histories.F
382!|| st_qaprint_transformations ../starter/source/output/qaprint/st_qaprint_transformations.F
383!|| st_qaprint_userwi ../starter/source/output/qaprint/st_qaprint_userwi.F
384!|| starter ../starter/source/starter/starter.F
385!||--- calls -----------------------------------------------------
386!|| blank2underscore ../common_source/qa/qa_out_mod.F
387!|| lastchar ../common_source/qa/qa_out_mod.F
388!||====================================================================
389 subroutine qaprint ( name, idin, value )
390#include "implicit_f.inc"
391
392 character(len=*) :: name
393 character(len=LEN_TRIM(name)) :: name2
394 integer idin, id
395 double precision value !(2)
396 real rvalue
397 character *20 srvalue
398 character *6 siid
399 character*4 simg
400 integer intstart, is
401 integer ma4cmplx
402 data ma4cmplx/-999/
403 character *40 qaprint_limit_char
404 character(len=512) :: warning_msg
405
406 qaprint_limit_char = ' '
407
408 if ( doqa /= 1 ) return
409
410 if (qaid == qaprint_limit) then
411C We don't go over a specified limit (default or manual set or limit threshold)
412 return
413 endif
414
415 qaid = qaid + 1
416
417C If the value (double precision) variable is 0.0 we consider using the idin (integer)
418C The problem with doing that, is that a SPECIFIC VARIABLE PRINT with a real id and a value =0.0 will result in losing the suffix
419C as it will be used as value e.g. (CALL QAPRINT('STOP_STARTER',2,0.0_8) => STOP_STARTER 2 and no more STOP_STARTER_2 0 ) !!!
420 if (value == 0.0) then
421C Forcing the id to 0, we don't want to add any name suffix in this case
422 id = 0
423 else
424 id = abs(idin)
425 endif
426
427 if ( id > 99999 ) id = 90000 + mod(id,10000)
428
429
430 if ( id == 0 ) then
431 intstart = 6
432 siid = ' '
433 else
434 write (siid,'(i6.6)') id
435 intstart = 1
436 if ( id <= 999 ) intstart = 3
437 siid(intstart:intstart) = '_'
438 endif
439
440 simg = '<i> '
441 is = 4
442
443 rvalue = real(value) !(i)
444 if ( rvalue == 0.0 ) then
445! normalize zero to limit p4 differences between platforms
446 srvalue = ' 0.00000'
447 else
448 write(srvalue,qa_format) value !(i)
449 endif
450
451C Replace possible blank char in name (when it comes from array print)
452 call blank2underscore(name,name2)
453
454C We don't go over 9999 lines, this is a default limitation
455 if (qaid == qaprint_limit) then
456
457 write(qaprint_limit_char, '(i12)') qaprint_limit
458 qaprint_limit_char = adjustl(qaprint_limit_char)
459 write ( lunitqa, 1002 ) qaid, 'QAPRINT_IS_LIMITED_TO_',qaprint_limit_char(1:len_trim(qaprint_limit_char)),
460 . '_LINES_(use_variable_QAPRINT_LIMIT_in_QA.files_to_change_limit)', siid(intstart:6), simg(is:4), 0
461
462 print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
463 write ( warning_msg, 1003 )
464 . 'WARNING : The QAPRINT max number of lines to be printed in the extract file has been reached ('
465 . ,qaprint_limit_char(1:len_trim(qaprint_limit_char)),' lines).'
466 print*,warning_msg(1:len_trim(warning_msg))
467 print*,'To change this limit please setenv the variable QAPRINT_LIMIT'
468 print*,'in the related QA.filesxxx'
469 print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
470
471 else
472C If the value (double precision) variable is 0.0 we consider using the idin (integer) as value
473 if (value == 0.0) then
474 write ( lunitqa, 1000 ) qaid, name2(1:len_trim(name2)), siid(intstart:6), simg(is:4), idin
475 else
476 write ( lunitqa, 1001 ) qaid, name2(1:len_trim(name2)), siid(intstart:6), simg(is:4), srvalue(1:lastchar(srvalue))
477 endif
478 endif
479
480 1000 format( i10, 2x, a, a, a, i12 )
481 1001 format( i10, 2x, a, a, a, a )
482 1002 format( i10, 2x, a, a, a, a, a, i12 )
483 1003 format( a, a, a )
484
485 is = 1
486
487 call flush(lunitqa)
488 RETURN
489 end subroutine qaprint
490
491! ----------------------------------------------------------------------
492!> @purpose
493!> print one entry to QA extract file in an energy style (<value> <value max>)
494!> @ingroup utl_qa
495!||====================================================================
496!|| qaprint2 ../common_source/qa/qa_out_mod.F
497!||--- called by ------------------------------------------------------
498!|| qaclose ../common_source/qa/qa_out_mod.F
499!||--- calls -----------------------------------------------------
500!|| lastchar ../common_source/qa/qa_out_mod.F
501!||====================================================================
502 subroutine qaprint2 ( name, idin, value, value2 )
503#include "implicit_f.inc"
504
505 character *(*) name
506 integer idin, id
507 double precision value !(2)
508 double precision value2 !(2)
509 real rvalue
510 real rvalue2
511 character *20 srvalue
512 character *20 srvalue2
513 character *6 siid
514 character*4 simg
515 integer intstart, is
516 integer ma4cmplx
517 data ma4cmplx/-999/
518
519 if ( doqa /= 1 ) return
520
521 qaid = qaid + 1
522
523 id = abs(idin)
524 if ( id > 99999 ) id = 90000 + mod(id,10000)
525
526 if ( id == 0 ) then
527 intstart = 6
528 siid = ' '
529 else
530 write (siid,'(i6.6)') id
531 intstart = 1
532 if ( id <= 999 ) intstart = 3
533 siid(intstart:intstart) = '_'
534 endif
535
536 simg = '<i> '
537 is = 4
538
539 rvalue = real(value) !(i)
540 if ( rvalue == 0.0 ) then
541! normalize zero to limit p4 differences between platforms
542 srvalue = ' 0.00000'
543 else
544 write(srvalue,qa_format) value !(i)
545 endif
546
547 rvalue2 = real(value2) !(i)
548 if ( rvalue2 == 0.0 ) then
549! normalize zero to limit p4 differences between platforms
550 srvalue2 = ' 0.00000'
551 else
552 write(srvalue2,qa_format) value2 !(i)
553 endif
554
555 write ( lunitqa, 1000 ) qaid, name(1:len_trim(name)), siid(intstart:6), simg(is:4),
556 . srvalue(1:lastchar(srvalue)),
557 . srvalue2(1:lastchar(srvalue2))
558 1000 format( i10, 2x, a, a, a, a, a )
559
560 is = 1
561
562 call flush(lunitqa)
563 RETURN
564 end subroutine qaprint2
565
566! ----------------------------------------------------------------------
567!> @purpose
568!> get QA status
569!> @ingroup utl_qa
570!||====================================================================
571!|| qastatus ../common_source/qa/qa_out_mod.F
572!||====================================================================
573 subroutine qastatus (istatus)
574#include "implicit_f.inc"
575 integer istatus
576
577 if ( doqa == 1) then
578 istatus = 1
579 else
580 istatus = 0
581 endif
582 RETURN
583 end subroutine qastatus
584
585! ----------------------------------------------------------------------
586!> @purpose
587!> write an integer value in standard values array qa_storage
588!> @ingroup utl_qa
589!||====================================================================
590!|| qaseti ../common_source/qa/qa_out_mod.F
591!||====================================================================
592 subroutine qaseti (pos,title,i)
593#include "implicit_f.inc"
594 integer pos
595 character(*) title
596 integer i
597
598 qa_storage(pos)%itype=1
599 write(qa_storage(pos)%title,'(A)')title(1:len_trim(title))
600 qa_storage(pos)%valuei=i
601 qa_storage(pos)%itype=1
602 RETURN
603 end subroutine qaseti
604
605! ----------------------------------------------------------------------
606!> @purpose
607!> write a real value in standard values array qa_storage
608!> @ingroup utl_qa
609!||====================================================================
610!|| qasetr ../common_source/qa/qa_out_mod.F
611!||====================================================================
612 subroutine qasetr (pos,title,r)
613#include "implicit_f.inc"
614 integer pos
615 character(*) title
616 double precision r
617
618 qa_storage(pos)%itype=2
619 write(qa_storage(pos)%title,'(A)')title(1:len_trim(title))
620 qa_storage(pos)%valuer=r
621 qa_storage(pos)%itype=1
622 RETURN
623 end subroutine qasetr
624
625! ----------------------------------------------------------------------
626!> @purpose
627!> close QA extract file
628!> @ingroup utl_qa
629!> Care when routine is called from Fortran (because of binding)
630!||====================================================================
631!|| qaclose ../common_source/qa/qa_out_mod.F
632!||--- called by ------------------------------------------------------
633!|| arret ../engine/source/system/arret.F
634!||--- calls -----------------------------------------------------
635!|| qaprint ../common_source/qa/qa_out_mod.F
636!|| qaprint2 ../common_source/qa/qa_out_mod.F
637!||====================================================================
638 subroutine qaclose ( ) bind ( C, name="qaclose_" )
639#include "implicit_f.inc"
640 integer i
641
642 if ( doqa /= 1 ) return
643
644C Exclusive section in case of SPM (concurrence!) only the 1st thread executes this
645!$OMP SINGLE
646
647C Look for EMAX index in struct
648 emax_index = 0
649 do i=1,lqa_storage
650 if (qa_storage(i)%title == "EMAX") then
651 emax_index = i
652 exit
653 end if
654 end do
655
656! dump value qa_storage values before closing ...
657 do i=1,lqa_storage
658 if (qa_storage(i)%itype>0) then
659 if (qa_storage(i)%title == 'IENERGY'
660 . .OR. qa_storage(i)%title == 'KENERGYT'
661 . .OR. qa_storage(i)%title == 'KENERGYR'
662 . .OR. qa_storage(i)%title == 'EXTWORK'
663 . ) then
664 call qaprint2 ( qa_storage(i)%title, qa_storage(i)%valuei, qa_storage(i)%valuer, qa_storage(emax_index)%valuer)
665 else
666 if (i /= emax_index) then
667C A trick to pass an integer is to use idin (2nd parameter) and valuer = 0.0
668 call qaprint ( qa_storage(i)%title, qa_storage(i)%valuei, qa_storage(i)%valuer)
669 end if
670 end if
671 end if
672 end do
673! dump value qa_storage values before closing end.
674
675 close ( lunitqa )
676
677!$OMP END SINGLE
678 return
679 RETURN
680 end subroutine qaclose
681
682! ----------------------------------------------------------------------
683!> @purpose
684!> Check if a given value is part of the values set by env variable
685!> Useful to make a condition on a qaprint
686!> Return true or false
687!> @ingroup utl_qa
688!||====================================================================
689!|| myqakey ../common_source/qa/qa_out_mod.F
690!||--- called by ------------------------------------------------------
691!|| qagetqakeyenv ../common_source/qa/qa_out_mod.F
692!||====================================================================
693 function myqakey ( value ) result (tf)
694#include "implicit_f.inc"
695 integer i
696 character (len=*) :: value
697 character *64 value_without_leading_blank
698 logical tf
699
700 tf = .false.
701 if ( doqa /= 1 ) return
702
703 do i=1,size(split_qakey_env)
704C Remove leading blank if any
705 value_without_leading_blank=adjustl(split_qakey_env(i))
706 if (value_without_leading_blank(1:len_trim(value_without_leading_blank)) == value(1:len_trim(value))) then
707 tf = .true.
708 exit
709 endif
710 enddo
711
712 end function myqakey
713
714! ----------------------------------------------------------------------
715!> @purpose
716!> Check if a given value is the predefined array of available qakeys
717!> Useful to check if a qakey is allowed/available
718!> Return true or false (false = program must exit with an error)
719!> @ingroup utl_qa
720!||====================================================================
721!|| is_value_in_qakeylist_avail ../common_source/qa/qa_out_mod.F
722!||--- called by ------------------------------------------------------
723!|| qagetqakeyenv ../common_source/qa/qa_out_mod.F
724!||====================================================================
725 function is_value_in_qakeylist_avail ( value ) result (tf)
726#include "implicit_f.inc"
727 integer i,len1,len2
728 character *64 value, value_without_leading_blank
729 logical tf
730
731 tf = .false.
732
733 do i=1,size(qakeylist_avail)
734C Remove leading blank if any
735 value_without_leading_blank=adjustl(qakeylist_avail(i))
736 len1=len_trim(value_without_leading_blank)
737 len2=len_trim(value)
738 if(len1 == len2)then
739 if (value_without_leading_blank(1:len1) == value(1:len2)) then
740 tf = .true.
741 exit
742 endif
743 endif
744 enddo
745
746 end function is_value_in_qakeylist_avail
747
748! ----------------------------------------------------------------------
749!||====================================================================
750!|| lastchar ../common_source/qa/qa_out_mod.F
751!||--- called by ------------------------------------------------------
752!|| qaprint ../common_source/qa/qa_out_mod.F
753!|| qaprint2 ../common_source/qa/qa_out_mod.F
754!||====================================================================
755 integer function lastchar(a)
756#include "implicit_f.inc"
757 character *(*) a
758
759c lmax = len(a)
760c do while ( l <= lmax .and. a(l:l) > ' ' )
761c l = l + 1
762c enddo
763c lastchar = l
764 lastchar=len_trim(a)
765 return
766 end function lastchar
767
768!!!!!!!!!!!!!!!!!!!!!!!!!!
769! Not used function
770!!!!!!!!!!!!!!!!!!!!!!!!!!
771
772! ----------------------------------------------------------------------
773!> @purpose
774!> print 'QASKIP' into extract and terminate the program
775!> @note
776!> 'QASKIP' in the extract file will be identified by qa_script
777!> and will be regarded as a test to be skipped by QA
778!> @ingroup utl_qa
779C subroutine qaskip()
780C #include "implicit_f.inc"
781C integer iqa
782C call qastatus(iqa)
783C if (iqa <= 0) return
784C call qaprint('QASKIP',0, 0.0D0)
785C call qaclose()
786C stop 0
787C RETURN
788C end subroutine qaskip
789
790! ----------------------------------------------------------------------
791!> @purpose
792!> qa print for integer array
793!> @ingroup utl_qa
794C subroutine qaprint_ia ( name,ivar,ndim,index,ilast )
795C #include "implicit_f.inc"
796C integer ndim, index, ilast
797C integer ivar(ndim)
798C character*(*) name
799C character*48 tmpmsg
800C integer nlen
801C !integer lastchar, nlen
802C !external lastchar
803C #define NQAVAR 10
804C #define LIQAVAR 30
805C #define LRQAVAR 40
806C integer i, ifirst, iqavar(3,NQAVAR)
807C double precision rqavar(4,NQAVAR), vari
808C !
809C data ifirst /1/, iqavar /LIQAVAR*0/, rqavar /LRQAVAR*0.0d0/
810C !
811C if (doqa /= 1) return
812C !
813C if (ifirst == 1) then
814C do i = 1,NQAVAR
815C iqavar(1,i) = 0
816C iqavar(2,i) = 0
817C iqavar(3,i) = 0
818C rqavar(1,i) = 1.0d99
819C rqavar(2,i) =-1.0d99
820C rqavar(3,i) = 0.0d0
821C rqavar(4,i) = 0.0d0
822C enddo
823C ifirst = 0
824C endif
825C !
826C do i = 1,ndim
827C vari = ivar(i)
828C if (vari < rqavar(1,index)) then
829C rqavar(1,index) = vari
830C iqavar(1,index) = iqavar(3,index) + i
831C endif
832C if (vari > rqavar(2,index)) then
833C rqavar(2,index) = vari
834C iqavar(2,index) = iqavar(3,index) + i
835C endif
836C rqavar(3,index) = rqavar(3,index) + vari
837C rqavar(4,index) = rqavar(4,index) + vari**2
838C enddo
839C iqavar(3,index) = iqavar(3,index) + ndim
840C !
841C nlen = lastchar(name)
842C !
843C if (ilast /= 0) then
844C if (iqavar(3,index) == 0) then
845C write(tmpmsg,'(A,A)') name(1:nlen),'-ndim'
846C call qaprint(tmpmsg,0, 1.0d0*iqavar(3,index))
847C else if (iqavar(3,index) == 1) then
848C write(tmpmsg,'(A,A)') name(1:nlen),'-var'
849C call qaprint(tmpmsg,0, 1.0d0*ivar(1))
850C else
851C write(tmpmsg,'(A,A)') name(1:nlen),'-ndim'
852C call qaprint(tmpmsg,0, 1.0d0*iqavar(3,index))
853C write(tmpmsg,'(A,A)') name(1:nlen),'-minvar'
854C call qaprint(tmpmsg,0, 1.0d0*rqavar(1,index))
855C write(tmpmsg,'(A,A)') name(1:nlen),'-iminvar'
856C call qaprint(tmpmsg,0, 1.0d0*iqavar(1,index))
857C write(tmpmsg,'(A,A)') name(1:nlen),'-maxvar'
858C call qaprint(tmpmsg,0, 1.0d0*rqavar(2,index))
859C write(tmpmsg,'(A,A)') name(1:nlen),'-imaxvar'
860C call qaprint(tmpmsg,0, 1.0d0*iqavar(2,index))
861C write(tmpmsg,'(A,A)') name(1:nlen),'-sumvar'
862C call qaprint(tmpmsg,0, 1.0d0*rqavar(3,index))
863C write(tmpmsg,'(A,A)') name(1:nlen),'-normvar'
864C call qaprint(tmpmsg,0, 1.0d0*rqavar(4,index))
865C endif
866C iqavar(1,index) = 0
867C iqavar(2,index) = 0
868C iqavar(3,index) = 0
869C rqavar(1,index) = 1.0d99
870C rqavar(2,index) =-1.0d99
871C rqavar(3,index) = 0.0d0
872C rqavar(4,index) = 0.0d0
873C endif
874C !
875C return
876C RETURN
877C end subroutine qaprint_ia
878
879! ----------------------------------------------------------------------
880!> @purpose
881!> qa print for real array
882!> @ingroup utl_qa
883C subroutine qaprint_ra ( name,rvar,ndim,index,ilast )
884C #include "implicit_f.inc"
885C integer ndim, index, ilast
886C double precision rvar(ndim)
887C character*(*) name
888C character*48 tmpmsg
889C integer nlen
890C !integer lastchar, nlen
891C !external lastchar
892C #define NQAVAR 10
893C #define LIQAVAR 30
894C #define LRQAVAR 40
895C integer i, ifirst, iqavar(3,NQAVAR)
896C double precision rqavar(4,NQAVAR), vari
897C !
898C data ifirst /1/, iqavar /LIQAVAR*0/, rqavar /LRQAVAR*0.0d0/
899C !
900C if (doqa /= 1) return
901C !
902C if (ifirst == 1) then
903C do i = 1,NQAVAR
904C rqavar(1,i) = 1.0d99
905C rqavar(2,i) =-1.0d99
906C enddo
907C ifirst = 0
908C endif
909C !
910C do i = 1,ndim
911C vari = rvar(i)
912C if (vari < rqavar(1,index)) then
913C rqavar(1,index) = vari
914C iqavar(1,index) = iqavar(3,index) + i
915C endif
916C if (vari > rqavar(2,index)) then
917C rqavar(2,index) = vari
918C iqavar(2,index) = iqavar(3,index) + i
919C endif
920C rqavar(3,index) = rqavar(3,index) + vari
921C rqavar(4,index) = rqavar(4,index) + vari**2
922C enddo
923C iqavar(3,index) = iqavar(3,index) + ndim
924C !
925C nlen = lastchar(name)
926C !
927C if (ilast /= 0) then
928C if (iqavar(3,index) == 0) then
929C write(tmpmsg,'(A,A)') name(1:nlen),'-ndim'
930C call qaprint(tmpmsg,0, 1.0d0*iqavar(3,index))
931C else if (iqavar(3,index) == 1) then
932C write(tmpmsg,'(A,A)') name(1:nlen),'-var'
933C call qaprint(tmpmsg,0, 1.0d0*rvar(1))
934C else
935C write(tmpmsg,'(A,A)') name(1:nlen),'-ndim'
936C call qaprint(tmpmsg,0, 1.0d0*iqavar(3,index))
937C write(tmpmsg,'(A,A)') name(1:nlen),'-minvar'
938C call qaprint(tmpmsg,0, 1.0d0*rqavar(1,index))
939C write(tmpmsg,'(A,A)') name(1:nlen),'-iminvar'
940C call qaprint(tmpmsg,0, 1.0d0*iqavar(1,index))
941C write(tmpmsg,'(A,A)') name(1:nlen),'-maxvar'
942C call qaprint(tmpmsg,0, 1.0d0*rqavar(2,index))
943C write(tmpmsg,'(A,A)') name(1:nlen),'-imaxvar'
944C call qaprint(tmpmsg,0, 1.0d0*iqavar(2,index))
945C write(tmpmsg,'(A,A)') name(1:nlen),'-sumvar'
946C call qaprint(tmpmsg,0, 1.0d0*rqavar(3,index))
947C write(tmpmsg,'(A,A)') name(1:nlen),'-normvar'
948C call qaprint(tmpmsg,0, 1.0d0*rqavar(4,index))
949C endif
950C iqavar(1,index) = 0
951C iqavar(2,index) = 0
952C iqavar(3,index) = 0
953C rqavar(1,index) = 1.0d99
954C rqavar(2,index) =-1.0d99
955C rqavar(3,index) = 0.0d0
956C rqavar(4,index) = 0.0d0
957C endif
958C !
959C return
960C RETURN
961C end subroutine qaprint_ra
962
963!! ----------------------------------------------------------------------
964!!> @purpose
965!!> print a complex value in magnitude and radian to QA extract file
966!!> @ingroup utl_qa
967! subroutine qaprint_c ( name, idin, value )
968!#include "implicit_f.inc"
969!
970! character *(*) name
971! integer idin, id
972! double precision value(2)
973!!
974! double precision rvalue
975! character *20 srvalue
976! character *6 siid
977! character*4 simg
978! integer i, nvals, intstart, is, lastchar, namelen
979! logical chk
980!
981!
982! if ( doqa /= 1 ) return
983!
984! qaid = qaid + 1
985!
986! id = abs(idin)
987! if ( id > 99999 ) &
988! id = 90000 + mod(id,10000)
989!
990!
991! if ( id == 0 ) then
992! intstart = 6
993! siid = ' '
994! else
995! write (siid,'(i6.6)') id
996! intstart = 1
997! if ( id <= 999 ) intstart = 3
998! siid(intstart:intstart) = '_'
999! endif
1000!
1001! simg = '<M> '
1002!
1003! rvalue = ABS(CMPLX(value(1),value(2)))
1004! if ( rvalue == 0.0D0 ) then
1005!! normalize zero to limit p4 differences between platforms
1006! srvalue = ' 0.00000'
1007! else
1008! write(srvalue,qa_format) rvalue
1009! endif
1010!
1011! write ( lunitqa, 1000 ) qaid, name, &
1012! siid(intstart:6), simg, srvalue(1:lastchar(srvalue))
1013! 1000 format( i10, 2x, a, a, a, a )
1014!
1015! simg = '<A> '
1016!
1017! if ( rvalue /= 0.0D0 ) then
1018! rvalue = ATAN2(value(2),value(1))
1019! end if
1020!
1021! if ( rvalue == 0.0D0 ) then
1022!! normalize zero to limit p4 differences between platforms
1023! srvalue = ' 0.00000'
1024! else
1025! write(srvalue,qa_format) rvalue
1026! endif
1027!
1028! write ( lunitqa, 1000 ) qaid, name, &
1029! siid(intstart:6), simg, srvalue(1:lastchar(srvalue))
1030!
1031!
1032! call flush(lunitqa)
1033!
1034! RETURN
1035! end subroutine qaprint_c
1036! ----------------------------------------------------------------------
1037
1038
1039
1040
1041
1042 end module qa_out_mod
qa_out_mod
Definition qa_out_mod.F:78
qa_out_mod::lunitqa
integer lunitqa
Definition qa_out_mod.F:84
qa_out_mod::qasetr
subroutine qasetr(pos, title, r)
@purpose write a real value in standard values array qa_storage
Definition qa_out_mod.F:613
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::emax_index
integer emax_index
Definition qa_out_mod.F:107
qa_out_mod::qaclose
subroutine qaclose()
@purpose close QA extract fileCare when routine is called from Fortran (because of binding)
Definition qa_out_mod.F:639
qa_out_mod::next_index
integer next_index
Definition qa_out_mod.F:84
qa_out_mod::qaopen
subroutine qaopen(step)
@purpose open QA extract file
Definition qa_out_mod.F:132
qa_out_mod::qaprint2
subroutine qaprint2(name, idin, value, value2)
@purpose print one entry to QA extract file in an energy style ()
Definition qa_out_mod.F:503
qa_out_mod::qaid
integer qaid
Definition qa_out_mod.F:84
qa_out_mod::qaprint_limit_default
integer, parameter qaprint_limit_default
Definition qa_out_mod.F:87
qa_out_mod::qa_storage
type(tqa_value), dimension(:), allocatable qa_storage
Definition qa_out_mod.F:98
qa_out_mod::qagetqakeyenv
subroutine qagetqakeyenv()
@purpose get and store the possible values of the QAKEY env variable
Definition qa_out_mod.F:220
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
qa_out_mod::split_qakey_env
character(len=64), dimension(520) split_qakey_env
Definition qa_out_mod.F:115
qa_out_mod::nqakeylist_avail
integer nqakeylist_avail
Definition qa_out_mod.F:111
qa_out_mod::qaseti
subroutine qaseti(pos, title, i)
@purpose write an integer value in standard values array qa_storage
Definition qa_out_mod.F:593
qa_out_mod::blank2underscore
subroutine blank2underscore(textin, textout)
@purpose replace blank char with _ for a given string
Definition qa_out_mod.F:320
qa_out_mod::is_value_in_qakeylist_avail
logical function is_value_in_qakeylist_avail(value)
@purpose Check if a given value is the predefined array of available qakeys Useful to check if a qake...
Definition qa_out_mod.F:726
qa_out_mod::qaprint_limit
integer qaprint_limit
Definition qa_out_mod.F:89
qa_out_mod::qaprint_limit_maxx
integer, parameter qaprint_limit_maxx
Definition qa_out_mod.F:88
qa_out_mod::lqa_storage
integer lqa_storage
Definition qa_out_mod.F:85
qa_out_mod::qa_format
character *12 qa_format
Definition qa_out_mod.F:100
qa_out_mod::lastchar
integer function lastchar(a)
Definition qa_out_mod.F:756
qa_out_mod::qastatus
subroutine qastatus(istatus)
@purpose get QA status
Definition qa_out_mod.F:574
qa_out_mod::doqa
integer doqa
Definition qa_out_mod.F:84
qa_out_mod::tqa_value
Definition qa_out_mod.F:91