hm_read_thgrsurf.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/.
!||====================================================================
!||    hm_read_thgrsurf         ../starter/source/output/th/hm_read_thgrsurf.F
!||--- called by ------------------------------------------------------
!||    hm_read_thgrou           ../starter/source/output/th/hm_read_thgrou.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                   ../starter/source/output/message/message.F
!||    fretitl                  ../starter/source/starter/freform.F
!||    fretitl2                 ../starter/source/starter/freform.F
!||    hm_get_int_array_index   ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
!||    hm_get_intv              ../starter/source/devtools/hm_reader/hm_get_intv.F
!||    hm_thvarc                ../starter/source/output/th/hm_read_thvarc.F
!||    hord                     ../starter/source/output/th/hord.F
!||    r2r_exist                ../starter/source/coupling/rad2rad/routines_r2r.F
!||    zeroin                   ../starter/source/system/zeroin.F
!||--- uses       -----------------------------------------------------
!||    format_mod               ../starter/share/modules1/format_mod.F90
!||    message_mod              ../starter/share/message_module/message_mod.F
!||    submodel_mod             ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE hm_read_thgrsurf(
     1      ITYP   ,KEY    ,
     3      IAD    ,IFI    ,ITHGRP   ,ITHBUF ,
     4      NV     ,VARE   ,NUM      ,VARG   ,NVG     ,
     5      IVARG  ,NSNE   ,NV0      ,ITHVAR ,FLAGABF ,NVARABF,
     6      IGRSURF,IGS    ,LSUBMODEL)
C-----------------------------------------------
C   D e s c r i p t i o n
C-----------------------------------------------
C Starter Reader for option /TH/SURF
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE groupdef_mod , only : surf_
      USE message_mod , only : ancmsg, aninfo_blind_1, msgerror, msgwarning
      USE submodel_mod , only : submodel_data, nsubmod
      USE names_and_titles_mod , ONLY : nchartitle
      USE format_mod , ONLY : fmw_i_a
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      "scr03_c.inc"
#include      "scr17_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
#include      "r2r_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER,INTENT(IN) :: ITYP,NV,NUM,NVG,IVARG(18,*),NV0,FLAGABF
      INTEGER,INTENT(INOUT) :: ITHGRP(NITHGR), IGS, IFI, IAD, NSNE, NVARABF, ITHVAR(*), ITHBUF(*)
      CHARACTER*10,INTENT(IN) :: VARE(NV),KEY,VARG(NVG)
      TYPE (SURF_),INTENT(INOUT), DIMENSION(NSURF) :: IGRSURF
      TYPE(SUBMODEL_DATA),INTENT(IN) :: LSUBMODEL(NSUBMOD)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER J, I,ID,NNE,
     .        k,iad0,
     .        ifitmp,nvar,n,iad1,iad2,ititle(ltitr),
     .        ids,idsmax,
     .        num_found
      CHARACTER(LEN=NCHARTITLE) :: TITR
      CHARACTER MESS*40
      LOGICAL IS_AVAILABLE
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER HM_THVARC
      INTEGER R2R_EXIST
      DATA MESS/'TH GROUP DEFINITION                     '/
C-----------------------------------------------
C   S o u r c e   L i n e s
C-----------------------------------------------
      id=ithgrp(1)
      CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
      ithgrp(2)=ityp
      ithgrp(3)=0
      ifitmp=ifi+1000
      ! Number of variables indicated by the user                                                                   
      CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)                                           
 
      ! Number of stored variables and reading the variables                                                        
      IF (nvar>0) nvar = hm_thvarc(vare,nv,ithbuf(iad),varg,nvg,ivarg,nv0,id,titr ,lsubmodel)                       
 
      IF(nvar == 0) THEN
        IF(ityp /= 116)THEN
         CALL ancmsg(msgid=1109,msgtype=msgerror,anmode=aninfo_blind_1,i1=id,c1=titr )
        ENDIF
        igs = igs - 1
        ithgrp(1:nithgr)=0
      ELSE
        CALL hm_get_intv('idsmax',idsmax,is_available,lsubmodel)  
        ithgrp(6)=nvar
        ithgrp(7)=iad
        iad=iad+nvar
        ifi=ifi+nvar
        nne=idsmax
        ithgrp(4)=nne
        ithgrp(5)=iad
        iad2=iad+3*nne
        ithgrp(8)=iad2
        ifi=ifi+3*nne+40*nne
        CALL zeroin(iad,iad+43*nne-1,ithbuf)      
C
        num_found=0
        DO k = 1,idsmax
          CALL hm_get_int_array_index('ids',ids,k,is_available,lsubmodel) 
          n=0
          IF(ids/=0)THEN
            IF (nsubdom>0) THEN
              ! Multidomain : skip if entity does not exist---------------
              IF(r2r_exist(ityp,ids)==0) cycle !next K
              ENDIF      
            DO j=1,num
              IF(ids == igrsurf(j)%ID)THEN
                 n=j
                 igrsurf(j)%TH_SURF=1          
                 num_found=num_found+1
                 EXIT
              ENDIF
            ENDDO
            nsne=nsne+1
            ithbuf(iad)=n
            iad=iad+1
          ENDIF
          IF(n == 0)THEN
            CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
            CALL ancmsg(msgid=257, msgtype=msgwarning, anmode=aninfo_blind_1, i1=ithgrp(1), i2=ids, c1=titr, c2=key)
          ENDIF             
        ENDDO !next K
C
        iad = ithgrp(5)
        CALL hord(ithbuf(iad),num_found)
C
        DO i=1,nne
          n=ithbuf(iad)
          IF(n > 0)THEN
            ithbuf(iad+2*nne)=igrsurf(n)%ID
            DO j=1,40
              CALL fretitl(igrsurf(n)%TITLE,ititle,ltitr)
              ithbuf(iad2+j-1)=ititle(j)
            ENDDO
            iad=iad+1
            iad2=iad2+40
          ENDIF
        ENDDO
C
        iad=iad2
C
C=======================================================================
C ABF FILES
C=======================================================================
          nvar=ithgrp(6)
          iad0=ithgrp(7)
          ithgrp(9)=nvarabf
          DO j=iad0,iad0+nvar-1
            DO k=1,10
              ithvar((ithgrp(9)+(j-iad0)-1)*10+k)=ichar(vare(ithbuf(j))(k:k))
            ENDDO
          ENDDO
          nvarabf = nvarabf + nvar
C=======================================================================
C PRINTOUT
C=======================================================================
          IF(ipri<1)RETURN
          n=ithgrp(4)
          iad1=ithgrp(5)
          nvar=ithgrp(6)
          iad0=ithgrp(7)
          iad2=ithgrp(8)
          WRITE(iout,'(//)')
          CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
          WRITE(iout,'(A,I10,3A,I3,A,I5,2A)')' TH GROUP:',ithgrp(1),',',trim(titr),',',nvar,' VAR',n, key,':'
          WRITE(iout,'(A)')' -------------------'
          WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
          WRITE(iout,'(3A)')'    ',key,'        NAME '
          DO k=iad1,iad1+n-1
             CALL fretitl2(titr,ithbuf(iad2),40)
             iad2=iad2+40
             WRITE(iout,fmt=fmw_i_a)igrsurf(ithbuf(k))%ID,titr(1:40)
          ENDDO
C
        ENDIF
      RETURN
      END