hm__read__gauge_8F_source.html

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_gauge          ../starter/source/output/gauge/hm_read_gauge.F

!||--- called by ------------------------------------------------------

!||    lectur                 ../starter/source/starter/lectur.F

!||--- calls      -----------------------------------------------------

!||    ancmsg                 ../starter/source/output/message/message.F

!||    fretitl                ../starter/source/starter/freform.F

!||    hm_get_floatv          ../starter/source/devtools/hm_reader/hm_get_floatv.F

!||    hm_get_intv            ../starter/source/devtools/hm_reader/hm_get_intv.f

!||    hm_option_count        ../starter/source/devtools/hm_reader/hm_option_count.F

!||    hm_option_read_key     ../starter/source/devtools/hm_reader/hm_option_read_key.F

!||    hm_option_start        ../starter/source/devtools/hm_reader/hm_option_start.F

!||    sz_r2r                 ../starter/source/coupling/rad2rad/routines_r2r.F

!||    usr2sys                ../starter/source/system/sysfus.F

!||    vdouble                ../starter/source/system/sysfus.F

!||--- uses       -----------------------------------------------------

!||    hm_option_read_mod     ../starter/share/modules1/hm_option_read_mod.F

!||    message_mod            ../starter/share/message_module/message_mod.F

!||    r2r_mod                ../starter/share/modules1/r2r_mod.F

!||    submodel_mod           ../starter/share/modules1/submodel_mod.F

!||====================================================================


      SUBROUTINE hm_read_gauge(LGAUGE,GAUGE,ITABM1,UNITAB,IXC,NOM_OPT,LSUBMODEL)

C-----------------------------------------------

C   M o d u l e s

C-----------------------------------------------

      USE unitab_mod

      USE message_mod

      USE r2r_mod

      USE hm_option_read_mod

      USE submodel_mod

      USE names_and_titles_mod , ONLY : nchartitle, ncharkey

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      "scr17_c.inc"

#include      "units_c.inc"

#include      "com04_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-----------------------------------------------

      TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB

      INTEGER,INTENT(IN) :: IXC(NIXC,*),ITABM1(*)

      INTEGER,INTENT(INOUT) ::  LGAUGE(3,*)

      INTEGER NOM_OPT(LNOPT1,*)

      my_real gauge(llgauge,*)

      TYPE(submodel_data) LSUBMODEL(*)

C-----------------------------------------------

      LOGICAL IS_AVAILABLE

C-----------------------------------------------

C   E x t e r n a l   F u n c t i o n s

C-----------------------------------------------

      INTEGER USR2SYS

C-----------------------------------------------

C   L o c a l   V a r i a b l e s

C-----------------------------------------------

      INTEGER I, J,ID, NGAU, NOD, ISK, UID, IFLAGUNIT, IG, L,NBGAUGE_SPH,NBGAUGE_POINT

      INTEGER N,NS,NG,OFFS

      my_real ff,bid,dist,xgauge,ygauge,zgauge

      CHARACTER MESS*40

      CHARACTER(LEN=NCHARTITLE) :: TITR

      CHARACTER(LEN=NCHARKEY) :: KEY

      DATA mess/'GAUGE DEFINITION                        '/

C=======================================================================

      is_available = .false.

C-----------------------------------------------

C---------------------------------------------

C     LECTURE DES PARAMETRES DE GAUGES

C-----------------------------------------------

c     LGAUGE(3,*)

c 1:  -Isolid                              -(NUMELS_G+1) if SPH gauge

c 2:  GaugeId

c 3:  +Node or -Shell

c

c     => GAUGE(LLGAUGE,*), LLGAUGE = 37

c 1:  Dist (distance from Shell)           Dist (distance from Shell)

c 2:  XG                                   XG

c 3:  YG                                   YG

c 4:  ZG                                   ZG

c 5:  Alpha (Solid penetration ratio)      not yet used

c 6:                                       XSAV (SPH sorting)

c 7:                                       YSAV (SPH sorting)

c 8:                                       ZSAV (SPH sorting)

c 9:                                       FF (sph only)

c 10:                                      intantaneous Pressure

c 11:                                      intantaneous PA

c 12:                                      intantaneous Rho

c 13:                                      intantaneous E

c 14:                                      ! Butterworth !

c 15:                                      ! Butterworth !

c 16:                                      ! Butterworth !

c 17:                                      ! Butterworth !

c 18:                                      ! Butterworth !

c 19:                                      ! Butterworth !

c 20:                                      ! Butterworth !

c 21:                                      ! Butterworth !

c 22:                                      ! Butterworth !

c 23:                                      ! Butterworth !

c 24:                                      ! Butterworth !

c 25:                                      ! Butterworth !

c 26:                                      ! Butterworth !

c 27:                                      ! Butterworth !

c 28:                                      ! Butterworth !

c 29:                                      ! Butterworth !

c 30:  Pressure                            filtered Pressure

c 31:  PA                                  filtered PA

c 32:  Rho                                 filtered Rho

c 33:  E                                   filtered E

c 34:                                      ! Xpoint      !

c 35:                                      ! Ypoint      !

c 36:                                      ! Zpoint      !

c 37:                                      ! Butterworth !

C=======================================================================

      ng = 0

      ff = 0

      CALL hm_option_count('/GAUGE/SPH', nbgauge_sph)

C-----------------------------------------------------------------

      IF ( nbgauge_sph > 0)THEN

C-----------------------------------------------------------------

       CALL hm_option_start('/GAUGE/SPH')

       DO i=1,nbgauge_sph

        ng=ng+1

        !---Multidomaines --> on ignore les sections non tagees----

        IF(nsubdom > 0) THEN

          IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)

        ENDIF

        !----------------------------------------------------------

        key=''

        CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)

        CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)


        nom_opt(1,i)=ngau


        lgauge(1,i)=-(numels+1)

        dist = zero

        CALL hm_get_intv   ('NODE1'    ,nod   ,is_available,lsubmodel)

        CALL hm_get_intv   ('shell_ID' ,ns    ,is_available,lsubmodel)

        CALL hm_get_floatv ('DIST'     ,dist  ,is_available, lsubmodel, unitab)

        CALL hm_get_floatv ('Fcut'     ,ff    ,is_available, lsubmodel, unitab)


        gauge(1,i) =dist

        gauge(9,i) =ff

        lgauge(2,i)=ngau


        WRITE (iout,'(///,A)')'      SPH GAUGE'

        WRITE (iout,'(A/)')   '      ---------'

        WRITE (iout,'(A,I10)')' SPH GAUGE NUMBER . . . . . . . . . . .',ngau


        IF(nod /= 0)THEN

          lgauge(3,i)=usr2sys(nod,itabm1,mess,ngau)

          WRITE (iout,'(A,I10)')' NODE NUMBER. . . . . . . . . . . . . .',nod

        ELSEIF(ns /= 0)THEN

            DO j=1,numelc

              IF(ixc(nixc,j)==ns)THEN

                lgauge(3,i)=-j

                EXIT

              ENDIF

            ENDDO

            WRITE (iout,'(A,I10)')     ' SHELL NUMBER . . . . . . . . . . . . .',ns

            WRITE (iout,'(A,1PG20.13)')' DISTANCE . . . . . . . . . . . . . . .',dist

        ENDIF

        WRITE (iout,'(A,1PG20.13)')    ' 4-POLE BUTTERWORTH CORNER FREQUENCY. .',ff

C-------------------------------------


       ENDDO ! NBGAUGE_SPH


      ENDIF


C-----------------------------------------------

c--------/GAUGE/POINT

C-----------------------------------------------

      CALL hm_option_count('/GAUGE/POINT', nbgauge_point)

C-----------------------------------------------------------------

      IF ( nbgauge_point > 0)THEN

        CALL hm_option_start('/GAUGE/POINT')

          DO i=1,nbgauge_point

            key=''

            CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)

            nom_opt(1,i)=ngau

            CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)

            ng=ng+1

            !Multidomaines --> on ignore les sections non tagees----

            IF(nsubdom > 0) THEN

              IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)

            ENDIF

            !-----------------------------------------------------------------

            lgauge(1,ng)=0

            CALL hm_get_floatv ('Xi'     ,xgauge  ,is_available, lsubmodel, unitab)

            CALL hm_get_floatv ('Yi'     ,ygauge  ,is_available, lsubmodel, unitab)

            CALL hm_get_floatv ('Zi'     ,zgauge  ,is_available, lsubmodel, unitab)

            lgauge(2,ng)=ngau

            lgauge(3,ng)=0  ! ID shell or node only

            gauge(1,ng)=zero ! dist

            gauge(9,ng)=zero ! FF

            gauge(34,ng)=xgauge

            gauge(35,ng)=ygauge

            gauge(36,ng)=zgauge

            WRITE (iout,'(///,A)')'          GAUGE'

            WRITE (iout,'(A/)')   '          -----'

            WRITE (iout,'(A,I10)')' GAUGE NUMBER . . . . . . . . . . . . .',ngau

            WRITE (iout,'(A,I10)')' GAUGE POINT coordinate:'

            WRITE (iout,'(A,/1P3G20.13/)')'        Xg                  Yg                  Zg',xgauge, ygauge, zgauge

            WRITE (iout,'(a,1pg20.13)')' 4-pole butterworth corner frequency. .',FF

          ENDDO ! DO I=1,NBGAUGE_POINT

      ENDIF ! IF ( NBGAUGE_POINT > 0)

C-----------------------------------------------

c--------/GAUGE

C-----------------------------------------------

      CALL HM_OPTION_START('/gauge')

C-----------------------------------------------

       DO I=1,NBGAUGE

        KEY=''

        CALL HM_OPTION_READ_KEY(LSUBMODEL,OPTION_ID=NGAU,KEYWORD2=KEY,OPTION_TITR=TITR)

        NOM_OPT(1,I)=NGAU

        CALL FRETITL(TITR,NOM_OPT(LNOPT1-LTITR+1,I),LTITR)


        IF (KEY == 'sph.OR.'  KEY == 'point') CYCLE

        NG=NG+1

        !Multidomaines --> on ignore les sections non tagees----

        IF(NSUBDOM > 0) THEN

          IF(TAGGAU(NG) == 0) CALL SZ_R2R(TAGGAU,NG)

        ENDIF

        !-----------------------------------------------------------------

        LGAUGE(1,NG)=0


        DIST = ZERO

        CALL HM_GET_INTV   ('node1'    ,NOD   ,IS_AVAILABLE,LSUBMODEL)

        CALL HM_GET_INTV   ('shell_id' ,NS    ,IS_AVAILABLE,LSUBMODEL)

        CALL HM_GET_FLOATV ('dist'     ,DIST  ,IS_AVAILABLE, LSUBMODEL, UNITAB)


        GAUGE(1,NG)=DIST

        GAUGE(9,NG)=ZERO

        LGAUGE(2,NG)=NGAU


        WRITE (IOUT,'(///,a)')'          gauge'

        WRITE (IOUT,'(a/)')   '          -----'

        WRITE (IOUT,'(a,i10)')' gauge number . . . . . . . . . . . . .',NGAU

        IF(NOD /= 0)THEN

          LGAUGE(3,NG)=USR2SYS(NOD,ITABM1,MESS,NGAU)

          WRITE (IOUT,'(a,i10)')' node number. . . . . . . . . . . . . .',NOD

        ELSEIF(NS /= 0)THEN

            DO J=1,NUMELC

              IF(IXC(NIXC,J)==NS)THEN

                LGAUGE(3,NG)=-J

                EXIT

              ENDIF

            ENDDO

            IF (LGAUGE(3,NG) == 0)CALL ANCMSG(MSGID=3013,MSGTYPE=MSGERROR,ANMODE=ANINFO,I1=NGAU,C1=TITR,I2=NS)

            WRITE (IOUT,'(/,a,i10)')' shell number . . . . . . . . . . . . .',NS

            WRITE (IOUT,'(a,1pg20.13)')' distance . . . . . . . . . . . . . . .',DIST

        ENDIF

        WRITE (IOUT,'(a,1pg20.13)')' 4-pole butterworth corner frequency. .',FF

C-------------------------------------

      ENDDO ! NBGAUGE


C-------------------------------------

C Recherche des ID doubles

C-------------------------------------

      CALL VDOUBLE(NOM_OPT,LNOPT1,NBGAUGE,MESS,0,BID)

C----

      RETURN


      END

butterworth
subroutine butterworth(dt, freq, x2, x1, x, fx2, fx1, fx)
Definition butterworth.F:31

my_real
#define my_real
Definition cppsort.cpp:32

hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415

hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523

hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105

hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251

hm_read_gauge
subroutine hm_read_gauge(lgauge, gauge, itabm1, unitab, ixc, nom_opt, lsubmodel)
Definition hm_read_gauge.F:45

hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410

hm_option_read_mod
Definition hm_option_read_mod.F:408

message_mod
Definition message_mod.F:1249

names_and_titles_mod
Definition names_and_titles_mod.F:997

names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003

names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000

r2r_mod
Definition r2r_mod.F:125

r2r_mod::taggau
integer, dimension(:), allocatable taggau
Definition r2r_mod.F:142

submodel_mod
Definition submodel_mod.F:712

unitab_mod
Definition unitab_mod.F:513

sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:242

fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620

starter
program starter
Definition starter.F:39

submodel_mod::submodel_data
Definition submodel_mod.F:723