lecextlnk.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/.
!||====================================================================
!||    lecextlnk                ../starter/source/coupling/rad2rad/lecextlnk.F
!||--- called by ------------------------------------------------------
!||    lectur                   ../starter/source/starter/lectur.f
!||--- calls      -----------------------------------------------------
!||    ancmsg                   ../starter/source/output/message/message.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_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
!||--- 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
!||    reader_old_mod           ../starter/share/modules1/reader_old_mod.F90
!||    submodel_mod             ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE lecextlnk(IEXTER,IPART,LSUBMODEL)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE message_mod
        USE r2r_mod
        USE submodel_mod
        USE hm_option_read_mod
        USE names_and_titles_mod , ONLY : nchartitle, ncharkey
        USE reader_old_mod , ONLY : irec
C-------------------------------------
C     Read radioss link for external process coupling.
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      "units_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,*),IPART(LIPART1,*)
        TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NUSER, IGR, STAT,I,COMPT,SET
        CHARACTER MESS*40
        CHARACTER(LEN=NCHARKEY)::KEY
        CHARACTER(LEN=NCHARTITLE)::TITR
        INTEGER J,ADD,K
        INTEGER FLAG_OK,FOUND,NEL,ID,NELN
        INTEGER, DIMENSION(:), ALLOCATABLE :: ID_SUB_TEMP
        LOGICAL IS_AVAILABLE
        DATA mess/' ** ERROR EXTERNAL COUPLING DEFINITION '/
        WRITE(iout,1000)
        IF (nr2rlnk>0) WRITE(iout,1200)
C
C      IEXTER(1,M) ............... Id of GRNOD of the Link
C      IEXTER(2,M) ............... Link ser Id
C      IEXTER(3,M) ............... Id of 1st domain
C      IEXTER(4,M) ............... Id of 2nd domain
C      IEXTER(5,M) ............... Type du Link (4 ou 5)
C        -> pour fulldomain IEXTER(4,M) = 0
C        -> pour link classique IEXTER(4,M) = IEXTER(4,M) = -1
C
C
C      ISUBDOM(1,N) .............. Id of subdomain
C      ISUBDOM(2,N) .............. Nb of parts of the subdomain
C      ISUBDOM(3,N) .............. Adress of the parts of the subdomain in ISUBDOM_PART
C      ISUBDOM(4,N) .............. Id of principal link of subdomain
C      ISUBDOM(5,N) .............. Nb of nodes of subdomain
C      ISUBDOM(6,N) .............. Nb of elements of subdomain
C      ISUBDOM(7,N) .............. ROOTLEN
C
C      ISUBDOM_PART() ............ List of parts of the subdomain
C-----------------------------------------------
C
        IF (nr2rlnk > 0) THEN
C------------------------------------------------------------------
C------------------------READING OF LINKS--------------------------
C------------------------------------------------------------------
C
          is_available = .false.
          CALL hm_option_start('/EXTERN/LINK')
 
          DO i=1,nr2rlnk
            CALL hm_option_read_key(lsubmodel,option_id = nuser,option_titr = titr)
            CALL hm_get_intv('grnod_id',igr,is_available,lsubmodel)
C-------- CHECK NODE GROUP
            iexter(1,i) = igr
            iexter(2,i) = nuser
            iexter(3,i) = -1
            iexter(4,i) = -1
C-----    PRINTOUT
            WRITE(iout,1100) nuser,igr
          ENDDO
 
        ENDIF
 
        IF (nsubdom>0) THEN
C------------------------------------------------------------------
C------------------------READING OF SUBDOMAINS---------------------
C------------------------------------------------------------------
C
          is_available = .false.
          CALL hm_option_start('/SUBDOMAIN')
          ALLOCATE (isubdom_part(nb_part_sub),stat=stat)
          ALLOCATE (id_sub_temp(nb_part_sub),stat=stat)
          set = 0
          r2r_flag_err_off = 0
 
          DO i=1,nsubdom
            CALL hm_option_read_key(lsubmodel,option_id = nuser,option_titr = titr,keyword2 = key)
            CALL hm_get_intv('idsmax',nel,is_available,lsubmodel)
            CALL hm_get_intv('negativeIdsmax',neln,is_available,lsubmodel)
            IF (i>1) set = set+isubdom(1,i-1)
            isubdom(3,i)=set
            compt = 0
            DO j=1,nel
              CALL hm_get_int_array_index('ids',id,j,is_available,lsubmodel)
              compt=compt+1
              id_sub_temp(compt+set)=id
C----- CHECK PART ID
              flag_ok = 0
              DO k=1,npart
                IF(id==ipart(4,k)) THEN
                  flag_ok=1
                  isubdom_part(compt+set)=k
                END IF
              END DO
              IF (flag_ok==0) THEN
                CALL ancmsg(msgid=783,msgtype=msgerror,anmode=aninfo,i1=nuser,c1=titr,i2=id)
              ENDIF
            END DO
C--       if ID < 0 in list of part -> error message for size of interface is deactivated
            IF (neln > 0) r2r_flag_err_off = 1
C
C----- STORAGE OF DATA FOR SUBDOMAINS
            isubdom(1,i) = compt
            isubdom(2,i) = nuser
C
          ENDDO
 
          DO i=1,nsubdom
            WRITE(iout,1300) isubdom(2,i),isubdom(1,i)
            WRITE(iout,1301)
            add = isubdom(3,i)
            WRITE(iout,1302) (id_sub_temp(j+add),j=1,isubdom(1,i))
          END DO
 
          IF (flg_swale==1) THEN
C------------------------------------------------------------------
C-------------SWITCH OF FULL/SUB PARTS FOR ALE---------------------
C------------------------------------------------------------------
            nb_part_sub = npart - isubdom(1,1)
            DO i=1,isubdom(1,1)
              id_sub_temp(i) = isubdom_part(i)
            END DO
 
            DEALLOCATE (isubdom_part)
            ALLOCATE (isubdom_part(nb_part_sub),stat=stat)
            compt = 0
            DO i=1,npart
              found = 0
              DO j=1,isubdom(1,1)
                IF (id_sub_temp(j)==i) found = 1
              END DO
              IF (found==1) cycle
              compt = compt + 1
              isubdom_part(compt) = i
            END DO
            isubdom(1,1) = compt
 
          ENDIF
 
          DEALLOCATE (id_sub_temp)
 
        ENDIF
 
C------------------------------------------------------------------
        irec=irec+1
 
        RETURN
C------------------------------------------------------------------
 1000   FORMAT(
     .   //'      MULTIDOMAINS COUPLING DEFINITIONS '/
     .   '      --------------------------------- '/)
 1100   FORMAT(/10x,'EXTERNAL LINK IDENTIFIER . . . .',i10,
     .         /10x,'RADIOSS NODE GROUP ID . . . . . ',i10)
 1300   FORMAT(/10x,'SUBDOMAIN IDENTIFIER . . . . . .',i10,
     .         /10x,'NUMBER OF PARTS . . . . . . . . ',i10)
 1301   FORMAT( 10x,'LIST OF PARTS : ')
 1302   FORMAT(  9x,10i9)
 1200   FORMAT(' ** INFO : DATA RELATED TO EXTERNAL',
     .         ' COUPLING WILL BE CHECKED IN RADIOSS ENGINE.')
      END SUBROUTINE lecextlnk