hm_read_thgrki_rbody.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_thgrki_rbody     ../starter/source/output/th/hm_read_thgrki_rbody.F
!||--- called by ------------------------------------------------------
!||    hm_read_thgrou           ../starter/source/output/th/hm_read_thgrou.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                   ../starter/source/output/message/message.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
!||    hm_option_read_mod       ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod              ../starter/share/message_module/message_mod.F
!||    submodel_mod             ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE hm_read_thgrki_rbody(
     1      ITYP   ,KEY    ,INOPT1,
     3      IAD    ,IFI    ,ITHGRP, ITHBUF     ,
     4      NV     ,VARE   ,NUM   , VARG      ,NVG    ,
     5      IVARG  ,NSNE   ,NV0   , ITHVAR    ,FLAGABF, NVARABF,
     6      NOM_OPT,IGS    ,NPBY  , LSUBMODEL)
C
        USE message_mod
        USE submodel_mod
        USE hm_option_read_mod
        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      "param_c.inc"
#include      "r2r_c.inc"
#include      "scr03_c.inc"
#include      "scr17_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ITYP,INOPT1,
     .          ITHGRP(NITHGR),ITHBUF(*),
     .          IFI,IAD,NV,NUM,NVG,NSNE  ,IVARG(18,*),
     .          NV0,ITHVAR(*),FLAGABF,NVARABF,IGS
        CHARACTER*10 VARE(NV),KEY,VARG(NVG)
        INTEGER NOM_OPT(LNOPT1,*)
        TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
      INTEGER NPBY(NNPBY,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER J,JJ, I,ISU,ID,NNE,NOSYS,J10(10),NTOT,KK,IER,
     .          ok,igrs,nsu,k,l,jrec,cont,iad0,iadv,ntri,
     .          ifitmp,iadfin,nvar,m,n,iad1,iad2,isk,iproc,
     .          idsmax,ids,ids_obj1,
     .        tag(num),irb
        CHARACTER, DIMENSION(10) :: VAR
        LOGICAL :: IS_AVAILABLE
        CHARACTER(LEN=NCHARTITLE)::TITR
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
        INTEGER,EXTERNAL :: HM_THVARC,R2R_EXIST
C-----------------------------------------------
        is_available = .false.
        nsne = 0
        ! ID of the /TH
        id = ithgrp(1)
        ! Title of the /TH
        CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
        ! Type of the /th
        ithgrp(2)=ityp
        ithgrp(3)=0
        ifitmp=ifi+1000
c
        ! Number of variables indicated by the user
        CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel) 
c
        ! 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) 
c
        ! Filling the tables
        IF (nvar == 0) THEN
          IF (ityp /= 107)
     .      CALL ancmsg(msgid=1109,
     .           msgtype=msgerror ,
     .           anmode=aninfo_blind_1,
     .           i1=id,
     .           c1=titr )
          igs = igs - 1
          ithgrp(1:nithgr) = 0
        ELSE
c
          ! Number of Objects IDs
          CALL hm_get_intv('idsmax',idsmax,is_available,lsubmodel)  
          CALL hm_get_int_array_index('ids',ids_obj1,1,is_available,lsubmodel) 
 
          IF(idsmax > 0 .AND. ids_obj1 == 0) THEN 
            ! Filling tables
            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
            CALL zeroin(iad,iad+43*nne-1,ithbuf)
            nne = 0  
            tag(:)=0  
            idsmax = num
C  
            ! Loop over Objects IDs
            DO k = 1,idsmax
              ids = nom_opt(1,inopt1+k)
              IF (nsubdom > 0) THEN 
                IF (r2r_exist(ityp,ids) == 0) cycle
              ENDIF
              IF(ids==0)cycle !skip empty object
              !check then if object_id does exist
              n = 0
              DO j = 1,num
                IF (ids == nom_opt(1,inopt1+j)) THEN
                  n   = j
                  EXIT
                ENDIF
              ENDDO
              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),
     .                    c1=titr,
     .                    c2=key,
     .                    i2=ids)
              ELSE
                IF(npby(12,n) /= 0) THEN 
                  irb=npby(13,n)
                  IF(tag(irb) == 0) THEN
                    nne=nne+1
                    nsne=nsne+1
                    ithbuf(iad)=irb
                    iad=iad+1
                    tag(irb)=1
                  ENDIF
                ELSEIF(tag(n) == 0) THEN
                  nne=nne+1
                  nsne=nsne+1
                  ithbuf(iad)=n
                  iad=iad+1
                  tag(n)=1
                ENDIF
              ENDIF           
            ENDDO
C
            iad       = ithgrp(5)
            ithgrp(4) = nne
            iad2      = iad+3*nne
            ithgrp(8) = iad2
            ifi       = ifi+3*nne+40*nne   
cc
            CALL hord(ithbuf(iad),nne)
C
            DO i = 1,nne
              n = ithbuf(iad)
              ithbuf(iad+2*nne) = nom_opt(1,inopt1+n)
              DO j = 1,40
                ithbuf(iad2+j-1)=nom_opt(j+lnopt1-ltitr,inopt1+n)
              ENDDO
              iad=iad+1
              iad2=iad2+40
            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
C
            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)nom_opt(1,inopt1+ithbuf(k)),titr(1:40)
            ENDDO
C           
 
          ELSE
c
            ! Filling tables
            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
            CALL zeroin(iad,iad+43*nne-1,ithbuf)
            nne = 0  
            tag(:)=0  
C  
            ! Loop over Objects IDs
            DO k = 1,idsmax
              CALL hm_get_int_array_index('ids',ids,k,is_available,lsubmodel) 
              IF (nsubdom > 0) THEN 
                IF (r2r_exist(ityp,ids) == 0) cycle
              ENDIF
              IF(ids==0)cycle !skip empty object
              !check then if object_id does exist
              n = 0
              DO j = 1,num
                IF (ids == nom_opt(1,inopt1+j)) THEN
                  n   = j
                  EXIT
                ENDIF
              ENDDO
              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),
     .                    c1=titr,
     .                    c2=key,
     .                    i2=ids)
              ELSE
                IF(npby(12,n) /= 0) THEN 
                  irb=npby(13,n)
                  IF(tag(irb) == 0) THEN
                    nne=nne+1
                    nsne=nsne+1
                    ithbuf(iad)=irb
                    iad=iad+1
                    tag(irb)=1
                  ENDIF
                ELSEIF(tag(n) == 0) THEN
                  nne=nne+1
                  nsne=nsne+1
                  ithbuf(iad)=n
                  iad=iad+1
                  tag(n)=1
                ENDIF
              ENDIF           
            ENDDO
C
            iad       = ithgrp(5)
            ithgrp(4) = nne
            iad2      = iad+3*nne
            ithgrp(8) = iad2
            ifi       = ifi+3*nne+40*nne   
cc
            CALL hord(ithbuf(iad),nne)
C
            DO i = 1,nne
              n = ithbuf(iad)
              ithbuf(iad+2*nne) = nom_opt(1,inopt1+n)
              DO j = 1,40
                ithbuf(iad2+j-1)=nom_opt(j+lnopt1-ltitr,inopt1+n)
              ENDDO
              iad=iad+1
              iad2=iad2+40
            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
C
            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)nom_opt(1,inopt1+ithbuf(k)),titr(1:40)
            ENDDO
C
          ENDIF !IDSMAX > 0
        ENDIF !IF (NVAR == 0)
        RETURN
      END