hm__read__pload_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_pload          ../starter/source/loads/general/pload/hm_read_pload.F

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

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

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

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

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

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

!||    hm_get_intv            ../starter/source/devtools/hm_reader/hm_get_intv.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

!||    usr2sys                ../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_pload(IPRES     ,PRES     ,NPREL    ,ITAB    ,ITABM1  ,

     .                         IGRSURF   ,UNITAB   ,LSUBMODEL,LOADS   )

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

C   M o d u l e s

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

      USE unitab_mod

      USE r2r_mod

      USE message_mod

      USE groupdef_mod

      USE submodel_mod

      USE hm_option_read_mod

      USE pinchtype_mod

      USE loads_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      "param_c.inc"

#include      "units_c.inc"

#include      "scr03_c.inc"

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

      INTEGER IPRES(NIBCLD,*), ITAB(*), ITABM1(*)

      my_real

     .   pres(lfaccld,*)

      TYPE (SURF_)   , DIMENSION(NSURF)   :: IGRSURF

      TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)

      TYPE (LOADS_),INTENT(INOUT) :: LOADS

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

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

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

      INTEGER K, M, I1, I2, I3, I4, IFU, I, ISENS,NPR0,NN,ISU,IS,

     .        iad,id,j,uid,iflagunit,ifix_tmp,

     .        capt,h,sub_index,flag_pinch,kpinch,idel,ifunctype

      INTEGER N1,N2,N3,N4

      my_real fcx,fcy,fac_fcx,fac_fcy

      CHARACTER MESS*40

      CHARACTER(LEN=NCHARTITLE) :: TITR

      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

      DATA mess/'PRESSURE LOADS DEFINITION               '/

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

C     IBCL(NIBCLD,NUMCLD+NUMPRES), NUMCLD = Total nb of (cloads * nodes)

C                             NUMPRES = Total nb of (ploads * segments)

C     IPRES = IBCL(1:NIBCLD,NUMCCLD+1,NUMCLD+NUMPRES)

C     1: 1st node number of the segment

C     2: 2nd node number of the segment

C     3: 3rd node number of the segment

C     4: 4th node number of the segment

C     5: Function internal number

C     6: ISENS Sensor User ID

C     7: User ID

C     9: Itypfun                           Function type

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

C     FORC(LFACCLD,NUMCLD+NUMPRES)

C     PRES = FORC(LFACCLD,NUMCLD+1:NUMCLD+NUMPRES)

C     1: Fscale_y

C     2: 1/Ascale_x

C     3: /=0 <=> Pinching pressure

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

      is_available = .false.


      npr0=npreld

      npreld=0

      k=0

      nploadpinch=0

      kpinch=0

      pdel = 0

      ifunctype = 0

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

C START BROWSING MODEL /PLOAD

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

      CALL hm_option_start('/PLOAD')


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

C BROWSING MODEL SurPRESe  1->NP0

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

      DO i=1,npr0

        titr = ''

        CALL hm_option_read_key(lsubmodel,

     .                       option_id = id,

     .                       unit_id = uid,

     .                       submodel_index = sub_index,

     .                       option_titr = titr)


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

C EXTRACT DATAS (INTEGER VALUES)

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

        CALL hm_get_intv('entityid',isu,is_available,lsubmodel)

        CALL hm_get_intv('curveid',ifu,is_available,lsubmodel)

        CALL hm_get_intv('rad_sensor_id',isens,is_available,lsubmodel)

        CALL hm_get_intv('ipinch',flag_pinch,is_available,lsubmodel)

        CALL hm_get_intv('Idel',idel,is_available,lsubmodel)

        CALL hm_get_intv('Itypfun',ifunctype,is_available,lsubmodel)

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

C EXTRACT DATAS (REAL VALUES)

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

        CALL hm_get_floatv('xscale',fcx,is_available,lsubmodel,unitab)

        CALL hm_get_floatv_dim('xscale',fac_fcx,is_available,lsubmodel,unitab)

        CALL hm_get_floatv('magnitude',fcy,is_available,lsubmodel,unitab)

        CALL hm_get_floatv_dim('magnitude',fac_fcy,is_available,lsubmodel,unitab)

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

        iflagunit = 0

        DO j=1,unitab%NUNITS

          IF (unitab%UNIT_ID(j) == uid) THEN

            iflagunit = 1

            EXIT

          ENDIF

        ENDDO

        IF (uid/=0.AND.iflagunit==0) THEN

          CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,

     .                i2=uid,i1=id,c1='PRESSURE LOAD',

     .                 c2='PRESSURE LOAD',

     .                 c3=titr)

        ENDIF


        IF (fcx == zero) fcx = fac_fcx

        IF (fcy == zero) fcy = fac_fcy

        is=0

        DO j=1,nsurf

          IF (isu==igrsurf(j)%ID) is=j

        ENDDO

        IF( idel /= 2) THEN

            pdel = 1

            idel = 1

        ELSE

            pdel = 0

            idel = 0

        ENDIF

C

        IF(ifunctype == 0) ifunctype = 1 ! Abscissa function is time (by default)

                        !  IFUNCTYPE = 2 ! Abscissa function is nodal displacement

                        !  IFUNCTYPE = 3 ! Abscissa function is nodal velocity

C

        IF(is/=0)THEN

          nn=igrsurf(is)%NSEG

          kpinch=nn+1

          DO j=1,nn

              IF (iddom/=0) THEN

Cmultidomains -> shared segments are processed only once

                 capt=0

               DO h=1,4

                   IF (tagno(npart+igrsurf(is)%NODES(j,h))==1) capt = 1

               END DO

                 IF (capt==0) GOTO 150

              ENDIF

C

            IF(flag_pinch /= 1) THEN

              k=k+1

              ipres(1,k)  = igrsurf(is)%NODES(j,1)

              ipres(2,k)  = igrsurf(is)%NODES(j,2)

              ipres(3,k)  = igrsurf(is)%NODES(j,3)

              IF (igrsurf(is)%NODES(j,3)==igrsurf(is)%NODES(j,4)) THEN

C               true triangles (not segments built from 3 nodes).

                ipres(4,k) = 0

              ELSE

                ipres(4,k) = igrsurf(is)%NODES(j,4)

              ENDIF

              ipres(5,k)     = ifu

              ipres(6,k)     = isens

              ipres(7,k) = idel

              ipres(8,k) = 0

              ipres(9,k) = ifunctype

              pres(1,k) = fcy

              pres(2,k) = one/fcx

            ELSE

              nploadpinch = nploadpinch + 1

              kpinch=kpinch-1

              ipres(1,kpinch)  = igrsurf(is)%NODES(j,1)

              ipres(2,kpinch)  = igrsurf(is)%NODES(j,2)

              ipres(3,kpinch)  = igrsurf(is)%NODES(j,3)

              IF (igrsurf(is)%ELTYP(j)==7) THEN

C               true triangles (not segments built from 3 nodes).

                ipres(4,kpinch) = 0

              ELSE

                ipres(4,kpinch) = igrsurf(is)%NODES(j,4)

              ENDIF

              ipres(5,kpinch)     = ifu

              ipres(6,kpinch)     = isens

              ipres(7,kpinch) = idel

              ipres(8,kpinch) = 0

              ipres(9,kpinch) = ifunctype

              pres(1,kpinch) = fcy

              pres(2,kpinch) = one/fcx

            ENDIF

C

  150        CONTINUE

          ENDDO

Cmultidomains -> shared segments are counted only once

            IF (iddom>0) nn = nn-isurf_r2r(1,is)

          npreld=npreld+nn

        ELSE

          CALL ancmsg(msgid=3066,

     .                msgtype=msgerror,

     .                anmode=aninfo,

     .                i1=id,

     .                c1=titr)

        ENDIF

      ENDDO

C

      i1=1

      i2=min0(50,npreld)

C----

      loads%NLOAD_PLOAD = npreld

C----

C

   90  WRITE (iout,2000)


       DO i=i1,i2


         IF(ipres(4,i) == 0 .AND. ipres(3,i) == 0)THEN

            ! 2D / Surface made of lines

            WRITE (iout,'(3(1X,I10),A,1X,I10,1X,I10,2G20.13)') i,

     .        itab(ipres(1,i)),itab(ipres(2,i)),'                    ',

     .        ipres(5,i),ipres(6,i),one/pres(2,i),pres(1,i)


         ELSEIF(ipres(4,i) == 0 .AND. ipres(3,i) /= 0)THEN

            ! Surface made of 3 nodes

            WRITE (iout,'(4(1X,I10),A,1X,I10,1X,I10,2G20.13)') i,

     .        itab(ipres(1,i)),itab(ipres(2,i)),itab(ipres(3,i)),'          ',

     .        ipres(5,i),ipres(6,i),one/pres(2,i),pres(1,i)

         ELSE

            ! Surface made of 4 nodes

            WRITE (iout,'(6(1X,I10),1X,I10,2G20.13)') i,

     .        itab(ipres(1,i)),itab(ipres(2,i)),itab(ipres(3,i)),itab(ipres(4,i)),

     .        ipres(5,i),ipres(6,i),one/pres(2,i),pres(1,i)

         ENDIF


       ENDDO


       IF(i2==npreld)GOTO 200

       i1=i1+50

       i2=min0(i2+50,npreld)

       GOTO 90

 200  RETURN

 300  CALL ancmsg(msgid=157,

     .            msgtype=msgerror,

     .            anmode=aninfo,

     .            i1=k)

C---

 2000 FORMAT(//

     .'     PRESSURE   LOADS  '/

     .'     ----------------  '/

     .'       SEGM      NODE1      NODE2      NODE3      NODE4    CURVE',

     .'     SENSOR         SCALE-X                 SCALE-Y ')

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

      RETURN


      END


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:418

hm_get_floatv_dim
subroutine hm_get_floatv_dim(name, dim_fac, is_available, lsubmodel, unitab)
Definition hm_get_floatv_dim.F:161

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

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

hm_read_pload
subroutine hm_read_pload(ipres, pres, nprel, itab, itabm1, igrsurf, unitab, lsubmodel, loads)
Definition hm_read_pload.F:43

hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414

id
initmumps id
Definition multiplerhs_example.m:4

groupdef_mod
Definition groupdef_mod.F:668

hm_option_read_mod
Definition hm_option_read_mod.F:412

message_mod
Definition message_mod.F:1257

names_and_titles_mod
Definition names_and_titles_mod.F:1002

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

pinchtype_mod
Definition pinchtype_mod.F:69

pinchtype_mod::nploadpinch
integer nploadpinch
Definition pinchtype_mod.F:74

r2r_mod
Definition r2r_mod.F:125

r2r_mod::tagno
integer, dimension(:), allocatable tagno
Definition r2r_mod.F:132

r2r_mod::isurf_r2r
integer, dimension(:,:), allocatable isurf_r2r
Definition r2r_mod.F:143

submodel_mod
Definition submodel_mod.F:717

unitab_mod
Definition unitab_mod.F:517

ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895

starter
program starter
Definition starter.F:39

submodel_mod::submodel_data
Definition submodel_mod.F:728