Data Types
type	tqa_value

Functions/Subroutines
subroutine	qaopen (step)
	@purpose open QA extract file
subroutine	qagetqakeyenv ()
	@purpose get and store the possible values of the QAKEY env variable
subroutine	blank2underscore (textin, textout)
	@purpose replace blank char with _ for a given string
subroutine	qaprint (name, idin, value)
	@purpose print one entry to QA extract file example of call for real print CALL QAPRINT('MY_LABEL',0,12345.6_8) (2nd argument is 0, 3rd is the real value to be printed followed with '_8') example of call for integer print CALL QAPRINT('MY_LABEL',123456,0.0_8) (2nd argument is the integer value to be printed, 3rd must be 0.0_8)
subroutine	qaprint2 (name, idin, value, value2)
	@purpose print one entry to QA extract file in an energy style ()
subroutine	qastatus (istatus)
	@purpose get QA status
subroutine	qaseti (pos, title, i)
	@purpose write an integer value in standard values array qa_storage
subroutine	qasetr (pos, title, r)
	@purpose write a real value in standard values array qa_storage
subroutine	qaclose ()
	@purpose close QA extract fileCare when routine is called from Fortran (because of binding)
logical function	myqakey (value)
	@purpose Check if a given value is part of the values set by env variable Useful to make a condition on a qaprint Return true or false
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 qakey is allowed/available Return true or false (false = program must exit with an error)
integer function	lastchar (a)

Variables
integer	doqa
integer	lunitqa
integer	qaid
integer	next_index
integer	lqa_storage
integer, parameter	qaprint_limit_default = 10000
integer, parameter	qaprint_limit_maxx = 500000
integer	qaprint_limit
type(tqa_value), dimension(:), allocatable	qa_storage
character *12	qa_format
integer	emax_index
integer	nqakeylist_avail
character(len=64), dimension(520)	split_qakey_env

Function/Subroutine Documentation

◆ blank2underscore()

subroutine qa_out_mod::blank2underscore	(	character(len=*), intent(in)	textin,
		character(len=len_trim(textin)), intent(out)	textout )

@purpose replace blank char with _ for a given string

Definition at line 319 of file qa_out_mod.F.

#include      "implicit_f.inc"
          character(len=*), intent(in) :: textin
          character(len=LEN_TRIM(textin)), intent(out)  ::  textout
          integer i
 
          textout=textin
 
          do i=1,len_trim(textout)
            if (textout(i:i) == ' ') then
              textout(i:i)='_';
            endif
          enddo
 

◆ is_value_in_qakeylist_avail()

logical function qa_out_mod::is_value_in_qakeylist_avail ( value )

@purpose Check if a given value is the predefined array of available qakeys Useful to check if a qakey is allowed/available Return true or false (false = program must exit with an error)

Definition at line 725 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer i,len1,len2
          character *64 value, value_without_leading_blank
          logical tf
 
          tf = .false.
 
          do i=1,size(qakeylist_avail)
C         Remove leading blank if any
            value_without_leading_blank=adjustl(qakeylist_avail(i))
            len1=len_trim(value_without_leading_blank)
            len2=len_trim(value)
            if(len1 == len2)then
              if (value_without_leading_blank(1:len1) == value(1:len2)) then
                tf = .true.
                exit
              endif
            endif
          enddo
 

◆ lastchar()

integer function qa_out_mod::lastchar ( character *(*) a )

Definition at line 755 of file qa_out_mod.F.

#include "implicit_f.inc"
          character *(*) a
 
c      lmax = len(a)
c      do while ( l <= lmax .and. a(l:l) > ' ' )
c        l = l + 1
c      enddo
c      lastchar = l
          lastchar=len_trim(a)
          return

◆ myqakey()

logical function qa_out_mod::myqakey ( character (len=*) value )

@purpose Check if a given value is part of the values set by env variable Useful to make a condition on a qaprint Return true or false

Definition at line 693 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer i
          character (len=*) :: value
          character *64 value_without_leading_blank
          logical tf
 
          tf = .false.
          if ( doqa /= 1  ) return
 
          do i=1,size(split_qakey_env)
C         Remove leading blank if any
            value_without_leading_blank=adjustl(split_qakey_env(i))
            if (value_without_leading_blank(1:len_trim(value_without_leading_blank)) == value(1:len_trim(value))) then
              tf = .true.
              exit
            endif
          enddo
 

◆ qaclose()

subroutine qa_out_mod::qaclose

@purpose close QA extract fileCare when routine is called from Fortran (because of binding)

Definition at line 638 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer i
 
          if ( doqa /= 1  ) return
 
C     Exclusive section in case of SPM (concurrence!) only the 1st thread executes this
!$OMP SINGLE
 
C     Look for EMAX index in struct
          emax_index = 0
          do i=1,lqa_storage
            if (qa_storage(i)%title == "EMAX") then
              emax_index = i
              exit
            end if
          end do
 
! dump value qa_storage values before closing ...
          do i=1,lqa_storage
            if (qa_storage(i)%itype>0) then
              if   (qa_storage(i)%title == 'IENERGY'
     .         .OR. qa_storage(i)%title == 'KENERGYT'
     .         .OR. qa_storage(i)%title == 'KENERGYR'
     .         .OR. qa_storage(i)%title == 'EXTWORK'
     .        ) then
                call qaprint2 ( qa_storage(i)%title, qa_storage(i)%valuei, qa_storage(i)%valuer, qa_storage(emax_index)%valuer)
              else
                if (i /= emax_index) then
C             A trick to pass an integer is to use idin (2nd parameter) and valuer = 0.0
                  call qaprint ( qa_storage(i)%title, qa_storage(i)%valuei, qa_storage(i)%valuer)
                end if
              end if
            end if
          end do
! dump value qa_storage values before closing end.
 
          close ( lunitqa )
 
!$OMP END SINGLE
          return
          RETURN

◆ qagetqakeyenv()

subroutine qa_out_mod::qagetqakeyenv

@purpose get and store the possible values of the QAKEY env variable

Definition at line 219 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer QAKEY_ENV_len, QAKEY_ENV_status, QAKEY_SPECIFIC_len, QAKEY_SPECIFIC_status, i, j, k
C       length is (64 chars + 1 comma)*16 occurrence - last comma (no comma at the end) = 1039
          character(LEN=1039)  QAKEY_ENV, QAKEY_SPECIFIC
          character(64) temp_qakey
          integer QAPRINT_LIMIT_ENV_len, QAPRINT_LIMIT_ENV_status
          character(LEN=12) QAPRINT_LIMIT_ENV
 
C     Initializing qaprint_limit with its default value
          qaprint_limit = qaprint_limit_default
C     If the env variable QAPRINT_LIMIT is defined, we replace the limit
          qaprint_limit_env = ''
          call get_environment_variable("QAPRINT_LIMIT",qaprint_limit_env,qaprint_limit_env_len,qaprint_limit_env_status,.true.)
          if (qaprint_limit_env /= '') then
            read(qaprint_limit_env,'(i12)') qaprint_limit
          endif
 
          if (qaprint_limit > qaprint_limit_maxx) then
            qaprint_limit = qaprint_limit_maxx
          endif
 
C       WRITE(*,'(a,i12)') "TRACE qaprint_limit is ",qaprint_limit,"END"
 
          qakey_env = ''
          call get_environment_variable("QAKEY",qakey_env,qakey_env_len,qakey_env_status,.true.)
 
          temp_qakey=''
          j=1
          k=1
          do i=1,len_trim(qakey_env)+1
            if (qakey_env(i:i) == ',' .OR. i == len_trim(qakey_env)+1) then
              if (temp_qakey /= '') then
 
                ! Checking if the found keyword is allowed, if not => error reading input
                IF (is_value_in_qakeylist_avail(temp_qakey)) THEN
                  IF (.NOT. myqakey(temp_qakey)) THEN
                    split_qakey_env(j)=temp_qakey
                    j=j+1
                  ENDIF
                ELSE
                  print*,"ERROR : THE QAKEY ", temp_qakey(1:len_trim(temp_qakey)), " IS NOT AVAILABLE, ABORTING"
                  close ( lunitqa )
                  stop
                ENDIF
                temp_qakey=''
              endif
              k=1
            else
              temp_qakey(k:k)=qakey_env(i:i)
              k=k+1
            endif
          end do
 
          call get_environment_variable("QAKEY_SPECIFIC",qakey_specific,qakey_specific_len,qakey_specific_status,.true.)
 
          temp_qakey=''
          k=1
          do i=1,len_trim(qakey_specific)+1
            if (qakey_specific(i:i) == ',' .OR. i == len_trim(qakey_specific)+1) then
              if (temp_qakey /= '') then
 
                ! Checking if the found keyword is allowed, if not => error reading input
                IF (is_value_in_qakeylist_avail(temp_qakey)) THEN
                  IF (.NOT. myqakey(temp_qakey)) THEN
                    split_qakey_env(j)=temp_qakey
                    j=j+1
                  ENDIF
                ELSE
                  print*,"ERROR : THE QAKEY ", temp_qakey(1:len_trim(temp_qakey)), " IS NOT AVAILABLE, ABORTING"
                  close ( lunitqa )
                  stop
                ENDIF
                temp_qakey=''
              endif
              k=1
            else
              temp_qakey(k:k)=qakey_specific(i:i)
              k=k+1
            endif
          end do
 
C       TRACE
C         do i=1,size(split_qakey_env)
C             PRINT*,"QAKEY TRACE : ",split_qakey_env(i)
C         enddo
 
 
          RETURN

◆ qaopen()

subroutine qa_out_mod::qaopen ( character(len=*) step )

@purpose open QA extract file

Definition at line 131 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer preci
          integer i
          logical RD_extract_file
          character *100 env
          character(len=*) :: step
 
          rd_extract_file=.false.
 
          call getenv ( 'DO_QA', env )
          doqa = 0
 
          if ( env /= 'ON' ) then
            return
          endif
 
 
          allocate(qa_storage(lqa_storage))
          do i=1,lqa_storage
            qa_storage(i)%itype=0
            qa_storage(i)%title=''
            qa_storage(i)%valuer=0.0_8
            qa_storage(i)%valuei=0
          end do
 
!     open the file
          open ( lunitqa, file='RD-qa.extract', err=9010 )
 
C     In engine step we append print in the extract file, in starter we
C     create the file from scratch
 
          if (step(1:len_trim(step)) == "engine") then
 
C       We get the next index value (in the case we are in engine, we want
C       to continue the id at the following, so read the RD.extract file
C       to get the value and set qaid for next qaprint
 
            next_index=0
 1001       read ( lunitqa, 2001, end=3001 ) next_index
 2001       format(i10)
            goto 1001
 3001       continue
 
#ifdef __GFORTRAN__
            ! Only Gfortran / Intel compiler works fine
            ! -----------------------------------------
            ! Gfortran cannot write after EOF
            ! Needs to do a Backspace to place just before EOF.
            backspace lunitqa
#endif
 
            qaid = next_index
          endif
          qa_format = '(g16.9)'
          preci = 9
 
          write( qa_format, 1200 ) 7+preci, preci
 1200     format('(g',i2,'.',i1,')')
 
          doqa = 1
 
 
C     Get possible defined env variable QAKEY
          call qagetqakeyenv()
 
 
          return
 
 9010     continue
 
          write(*,*) 'Error opening extract file'
          doqa = 2
          RETURN

◆ qaprint()

subroutine qa_out_mod::qaprint	(	character(len=*)	name,
		integer	idin,
			value )

@purpose print one entry to QA extract file example of call for real print CALL QAPRINT('MY_LABEL',0,12345.6_8) (2nd argument is 0, 3rd is the real value to be printed followed with '_8') example of call for integer print CALL QAPRINT('MY_LABEL',123456,0.0_8) (2nd argument is the integer value to be printed, 3rd must be 0.0_8)

Definition at line 389 of file qa_out_mod.F.

#include "implicit_f.inc"
 
          character(len=*) :: name
          character(len=LEN_TRIM(name)) :: name2
          integer idin, id
          double precision value    !(2)
          real rvalue
          character *20 srvalue
          character *6  siid
          character*4 simg
          integer intstart, is
          integer ma4cmplx
          data ma4cmplx/-999/
          character *40 qaprint_limit_char
          character(len=512) :: warning_msg
 
          qaprint_limit_char = ' '
 
          if ( doqa /= 1  ) return
 
          if (qaid == qaprint_limit) then
c       we don't go over a specified limit (default or manual set or limit threshold)
            return
          endif
 
          qaid = qaid + 1
 
C     If the value (double precision) variable is 0.0 we consider using the idin (integer)
C     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
C     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  ) !!!
          if (value == 0.0) then
C       Forcing the id to 0, we don't want to add any name suffix in this case
            id = 0
          else
            id = abs(idin)
          endif
 
          if ( id > 99999 ) id = 90000 + mod(id,10000)
 
 
          if ( id == 0 ) then
            intstart = 6
            siid = ' '
          else
            write (siid,'(i6.6)') id
            intstart = 1
            if ( id <= 999 ) intstart = 3
            siid(intstart:intstart) = '_'
          endif
 
          simg = '<i> '
          is = 4
 
          rvalue = real(value)  !(i)
          if ( rvalue == 0.0 ) then
!     normalize zero to limit p4 differences between platforms
            srvalue = ' 0.00000'
          else
            write(srvalue,qa_format) value    !(i)
          endif
 
c       replace possible blank char in name(when it comes from array print)
          call blank2underscore(name,name2)
 
c       we don't go over 9999 lines, this is a default limitation
          if (qaid == qaprint_limit) then
 
            write(qaprint_limit_char, '(i12)') qaprint_limit
            qaprint_limit_char = ADJUSTL(qaprint_limit_char)
            write ( lunitqa, 1002 ) qaid, 'qaprint_is_limited_to_',qaprint_limit_char(1:LEN_TRIM(qaprint_limit_char)),
     .      '_lines_(use_variable_qaprint_limit_in_qa.files_to_change_limit)', siid(intstart:6), simg(is:4), 0
 
            PRINT*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
            write ( warning_msg, 1003 ) 
     .      'warning : the qaprint max number of lines to be printed in the extract file has been reached('
     .      ,qaprint_limit_char(1:LEN_TRIM(qaprint_limit_char)),' lines).'
            PRINT*,warning_msg(1:LEN_TRIM(warning_msg))
            PRINT*,'to change this limit please setenv the variable qaprint_limit'
            PRINT*,'in the related qa.filesxxx'
            PRINT*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
 
          else
C       If the value (double precision) variable is 0.0 we consider using the idin (integer) as value
            if (value == 0.0) then
              write ( lunitqa, 1000 ) qaid, name2(1:LEN_TRIM(name2)), siid(intstart:6), simg(is:4), idin
            else
              write ( lunitqa, 1001 ) qaid, name2(1:LEN_TRIM(name2)), siid(intstart:6), simg(is:4), srvalue(1:lastchar(srvalue))
            endif
          endif
 
 1000     format( i10, 2x, a, a, a, i12 )
 1001     format( i10, 2x, a, a, a, a )
 1002     format( i10, 2x, a, a, a, a, a, i12 )
 1003     format( a, a, a )
 
          is = 1
 
          call flush(lunitqa)
          RETURN

◆ qaprint2()

subroutine qa_out_mod::qaprint2	(	character ()	name,
		integer	idin,
			value,
		double precision, value	value2 )

@purpose print one entry to QA extract file in an energy style ()

Definition at line 502 of file qa_out_mod.F.

#include "implicit_f.inc"
 
          character *(*) name
          integer idin, id
          double precision value    !(2)
          double precision value2    !(2)
          real rvalue
          real rvalue2
          character *20 srvalue
          character *20 srvalue2
          character *6  siid
          character*4 simg
          integer intstart, is
          integer ma4cmplx
          data ma4cmplx/-999/
 
          if ( doqa /= 1  ) return
 
          qaid = qaid + 1
 
          id = abs(idin)
          if ( id > 99999 ) id = 90000 + mod(id,10000)
 
          if ( id == 0 ) then
            intstart = 6
            siid = ' '
          else
            write (siid,'(i6.6)') id
            intstart = 1
            if ( id <= 999 ) intstart = 3
            siid(intstart:intstart) = '_'
          endif
 
          simg = '<i> '
          is = 4
 
          rvalue = real(value)  !(i)
          if ( rvalue == 0.0 ) then
!     normalize zero to limit p4 differences between platforms
            srvalue = ' 0.00000'
          else
            write(srvalue,qa_format) value    !(i)
          endif
 
          rvalue2 = real(value2)  !(i)
          if ( rvalue2 == 0.0 ) then
!     normalize zero to limit p4 differences between platforms
            srvalue2 = ' 0.00000'
          else
            write(srvalue2,qa_format) value2    !(i)
          endif
 
          write ( lunitqa, 1000 ) qaid, name(1:len_trim(name)), siid(intstart:6), simg(is:4),
     .                                          srvalue(1:lastchar(srvalue)),
     .                                          srvalue2(1:lastchar(srvalue2))
 1000     format( i10, 2x, a, a, a, a, a )
 
          is = 1
 
          call flush(lunitqa)
          RETURN

◆ qaseti()

subroutine qa_out_mod::qaseti	(	integer	pos,
		character(*)	title,
		integer	i )

@purpose write an integer value in standard values array qa_storage

Definition at line 592 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer          pos
          character(*)     title
          integer          i
 
          qa_storage(pos)%itype=1
          write(qa_storage(pos)%title,'(A)')title(1:len_trim(title))
          qa_storage(pos)%valuei=i
          qa_storage(pos)%itype=1
          RETURN

◆ qasetr()

subroutine qa_out_mod::qasetr	(	integer	pos,
		character(*)	title,
		double precision	r )

@purpose write a real value in standard values array qa_storage

Definition at line 612 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer          pos
          character(*)     title
          double precision r
 
          qa_storage(pos)%itype=2
          write(qa_storage(pos)%title,'(A)')title(1:len_trim(title))
          qa_storage(pos)%valuer=r
          qa_storage(pos)%itype=1
          RETURN

◆ qastatus()

subroutine qa_out_mod::qastatus ( integer istatus )

@purpose get QA status

Definition at line 573 of file qa_out_mod.F.

#include "implicit_f.inc"
          integer istatus
 
          if ( doqa == 1) then
            istatus = 1
          else
            istatus = 0
          endif
          RETURN

Variable Documentation

◆ doqa

integer qa_out_mod::doqa

Definition at line 84 of file qa_out_mod.F.

84 integer doqa, lunitqa, qaid, next_index

◆ emax_index

integer qa_out_mod::emax_index

Definition at line 107 of file qa_out_mod.F.

107 integer emax_index

◆ lqa_storage

integer qa_out_mod::lqa_storage

Definition at line 85 of file qa_out_mod.F.

85 integer lqa_storage

◆ lunitqa

integer qa_out_mod::lunitqa

Definition at line 84 of file qa_out_mod.F.

◆ next_index

integer qa_out_mod::next_index

Definition at line 84 of file qa_out_mod.F.

◆ nqakeylist_avail

integer qa_out_mod::nqakeylist_avail

Definition at line 111 of file qa_out_mod.F.

111 INTEGER NQAKEYLIST_AVAIL

◆ qa_format

character*12 qa_out_mod::qa_format

Definition at line 100 of file qa_out_mod.F.

100 character*12 qa_format

◆ qa_storage

type(tqa_value), dimension(:), allocatable qa_out_mod::qa_storage

Definition at line 98 of file qa_out_mod.F.

98 type(tqa_value), dimension(:), allocatable :: qa_storage

◆ qaid

integer qa_out_mod::qaid

Definition at line 84 of file qa_out_mod.F.

◆ qaprint_limit

integer qa_out_mod::qaprint_limit

Definition at line 89 of file qa_out_mod.F.

89 integer qaprint_limit

◆ qaprint_limit_default

integer, parameter qa_out_mod::qaprint_limit_default = 10000

Definition at line 87 of file qa_out_mod.F.

87 integer,parameter :: qaprint_limit_default = 10000

◆ qaprint_limit_maxx

integer, parameter qa_out_mod::qaprint_limit_maxx = 500000

Definition at line 88 of file qa_out_mod.F.

88 integer,parameter :: qaprint_limit_maxx = 500000

◆ split_qakey_env

character(len=64), dimension(520) qa_out_mod::split_qakey_env

Definition at line 115 of file qa_out_mod.F.

115 CHARACTER(len=64), DIMENSION(520) :: split_qakey_env

OpenRadioss 2025.1.11 OpenRadioss project

Data Types

Functions/Subroutines

Variables

Function/Subroutine Documentation

◆ blank2underscore()

◆ is_value_in_qakeylist_avail()

◆ lastchar()

◆ myqakey()

◆ qaclose()

◆ qagetqakeyenv()

◆ qaopen()

◆ qaprint()

◆ qaprint2()

◆ qaseti()

◆ qasetr()

◆ qastatus()

Variable Documentation

◆ doqa

◆ emax_index

◆ lqa_storage

◆ lunitqa

◆ next_index

◆ nqakeylist_avail

◆ qa_format

◆ qa_storage

◆ qaid

◆ qaprint_limit

◆ qaprint_limit_default

◆ qaprint_limit_maxx

◆ split_qakey_env