pornod.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/.
!||====================================================================
!||    pornod                 ../starter/source/ale/pornod.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl2               ../starter/source/starter/freform.F
!||    ifrontplus             ../starter/source/spmd/node/frontplus.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.f
!||====================================================================
      SUBROUTINE pornod(GEO  ,IXS   ,IXQ   ,NODPOR ,ICODE  ,ITAB ,NPBY  ,LPBY  ,IGEO)
C-----------------------------------------------
C   D e s c r i p t i o n
C-----------------------------------------------
C This subroutine is marking and storing nodes related to porous option 
C-----------------------------------------------
C   M o d u l e s
C----------------------------------------------- 
      USE message_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   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "param_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER,INTENT(IN) :: IXS(NIXS,NUMELS),IXQ(NIXQ,NUMELQ),IGEO(NPROPGI,NUMGEO)
      INTEGER,INTENT(IN) :: ICODE(NUMNOD),ITAB(NUMNOD),NPBY(NNPBY,*),LPBY(*)
      INTEGER,INTENT(INOUT) :: NODPOR(*)
      my_real,INTENT(INOUT) :: geo(npropg,numgeo)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER, DIMENSION(NUMNOD) :: ITAG
      INTEGER IG,N,I,J,K,IC,IC1,IC2,IC3,IC4,JWARN,IRB,KRB,P
      INTEGER, DIMENSION(:,:),ALLOCATABLE :: INDEX
      INTEGER IWORK(70000),IT
      CHARACTER(len=nchartitle) :: TITR
C-----------------------------------------------
C   S o u r c e   L i n e s
C-----------------------------------------------
      !--------------------!
      !      TAGGING       !
      !--------------------!
      numpor=0
      DO i=1,numnod
        itag(i)=0
      END DO
C-----------------------------------------------      
      DO ig=1,numgeo
        IF(int(geo(12,ig)) /= 15)cycle !IG
        IF(n2d == 0)THEN
          DO i=1,numels
            IF(ixs(10,i) /= ig)cycle !I
            DO j=2,9
              IF(itag(ixs(j,i)) == 0)itag(ixs(j,i))=ig
            END DO !J=2,9
          END DO ! I=1,NUMELS
        ELSE
          DO i=1,numelq
            IF(ixq(6,i) /= ig)cycle !I
            DO j=2,5
              IF(itag(ixq(j,i)) == 0)itag(ixq(j,i))=ig
            END DO ! J=2,5
          END DO !I=1,NUMELQ
        ENDIF
 
      !--------------------!
      !  COUNT AND STORE   !
      !--------------------!
      n=0
      jwarn=0
      DO i=1,numnod
        IF(itag(i) /= ig)cycle !I
        ic=icode(i)
        ic1=ic/512
        ic2=(ic-512*ic1)/64
        ic3=(ic-512*ic1-64*ic2)/8
        ic4=ic-512*ic1-64*ic2-8*ic3
        IF(n2d == 0)THEN
          IF(ic4 == 7)cycle !I
        ELSE
          IF(ic4 >= 6)cycle !I
        ENDIF
        IF(int(geo(30,ig)) /= 0 .AND. ic1 /= 0)THEN
           jwarn = jwarn+1
           CALL fretitl2(titr,igeo(npropgi-ltitr+1,ig),ltitr)
           CALL ancmsg(msgid=358,msgtype=msgwarning,anmode=aninfo_blind_2,i1=igeo(1,ig),c1=titr,i2=itab(i))
        ENDIF
        n=n+1
        nodpor(numpor+n)=i
      END DO !I=1,NUMNOD
 
      !---------------------------!
      ! Sorting nodes by porosity !
      ! (spmd order)              !
      !---------------------------!
      ALLOCATE(index(n,3))
      DO i=1,n
        index(i,3)=nodpor(numpor+i)
      ENDDO
      IF(n > 0) CALL my_orders(0,iwork,index(1,3),index,n,1)
      DO i=1,n
        it = index(i,1)
        nodpor(numpor+i)=index(it,3)
      ENDDO
      DEALLOCATE(index)
      !-----------------------------------------
      !WARNING HONEYCOMB POROUS MEDIUM PID=',IG
      !-----------------------------------------      
      IF(jwarn > 0) THEN
         CALL fretitl2(titr,igeo(npropgi-ltitr+1,ig),ltitr)
         CALL ancmsg(msgid=359,msgtype=msgwarning,anmode=aninfo,i1=igeo(1,ig),c1=titr,i2=jwarn)
      ENDIF      
      geo(31,ig)=n+.1
      numpor=numpor+n
      irb=int(geo(29,ig))
      IF(irb /= 0)THEN
        k=1
        DO krb=1,nrbykin
          IF(npby(1,krb) == irb)THEN
            geo(33,ig) = krb+ em01
            geo(34,ig) = lpby(k)+em01
          ENDIF
          k=k+npby(2,krb)
        END DO !KRB=1,NRBYKIN
        IF(geo(33,ig) == zero)THEN
          geo(29,ig)=em01
          CALL fretitl2(titr,igeo(npropgi-ltitr+1,ig),ltitr)
          CALL ancmsg(msgid=360,msgtype=msgwarning,anmode=aninfo_blind_1,i1=igeo(1,ig),c1=titr,i2=irb)
        ELSE
        ! main node RB replicate on all procs for SPMD calculation of porosity
          DO p = 1, nspmd
           CALL ifrontplus(irb,p) 
          ENDDO
        ENDIF !IF (GEO(33,IG) == ZERO)
      ENDIF !IF(IRB /= 0)
      END DO !IG=1,NUMGEO
C-----------------------------------------------      
      RETURN
      END