i3pen2.F File Reference

#include "implicit_f.inc"
#include "units_c.inc"
#include "scr03_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	i3pen2 (x, irect, msr, nsv, iloc, irtl, nsn, cst, irtlo, fric0, fric, gap, iwpene, itab, id, titr)

Function/Subroutine Documentation

i3pen2()

subroutine i3pen2	(		x,
		integer, dimension(4,*)	irect,
		integer, dimension(*)	msr,
		integer, dimension(*)	nsv,
		integer, dimension(*)	iloc,
		integer, dimension(*)	irtl,
		integer	nsn,
			cst,
		integer, dimension(*)	irtlo,
			fric0,
			fric,
			gap,
		integer	iwpene,
		integer, dimension(*)	itab,
		integer	id,
		character(len=nchartitle)	titr )

Definition at line 34 of file i3pen2.F.

      USE message_mod
      USE names_and_titles_mod , ONLY : nchartitle
      USE format_mod , ONLY : fmw_5i_f, fmw_5i
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      "units_c.inc"
#include      "scr03_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NSN,IWPENE
      my_real fric, gap
      INTEGER IRECT(4,*), MSR(*), NSV(*), ILOC(*), IRTL(*), IRTLO(*), ITAB(*)
      my_real x(3,*), cst(2,*), fric0(3,*)
      INTEGER ID
      CHARACTER(LEN=NCHARTITLE) :: TITR
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER II, I, J, K, L, M, JJ
      my_real n2, n3, ys, zs, t2, t3, xl, pen, ss, ym1, ym2, zm1, zm2
C-----------------------------------------------
C   S o u r c e   L i n e s
C-----------------------------------------------
      DO 150 ii=1,nsn
      i=nsv(ii)
      j=iloc(ii)
      k=msr(j)
      l=irtl(ii)
      irtlo(ii)=0
      fric0(1,ii)=zero
      m=msr(irect(1,l))
      ym1=x(2,m)
      zm1=x(3,m)
      m=msr(irect(2,l))
      ym2=x(2,m)
      zm2=x(3,m)
      ys =x(2,i)
      zs =x(3,i)
C-----------------------------
C     PENETRATION
C-----------------------------
      t2=ym2-ym1
      t3=zm2-zm1
      xl=sqrt(t2**2+t3**2)
      IF(xl==0.0)THEN
       CALL ancmsg(msgid=80,msgtype=msgerror,anmode=aninfo,i1=id,c1=titr,i2=l,i3=itab(msr(irect(1,l))),i4=itab(msr(irect(2,l))))
      ENDIF
      t2=t2/xl
      t3=t3/xl
      n2= t3
      n3=-t2
      pen=n2*(ys-ym1)+n3*(zs-zm1)-gap
      IF(pen>0.0)THEN
       GOTO 110
      ENDIF
      ss=t2*(ys-ym1)+t3*(zs-zm1)
      ss=ss/xl
      ss=two*ss-one
      IF(ss> onep05)GO TO 110
      IF(ss<-onep05)GO TO 110
      IF(pen<zero)THEN
       iwpene=iwpene+1
       CALL ancmsg(msgid=346,msgtype=msgwarning,anmode=aninfo_blind_2,i1=id,i2=itab(i),c1=titr,r1=pen)
      ENDIF
      IF(ipri>=1)THEN
       WRITE(iout,fmt=fmw_5i_f)itab(i),itab(k),l,itab(msr(irect(1,l))),itab(msr(irect(2,l))),ss
      ENDIF
      IF(fric==0.0) GO TO 150
      irtlo(ii)=l
      cst(1,ii)=ss
      GO TO 150
 110  CONTINUE
      IF(ipri>=1)THEN
       WRITE(iout,fmt=fmw_5i)itab(i),itab(k),l,itab(msr(irect(1,l))),itab(msr(irect(2,l)))
      ENDIF
 150  CONTINUE
C
      RETURN