lecextlnk.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "r2r_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	lecextlnk (iexter, ipart, lsubmodel)

Function/Subroutine Documentation

lecextlnk()

subroutine lecextlnk	(	integer, dimension(nr2r,*)	iexter,
		integer, dimension(lipart1,*)	ipart,
		type(submodel_data), dimension(*), intent(in)	lsubmodel )

Definition at line 40 of file lecextlnk.F.

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.')