r2r_check.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/.
!||====================================================================
!||    r2r_check      ../starter/source/coupling/rad2rad/r2r_check.F
!||--- called by ------------------------------------------------------
!||    lectur         ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg         ../starter/source/output/message/message.F
!||    grfind         ../starter/source/starter/freform.F
!||--- uses       -----------------------------------------------------
!||    message_mod    ../starter/share/message_module/message_mod.F
!||    r2r_mod        ../starter/share/modules1/r2r_mod.F
!||    restmod        ../starter/share/modules1/restart_mod.F
!||====================================================================
      SUBROUTINE r2r_check(IEXTER ,IGRNOD   ,IPARTL)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE groupdef_mod
        USE message_mod
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE restmod
        USE r2r_mod
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      "com04_c.inc"
#include      "scr17_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-----------------------------------------------
        INTEGER IEXTER(NR2R,*),IPARTL(LIPART1,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER STAT,I,IGR,IGRS,N,K,ADD
        CHARACTER MESS*40
        INTEGER, DIMENSION(:), ALLOCATABLE :: TAGPART
C-----------------------------------------------
        TYPE (GROUP_)  ,DIMENSION(NGRNOD)  :: IGRNOD
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
        INTEGER GRFIND
C
        DATA mess/' ** ERROR EXTERNAL COUPLING DEFINITION '/
 
C----- Check if Id of subdomains-----------------------------------C
 
        IF (nsubdom>0) THEN
          DO n=1,nsubdom-1
            igr = isubdom(2,n)
            DO i=n+1,nsubdom
              IF (igr==isubdom(2,i)) THEN
                CALL ancmsg(msgid=792,
     .                    msgtype=msgerror,
     .                    anmode=aninfo,
     .                    i1=igr)
                ierr=ierr+1
              ENDIF
            END DO
          END DO
        ENDIF
 
C----- Check of parts of subdomains-------------------------------C
 
        ALLOCATE(tagpart(npart))
        tagpart = 0
 
        DO n=1,nsubdom
          add = isubdom(3,n)
          DO k=1,npart
            DO i=1,isubdom(1,n)
              IF(k == isubdom_part(i+add))THEN
                tagpart(k)=tagpart(k)+1
                IF (tagpart(k)>1) THEN
                  CALL ancmsg(msgid=827,
     .                        msgtype=msgerror,
     .                        anmode=aninfo,i1=isubdom(1,n),
     .                        i2=ipart(lipart1*(k-1)+4))
                  ierr=ierr+1
                ENDIF
              ENDIF
            ENDDO
          END DO
        END DO
 
C----- Check of common nodes between interfaces---------------------C
 
!        DO N=1,NR2RLNK-1
!     DO I=N+1,NR2RLNK
C                 CALL ANSTCKI(22)
C                 CALL ANSTCKI(9)
C                 CALL ANSTCKI(8)
C               CALL ANCERR(792,ANINFO)
C     IERR=IERR+1
!     END DO
!  END DO
 
C----- Check of multidomains node groups-----------------------------C
 
        DO n=1,nr2rlnk
          igr = iexter(1,n)
          igrs = grfind(igr,igrnod,mess)
          iexter(1,n) = igrs
          IF (igrs==0) ierr=ierr+1
        END DO
 
C--------------------------------------------------------------------C
 
        RETURN
      END SUBROUTINE r2r_check