cstraini4.F File Reference

#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	cstraini4 (jft, jlt, nft, nel, numshel, istrain, gstr, sigsh, nsigsh, numel, ix, nix, ptsh, thke, gstrm, e1x, e2x, e3x, e1y, e2y, e3y, e1z, e2z, e3z)

Function/Subroutine Documentation

cstraini4()

subroutine cstraini4	(	integer, intent(in)	jft,
		integer, intent(in)	jlt,
		integer, intent(in)	nft,
		integer, intent(in)	nel,
		integer, intent(in)	numshel,
		integer, intent(in)	istrain,
		intent(out)	gstr,
		intent(in)	sigsh,
		integer, intent(in)	nsigsh,
		integer, intent(in)	numel,
		integer, dimension(nix,numel), intent(in)	ix,
		integer, intent(in)	nix,
		integer, dimension(numel), intent(in)	ptsh,
		intent(in)	thke,
		intent(out)	gstrm,
		intent(in)	e1x,
		intent(in)	e2x,
		intent(in)	e3x,
		intent(in)	e1y,
		intent(in)	e2y,
		intent(in)	e3y,
		intent(in)	e1z,
		intent(in)	e2z,
		intent(in)	e3z )

Definition at line 33 of file cstraini4.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   A n a l y s e   M o d u l e
C-----------------------------------------------
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "mvsiz_p.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: JFT,JLT,NUMEL,NIX,NFT,
     .                       ISTRAIN,NEL,NSIGSH,NUMSHEL
      INTEGER, DIMENSION(NIX,NUMEL), INTENT(IN) :: IX
      INTEGER, DIMENSION(NUMEL), INTENT(IN) :: PTSH
      my_real, DIMENSION(NSIGSH,NUMSHEL),INTENT(IN) :: sigsh
      my_real, DIMENSION(NEL,8,4),INTENT(OUT) :: gstr
      my_real, DIMENSION(NEL,8),  INTENT(OUT) :: gstrm
      my_real, DIMENSION(NEL),INTENT(IN) :: thke 
      my_real, DIMENSION(MVSIZ),INTENT(IN) :: 
     .               e1x,e2x,e3x,e1y,e2y,e3y,e1z,e2z,e3z  
C------------------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,II,J,JJ,N,NPTI,I1,I2,PT,PID1,IPID1,L_PLA,NLAY,
     .   ILAY,LAYNPT_MAX,LAY_MAX,NPTT,NPTMX,IP,PTS,LENS,IPT_ALL,
     .   IPT,PTN,JDIR,ILAW,NPGI,NPG
      INTEGER LI(MVSIZ)
      my_real 
     .    e1(6),e2(6),z1,z2,z0,aa,e1g(6,4),e2g(6,4),z1g(4),z2g(4),ung,r1
C=======================================================================
!
      npg=4
      DO i=jft,jlt
        IF (abs(isigi) /= 3.AND.abs(isigi) /= 4.AND.abs(isigi) /= 5)THEN
          ii = i+nft
          n = nint(sigsh(1,ii))
          IF (n /= ix(nix,ii)) THEN
            jj = ii
            DO j = 1,numel
              ii= j
              n = nint(sigsh(1,ii))
              IF (n == 0) GOTO 100
              IF (n == ix(nix,jj)) GOTO 60
            ENDDO
 60         CONTINUE
          ENDIF
        ELSE
          jj=nft+i
          n =ix(nix,jj)
          ii=ptsh(jj)
          IF (ii == 0) GOTO 100
        ENDIF
        li(i) = ii
        npti=nint(sigsh(2,ii))
        npgi=nint(sigsh(nvshell,ii))
C--- in global sys NPGI=4 for QEPH like stress now
         IF(sigsh(17,ii) == one .AND. npgi==npg )THEN
            pt = inishvar1          
             IF (npti==1) THEN
               DO ip = 1,npg
                 e1(1:6) = sigsh(pt:pt+5,ii)
                 z1 = sigsh(pt+6,ii)
                   CALL cg2leps(
     7              e1x(i) ,e2x(i),e3x(i),e1y(i),e2y(i),e3y(i),
     8              e1z(i) ,e2z(i),e3z(i),e1   )
                   gstr(i,1:5,ip) = e1(1:5)
                 pt = pt + 7
               END DO 
             ELSE
               aa = half*thke(i)
               DO ip = 1,npg
                 e1g(1:6,ip) = sigsh(pt:pt+5,ii)
                 z1g(ip) = sigsh(pt+6,ii)
                 pt = pt + 7
               END DO 
               DO ip = 1,npg
                 e2g(1:6,ip) = sigsh(pt:pt+5,ii)
                 z2g(ip) = sigsh(pt+6,ii)
                 pt = pt + 7
               END DO 
               DO ip = 1,npg
                 CALL cg2leps(
     7              e1x(i) ,e2x(i),e3x(i),e1y(i),e2y(i),e3y(i),
     8              e1z(i) ,e2z(i),e3z(i),e1g(1,ip))
                 CALL cg2leps(
     7              e1x(i) ,e2x(i),e3x(i),e1y(i),e2y(i),e3y(i),
     8              e1z(i) ,e2z(i),e3z(i),e2g(1,ip))
                 IF (z1g(ip)==z2g(ip)) THEN
c                error out
                   CALL ancmsg(msgid=1904,
     .                anmode=aninfo,
     .                msgtype=msgerror,
     .                i1=n,
     .                r1=z1g(ip))
                 ELSEIF (z1g(ip)==zero) THEN
                  gstr(i,1:5,ip)=e1g(1:5,ip)
                  z0 = aa*z2g(ip)
                  gstr(i,6:8,ip)=(e2g(1:3,ip)-e1g(1:3,ip))/z0
                 ELSEIF (z2g(ip)==zero) THEN
                  gstr(i,1:5,ip)=e2g(1:5,ip)
                  z0 = aa*z1g(ip)
                  gstr(i,6:8,ip)=(e1g(1:3,ip)-e2g(1:3,ip))/z0
                 ELSE
                  z0 = aa*(z2g(ip)-z1g(ip))
                  gstr(i,6:8,ip)=(e2g(1:3,ip)-e1g(1:3,ip))/z0
                  gstr(i,1:3,ip)=e1g(1:3,ip)-aa*z1g(ip)*gstr(i,6:8,ip)
                  gstr(i,4:5,ip)= half*(e2g(4:5,ip)+e1g(4:5,ip))
                 END IF
               END DO 
             END IF
           gstrm(i,1:8) = zero
           ung = one/npg          
           DO ip = 1,npg
             gstrm(i,1:8) = gstrm(i,1:8) + ung*gstr(i,1:8,ip)
           END DO
         ENDIF
 100  CONTINUE
      ENDDO
C-----------
      RETURN