VECFEM3 Reference Manual: veme00exm09.html

    C*******************************************************************
    C**
    C**    v e m e 0 0 e x m 0 9
    C**
    C**  solution of a 2-dimensional, linear structural analysis
    C**  problem with element depending material coefficients. The mesh
    C**  is generated by this program.
    C**
    C**   by L. Grosz                         Karlsruhe, June 1995
    C**
    C*******************************************************************
    C**
    C**   Here we give an example for the use of veme00 to solve
    C**   a 2D linear structural analysis problems for a curved beam
    C**   tracted by a surface load (plane stress, NK=DIM=2). The
    C**   components of the solution vector u=(u1,u2) are the
    C**   displacements of the body in the directions x1, x2.
    C**   The vector of distortions in the global Cartesian
    C**   coordinates is defined by
    C**
    C**    eps1  = u1x1
    C**    eps2  = u2x2
    C**    eps12 = (u2x1+u1x2)/2
    C**
    C**   where the notations of equation are used. Corresponding
    C**   the stress vector has the form (s1,s2,s12). By Hook's law
    C**   the stress and distortion vector corresponds for isotropic
    C**   materials by
    C**
    C**    | s1  |       | C11  C12   0     |   | eps1  |
    C**    | s2  |       | C12  C11   0     |   | eps2  |
    C**    | s12 |       |  0    0   2*C44  |   | eps12 |
    C**
    C**   where the C-entries are given by the two values E and NY
    C**   called modulus of elasticity and Poisson's number.
    C**
    C**  If the body is tracted by a suface load p=(p1,p2) the
    C**  displacement of the body is the solution of the linear
    C**  functional equation L(v,u)=F(v) with
    C**
    C**   L(v,u)=area{ v1x1 * s1  + v1x2 * s12 +
    C**                v2x1 * s12 + v2x2 * s2  }
    C**  [1]
    C**
    C**   F(v)=line{ v1 * p1 + v2 * p2 }.
    C**
    C**  Additionally u has to fulfill the prescribed Dirichlet
    C**  conditions, which gives the restraint conditions for the
    C**  displacement of the body, see equation, veme00.
    C**
    C**  The domain is a curved 2D beam of length L and height H. The
    C**  boundaries along the beam are parabolic curve:
    C**
    C**
    C**            p=(p1,p2)=(0,-1)      surface load
    C**         |||||||||||||||
    C**
    C**             / --  \
    C**           /         \
    C**         /     ---     \   +
    C**   +     |    /   \    |   | H0
    C** H |     |  /       \  |   |
    C**   +      /           \    +
    C**
    C**         +-------------+
    C**                L
    C**
    C**  The example program generates a subdivision of the beam into
    C**  quadrilateral element and the upper edge into line elements,
    C**  where the surface load p=(p1,p2) attacks. The modulus of
    C**  elasticity and the Poisson's number depend on the element.
    C**  They are the average values on this element. The values
    C**  will be set by a random sample, which is used in the
    C**  simulation of wooden beams. The generated mesh and the
    C**  computed displacements and the stresses are written to the
    C**  I-DEAS universal files.
    C**
          PROGRAM VEMEXM
    C**
    C**-----------------------------------------------------------------
    C**
          IMPLICIT NONE
          include 'bytes.h'
    C**
    C**-----------------------------------------------------------------
    C**
    C**  Set the dimensions of the beam:
    C**
          DOUBLE PRECISION L,H,H0

          PARAMETER (L=10,H=1,H0=.6)
    C**
    C**-----------------------------------------------------------------
    C**
    C**    some parameters which may be chanced:
    C**
    C**    ELEM1 = number of elements along the beam.
    C**    ELEM2 = number of elements along the beam height.
    C**    STORE = total storage of process in Mbytes.
    C**
          INTEGER       ELEM1,ELEM2,STORE

          PARAMETER (ELEM2=4,
         &           ELEM1=ELEM2*(L/H),
         &           STORE=5)
    C**
    C**   ELEM1 is selected, so that the elements are nearly
    C**   square.
    C**
    C**-----------------------------------------------------------------
    C**
    C**    N1 = number of nodes along the beam
    C**    N2 = number of nodes in direction beam height
    C**
    C**    other parameters are explained in mesh.
    C**
          INTEGER       N1,N2,NK,DIM,NN,LOUT

          PARAMETER (N1=2*ELEM1+1,
         &           N2=2*ELEM2+1,
         &           NK=2,
         &           DIM=2,
         &           NN=N1*N2,
         &           LOUT=6)
    C**
    C**-----------------------------------------------------------------
    C**
    C**   the length of the array for the mesh are set:
    C**
          INTEGER       LU,LDISP,LSTRES,LNODN,LNOD,LNOPRM,LNEK,LRPARM,
         &              LIPARM,LDNOD,LIDPRM,LRDPRM,LIVEM,LRVEM,LLVEM,LBIG

          PARAMETER  (LU    =NN*NK,
         &            LDISP =NN*3,
         &            LSTRES=NN*6,
         &            LNODN =NN,
         &            LNOD  =NN*DIM,
         &            LNOPRM=1,

         &            LNEK=(8*(ELEM1*ELEM2+1)+3*(ELEM1+1))*2,
         &            LIPARM=ELEM1*ELEM2+ELEM1+2,
         &            LRPARM=2*(ELEM1*ELEM2+1),

         &            LDNOD =2*NK*2,
         &            LIDPRM=1,
         &            LRDPRM=1,

         &            LIVEM =700+LU+LDNOD/2,
         &            LLVEM =500,
         &            LRVEM =60)
    C**
    C**-----------------------------------------------------------------
    C**
    C**   RBIG should be as large as possible: the available
    C**   storage STORE is reduced by all allocated array.
    C**   the remaining storage is reserved for RBIG.
    C**
          PARAMETER ( LBIG=(STORE * 1 000 000)/IREAL
         &               - (LU+LDISP+LSTRES+LNOD+LNOPRM+LRPARM+LRDPRM)
         &               - (LIVEM+LNODN+LNEK+LIPARM+LDNOD+LIDPRM)/RPI )
    C**
    C**-----------------------------------------------------------------
    C**
    C**      variables and arrays :
    C**      --------------------
    C**
          DOUBLE PRECISION T,NOD(LNOD),NOPARM(LNOPRM),RPARM(LRPARM),
         &                 RDPARM(LRDPRM),RBIG(LBIG),U(LU),RVEM(LRVEM),
         &                 GDISP(LDISP),ESTRES(LSTRES)

          INTEGER          IVEM(LIVEM),NODNUM(LNODN),NEK(LNEK),
         &                 IPARM(LIPARM),DNOD(LDNOD),IDPARM(LIDPRM),
         &                 IBIG(RPI*LBIG)

          LOGICAL          MASKL(NK,NK,2),MASKF(NK,2),LVEM(LLVEM)
    C***
          INTEGER          INFO,S,NE1,ADNEK1,NE2,ADNEK2,ADIVP2,ADIVP1,NDC1,
         &                 NDC2,ADDCG1,ADDCG2,MYPROC,Z1,Z2,NGROUP,MESH,
         &                 GINFO,GINFO1,DINFO,DINFO1,ELNUM,ADRVP1
          DOUBLE PRECISION E0,NY0,X1,X2
          CHARACTER*80     TEXT1,TEXT2,NAME
    C***
          EXTERNAL VEM630,VEM500
          EXTERNAL DUMMY,USERB,USERL,USERF,USERC,DISP,STRESS
    C**
    C**-----------------------------------------------------------------
    C**
    C**  The equivalence of RBIG and IBIG is very important :
    C**
          EQUIVALENCE (RBIG,IBIG)
    C**
    C**-----------------------------------------------------------------
    C**
    C**  set the average value of E-modulus and the Poisson's number:
    C**
          E0=1.93D4
          NY0=.3
    C**
    C**-----------------------------------------------------------------
    C**
    C**   get task ids :
    C**
          NAME='a.out'
          CALL COMBGN(IVEM(200),MYPROC,LIVEM-203,IVEM(204),NAME,INFO)
          IF (INFO.NE.0) GOTO 9999
          IVEM(201)=MYPROC
          IVEM(202)=0
          IVEM(203)=IVEM(204)
          IF (IVEM(200).NE.1) THEN
    	PRINT*,'This program does not run on a parallel computer !'
            GOTO 9999
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**** set some VECFEM parameters for mesh management:
    C**   ----------------------------------------------
    C**
          MESH  =210
          NGROUP=2
          GINFO =30
          GINFO1=23+2*NK
          DINFO =GINFO+GINFO1*NGROUP
          DINFO1=17
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the parameters are copied into IVEM :
    C**   -----------------------------------
    C**
          IVEM(1)=MESH
          IVEM(MESH+ 1)=N1*N2
          IVEM(MESH+ 2)=NK
          IVEM(MESH+ 3)=DIM
          IVEM(MESH+ 4)=NGROUP
          IVEM(MESH+ 5)=NN
          IVEM(MESH+13)=NN
          IVEM(MESH+14)=0
          IVEM(MESH+15)=0
          IVEM(MESH+18)=0

          IVEM(MESH+21)=GINFO
          IVEM(MESH+22)=GINFO1
          IVEM(MESH+23)=DINFO
          IVEM(MESH+24)=DINFO1
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the generation of the geometrical nodes :
    C**   ---------------------------------------
    C**
          DO 10 Z2=1,N2
            DO 10 Z1=1,N1

              X1=DBLE(Z1-1)/DBLE(N1-1)
              X2=DBLE(Z2-1)/DBLE(N2-1)

              NOD(Z1+N1*(Z2-1)   )= L  * (X1-0.5)
              NOD(Z1+N1*(Z2-1)+NN)= 4. * (1.-X1)*X1 * H0 + H*X2

              NODNUM(Z1+N1*(Z2-1))=Z1+N1*(Z2-1)
     10   CONTINUE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the generation of the elements :
    C**   -------------------------------
    C**
    C**   The domain is covered by quadrilateral elements of order 2
    C**   and the upper boundary, where the surface load attacks,
    C**   is described by line elments of order 2. The following
    C**   picture illustrates the construction of the quadrilateral
    C**   element with lower node S:
    C**
    C**       S+2*N1   S+2*N1+1   S+2*N1+2
    C**            4-----7-----3
    C**            |           |
    C**      S+N1  8           6  S+N1+2
    C**            |           |
    C**            1-----5-----4
    C**            S     S+1      S+2
    C**
    C**   ADNEK1 defines the start address of the quadrilateral
    C**   elements in NEK and ADIVP1 defines the start address of
    C**   the element id number assigned to the elements. The element
    C**   id number is unique. Since the modulus of elasticity and the
    C**   Poisson's number varry with the elements, they are assigned
    C**   to the elements as real vector parameter (NRVP=2). ADRVP1
    C**   sets the address of the first parameter. NE1 is the number
    C**   of quadrilateral elements. ELNUM counts the elements in
    C**   group 1:
    C**
          ADNEK1=1
          ADIVP1=1
          ADRVP1=1
          NE1=ELEM1*ELEM2

          DO 20 Z2=1,ELEM2
            DO 20 Z1=1,ELEM1

              ELNUM=Z1+ELEM1*(Z2-1)
              S   =2*(Z1-1) + 2*(Z2-1) * N1 + 1

              IPARM(ADIVP1-1+ELNUM)=ELNUM

              NEK(ADNEK1-1+ELNUM      )=S
              NEK(ADNEK1-1+ELNUM+  NE1)=S         + 2
              NEK(ADNEK1-1+ELNUM+2*NE1)=S + 2 *N1 + 2
              NEK(ADNEK1-1+ELNUM+3*NE1)=S + 2 *N1
              NEK(ADNEK1-1+ELNUM+4*NE1)=S         + 1
              NEK(ADNEK1-1+ELNUM+5*NE1)=S +    N1 + 2
              NEK(ADNEK1-1+ELNUM+6*NE1)=S + 2 *N1 + 1
              NEK(ADNEK1-1+ELNUM+7*NE1)=S +    N1
    C**
    C**       The modulus of elasticty and the Poisson's number on
    C**       the element is set by a random sample, so that the
    C**       average value will be E0 and NY0 with a dispersion of
    C**       of 20%. Actually we have only realized an idea of
    C**       of this model.
    C**
              RPARM(ADRVP1-1+ELNUM    )= E0  * (1.+.2*SIN(FLOAT(Z1**2+Z2)))
              RPARM(ADRVP1-1+ELNUM+NE1)= NY0 * (1.+.2*SIN(FLOAT(Z1+Z2**2)))
     20   CONTINUE
    C**
    C**   ADNEK2 defines the start address of the line elements
    C**   in NEK and ADIVP2 defines the start address of the
    C**   element id number assigned to the elements. The entries 1 to
    C**   8*NE1 in NEK and 1 to NE1 in IPARM are already used by
    C**   the elements in group 1. NE2 is the number of line elements
    C**   on the upper boundary.
    C**
    C**             S    S+1   S+2
    C**             2-----3-----1
    C**
          ADNEK2=ADNEK1+8*NE1
          ADIVP2=ADIVP1+NE1
          NE2=ELEM1

          DO 34 Z1=1,ELEM1
            S   =2*(Z1-1) + (N2-1) * N1 + 1

            IPARM(ADIVP2-1+Z1)=Z1+ELEM1*ELEM2

            NEK(ADNEK2-1+Z1      )=S + 2
            NEK(ADNEK2-1+Z1+  NE2)=S
            NEK(ADNEK2-1+Z1+2*NE2)=S + 1
     34   CONTINUE
    C**
    C**-----------------------------------------------------------------
    C**
    C**   the start addresses, etc are written to IVEM:
    C**   --------------------------------------------
    C**
    C**   group 1: quadrilateral elements
    C**
          IVEM(MESH+GINFO   ) = NE1
          IVEM(MESH+GINFO+ 1) = 8
          IVEM(MESH+GINFO+ 2) = 4
          IVEM(MESH+GINFO+ 3) = 2
          IVEM(MESH+GINFO+ 4) = ADNEK1
          IVEM(MESH+GINFO+ 5) = NE1
          IVEM(MESH+GINFO+ 8) = 0
          IVEM(MESH+GINFO+ 9) = ADRVP1
          IVEM(MESH+GINFO+10) = NE1
          IVEM(MESH+GINFO+11) = 2
          IVEM(MESH+GINFO+13) = 0
          IVEM(MESH+GINFO+14) = ADIVP1
          IVEM(MESH+GINFO+15) = NE1
          IVEM(MESH+GINFO+16) = 1
          IVEM(MESH+GINFO+20) = ADNEK1
          IVEM(MESH+GINFO+21) = NE1
          IVEM(MESH+GINFO+23) = 8
    C**
    C**   group 2: line elements
    C**
          IVEM(MESH+GINFO+GINFO1   ) = NE2
          IVEM(MESH+GINFO+GINFO1+ 1) = 3
          IVEM(MESH+GINFO+GINFO1+ 2) = 2
          IVEM(MESH+GINFO+GINFO1+ 3) = 1
          IVEM(MESH+GINFO+GINFO1+ 4) = ADNEK2
          IVEM(MESH+GINFO+GINFO1+ 5) = NE2
          IVEM(MESH+GINFO+GINFO1+ 8) = 0
          IVEM(MESH+GINFO+GINFO1+11) = 0
          IVEM(MESH+GINFO+GINFO1+13) = 0
          IVEM(MESH+GINFO+GINFO1+14) = ADIVP2
          IVEM(MESH+GINFO+GINFO1+15) = NE2
          IVEM(MESH+GINFO+GINFO1+16) = 1
          IVEM(MESH+GINFO+GINFO1+20) = ADNEK2
          IVEM(MESH+GINFO+GINFO1+21) = NE2
          IVEM(MESH+GINFO+GINFO1+23) = 3
    C**
    C**-----------------------------------------------------------------
    C**
    C**   generation of the nodes with Dirichlet conditions :
    C**   -------------------------------------------------
    C**
    C**   NDC1/NDC2 counts the Dirichlet condition generated for
    C**   component 1/2. ADDCG1/ADDCG2 gives the start address of
    C**   node ids in DNOD.
    C**
    C**   for component 1 the left and the right contact point of the
    C**   get Dirichlet conditions:
    C**
          NDC1=1
          ADDCG1=1
          DNOD(ADDCG1  )=1
    C**
    C**   for component 2 the left contact point of the beam get a
    C**   Dirichlet condition:
    C**
          NDC2=2
          ADDCG2=NDC1+ADDCG1
          DNOD(ADDCG2  )=1
          DNOD(ADDCG2+1)=N1
    C**
    C**-----------------------------------------------------------------
    C**
    C**   the start addresses,etc are written to IVEM:
    C**
    C**   component 1:
    C**
          IVEM(MESH+DINFO   ) = NDC1
          IVEM(MESH+DINFO+ 1) = ADDCG1
          IVEM(MESH+DINFO+ 2) = ADDCG1
          IVEM(MESH+DINFO+ 4) = 0
          IVEM(MESH+DINFO+ 7) = 0
          IVEM(MESH+DINFO+ 9) = 0
          IVEM(MESH+DINFO+12) = 0
    C**
    C**   component 2:
    C**
          IVEM(MESH+DINFO+DINFO1   ) = NDC2
          IVEM(MESH+DINFO+DINFO1+ 1) = ADDCG2
          IVEM(MESH+DINFO+DINFO1+ 2) = ADDCG2
          IVEM(MESH+DINFO+DINFO1+ 4) = 0
          IVEM(MESH+DINFO+DINFO1+ 7) = 0
          IVEM(MESH+DINFO+DINFO1+ 9) = 0
          IVEM(MESH+DINFO+DINFO1+12) = 0
    C**
    C**-----------------------------------------------------------------
    C**
    C**** print mesh :
    C**   ----------
    C**
          IVEM(20)=LOUT
          IVEM(21)=1111
          IVEM(22)=2

          CALL VEMU01(LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
         &            LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,
         &            LNODN,NODNUM,LNOD,NOD,LNOPRM,NOPARM,LBIG,RBIG,IBIG)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** distribute mesh :
    C**   ----------------
    C**
          IVEM(80)=LOUT
          IVEM(81)=1
          IVEM(51)=2

          CALL VEMDIS (LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM ,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,
         &             LNODN,NODNUM,LNOD,NOD,LNOPRM,NOPARM,
         &             LBIG,RBIG,IBIG)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** call of VECFEM :
    C**   --------------
    C**
          OPEN(10,FORM='UNFORMATTED',STATUS='SCRATCH')
          OPEN(11,FORM='UNFORMATTED',STATUS='SCRATCH')

          LVEM(1)=.TRUE.
          LVEM(5)=.FALSE.
          LVEM(9)=.FALSE.
          RVEM(3)=1.D-4
          IVEM(3)=0
          IVEM(10)=10
          IVEM(11)=11
          IVEM(40)=LOUT
          IVEM(41)=100
          IVEM(45)=500
          IVEM(46)=0
          IVEM(52)=1
          IVEM(70)=123
          IVEM(71)=1
          IVEM(72)=10 000

          MASKL(1,1,1)=.TRUE.
          MASKL(1,2,1)=.TRUE.
          MASKL(2,1,1)=.TRUE.
          MASKL(2,2,1)=.TRUE.
          MASKL(1,1,2)=.FALSE.
          MASKL(1,2,2)=.FALSE.
          MASKL(2,1,2)=.FALSE.
          MASKL(2,2,2)=.FALSE.
          MASKF(1,1)=.FALSE.
          MASKF(2,1)=.FALSE.
          MASKF(1,2)=.FALSE.
          MASKF(2,2)=.TRUE.

          CALL VEME00 (T,LU,U,
         &             LIVEM,IVEM,LLVEM,LVEM,LRVEM,RVEM,
         &             LNEK, NEK ,LRPARM ,RPARM ,LIPARM ,IPARM ,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,LNODN,
         &             NODNUM,LNOD,NOD,LNOPRM,NOPARM,LBIG,RBIG,IBIG,
         &             MASKL,MASKF,USERB,USERL,USERF,
         &             VEM500,VEM630)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the displacements are computed at the geometrical nodes :
    C**   -------------------------------------------------------
    C**
          IVEM(4)=30
          IVEM(30)=LOUT
          IVEM(31)=1
          IVEM(32)=NN
          IVEM(33)=2
          CALL VEMU05 (T,LDISP,GDISP,LU,U,
         &             LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,LNODN,
         &             NODNUM,LNOD,NOD,LNOPRM,NOPARM,
         &             LBIG,RBIG,IBIG,DISP)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the stresses are computed at the center points of elements :
    C**   ----------------------------------------------------------
    C**
          IVEM(30)=LOUT
          IVEM(31)=1
          IVEM(33)=6

          CALL VEMU03 (T,LSTRES,ESTRES,LU,U,
         &             LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,LNODN,
         &             NODNUM,LNOD,NOD,LNOPRM,NOPARM,
         &             LBIG,RBIG,IBIG,STRESS)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the displacements are written to the I-DEAS result file :
    C**   -------------------------------------------------------
    C**
          IVEM(120)=LOUT
          IVEM(121)=1
          IVEM(127)=99
          IVEM(128)=NN
          IVEM(129)=2
          IVEM(130)=1
          IVEM(131)=2
          IVEM(132)=8
          IVEM(137)=1
          IVEM(138)=-1
          TEXT1='displacements'
          TEXT2='veme00exm09'

          OPEN(99,FILE='disp.unv',STATUS= 'UNKNOWN',FORM='FORMATTED')
          CALL VEID97 (TEXT1,TEXT2,T,LDISP,GDISP,
         &             LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,LNODN,
         &             NODNUM,LNOD,NOD,LNOPRM,NOPARM,
         &             LBIG,RBIG,IBIG)
          CLOSE(99)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the stresses are written to the I-DEAS element result file :
    C**   ----------------------------------------------------------
    C**
          IVEM(120)=LOUT
          IVEM(121)=1
          IVEM(133)=99
          IVEM(134)=1
          IVEM(135)=4
          IVEM(136)=2
          IVEM(137)=2
          IVEM(138)=-1
          TEXT1='stresses'
          TEXT2='veme00exm09'

          OPEN(99,FILE='stress.unv',STATUS= 'UNKNOWN',FORM='FORMATTED')
          CALL VEID99 (TEXT1,TEXT2,T,LSTRES,ESTRES,
         &             LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,LNODN,
         &             NODNUM,LNOD,NOD,LNOPRM,NOPARM,
         &             LBIG,RBIG,IBIG)
          CLOSE(99)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the mesh arrays written to the I-DEAS universal file :
    C**   ----------------------------------------------------
    C**
          IVEM(120)=LOUT
          IVEM(121)=1
          IVEM(124)=0
          IVEM(125)=99
          TEXT1='veme00exm09'

          OPEN(99,FILE='mesh.unv',STATUS= 'UNKNOWN',FORM='FORMATTED')
          CALL VEMIDE (TEXT1,
         &             LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
         &             LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,
         &             LNODN,NODNUM,LNOD,NOD,LNOPRM,NOPARM,
         &             LBIG,RBIG,IBIG)
          CLOSE(99)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
    9999  CALL COMEND(IVEM(200),INFO)
          E    N    D

          SUBROUTINE DISP(T,GROUP,LAST,NELIS,
         &                 NRSP,RSPARM,NRVP,RVP1,RVPARM,
         &                 NISP,ISPARM,NIVP,IVP1,IVPARM,
         &                 L,DIM,X,NK,U,DUDX,NOP,NOPARM,DNOPDX,N,CU)
          IMPLICIT NONE
    C**
    C*******************************************************************
    C**
    C**  The routine DISP copies the input solution to the output
    C**  CU. So the calling routine vemu05 interpolates the
    C**  displacements from the global nodes onto the geometrical
    C**  nodes, see userc, vemu05.
    C**
    C*******************************************************************
    C**
          INTEGER            GROUP,LAST,NELIS,L,DIM,NK,N,
         &                   NRSP,RVP1,NRVP,NISP,IVP1,NIVP,NOP

          DOUBLE PRECISION   T,X(L,DIM),U(L,NK),DUDX(L,NK,DIM),
         &                   RSPARM(NRSP),RVPARM(RVP1,NRVP),
         &                   NOPARM(L,NOP),DNOPDX(L,NOP,DIM),CU(L,N)

          INTEGER            ISPARM(NISP),IVPARM(IVP1,NIVP)
    C**
    C**-----------------------------------------------------------------
    C**
          INTEGER Z
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   --------------------
    C**
          DO 10 Z=1,NELIS
            CU(Z,1) = U(Z,1)
            CU(Z,2) = U(Z,2)
    10    CONTINUE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
          R E T U R N
    C**---end of DISP--------------------------------------------------
          E    N    D

          SUBROUTINE STRESS(T,GROUP,LAST,NELIS,
         &                  NRSP,RSPARM,NRVP,RVP1,RVPARM,
         &                  NISP,ISPARM,NIVP,IVP1,IVPARM,
         &                  L,DIM,X,NK,U,DUDX,NOP,NOPARM,DNOPDX,N,CU)
          IMPLICIT NONE
    C**
    C*******************************************************************
    C**
    C**  The routine STRESS evaluates the stress vector for the given
    C**  displacement. The succession in the output vector is
    C**  prescribed by I-DEAS, see userc, vemu03, veid99.
    C**
    C*******************************************************************
    C**
          INTEGER            GROUP,LAST,NELIS,L,DIM,NK,N,
         &                   NRSP,RVP1,NRVP,NISP,IVP1,NIVP,NOP

          DOUBLE PRECISION   T,X(L,DIM),U(L,NK),DUDX(L,NK,DIM),
         &                   RSPARM(NRSP),RVPARM(RVP1,NRVP),
         &                   NOPARM(L,NOP),DNOPDX(L,NOP,DIM),CU(L,N)

          INTEGER            ISPARM(NISP),IVPARM(IVP1,NIVP)
    C**
    C**-----------------------------------------------------------------
    C**
          INTEGER Z
          DOUBLE PRECISION  EPS1,EPS2,EPS12,E,NY,C11,C44,C12
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   --------------------
    C**

          DO 100 Z=1,NELIS
    	E =RVPARM(LAST+Z,1)
    	NY=RVPARM(LAST+Z,2)
            C11=E*(1-NY)/(1+NY)
            C44=E/2/(1+NY)
            C12=E*NY/(1+NY)/(1-NY)

            EPS1 =DUDX(Z,1,1)
            EPS2 =DUDX(Z,2,2)
            EPS12=DUDX(Z,1,2)+DUDX(Z,2,1)

            CU(Z,1)=C11*EPS1+C12*EPS2
            CU(Z,2)=C44*EPS12
            CU(Z,3)=0
            CU(Z,4)=C12*EPS1+C11*EPS2
            CU(Z,5)=0
            CU(Z,6)=0

    100   CONTINUE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
          R E T U R N
    C**---end of STRESS-------------------------------------------------
          E    N    D

          SUBROUTINE USERB(T,COMPU,RHS,
         &                 NRSDP,RSDPRM,NRVDP,RVDP1,RVDPRM,
         &                 NISDP,ISDPRM,NIVDP,IVDP1,IVDPRM,
         &                 NDC,DIM,X,NOP,NOPARM,B)
          IMPLICIT NONE
    C**
    C*******************************************************************
    C**
    C**  The routine USERB sets the Dirichlet boundary conditions,
    C**  see userb. For this application these conditions gives
    C**  the restrain conditions for the displacements, which are equal
    C**  to zero for both directions. Therefore therfore zeros are the
    C**  values of the output vector B for all components.
    C**
    C*******************************************************************
    C**
          INTEGER          COMPU,RHS,NRSDP,NRVDP,RVDP1,NISDP,NIVDP,IVDP1,
         &                 NDC,DIM,NOP

          DOUBLE PRECISION T,RSDPRM(NRSDP),RVDPRM(RVDP1,NRVDP),
         &                 X(NDC,DIM),NOPARM(NDC,NOP),B(NDC)

          INTEGER          ISDPRM(NISDP),IVDPRM(IVDP1,NIVDP)
    C**
    C**-----------------------------------------------------------------
    C**
          INTEGER Z
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   --------------------
    C**
          IF (COMPU.EQ.1) THEN
            DO 10 Z=1,NDC
              B(Z)=0
    10      CONTINUE
          ENDIF

          IF (COMPU.EQ.2) THEN
            DO 20 Z=1,NDC
              B(Z)=0
    20      CONTINUE
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
          R E T U R N
    C**---end of USERB--------------------------------------------------
          E    N    D

          SUBROUTINE USERL(T,GROUP,CLASS,COMPV,COMPU,LAST,
         &                 NELIS,L,DIM,X,TAU,NK,U,DUDX,
         &                 LT,UT,DUTDX,NOP,NOPARM,DNOPDX,
         &                 NRSP,RSPARM,NRVP,RVP1,RVPARM,
         &                 NISP,ISPARM,NIVP,IVP1,IVPARM,
         &                 L3,L2,L1,L0)
          IMPLICIT NONE
    C**
    C*******************************************************************
    C**
    C**  The routine USERL sets the coefficients of the bilinear form,
    C**  see userl. The values of the coefficients L3 (L2=L1=L0=0 !)
    C**  is read from the definition [1] of the bilinear form:
    C**
    C**   L(v,u)=area{ C11*v1x1*u1x1+C44*v1x2*u1x2+
    C**                C12*v1x1*u2x2+C44*v1x2*u2x1+
    C**                C12*v2x2*u1x1+C44*v2x1*u1x2+
    C**                C44*v2x1*u2x1+C11*v2x2*u2x2 }
    C**
    C*******************************************************************
    C**
          INTEGER          GROUP,CLASS,COMPV,COMPU,LAST,NELIS,L,LT,
         &                 DIM,NK,NOP,NRSP,RVP1,NRVP,NISP,IVP1,NIVP

          DOUBLE PRECISION T,X(L,DIM),TAU(L,DIM,CLASS),U(L,NK),UT(LT,NK),
         &                 DUDX(L,NK,CLASS),DUTDX(LT,NK,CLASS),
         &                 NOPARM(L,NOP),DNOPDX(L,NOP,CLASS),
         &                 RSPARM(NRSP),RVPARM(RVP1,NRVP),
         &                 L3(L,CLASS,CLASS),L2(L,CLASS),L1(L,CLASS),L0(L)

          INTEGER          ISPARM(NISP),IVPARM(IVP1,NIVP)
    C**
    C**-----------------------------------------------------------------
    C**
          INTEGER Z
          DOUBLE PRECISION E,NY,C11,C44,C12
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   ---------------------
    C**
          IF (CLASS.EQ.2) THEN

            IF ((COMPV.EQ.1).AND.(COMPU.EQ.1)) THEN
              DO 10 Z=1,NELIS
    	    E =RVPARM(LAST+Z,1)
    	    NY=RVPARM(LAST+Z,2)
                C11=E*(1-NY)/(1+NY)
                C44=E/2/(1+NY)

                L3(Z,1,1)=C11
                L3(Z,2,2)=C44
    10        CONTINUE
            ENDIF

            IF ((COMPV.EQ.2).AND.(COMPU.EQ.2)) THEN
              DO 20 Z=1,NELIS
      	    E =RVPARM(LAST+Z,1)
    	    NY=RVPARM(LAST+Z,2)
                C11=E*(1-NY)/(1+NY)
                C44=E/2/(1+NY)

                L3(Z,1,1)=C44
                L3(Z,2,2)=C11
    20        CONTINUE
            ENDIF

            IF  (((COMPV.EQ.1) .AND. (COMPU.EQ.2)) .OR.
         &       ((COMPV.EQ.2) .AND. (COMPU.EQ.1))) THEN
              DO 40 Z=1,NELIS
      	    E =RVPARM(LAST+Z,1)
    	    NY=RVPARM(LAST+Z,2)
                C44=E/2/(1+NY)
                C12=E*NY/(1+NY)/(1-NY)
                L3(Z,COMPV,COMPU)=C12
                L3(Z,COMPU,COMPV)=C44
    40        CONTINUE
            ENDIF

          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
          R E T U R N
    C**---end of USERL--------------------------------------------------
          E    N    D

          SUBROUTINE USERF (T,GROUP,CLASS,COMPV,RHS,LAST,
         &                  NELIS,L,DIM,X,TAU,NK,U,DUDX,
         &                  LT,UT,DUTDX,NOP,NOPARM,DNOPDX,
         &                  NRSP,RSPARM,NRVP,RVP1,RVPARM,
         &                  NISP,ISPARM,NIVP,IVP1,IVPARM,
         &                  F1,F0)
          IMPLICIT NONE
    C**
    C*******************************************************************
    C**
    C**  The routine USERF sets the coefficients of the linear form,
    C**  see userf. The values of the coefficients F0 (F1=0 !) is
    C**  read from the definition [1] of the linear form:
    C**
    C**   F(v)=line{ - v2 }.
    C**
    C**  Therefore the output vector F0 for the second component of
    C**  the test function is equal to -1.
    C**
    C*******************************************************************
    C**
          INTEGER          GROUP,CLASS,COMPV,RHS,LAST,NELIS,L,LT,DIM,NK,NOP,
         &                 NRSP,RVP1,NRVP,NISP,IVP1,NIVP

          DOUBLE PRECISION T,X(L,DIM),TAU(L,DIM,CLASS),U(L,NK),UT(LT,NK),
         &                 DUDX(L,NK,CLASS),DUTDX(LT,NK,CLASS),
         &                 NOPARM(L,NOP),DNOPDX(L,NOP,CLASS),
         &                 RSPARM(NRSP),RVPARM(RVP1,NRVP),
         &                 F1(L,CLASS),F0(L)

          INTEGER          ISPARM(NISP),IVPARM(IVP1,NIVP)
    C**
    C**-----------------------------------------------------------------
    C**
          INTEGER          Z
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   --------------------
    C**
          IF (CLASS.EQ.1) THEN
    	IF (COMPV.EQ.2) THEN
              DO 10 Z=1,NELIS
                F0(Z)=-1.
    10        CONTINUE
    	ENDIF
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
          R E T U R N
    C**---end of USERF--------------------------------------------------
          E    N    D