hm_read_thgrki.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           ../starter/source/output/th/hm_read_thgrki.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(
     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,LSUBMODEL,LITHBUFMX)
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      "scr03_c.inc"
#include      "scr17_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
#include      "r2r_c.inc"
#include      "tabsiz_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(LITHBUFMX),
     .          IFI,IAD,NV,NUM,NVG,NSNE  ,IVARG(18,*),
     .          NV0,ITHVAR(SITHVAR),FLAGABF,NVARABF,IGS
        INTEGER,INTENT(IN) :: LITHBUFMX
        CHARACTER*10 VARE(NV),KEY,VARG(NVG)
        INTEGER NOM_OPT(LNOPT1,SNOM_OPT/LNOPT1)
        TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
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
        CHARACTER(LEN=NCHARTITLE)::TITR
        CHARACTER, DIMENSION(10) :: VAR
        LOGICAL, DIMENSION(:), ALLOCATABLE :: FOUND
        LOGICAL :: IS_AVAILABLE
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 (output labels)
        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
 
           IF ( trim(key) == 'RWALL'    .OR. trim(key) == 'CLUSTER'
     .     .OR. trim(key) == 'BEAM'     .OR. trim(key) == 'CYL_JO'  
     .     .OR. trim(key) == 'FXBODY'   .OR. trim(key) == 'FRAME' 
     .     .OR. trim(key) == 'SPH_FLOW' .OR. trim(key) == 'SLIPRING'  
     .     .OR. trim(key) == 'RETRACTOR') THEN 
              CALL ancmsg(msgid=3083,
     .              msgtype=msgwarning,
     .              anmode=aninfo,
     .              i1=id,
     .              c1=titr )
            ENDIF 
 
            ! 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)
            ALLOCATE(found(num))
            found(1:num) = .false.
            nne = 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
              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 (.NOT. found(n)) THEN
                  nne  = nne + 1
                  nsne = nsne+1
                  ithbuf(iad) = n
                  iad = iad+1
                  found(n) = .true.
                ELSE 
                  CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
                  CALL ancmsg(msgid=256,
     .                      msgtype=msgwarning,
     .                      anmode=aninfo_blind_1,
     .                      i1=ithgrp(1),
     .                      c1=titr,
     .                      c2=key,
     .                      i2=ids)
             
                ENDIF
              ENDIF           
            ENDDO
C
            ithgrp(4) = nne
            iad2      = ithgrp(5)+3*nne
            ithgrp(8) = iad2
            ifi       = ifi+3*nne+40*nne
            iad       = ithgrp(5)     
c
            DEALLOCATE(found)
c
            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           
 
          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)
            ALLOCATE(found(num))
            found(1:num) = .false.
            nne = 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
              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 (.NOT. found(n)) THEN
                  nne  = nne + 1
                  nsne = nsne+1
                  ithbuf(iad) = n
                  iad = iad+1
                  found(n) = .true.
                ELSE 
                  CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
                  CALL ancmsg(msgid=256,
     .                      msgtype=msgwarning,
     .                      anmode=aninfo_blind_1,
     .                      i1=ithgrp(1),
     .                      c1=titr,
     .                      c2=key,
     .                      i2=ids)
             
                ENDIF
              ENDIF           
            ENDDO
C
            ithgrp(4) = nne
            iad2      = ithgrp(5)+3*nne
            ithgrp(8) = iad2
            ifi       = ifi+3*nne+40*nne
            iad       = ithgrp(5)     
c
            DEALLOCATE(found)
c
            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 .AND. IDS_OBJ1 == 0)
        ENDIF
        RETURN
      END