s16sigp3.F File Reference

#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	s16sigp3 (lft, llt, nel, nptr, nlay, nptt, icp, mtn, npe, nipmax, px, py, pz, vx, vy, vz, w_gauss, defp, pm, mxt, sig, dt1, elbuf_str)

Function/Subroutine Documentation

s16sigp3()

subroutine s16sigp3	(	integer	lft,
		integer	llt,
		integer	nel,
		integer	nptr,
		integer	nlay,
		integer	nptt,
		integer	icp,
		integer	mtn,
		integer	npe,
		integer	nipmax,
			px,
			py,
			pz,
			vx,
			vy,
			vz,
			w_gauss,
			defp,
			pm,
		integer, dimension(*)	mxt,
			sig,
			dt1,
		type (elbuf_struct_), target	elbuf_str )

Definition at line 32 of file s16sigp3.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE elbufdef_mod            
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "mvsiz_p.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER LFT,LLT, NPTR,NLAY,NPTT,ICR,ICS,ICT,ICP,NEL,
     .        MTN,NPE,NIPMAX,MXT(*)
      my_real
     .  vx(mvsiz,*),vy(mvsiz,*),vz(mvsiz,*),
     .  px(mvsiz,npe,*),py(mvsiz,npe,*),pz(mvsiz,npe,*),
     .  dt1 ,w_gauss(9,9),defp(*),pm(npropm,*),sig(nel,6)
      TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_STR
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,IL,IS,IT,IR,IP,WI,N, MX
C     REAL
      my_real
     .  dvm(mvsiz), dv(mvsiz,nipmax),fac(mvsiz),dt3,dvp,f,e0(mvsiz)
      TYPE(G_BUFEL_) ,POINTER :: GBUF
      TYPE(L_BUFEL_) ,POINTER :: LBUF     
C=======================================================================
      gbuf => elbuf_str%GBUF
      is = 1
      DO i=lft,llt
        dvm(i)=zero
      ENDDO
 
      DO it=1,nptt
       DO ir=1,nptr
        DO il=1,nlay
          lbuf => elbuf_str%BUFLY(il)%LBUF(ir,is,it)
          ip = ir + ( (il-1) + (it-1)*nlay )*nptr
          wi = w_gauss(ir,nptr)*w_gauss(il,nlay)*w_gauss(it,nptt)
         DO i=lft,llt
           dv(i,ip)=zero
         ENDDO
         DO n=1,npe
          DO i=lft,llt
            dv(i,ip)=dv(i,ip)+px(i,n,ip)*vx(i,n)+py(i,n,ip)*vy(i,n)
     .              +pz(i,n,ip)*vz(i,n)
            dvm(i)=dvm(i)+dv(i,ip)*wi
          ENDDO
         ENDDO
        ENDDO
       ENDDO
      ENDDO
 
      dt3=third*dt1
      IF (icp == 1) THEN
        DO i=lft,llt
          fac(i)=one
        ENDDO
      ELSEIF (icp == 2) THEN
        mx = mxt(lft)
        DO i=lft,llt
          e0(i)  = pm(20,mx)
        ENDDO
        CALL s8csigp3(sig,e0 ,defp,fac,gbuf%G_PLA,nel)
      ENDIF
C
      DO it=1,nptt
       DO ir=1,nptr
        DO il=1,nlay
          lbuf => elbuf_str%BUFLY(il)%LBUF(ir,is,it)
          ip = ir + ( (il-1) + (it-1)*nlay )*nptr
          DO i=lft,llt
            f = lbuf%OFF(i)*fac(i)
            dvp  = dt3*f*(dvm(i)-dv(i,ip))
            IF (dvp > one) THEN
              dvp =zero
              lbuf%OFF(i)=zero
            ENDIF
            lbuf%VOL(i)  = lbuf%VOL(i) *(one- dvp)
            lbuf%EINT(i) = lbuf%EINT(i)*(one- dvp)
          ENDDO 
        ENDDO
       ENDDO
      ENDDO
C-----------
      RETURN