VECFEM3 Reference Manual: veme00exm08.html

    C****************************************************************
    C**
    C**    v e m e 0 0 e x m 0 8 :
    C**
    C**  The linearized Navier-Stokes equations on 3-dimensional domain.
    C**  The mesh is generated distributed on the processors.
    C**
    C**   by L. Grosz                             Canberra, Nov. 1997
    C**
    C****************************************************************
    C**
    C**  The problem is a system of four partial differential
    C**  equations four the three velocity components u1,u2 and u3 and
    C**  the pressure u4 which is the linearization of the Navier-Stokes
    C**  equations at velocity (w1,w2,w3).
    C**  The domain is the 3-dimensional unit cube [0,1]^3.
    C**  Using the notations in equation the problem is given by
    C**  the functional equation:
    C**
    C**    Dirichlet conditions:
    C**      u1=b1 at x1=0 and x1=1
    C**      u2=b2 at x2=0 and x2=1
    C**      u3=b3 at x3=0 and x3=1
    C**      u4=b4 at (x1,x2,x3)=(1/2,1/2,1/2)
    C**
    C**   linear functional equation: L(v,u)=F(v)
    C**
    C**    with L(v,u)=
    C**    volume{v1x1*(u1x1+u4)+v1x2*u1x2+v1x3*u1x3+
    C**           Re*v1*(w1*u1x1+w2*u1x2+w3*u1x3+u1*w1x1+u2*w1x2+u3*w1x3)
    C**       +   v2x1*u2x1+v2x2*(u2x2+u4)+v2x3*u2x3+
    C**           Re*v2*(w1*u2x1+w2*u2x2+w3*u2x3+u1*w2x1+u2*w2x2+u3*w2x3)
    C**       +   v3x1*u3x1+v3x2*u3x2+v3x3*(u3x3+u4)+
    C**           Re*v3*(w1*u3x1+w2*u3x2+w3*u3x3+u1*w3x1+u2*w3x2+u3*w3x3)
    C**       +   v4*(u1x1+u2x2+u3x3)}
    C**
    C**    with F(v)=volume{v1*f1+v2*f2+v3*f3}+area{v1*g1+v2*g2+v3*g3}
    C**
    C**  The functions b, f and g are selected so that
    C**
    C**       u1=x1*(x3-x2) =w1
    C**       u2=x2*(x1-x3) =w2
    C**       u3=x3*(x2-x1) =w3
    C**       u4=(x1+x2+x3)/3
    C**
    C**  is the exact solution of this problem. The real value Re
    C**  controls numerical behaviour of the problem. For increasing
    C**  values of Re the problem will get ill-posed and you have to
    C**  expect that the calculation fails.
    C**
    C**  The mesh of ELEM1 X ELEM2 X ELEM3 elements is generated distributed
    C**  on the processors. The mixed FEM method with order two elements
    C**  for the velocity components (u1,u2,u3) and order one elements for
    C**  the pressure component u4 are used.
    C**
    C**-----------------------------------------------------------------
    C**
          PROGRAM VEMEXM
    C**
    C**-----------------------------------------------------------------
    C**
          IMPLICIT NONE
          include 'bytes.h'
    C**
    C**    some parameters which may be chanced:
    C**
    C**    NPROC = number of processors
    C**    ELEM1 = number of elements in x1 direction,
    C**            in x2 direction also ELEM1 elements will be
    C**            generated, but only about ELEM1/NPROC on this
    C**            process.
    C**    ELEM2    = number of elements in x2 direction on process
    C**    ELEM3    = number of elements in x3 direction on process
    C**    STORE = total storage of process in Mbytes.
    C**
          INTEGER       NPROC,ELEM1,ELEM2,ELEM3
          REAL          STORE

          PARAMETER (NPROC=1,
         &           STORE=15,
         &           ELEM1=5,
         &           ELEM2=5,
         &           ELEM3=5)
    C**
    C**-----------------------------------------------------------------
    C**
    C**    N1,N2,N3 = number of nodes in x1,x2,x3-direction on the
    C**               process
    C**    E3DIM    = maximal number of elements in x3-direction generated
    C**               on a processor
    C**    N3DIM    = maximal number of nodes in x3-direction generated
    C**               on a processor
    C**
    C**    other parameters are explained in mesh.
    C**
          INTEGER       NK,DIM,N1,N2,N3DIM,E3DIM,LOUT,NGROUP,N3

          PARAMETER (N1=2*ELEM1+1,
         &           N2=2*ELEM2+1,
         &           N3=2*ELEM3+1,
         &           E3DIM=(ELEM3/NPROC)+1,
         &           N3DIM=2*E3DIM+1,

         &           NK=4,
         &           NGROUP=2,
         &           DIM=3,
         &           LOUT=6)
    C**
    C**-----------------------------------------------------------------
    C**
    C**   the length of the array for the mesh are set:
    C**   they are a little bit greater than actual used in the
    C**   mesh generation. this is necessary for the mesh distribution.
    C**
          INTEGER       NN,LU,LNODN,LNOD,LNOPRM,LNEK,LRPARM,LIPARM,
         &              LDNOD,LIDPRM,LRDPRM,LIVEM,LRVEM,LLVEM,LBIG

          PARAMETER  (NN=N1*N2*N3DIM*1.5,
         &            LU    =NN*NK,
         &            LNODN =NN,
         &            LNOD  =NN*DIM,
         &            LNOPRM=1,

         &            LNEK=(2*NK*20*(ELEM1*ELEM2*E3DIM)+
         &              2*NK*8*2*(ELEM1*ELEM2+E3DIM*ELEM1+E3DIM*ELEM2)),
         &            LIPARM=(ELEM1*ELEM2*E3DIM+
         &              2*(ELEM1*ELEM2+E3DIM*ELEM1+E3DIM*ELEM2)),
         &            LRPARM=1,

         &            LDNOD =2*NK*2*(N3DIM*N2+N3DIM*N1+N2*N1),
         &            LIDPRM=1,
         &            LRDPRM=1,

         &            LIVEM =800+LU+LDNOD/2,
         &            LLVEM =500,
         &            LRVEM =60+2*LU)
    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
         &               - (2*LU+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),
         &                 ERRG(LU),NRMERR(NK)

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

          LOGICAL          MASKL(NK,NK,2),MASKF(NK,2),LVEM(LLVEM)
    C
          INTEGER          MYPROC,INFO,OUTFLG,GINFO,GINFO1,ELEM3L,ELEM30,
         &                 N30,N3L,MESH,DINFO,DINFO1,NDNUM0,ELNUM0,
         &                 Z3,Z2,Z1,ADGEO1,ADIVP1,NE1,S,HERE,ELMID,
         &                 ADGEO2,ADIVP2,NE2,NE0,ADDC,NDC,DEF
          CHARACTER*80     NAME
          DOUBLE PRECISION RE, X30
    C
          EXTERNAL VEM630,VEM500
          EXTERNAL DUMMY,USERL,USERF,USERC,USERB,USERU0
    C**
    C**-----------------------------------------------------------------
    C**
    C**  The equivalence of RBIG and IBIG is very important :
    C**
          EQUIVALENCE (RBIG,IBIG)
    C**
    C**-----------------------------------------------------------------
    C**
    C**   The common block PROP transports the real value RE to the
    C**   subroutines:
    C**
          COMMON/PROP/RE
          RE=10.0
    C**
    C**-----------------------------------------------------------------
    C**
    C**   get task ids :
    C**
          NAME='a.out'
          IVEM(200)=NPROC
          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.NPROC) then
    	IF (MYPROC.EQ.0) then
    	  PRINT*,'Number of processors does not fit !'
    	ENDIF
    	GOTO 9999
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**   a protocol is printed only on process 1 :
    C**
          IF (MYPROC.EQ.1) THEN
            OUTFLG=1
          ELSE
            OUTFLG=0
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**   ELEM3L is the number of elements in x3-direction
    C**   generated on this processor. ELEM30/N30 is the first element/node
    C**   that is generated on this processor.
    C**
          ELEM3L=ELEM3/NPROC
          DEF=ELEM3-ELEM3L*NPROC
          IF (MYPROC.LE.DEF) THEN
            ELEM3L=ELEM3L+1
            ELEM30=ELEM3L*(MYPROC-1)
          ELSE
            ELEM30=DEF*(ELEM3L+1)+ELEM3L*(MYPROC-DEF-1)
          ENDIF
          N30=2*ELEM30+1
          N3L=2*ELEM3L+1
    C**
    C**-----------------------------------------------------------------
    C**
    C**   This process generates the nodes in the subdomain
    C**   [0,1] x [0,1] x [ X30,X30+1/NPROC] starting with the node id
    C**   number NDNUM0. The nodes with x3=X30 are also generated on
    C**   process MYPROC-1 and the nodes with x3=X30+1/NPROC are also
    C**   generated on process MYPROC+1. The first element generated
    C**   on the process gets the element id number ELNUM0.
    C**
          X30=DBLE(N30-1)/DBLE(N3-1)
          NDNUM0=N1*N2*(N30-1)+1
          ELNUM0=ELEM1*ELEM2*ELEM30+
         &         2*(ELEM1*ELEM2+ELEM30*ELEM2+ELEM1*ELEM30)+1
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the parameters are copied into IVEM :
    C**   -----------------------------------
    C**
          MESH  =210+NPROC
          GINFO =30
          GINFO1=23+2*NK
          DINFO =GINFO+GINFO1*NGROUP
          DINFO1=17
          IVEM(1)=MESH
          IVEM(MESH+ 1)=N1*N2*N3L
          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**
    C**   the grid is regular with N1 points in x1- and N2 points in
    C**   x2 direction.
    C**
          DO 10 Z3=1,N3L
           DO 10 Z2=1,N2
            DO 10 Z1=1,N1
              NOD(Z1+N1*(Z2-1)+N1*N2*(Z3-1)     )=DBLE(Z1-1)/DBLE(N1-1)
              NOD(Z1+N1*(Z2-1)+N1*N2*(Z3-1)+  NN)=DBLE(Z2-1)/DBLE(N2-1)
              NOD(Z1+N1*(Z2-1)+N1*N2*(Z3-1)+2*NN)=
         &                DBLE(Z3-1)/DBLE(N3-1)+X30
              NODNUM(Z1+N1*(Z2-1)+N1*N2*(Z3-1))=Z1+N1*(Z2-1)+N1*N2*(Z3-1)
         &                                                       +NDNUM0-1
     10   CONTINUE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** the generation of the elements :
    C**   -------------------------------
    C**
    C**   The domain is covered by hexahedron elements of order 2
    C**   and consequently the boundaries are described by
    C**   quadrilateral elements of order 2. The succession of the
    C**   nodes in the element is defined in vemu02 and vembuild(3).
    C**   The lowest node id in an element is S.
    C**
    C**   ADGEO1 defines the start address of the hexahedrons
    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 over all processes. NE1 is the number of
    C**   hexahedrons elements generated on the process. HERE gives
    C**   the address of the element in NEK, which lowest vertex has
    C**   the node id S over all processes.
    C**
          ADGEO1=1
          ADIVP1=1
          NE1=ELEM1*ELEM2*ELEM3L

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

              S=2*(Z1-1)+2*(Z2-1)*N1+2*N1*N2*(Z3-1)+NDNUM0
              HERE=Z1+ELEM1*(Z2-1)+ELEM1*ELEM2*(Z3-1)+ADGEO1-1
              ELMID=Z1+ELEM1*(Z2-1)+ELEM1*ELEM2*(Z3-1)+ELNUM0

              IPARM(ADIVP1-1+Z1+ELEM1*(Z2-1)+ELEM1*ELEM2*(Z3-1))=ELMID

              NEK(HERE       )=S
              NEK(HERE+   NE1)=S+2
              NEK(HERE+ 2*NE1)=S+2*N1+2
              NEK(HERE+ 3*NE1)=S+2*N1
              NEK(HERE+ 4*NE1)=S+2*N1*N2
              NEK(HERE+ 5*NE1)=S+2*N1*N2+2
              NEK(HERE+ 6*NE1)=S+2*N1*N2+2*N1+2
              NEK(HERE+ 7*NE1)=S+2*N1*N2+2*N1
              NEK(HERE+ 8*NE1)=S+1
              NEK(HERE+ 9*NE1)=S+N1+2
              NEK(HERE+10*NE1)=S+2*N1+1
              NEK(HERE+11*NE1)=S+N1
              NEK(HERE+12*NE1)=S+N1*N2
              NEK(HERE+13*NE1)=S+N1*N2+2
              NEK(HERE+14*NE1)=S+N1*N2+2*N1+2
              NEK(HERE+15*NE1)=S+N1*N2+2*N1
              NEK(HERE+16*NE1)=S+2*N1*N2+1
              NEK(HERE+17*NE1)=S+2*N1*N2+N1+2
              NEK(HERE+18*NE1)=S+2*N1*N2+2*N1+1
              NEK(HERE+19*NE1)=S+2*N1*N2+N1

     20   CONTINUE
    C**
    C**   ADGEO2 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**   20*NE1 in NEK and 1 to NE1 in IPARM are already used by
    C**   the elements in group 1. NE2 is the number of
    C**   quadrilateral elements generated on the process, where the
    C**   elements on boundary B1/B6 are only generated on process 1
    C**   or NPROC. HERE gives the address of the element in NEK, which
    C**   is a boundary element of the hexahedrons element with lowest
    C**   node id S.
    C**
          ADGEO2=ADGEO1+20*NE1
          ADIVP2=ADIVP1+NE1
          NE2=2*(ELEM1+ELEM2)*ELEM3L
          IF (MYPROC.EQ.1) NE2=NE2+ELEM1*ELEM2
          IF (MYPROC.EQ.NPROC) NE2=NE2+ELEM1*ELEM2
          NE0=0
    C**
    C**   these are the quadrilateral elements on boundary 1 (x3=0):
    C**   only on process 1. NE0 counts the already generated line
    C**   elements
    C**
    C****  elements on boundary 1 (x3=0): (only on process 1)
    C**
          IF (MYPROC.EQ.1) THEN
            DO 31 Z2=1,ELEM2
              DO 31 Z1=1,ELEM1

                HERE=Z1+ELEM1*(Z2-1)+NE0+ADGEO2-1
                ELMID=Z1+ELEM1*(Z2-1)+ELEM1*ELEM2*ELEM3L+NE0+ELNUM0
                S=2*(Z1-1)+2*(Z2-1)*N1+NDNUM0

                IPARM(ADIVP2-1+NE0+Z1+ELEM1*(Z2-1))=ELMID

                NEK(HERE      )= S
                NEK(HERE+  NE2)= S+2*N1
                NEK(HERE+2*NE2)= S+2*N1+2
                NEK(HERE+3*NE2)= S+2
                NEK(HERE+4*NE2)= S+N1
                NEK(HERE+5*NE2)= S+2*N1+1
                NEK(HERE+6*NE2)= S+N1+2
                NEK(HERE+7*NE2)= S+1

     31     CONTINUE
            NE0=NE0+ELEM1*ELEM2
          ENDIF
    C**
    C****  elements on boundary 6 (x3=2): (only on process NPROC)
    C**
          IF (MYPROC.EQ.NPROC) THEN
            DO 32 Z2=1,ELEM2
              DO 32 Z1=1,ELEM1

                HERE=Z1+ELEM1*(Z2-1)+NE0+ADGEO2-1
                ELMID=Z1+ELEM1*(Z2-1)+ELEM1*ELEM2*ELEM3L+NE0+ELNUM0
                S=2*(Z1-1)+2*(Z2-1)*N1+2*N1*N2*ELEM3L+NDNUM0

                IPARM(ADIVP2-1+NE0+Z1+ELEM1*(Z2-1))=ELMID

                NEK(HERE      )= S
                NEK(HERE+  NE2)= S+2
                NEK(HERE+2*NE2)= S+2*N1+2
                NEK(HERE+3*NE2)= S+2*N1
                NEK(HERE+4*NE2)= S+1
                NEK(HERE+5*NE2)= S+N1+2
                NEK(HERE+6*NE2)= S+2*N1+1
                NEK(HERE+7*NE2)= S+N1

     32     CONTINUE
            NE0=NE0+ELEM1*ELEM2
          ENDIF
    C**
    C****  elements on boundary 5 (x1=0):
    C**
          DO 33 Z3=1,ELEM3L
            DO 33 Z2=1,ELEM2

              HERE=Z2+ELEM2*(Z3-1)+NE0+ADGEO2-1
              ELMID=Z2+ELEM2*(Z3-1)+ELEM1*ELEM2*ELEM3L+NE0+ELNUM0
              S=2*(Z2-1)*N1+2*N1*N2*(Z3-1)+NDNUM0

              IPARM(ADIVP2-1+NE0+Z2+ELEM2*(Z3-1))=ELMID

              NEK(HERE      )= S
              NEK(HERE+  NE2)= S+2*N1*N2
              NEK(HERE+2*NE2)= S+2*N1*N2+2*N1
              NEK(HERE+3*NE2)= S+2*N1
              NEK(HERE+4*NE2)= S+N1*N2
              NEK(HERE+5*NE2)= S+2*N1*N2+N1
              NEK(HERE+6*NE2)= S+N1*N2+2*N1
              NEK(HERE+7*NE2)= S+N1

     33   CONTINUE
          NE0=NE0+ELEM3L*ELEM2
    C**
    C****  elements on boundary 3 (x1=1):
    C**
          DO 34 Z3=1,ELEM3L
            DO 34 Z2=1,ELEM2

              HERE=Z2+ELEM2*(Z3-1)+NE0+ADGEO2-1
              ELMID=Z2+ELEM2*(Z3-1)+ELEM1*ELEM2*ELEM3L+NE0+ELNUM0
              S=2*ELEM1+2*(Z2-1)*N1+2*N1*N2*(Z3-1)+NDNUM0

              IPARM(ADIVP2-1+NE0+Z2+ELEM2*(Z3-1))=ELMID

              NEK(HERE      )= S
              NEK(HERE+  NE2)= S+2*N1
              NEK(HERE+2*NE2)= S+2*N1*N2+2*N1
              NEK(HERE+3*NE2)= S+2*N1*N2
              NEK(HERE+4*NE2)= S+N1
              NEK(HERE+5*NE2)= S+N1*N2+2*N1
              NEK(HERE+6*NE2)= S+2*N1*N2+N1
              NEK(HERE+7*NE2)= S+N1*N2

     34   CONTINUE
          NE0=NE0+ELEM3L*ELEM2
    C**
    C****  elements on boundary 2 (x2=0):
    C**
          DO 35 Z3=1,ELEM3L
            DO 35 Z1=1,ELEM1
              HERE=Z1+ELEM1*(Z3-1)+NE0+ADGEO2-1
              ELMID=Z3+ELEM3L*(Z1-1)+ELEM1*ELEM2*ELEM3L+NE0+ELNUM0
              S=2*(Z1-1)+2*N1*N2*(Z3-1)+NDNUM0

              IPARM(ADIVP2-1+NE0+Z1+ELEM1*(Z3-1))=ELMID

              NEK(HERE      )= S
              NEK(HERE+  NE2)= S+2
              NEK(HERE+2*NE2)= S+2*N2*N1+2
              NEK(HERE+3*NE2)= S+2*N1*N2
              NEK(HERE+4*NE2)= S+1
              NEK(HERE+5*NE2)= S+N1*N2+2
              NEK(HERE+6*NE2)= S+2*N2*N1+1
              NEK(HERE+7*NE2)= S+N1*N2

     35   CONTINUE
          NE0=NE0+ELEM3L*ELEM1
    C**
    C****  elements on boundary 4 (x2=1):
    C**
          DO 36 Z3=1,ELEM3L
            DO 36 Z1=1,ELEM1
              HERE=Z1+ELEM1*(Z3-1)+NE0+ADGEO2-1
              ELMID=Z3+ELEM3L*(Z1-1)+ELEM1*ELEM2*ELEM3L+NE0+ELNUM0
              S=2*(Z1-1)+2*ELEM2*N1+2*N1*N2*(Z3-1)+NDNUM0

              IPARM(ADIVP2-1+NE0+Z1+ELEM1*(Z3-1))=ELMID

              NEK(HERE      )= S
              NEK(HERE+  NE2)= S+2*N1*N2
              NEK(HERE+2*NE2)= S+2*N1*N2+2
              NEK(HERE+3*NE2)= S+2
              NEK(HERE+4*NE2)= S+N1*N2
              NEK(HERE+5*NE2)= S+2*N2*N1+1
              NEK(HERE+6*NE2)= S+N1*N2+2
              NEK(HERE+7*NE2)= S+1

     36   CONTINUE
    C**
    C**
    C**-----------------------------------------------------------------
    C**
    C**   the start addresses, etc are written to IVEM:
    C**
    C**   group 1: hexahedrons elements
    C**
          IVEM(MESH+GINFO   ) = NE1
          IVEM(MESH+GINFO+ 2) = 8
          IVEM(MESH+GINFO+ 3) = 3
          IVEM(MESH+GINFO+ 8) = 0
          IVEM(MESH+GINFO+11) = 0
          IVEM(MESH+GINFO+13) = 0
          IVEM(MESH+GINFO+14) = ADIVP1
          IVEM(MESH+GINFO+15) = NE1
          IVEM(MESH+GINFO+16) = 1
          IVEM(MESH+GINFO+20) = ADGEO1
          IVEM(MESH+GINFO+21) = NE1
          IVEM(MESH+GINFO+23) = 20
    C**
    C**   group 2: quadrilateral elements
    C**
          IVEM(MESH+GINFO+GINFO1   ) = NE2
          IVEM(MESH+GINFO+GINFO1+ 2) = 4
          IVEM(MESH+GINFO+GINFO1+ 3) = 2
          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) = ADGEO2
          IVEM(MESH+GINFO+GINFO1+21) = NE2
          IVEM(MESH+GINFO+GINFO1+23) = 8
    C**
    C**-----------------------------------------------------------------
    C**
    C**   generation of the nodes with Dirichlet conditions :
    C**   -------------------------------------------------
    C**
    C**   The node with node id number 1 gets a Dirichlet condition:
    C**   (only on processor 1)
    C**
          ADDC=0
    C**
    C**   component 1:
    C**
          NDC=0
          DO 41 Z3=1,N3L
            DO 41 Z2=1,N2
              NDC=NDC+1
              DNOD(ADDC+NDC)=1+N1*(Z2-1)+N1*N2*(NDNUM0-1+Z3-1)
              NDC=NDC+1
              DNOD(ADDC+NDC)=N1+N1*(Z2-1)+N1*N2*(NDNUM0-1+Z3-1)
     41   CONTINUE

          IVEM(MESH+DINFO   ) = NDC
          IVEM(MESH+DINFO+ 2) = ADDC+1
          IVEM(MESH+DINFO+ 4) = 0
          IVEM(MESH+DINFO+ 7) = 0
          IVEM(MESH+DINFO+ 9) = 0
          IVEM(MESH+DINFO+12) = 0
          ADDC=ADDC+NDC
    C**
    C**   component 2:
    C**
          NDC=0
          DO 42 Z3=1,N3L
            DO 42 Z1=1,N1
              NDC=NDC+1
              DNOD(ADDC+NDC)=Z1+N1*N2*(NDNUM0-1+Z3-1)
              NDC=NDC+1
              DNOD(ADDC+NDC)=Z1+N1*(N2-1)+N1*N2*(NDNUM0-1+Z3-1)
     42   CONTINUE

          IVEM(MESH+DINFO+DINFO1   ) = NDC
          IVEM(MESH+DINFO+DINFO1+ 2) = ADDC+1
          IVEM(MESH+DINFO+DINFO1+ 4) = 0
          IVEM(MESH+DINFO+DINFO1+ 7) = 0
          IVEM(MESH+DINFO+DINFO1+ 9) = 0
          IVEM(MESH+DINFO+DINFO1+12) = 0
          ADDC=ADDC+NDC
    C**
    C**   component 3:
    C**
          NDC=0
          IF (MYPROC.EQ.1) THEN
            DO 43 Z1=1,N1
              DO 43 Z2=1,N2
                NDC=NDC+1
                DNOD(ADDC+NDC)=Z1+N1*(Z2-1)
     43     CONTINUE
          ENDIF
          IF (MYPROC.EQ.NPROC) THEN
            DO 44 Z1=1,N1
             DO 44 Z2=1,N2
               NDC=NDC+1
               DNOD(ADDC+NDC)=Z1+N1*(Z2-1)+N1*N2*(N3-1)
     44     CONTINUE
          ENDIF
          IVEM(MESH+DINFO+2*DINFO1   ) = NDC
          IVEM(MESH+DINFO+2*DINFO1+ 2) = ADDC+1
          IVEM(MESH+DINFO+2*DINFO1+ 4) = 0
          IVEM(MESH+DINFO+2*DINFO1+ 7) = 0
          IVEM(MESH+DINFO+2*DINFO1+ 9) = 0
          IVEM(MESH+DINFO+2*DINFO1+12) = 0
          ADDC=ADDC+NDC
    C**
    C**
    C**   component 4:
    C**
          DNOD(ADDC+1)=N1*N2*(((ELEM3+1)/2)*2+1)
          IVEM(MESH+DINFO+3*DINFO1   ) = 1
          IVEM(MESH+DINFO+3*DINFO1+ 2) = ADDC+1
          IVEM(MESH+DINFO+3*DINFO1+ 4) = 0
          IVEM(MESH+DINFO+3*DINFO1+ 7) = 0
          IVEM(MESH+DINFO+3*DINFO1+ 9) = 0
          IVEM(MESH+DINFO+3*DINFO1+12) = 0
    C**
    C**-----------------------------------------------------------------
    C**
    C**** print mesh on processor 1
    C**   -------------------------
    C**
          IVEM(20)=LOUT
          IVEM(21)=0000*OUTFLG
          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**** generate mixed mesh :
    C**   -------------------
    C**
          PROPO(1,1)=2
          PROPO(2,1)=2
          PROPO(3,1)=2
          PROPO(4,1)=1
          PROPO(1,2)=2
          PROPO(2,2)=2
          PROPO(3,2)=2
          PROPO(4,2)=1
          IVEM(101)=LOUT
          IVEM(102)=OUTFLG

          CALL VEMGE2 (PROPO,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)=OUTFLG
          IVEM(51)=3

          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**** set the initial solution :
    C**   -------------------------
    C**
          IVEM(30)=LOUT
          IVEM(31)=OUTFLG*0

          CALL VEMU08(T,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, USERU0)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** set masks :
    C**   ---------
    C**
          MASKF(1,1)=.TRUE.
          MASKF(2,1)=.TRUE.
          MASKF(3,1)=.TRUE.
          MASKF(4,1)=.FALSE.

          MASKF(1,2)=.TRUE.
          MASKF(2,2)=.TRUE.
          MASKF(3,2)=.TRUE.
          MASKF(4,2)=.FALSE.

          MASKL(1,1,1)=.TRUE.
          MASKL(1,2,1)=.TRUE.
          MASKL(1,3,1)=.TRUE.
          MASKL(1,4,1)=.TRUE.

          MASKL(2,1,1)=.TRUE.
          MASKL(2,2,1)=.TRUE.
          MASKL(2,3,1)=.TRUE.
          MASKL(2,4,1)=.TRUE.

          MASKL(3,1,1)=.TRUE.
          MASKL(3,2,1)=.TRUE.
          MASKL(3,3,1)=.TRUE.
          MASKL(3,4,1)=.TRUE.

          MASKL(4,1,1)=.TRUE.
          MASKL(4,2,1)=.TRUE.
          MASKL(4,3,1)=.TRUE.
          MASKL(4,4,1)=.FALSE.

          MASKL(1,1,2)=.FALSE.
          MASKL(1,2,2)=.FALSE.
          MASKL(1,3,2)=.FALSE.
          MASKL(1,4,2)=.FALSE.

          MASKL(2,1,2)=.FALSE.
          MASKL(2,2,2)=.FALSE.
          MASKL(2,3,2)=.FALSE.
          MASKL(2,4,2)=.FALSE.

          MASKL(3,1,2)=.FALSE.
          MASKL(3,2,2)=.FALSE.
          MASKL(3,3,2)=.FALSE.
          MASKL(3,4,2)=.FALSE.

          MASKL(4,1,2)=.FALSE.
          MASKL(4,2,2)=.FALSE.
          MASKL(4,3,2)=.FALSE.
          MASKL(4,4,2)=.FALSE.
    C**
    C**-----------------------------------------------------------------
    C**
    C**** call of VECFEM :
    C**   --------------
    C**
          OPEN(10,FORM='UNFORMATTED',STATUS='SCRATCH')
          OPEN(11,FORM='UNFORMATTED',STATUS='SCRATCH')

          LVEM(1)=.FALSE.
          LVEM(5)=.FALSE.
          LVEM(9)=.TRUE.

          RVEM(3)=1.D-10

          IVEM(3)=0
          IVEM(10)=10
          IVEM(11)=11
          IVEM(40)=LOUT
          IVEM(41)=50*OUTFLG
          IVEM(45)=500
          IVEM(46)=0
          IVEM(52)=1
          IVEM(70)=10
          IVEM(71)=11
          IVEM(72)=10 000
          IVEM(73)=19

          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).GT.1) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** compute the error on the geometrical nodes :
    C**   ------------------------------------------
    C**
          IVEM(4)=30
          IVEM(30)=LOUT
          IVEM(31)=OUTFLG*0
          IVEM(32)=LNODN
          IVEM(33)=NK

          CALL VEMU05 (T,LU,ERRG,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,
         &             USERC)
          IF (IVEM(2).NE.0) GOTO 9999
    C**
    C**-----------------------------------------------------------------
    C**
    C**** print the error and its norm :
    C**   ----------------------------
    C**
          IVEM(23)=LOUT
          IVEM(24)=OUTFLG
          IVEM(25)=IVEM(32)
          IVEM(26)=IVEM(33)

          CALL VEMU13 (LU,ERRG,NRMERR,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**** end of calculation
    C**   ------------------
    C**
    9999  CALL COMEND(IVEM(200),INFO)
          E    N    D
          SUBROUTINE USERU0 (T,NE,L,DIM,X,NOP,NOPARM,COMPU,U0)
    C**
    C*******************************************************************
    C**
    C**   USERU0 sets the initial guess for veme02 or the initial
    C**          solution for vemp02.
    C**
    C*******************************************************************
    C**
          IMPLICIT DOUBLE PRECISION (S,T)
    C**
    C**-----------------------------------------------------------------
    C**
    C**      Formal Parameters : see man vemu08
    C**      -----------------
    C**
          INTEGER          NE,L,DIM,NOP,COMPU

          DOUBLE PRECISION T,X(L,DIM),NOPARM(L,NOP),U0(NE)
    C**
    C**-----------------------------------------------------------------
    C**
          INTEGER          Z
          Z=0
    C**
    C**-----------------------------------------------------------------
    C**
    C**** Start of Calculation :
    C**   --------------------
    C**
          IF (COMPU.EQ.1) THEN
            DO 10 Z=1,NE
              U0(Z) = X(Z,1)*(X(Z,3)-X(Z,2))
    10      CONTINUE
          ENDIF
          IF (COMPU.EQ.2) THEN
            DO 20 Z=1,NE
              U0(Z) = X(Z,2)*(X(Z,1)-X(Z,3))
    20      CONTINUE
          ENDIF
          IF (COMPU.EQ.3) THEN
            DO 30 Z=1,NE
              U0(Z) = X(Z,3)*(X(Z,2)-X(Z,1))
    30      CONTINUE
          ENDIF
          IF (COMPU.EQ.4) THEN
            DO 40 Z=1,NE
              U0(Z) = (X(Z,1)+X(Z,2)+X(Z,3))/3.D0
    40      CONTINUE
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**** End of Calculation :
    C**   ------------------
    C**
          R E T U R N
    C**---end of USERU0-------------------------------------------------
          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)
    C**
    C****************************************************************
    C**
    C**  The routine USERL sets the coefficients of the bilinear form,
    C**  see userl:
    C**
    C**   L(v,u)=volume{v1x1*(u1x1+u4)+v1x2*u1x2+v1x3*u1x3+
    C**             Re*v1*(w1*u1x1+w2*u1x2+w3*u1x3+u1*w1x1+u2*w1x2+u3*w1x3)
    C**         +   v2x1*u2x1+v2x2*(u2x2+u4)+v2x3*u2x3+
    C**             Re*v2*(w1*u2x1+w2*u2x2+w3*u2x3+u1*w2x1+u2*w2x2+u3*w2x3)
    C**         +   v3x1*u3x1+v3x2*u3x2+v3x3*(u3x3+u4)+
    C**             Re*v3*(w1*u3x1+w2*u3x2+w3*u3x3+u1*w3x1+u2*w3x2+u3*w3x3)
    C**         +   v4*(u1x1+u2x2+u3x3)}
    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 RE
          COMMON/PROP/RE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   ---------------------
    C**
          IF ((COMPV.EQ.1).AND.(COMPU.EQ.1).AND.(CLASS.EQ.3)) THEN
            DO 4 Z=1,NELIS
              L0(Z)=RE*(X(Z,3)-X(Z,2))
              L1(Z,1)=RE*X(Z,1)*(X(Z,3)-X(Z,2))
              L1(Z,2)=RE*X(Z,2)*(X(Z,1)-X(Z,3))
              L1(Z,3)=RE*X(Z,3)*(X(Z,2)-X(Z,1))
              L3(Z,1,1)=1.D0
              L3(Z,2,2)=1.D0
              L3(Z,3,3)=1.D0
     4      CONTINUE
          ENDIF

          IF ((COMPV.EQ.1).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
            DO 8 Z=1,NELIS
              L0(Z)=-RE*X(Z,1)
     8      CONTINUE
          ENDIF

          IF ((COMPV.EQ.1).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
            DO 12 Z=1,NELIS
              L0(Z)=RE*X(Z,1)
     12     CONTINUE
          ENDIF

          IF ((COMPV.EQ.1).AND.(COMPU.EQ.4).AND.(CLASS.EQ.3)) THEN
            DO 16 Z=1,NELIS
              L2(Z,1)=1.D0
     16     CONTINUE
          ENDIF

          IF ((COMPV.EQ.2).AND.(COMPU.EQ.1).AND.(CLASS.EQ.3)) THEN
            DO 20 Z=1,NELIS
              L0(Z)=RE*X(Z,2)
     20     CONTINUE
          ENDIF

          IF ((COMPV.EQ.2).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
            DO 24 Z=1,NELIS
              L0(Z)=RE*(X(Z,1)-X(Z,3))
              L1(Z,1)=RE*X(Z,1)*(X(Z,3)-X(Z,2))
              L1(Z,2)=RE*X(Z,2)*(X(Z,1)-X(Z,3))
              L1(Z,3)=RE*X(Z,3)*(X(Z,2)-X(Z,1))
              L3(Z,1,1)=1.D0
              L3(Z,2,2)=1.D0
              L3(Z,3,3)=1.D0
     24     CONTINUE
          ENDIF

          IF ((COMPV.EQ.2).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
            DO 28 Z=1,NELIS
              L0(Z)=-RE*X(Z,2)
     28     CONTINUE
          ENDIF

          IF ((COMPV.EQ.2).AND.(COMPU.EQ.4).AND.(CLASS.EQ.3)) THEN
            DO 32 Z=1,NELIS
              L2(Z,2)=1.D0
     32     CONTINUE
          ENDIF

          IF ((COMPV.EQ.3).AND.(COMPU.EQ.1).AND.(CLASS.EQ.3)) THEN
            DO 36 Z=1,NELIS
              L0(Z)=-RE*X(Z,3)
     36     CONTINUE
          ENDIF

          IF ((COMPV.EQ.3).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
            DO 40 Z=1,NELIS
              L0(Z)=RE*X(Z,3)
     40     CONTINUE
          ENDIF

          IF ((COMPV.EQ.3).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
            DO 44 Z=1,NELIS
              L0(Z)=RE*(X(Z,2)-X(Z,1))
              L1(Z,1)=RE*X(Z,1)*(X(Z,3)-X(Z,2))
              L1(Z,2)=RE*X(Z,2)*(X(Z,1)-X(Z,3))
              L1(Z,3)=RE*X(Z,3)*(X(Z,2)-X(Z,1))
              L3(Z,1,1)=1.D0
              L3(Z,2,2)=1.D0
              L3(Z,3,3)=1.D0
     44     CONTINUE
          ENDIF

          IF ((COMPV.EQ.3).AND.(COMPU.EQ.4).AND.(CLASS.EQ.3)) THEN
            DO 48 Z=1,NELIS
              L2(Z,3)=1.D0
     48     CONTINUE
          ENDIF

          IF ((COMPV.EQ.4).AND.(COMPU.EQ.1).AND.(CLASS.EQ.3)) THEN
            DO 52 Z=1,NELIS
              L1(Z,1)=1.D0
     52     CONTINUE
          ENDIF

          IF ((COMPV.EQ.4).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
            DO 56 Z=1,NELIS
              L1(Z,2)=1.D0
     56     CONTINUE
          ENDIF

          IF ((COMPV.EQ.4).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
            DO 60 Z=1,NELIS
              L1(Z,3)=1.D0
     60     CONTINUE
          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)
    C**
    C****************************************************************
    C**
    C**  the routine USERF sets the coefficients of the linear form F,
    C**  see userf:
    C**
    C**     F(v)=volume{v1*f1+v2*f2+v3*f3}+area{v1*g1+v2*g2+v3*g3}
    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
          DOUBLE PRECISION RE
          COMMON/PROP/RE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** start of calculation :
    C**   --------------------
    C**
    C**   the coefficients for the volume integration :
    C**
          IF (CLASS.EQ.3) THEN
            IF (COMPV.EQ.1) THEN
              DO 4 Z=1,NELIS
                F0(Z)=-1.D0/3.D0+2*RE*(X(Z,1)*(X(Z,3)**2+X(Z,2)**2)-
         &                     X(Z,1)**2*(X(Z,2)+X(Z,3)))
     4        CONTINUE
            ENDIF

            IF (COMPV.EQ.2) THEN
              DO 8 Z=1,NELIS
                F0(Z)=-1.D0/3.D0+2*RE*(X(Z,2)*(X(Z,1)**2+X(Z,3)**2)-
         &                     X(Z,2)**2*(X(Z,3)+X(Z,1)))
     8        CONTINUE
            ENDIF

            IF (COMPV.EQ.3) THEN
              DO 12 Z=1,NELIS
                F0(Z)=-1.D0/3.D0+2*RE*(X(Z,3)*(X(Z,1)**2+X(Z,2)**2)-
         &                    X(Z,3)**2*(X(Z,1)+X(Z,2)))
    12        CONTINUE
            ENDIF
          ENDIF
    C**
    C**-----------------------------------------------------------------
    C**
    C**   the coefficients for the area integration :
    C**
          IF (CLASS.EQ.2) THEN
            IF (COMPV.EQ.1) THEN
              DO 3 Z=1,NELIS
                IF (X(Z,2).LT.0.0001D0) F0(Z)= X(Z,1)
                IF (X(Z,2).GT.0.9999D0) F0(Z)=-X(Z,1)

                IF (X(Z,3).LT.0.0001D0) F0(Z)=-X(Z,1)
                IF (X(Z,3).GT.0.9999D0) F0(Z)= X(Z,1)
     3        CONTINUE
            ENDIF

            IF (COMPV.EQ.2) THEN
              DO 7 Z=1,NELIS
                IF (X(Z,1).LT.0.0001D0) F0(Z)=-X(Z,2)
                IF (X(Z,1).GT.0.9999D0) F0(Z)= X(Z,2)

                IF (X(Z,3).LT.0.0001D0) F0(Z)= X(Z,2)
                IF (X(Z,3).GT.0.9999D0) F0(Z)=-X(Z,2)
     7        CONTINUE
            ENDIF

            IF (COMPV.EQ.3) THEN
              DO 11 Z=1,NELIS
                IF (X(Z,1).LT.0.0001D0) F0(Z)= X(Z,3)
                IF (X(Z,1).GT.0.9999D0) F0(Z)=-X(Z,3)

                IF (X(Z,2).LT.0.0001D0) F0(Z)=-X(Z,3)
                IF (X(Z,2).GT.0.9999D0) F0(Z)= X(Z,3)
     11       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

          SUBROUTINE USERB(T,COMPU,RHS,
         &                 NRSDP,RSDPRM,NRVDP,RVDP1,RVDPRM,
         &                 NISDP,ISDPRM,NIVDP,IVDP1,IVDPRM,
         &                 NDC,DIM,X,NOP,NOPARM,B)
    C**
    C****************************************************************
    C**
    C**  the routine USERB sets the Dirichlet boundary conditions,
    C**  see userb. here the solution is set to zero, which is
    C**  the exact solution at the origin.
    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) = X(Z,1)*(X(Z,3)-X(Z,2))
    10      CONTINUE
          ENDIF
          IF (COMPU.EQ.2) THEN
            DO 20 Z=1,NDC
              B(Z) = X(Z,2)*(X(Z,1)-X(Z,3))
    20      CONTINUE
          ENDIF
          IF (COMPU.EQ.3) THEN
            DO 30 Z=1,NDC
              B(Z) = X(Z,3)*(X(Z,2)-X(Z,1))
    30      CONTINUE
          ENDIF
          IF (COMPU.EQ.4) THEN
            DO 40 Z=1,NDC
              B(Z) = (X(Z,1)+X(Z,2)+X(Z,3))/3.D0
    40      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 USERC(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)
    C**
    C****************************************************************
    C**
    C**  the routine USERC computes in this case the error of the
    C**  computed solution, see userc.
    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) = ABS( U(Z,1) - X(Z,1)*(X(Z,3)-X(Z,2)))
            CU(Z,2) = ABS( U(Z,2) - X(Z,2)*(X(Z,1)-X(Z,3)))
            CU(Z,3) = ABS( U(Z,3) - X(Z,3)*(X(Z,2)-X(Z,1)))
            CU(Z,4) = ABS( U(Z,4) - (X(Z,1)+X(Z,2)+X(Z,3))/3.D0)
    10    CONTINUE
    C**
    C**-----------------------------------------------------------------
    C**
    C**** end of calculation
    C**   ------------------
    C**
          R E T U R N
    C**---end of USERC--------------------------------------------------
          E    N    D