st_qaprint_properties.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    st_qaprint_properties   ../starter/source/output/qaprint/st_qaprint_properties.F
!||--- called by ------------------------------------------------------
!||    st_qaprint_driver       ../starter/source/output/qaprint/st_qaprint_driver.F
!||--- calls      -----------------------------------------------------
!||    fretitl2                ../starter/source/starter/freform.F
!||--- uses       -----------------------------------------------------
!||====================================================================
      SUBROUTINE st_qaprint_properties(IGEO      ,GEO       ,BUFGEO    ,
     .                                 PM_STACK  ,GEO_STACK ,IGEO_STACK)
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE qa_out_mod
      USE names_and_titles_mod , ONLY : nchartitle
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: IGEO(NPROPGI,NUMGEO),IGEO_STACK(4* NPT_STACK+2,NS_STACK)
      my_real, INTENT(IN) :: geo(npropg,numgeo),geo_stack(6*npt_stack+1,ns_stack),
     .                       pm_stack(20,ns_stack),bufgeo(*)
C--------------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, MY_ID, MY_PID, 
     .        iadbuf, nuparam, iadmat, njmat, iadpid, njpid, iadfun, njfun, iadtab, njtab
      CHARACTER(LEN=NCHARTITLE) :: TITR
      CHARACTER (LEN=255) :: VARNAME
      DOUBLE PRECISION TEMP_DOUBLE
C=======================================================================
 
      IF (myqakey('PROPERTIES')) THEN
 
        DO my_pid=1,numgeo
        CALL fretitl2(titr,igeo(npropgi-ltitr+1,my_pid),ltitr) 
C
C         Le Titr de la PID sert de nom de la variable dans le ref.extract , suivi de l'ID de la PID 
C         2 PIDs peuvent avoir le meme titre
          IF(len_trim(titr)/=0)THEN
            CALL qaprint(titr(1:len_trim(titr)),igeo(1,my_pid),0.0_8)
          ELSE
            CALL qaprint('A_PID_FAKE_NAME',igeo(1,my_pid),0.0_8)
          END IF
          DO i=1,npropgi-ltitr ! si on ne peut pas tester une chaine de caracteres, do i=1,npropgi
            IF(igeo(i,my_pid)/=0)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'IGEO_',i      ! IGEO(11) => 'IGEO_11'
              CALL qaprint(varname(1:len_trim(varname)),igeo(i,my_pid),0.0_8)
            END IF
          END DO
          DO i=1,npropg
            IF(geo(i,my_pid)/=zero)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'GEO_',i
              temp_double = geo(i,my_pid)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
C---------------------------------------------------
C Warning: Some properties are storing some other data at the same locations 
C         as the addresses (IADBUF, NUPARAM, etc) in IGEO
C         => to be cleaned before branching THIS !
C---------------------------------------------------
          iadbuf =igeo(57,my_pid)
          nuparam=igeo(52,my_pid)
          DO i=1,nuparam
            IF(bufgeo(iadbuf+i-1)/=zero)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'BUFGEO_IADBUF_',i
              temp_double = bufgeo(iadbuf+i-1)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
          iadfun =igeo(58,my_pid)
          njfun  =igeo(53,my_pid)
          DO i=1,njfun
            IF(bufgeo(iadfun+i-1)/=zero)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'BUFGEO_IADFUN_',i
              temp_double = bufgeo(iadfun+i-1)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
          iadmat =igeo(59,my_pid)
          njmat  =igeo(54,my_pid)
          DO i=1,njmat
            IF(bufgeo(iadmat+i-1)/=zero)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'BUFGEO_IADMAT_',i
              temp_double = bufgeo(iadmat+i-1)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
          iadpid =igeo(60,my_pid)
          njpid  =igeo(55,my_pid)
          DO i=1,njpid
            IF(bufgeo(iadpid+i-1)/=zero)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'BUFGEO_IADPID_',i
              temp_double = bufgeo(iadpid+i-1)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
          iadtab =igeo(61,my_pid)
          njtab  =igeo(56,my_pid)
          DO i=1,njtab
            IF(bufgeo(iadtab+i-1)/=zero)THEN
C
C             VARNAME: variable name in ref.extract (without blanks)
              WRITE(varname,'(A,I0)') 'BUFGEO_IADTAB_',i
              temp_double = bufgeo(iadtab+i-1)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
        END DO
c          
        DO my_pid=1,ns_stack
          my_id = my_pid
          CALL qaprint('STACK_NAME_NO', my_id,0.0_8)
c
          DO i=1,20
            IF (pm_stack(i,my_pid) /= zero) THEN
              WRITE(varname,'(A,I0)') 'STACK_PM_',i
              temp_double = pm_stack(i,my_pid)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
c                  
          DO i=1,6*npt_stack+1
            IF (geo_stack(i,my_pid) /= zero) THEN
              WRITE(varname,'(A,I0)') 'STACK_GEO_',i
              temp_double = geo_stack(i,my_pid)
              CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
            END IF
          END DO
c        
          DO i=1,3*npt_stack+2
            IF (igeo_stack(i,my_pid) /= 0) THEN
              WRITE(varname,'(A,I0)') 'STACK_IGEO_',i     
              CALL qaprint(varname(1:len_trim(varname)),igeo_stack(i,my_pid),0.0_8)
            END IF
          END DO                
        END DO
c        
      END IF
C-----------------------------------------------------------------------
      RETURN
      END