hm_read_rlink.F File Reference

#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "scr03_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "r2r_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	hm_read_link (nnlink, lllink, itab, itabm1, ikine, igrnod, iskn, iframe, nom_opt, lsubmodel)

Function/Subroutine Documentation

hm_read_link()

subroutine hm_read_link	(	integer, dimension(10,*)	nnlink,
		integer, dimension(*)	lllink,
		integer, dimension(*)	itab,
		integer, dimension(*)	itabm1,
		integer, dimension(*)	ikine,
		type (group_), dimension(ngrnod), target	igrnod,
		integer, dimension(liskn,*)	iskn,
		integer, dimension(liskn,*)	iframe,
		integer, dimension(lnopt1,*)	nom_opt,
		type(submodel_data), dimension(*)	lsubmodel )

Definition at line 44 of file hm_read_rlink.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE r2r_mod
      USE message_mod
      USE groupdef_mod
      USE hm_option_read_mod    
      USE submodel_mod
      USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
      USE format_mod , ONLY : fmw_10i
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      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "scr03_c.inc"
#include      "scr17_c.inc"
#include      "param_c.inc"
#include      "r2r_c.inc"
#include      "sphcom.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NNLINK(10,*), LLLINK(*), ITAB(*), ITABM1(*),
     .        IKINE(*),ISKN(LISKN,*),IFRAME(LISKN,*)
      INTEGER NOM_OPT(LNOPT1,*)
      TYPE(SUBMODEL_DATA) LSUBMODEL(*)
C-----------------------------------------------
      TYPE (GROUP_)  ,TARGET, DIMENSION(NGRNOD)  :: IGRNOD
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER K, N, NSL, NUSER, J, I, IGU,IC,ICR,J10(10),
     .   IGRS, NOSYS,J6(6),IS,IPOL,IDIR,ISL,IKINE1(3*NUMNOD),NLK
      CHARACTER MESS*40,CODE*7
      CHARACTER(LEN=NCHARKEY) :: KEY
      CHARACTER(LEN=NCHARTITLE) :: TITR
      CHARACTER(LEN=NCHARFIELD) :: STRING
      my_real bid
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER NGR2USR
!
      INTEGER, DIMENSION(:), POINTER :: INGR2USR
C
      DATA mess/'STANDARD RIGID LINK DEFINITION          '/
C-----------------------------------------------
      LOGICAL IS_AVAILABLE
C=======================================================================
      is_available = .false.
C-----------------------------------------------
      nsl = 0
      k=0
      WRITE(iout,1000)
      nlk = 0
C
C-----------------------------------------------
      CALL hm_option_start('/RLINK')       
C-----------------------------------------------
C
      DO i=1,3*numnod
        ikine1(i) = 0
      ENDDO
C
      DO n=1,nlink
C
C      READING DES CARTES D'INPUT
C
       nlk=nlk+1
C----------Multidomaines --> on ignore les rlink non tages--------
       IF(nsubdom > 0)THEN
         IF(taglnk(nlk) == 0)CALL sz_r2r(taglnk,nlk)
       END IF
C-----------------------------------------------------------------
       CALL hm_option_read_key(lsubmodel, 
     .                          option_id      = nuser, 
     .                          option_titr    = titr)           
       nom_opt(1,n) = nuser
       CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
!Tx, Ty, Tz, OmegaX, OmegaY, OmegaZ, SKEW_CSID, dependentnodeset, RLINK_IPOL);
C--------------------read card-------------------------------------
       CALL hm_get_intv('Tx'      ,j6(1) ,is_available,lsubmodel)  
       CALL hm_get_intv('Ty'      ,j6(2) ,is_available,lsubmodel)  
       CALL hm_get_intv('Tz'      ,j6(3) ,is_available,lsubmodel) 
       CALL hm_get_intv('OmegaX'  ,j6(4) ,is_available,lsubmodel)  
       CALL hm_get_intv('OmegaY'  ,j6(5) ,is_available,lsubmodel)  
       CALL hm_get_intv('OmegaZ'  ,j6(6) ,is_available,lsubmodel) 
 
       CALL hm_get_intv('SKEW_CSID'         ,is  ,is_available,lsubmodel) 
       CALL hm_get_intv('dependentnodeset'  ,igu ,is_available,lsubmodel) 
       CALL hm_get_intv('RLINK_IPOL'        ,ipol,is_available,lsubmodel) 
C-----------------------------------------------------------------
       ic =j6(1)*4 +j6(2)*2 +j6(3)
       icr=j6(4)*4 +j6(5)*2 +j6(6)
       IF (icr > 0.AND.iroddl==0) THEN
         CALL ancmsg(msgid=844,
     .               msgtype=msgwarning,
     .               anmode=aninfo_blind_1,
     .               i1=nuser,
     .               c1=titr)
       END IF
C------------------------------------------------------------------
C            SEARCH FOR SECONDARY NODES
C------------------------------------------------------------------
C     NODE GROUP
C------------------------------------------------------------------
       nsl = 0
       ingr2usr => igrnod(1:ngrnod)%ID
       igrs=ngr2usr(igu,ingr2usr,ngrnod)
       IF(igrs /= 0)THEN
        DO j=1,igrnod(igrs)%NENTITY
          nsl = nsl + 1
          lllink(k+nsl)=igrnod(igrs)%ENTITY(j)
        ENDDO
       ENDIF
 
C------------------------------------------------------------
C      Condition cinematique incompatible
C------------------------------------------------------------
        DO j=1,nsl
         DO idir=1,6
            CALL kinset(1024,itab(lllink(j+k)),ikine(lllink(j+k)),
     .                   idir,0,ikine1(lllink(j+k)))
          ENDDO
        ENDDO
C------------------------------------------------------------------
C      IMPRESSIONS
C------------------------------------------------------------------
       IF(ipol == 0)THEN
         WRITE(iout,1100) nuser,trim(titr),j6,is,nsl
       ELSE
         WRITE(iout,1200) nuser,trim(titr),j6,is,nsl
       ENDIF
C
       IF(ipri >= 1) THEN
         WRITE(iout,'(/10X,A)')'SECONDARY NODES :   '
         WRITE(iout,fmt=fmw_10i) (itab(lllink(i+k)),i=1,nsl)
         WRITE(iout,'(//)')
       ENDIF
       IF(ipol == 0)THEN
         DO 640 j=0,numskw+min(1,nspcond)*numsph+nsubmod
           IF(is == iskn(4,j+1)) THEN
             is=j+1
             GO TO 660
           ENDIF
 640      CONTINUE
C
         CALL ancmsg(msgid=184,
     .               msgtype=msgerror,
     .               anmode=aninfo,
     .               c1='RIGID LINK',
     .               i1=nuser,
     .               c2='RIGID LINK',
     .               c3=titr,
     .               i2=is)
 660     CONTINUE
       ELSE
         DO j=0,numfram
           IF(is==iframe(4,j+1)) THEN
             is=j+1
             GO TO 661
           ENDIF
         ENDDO
         WRITE(istdo,*)' ** ERROR WRONG FRAME NUMBER'
         WRITE(iout,*)' ** ERROR WRONG FRAME NUMBER'
         ierr=ierr+1
 661     CONTINUE
       ENDIF
       nnlink(1,n)=nsl
       nnlink(2,n)=nuser
       nnlink(3,n)=ic
       nnlink(4,n)=icr
       nnlink(5,n)=is
       nnlink(6,n)=ipol
C
       k  = k+nsl
      ENDDO
C-------------------------------------
C     Search for double IDs
C-------------------------------------
      CALL udouble(nom_opt,lnopt1,nlink,mess,0,bid)
      RETURN
C
 1000 FORMAT(
     . '      RIGID LINK DEFINITIONS '/
     . '      ---------------------- '/)
 1100 FORMAT(/10x,'RIGID LINK NUMBER . . . .',i10,/,a,
     .       /10x,'DOF ( X,Y,Z, XX,YY,ZZ). .  ',3i1,2x,3i1
     .       /10x,'SKEW FRAME. . . . . . . .',i10
     .       /10x,'NUMBER OF NODES . . . . .',i10,//)
 1200 FORMAT(/10x,'POLAR RIGID LINK NUMBER .',i10,/,a,
     .       /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . ',3i1,2x,3i1
     .       /10x,'POLAR FRAME . . . . . . .',i10
     .       /10x,'NUMBER OF NODES . . . . .',i10,//)