Sources Esope | Cast3M

effi2
C EFFI2     SOURCE    CHAT      05/01/12    23:28:26     5004
      SUBROUTINE EFFI2(VALCAR,TYVAL,NCA1,NCAR1,REL,LRE,IB,IGAU,XATEF1,
     &NSTEP,DREND,CELEM)
***************************************************************
* calcule la matrice d efficacite directionnelle
* puis transforme la matrice elementaire par blocs
***************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION VALCAR(*),REL(LRE,LRE)
      CHARACTER*16 TYVAL(*)
      CHARACTER*8 CELEM
      dimension xatef1(3,3),xmat1(3,3),tq(3,3),xres(3,3)
      dimension xmat2(3,3), q(3,3),xmat3(3,3)
      logical drend
 
      if (drend) goto 1000
* matrice de rotation
      w1x = valcar(ncar1+1)
      w1y = valcar(ncar1+2)
      w1z = valcar(ncar1+3)
      w2x = valcar(ncar1+4)
      w2y = valcar(ncar1+5)
      w2z = valcar(ncar1+6)
      tq(1,1) = w1x
      tq(2,1) = w1y
      tq(1,2) = w2x
      tq(2,2) = w2y
      if (nstep.gt.2) then
        w3x = w1y*w2z - w1z*w2y
        w3y = w2x*w1z - w2z*w1x
        w3z = w1x*w2y - w1y*w2x
        tq(3,1) = w1z
        tq(3,2) = w2z
        tq(1,3) = w3x
        tq(2,3) = w3y
        tq(3,3) = w3z
      endif
      do i = 1,nstep
        do j = 1, nstep
           q(i,j) = tq(j,i)
        enddo
      enddo
 
* efficacite
* produit
      do i = 1,nstep
        do j = 1, nstep
         cc= 0.d0
            do k1 = 1,nstep
                cc = cc + tq(i,k1)*xatef1(k1,j)
            enddo
         xmat2(i,j) = cc
        enddo
      enddo
      do i = 1,nstep
        do j = 1, nstep
         cc= 0.d0
            do k1 = 1,nstep
                cc = cc + xmat2(i,k1)*q(k1,j)
            enddo
         xatef1(i,j) = cc
        enddo
      enddo
 
 
 
 1000 CONTINUE
* affecte la rigidite elementaire
c ----------------------------------------
c  elements massifs
c ----------------------------------------
      if (CELEM.NE.'MASSIF  ') goto 2000
      kind = int(LRE/NSTEP)
      DO jind1 = 1,kind
        DO jind2 =1,kind
 
* decoupe un bloc
         do in1 = 1,nstep
           do in2 = 1, nstep
                xmat1(in1,in2) =
     &         REL((jind1 - 1)*nstep + in1,(jind2 - 1)*nstep + in2)
*         if (ib.eq.1.and.igau.eq.1.and.jind1.eq.1.and.jind2.eq.2)
*     & write(6,*) in1,in2,xmat1(in1,in2) ,
*     & ((jind1 - 1)*nstep + in1), ((jind2 - 1)*nstep + in2)
           enddo
         enddo
* multiplie et range
         do in1 = 1,nstep
           do in2 = 1, nstep
             cc = 0.D0
              do k1 = 1,nstep
                 cc = cc + (xatef1(in1,k1) * xmat1(k1,in2))
*       if (igau.eq.5.and.jind1.eq.6.and.jind2.eq.7)
*     &write(6,*) in1,in2,xatef1(in1,k1) ,  xmat1(k1,in2)
              enddo
 
           REL((jind1 - 1)*nstep + in1,(jind2 - 1)*nstep + in2) = cc
*         if (ib.eq.1.and.igau.eq.5.and.jind1.eq.6.and.jind2.eq.7)
*     & write(6,*) ((jind1 - 1)*nstep + in1),((jind2 - 1)*nstep + in2),
*     & in1,in2, cc
*      if (ib.eq.1.and.igau.eq.5.and.jind1.eq.5)
*     & write(6,*) ((jind1 - 1)*nstep + in1),((jind2 - 1)*nstep + in2),
*     & in1,in2, xmat1(in1,in2),cc
           enddo
         enddo
 
 
        ENDDO
      ENDDO
      RETURN
 
 2000 CONTINUE
c ----------------------------------------
c  elements
c ----------------------------------------
      RETURN
      END