C*******************************************************************
C**
C** v e m p 0 2 e x m 0 1
C**
C** two coupled, time-dependent Poisson equation on the
C** 2-dimensional unit cube. For the solution the nonsteady
C** solver is used. The isoparametrical mesh is generated
C** distributed on the processors.
C**
C** by L. Grosz Karlsruhe, Sept. 1994
C**
C*******************************************************************
C**
C**
C** boundary 3
C** (0,1) (1,1)
C** - - *--------------* - - - - - - -
C** | | on process 3
C** - - |- - - - | - - - - - - -
C** boundary 4 | | boundary 2 on process 2
C** - - |- - - - | - - - - - - - -
C** | | on process 1
C** - - *--------------* - - - - - - -
C** x2 ^ (0,0) (1,0)
C** | boundary 1
C** --x1
C**
C** The problem is a system of two coupled, time dependent
C** Poisson equations, which is solved by the nonsteady solver
C** vemp02. The domain is the 2-dimensional [0,1] x [0,1]
C** unit cube. For the first solution component Neuman boundary
C** conditions on x2=1 and x2=0 (boundary 2 and boundary 4) and
C** Dirichlet conditions on x2=0 and x2=1 (boundary 1 and
C** boundary 3) are prescribed. For the second component Neuman
C** boundary conditions on x2=0 and x2=1 (boundary 1 and
C** boundary 4) and Dirichlet conditions on x2=1 and x2=0
C** (boundary 2 and boundary 4) are prescribed. Using the
C** notations in equation the problem is given by the
C** functional equation:
C**
C** Dirichlet conditions: for all 0<t<=5
C** u1=b1
C** u2=b2
C**
C** Initial solution: at t=0
C** u1=u01
C** u2=u02
C**
C** nonlinear functional Equation: F{t,ut,u}(v)=0 for 0<t<=5
C**
C** with F{t,ut,u}(v)=
C**
C** area{v1x1 * u1x1 + v1x2 * u1x2+(10.*u1+ u2 + ut1 + f1)*v1
C** + v2x1 * u2x1 + v2x2 * u2x2+( u1+10.*u2 + ut2 + f2)*v2}
C** + line{v1 * g1 + v2 * g2}
C**
C** The functions b1, b2, u01, u02, f1, f2, g1 and g2 are selected
C** so that u1=x2^2*x1*exp(t) and u2=x1*(1.-exp(-10*t)) is the
C** exact solution of this problem.
C**
C** The domain is subdivided into quadrilateral elements of
C** order 2. Therefore the boundary is subdivided into line
C** elements of order 2. The mesh is generated distributed onto
C** the processes. The error of the computed solution
C** approximation is calculated.
C**
PROGRAM VEMEXM
C**
C**-----------------------------------------------------------------
C**
IMPLICIT NONE
include 'bytes.h'
C**
C**-----------------------------------------------------------------
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** STORE = total storage of process in Mbytes.
C** LSYM = indicates the symmetry of the bilinear form.
C**
INTEGER NPROC,ELEM1,STORE
LOGICAL LSYM
PARAMETER (NPROC=1,
& ELEM1=16,
& STORE=5,
& LSYM=.TRUE.)
C**
C**-----------------------------------------------------------------
C**
C** ELEM2 = number of elements in x2 direction on process
C** N1,N2 = number of nodes in x1,x2-direction on the
C** process
C**
C** other parameters are explained in mesh.
C**
INTEGER N1,N2,NK,NGROUP,DIM,MESH,GINFO,GINFO1,DINFO,DINFO1,
& ELEM2,LOUT
PARAMETER (ELEM2=(ELEM1+NPROC-1)/NPROC,
& N1=2*ELEM1+1,
& N2=2*ELEM2+1,
& NK=2,
& NGROUP=2,
& DIM=2,
& MESH =210+NPROC,
& GINFO =30,
& GINFO1=23+2*NK,
& DINFO =GINFO+GINFO1*NGROUP,
& DINFO1=17,
& 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*1.5,
& LU =NN*NK,
& LNODN =NN,
& LNOD =NN*DIM,
& LNOPRM=1,
& LNEK=(8*(ELEM1*ELEM2+1)+6*(ELEM1+ELEM2+1))*3,
& LIPARM=(ELEM1*ELEM2+2*(ELEM1+ELEM2)+2)*1.5,
& LRPARM=1,
& LDNOD =2*(N1+N2)*NK*1.5,
& LIDPRM=(N1+N2)*NK*1.5,
& LRDPRM=1,
& LIVEM =MESH+DINFO+DINFO1*NK+600+LU+LDNOD/2,
& LLVEM =500,
& LRVEM =60+15*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
& - (3*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),
& EEST(LU),ERRG(LU),NRMERR(NK)
INTEGER IVEM(LIVEM),NODNUM(LNODN),NEK(LNEK),
& IPARM(LIPARM),DNOD(LDNOD),IDPARM(LIDPRM),
& IBIG(RPI*LBIG)
LOGICAL MASKL(NK,NK,NGROUP),MASKF(NK,NGROUP),LVEM(LLVEM)
C***
INTEGER MYPROC,INFO,OUTFLG,NDNUM0,HERE,S,NE1,ADGEO1,
& NE2,ADGEO2,ADIVP2,ADIVP1,NE0,NDC1,NDC2,
& ADDCG1,ADDCG2,ELNUM0,SPACE,LSPACE,STEP
INTEGER Z1,Z2
DOUBLE PRECISION X20
CHARACTER*80 NAME
C***
EXTERNAL VEM630,VEM500
EXTERNAL DUMMY,USERB,USRFUT,USRFU,USERF,USERC,USERU0
C**
C**-----------------------------------------------------------------
C**
C** The equivalence of RBIG and IBIG is very important :
C**
EQUIVALENCE (RBIG,IBIG)
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 (NPROC.NE.IVEM(200)) THEN
PRINT*,'Set NPROC=',IVEM(200)
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**** 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** This process generates the nodes in the subdomain
C** [0,1] x [ X20,X20+1/NPROC] starting with the node id number
C** NDNUM0. The nodes with x2=X20 are also generated on process
C** MYPROC-1 and the nodes with x2=X20+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**
X20=DBLE(MYPROC-1)/DBLE(IVEM(200))
NDNUM0=(MYPROC-1)*N1*(N2-1)+1
ELNUM0=(MYPROC-1)*(ELEM1*ELEM2+ELEM1+2*ELEM2)+1
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 Z2=1,N2
DO 10 Z1=1,N1
NOD(Z1+N1*(Z2-1) )=DBLE(Z1-1)/DBLE(N1-1)
NOD(Z1+N1*(Z2-1)+NN)=DBLE(Z2-1)/DBLE(IVEM(200)*(N2-1))+X20
NODNUM(Z1+N1*(Z2-1) )=Z1+N1*(Z2-1)+NDNUM0-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 consequently the boundary is described by line elments
C** of order 2. The following picture illustrates the
C** construction of the quadrilateral element with lower S
C** and its boundary elements which are only generated
C** if they are a subset of the boundary of the domain:
C**
C** S+2*N1 S+2*N1+1 S+2*N1+2
C** 3-----2-----1
C** 1 4-----7-----3 2
C** | | | |
C** S+N1 3 8 6 3 S+N1+2
C** | | | |
C** 2 1-----5-----4 1
C** 1-----3-----2
C** S S+1 S+2
C**
C** ADGEO1 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 over all processes. NE1 is the number of
C** quadrilateral 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
DO 20 Z2=1,ELEM2
DO 20 Z1=1,ELEM1
HERE=Z1+ELEM1*(Z2-1)+ADGEO1-1
S =2*(Z1-1) + 2*(Z2-1) * N1 + NDNUM0
IPARM(ADIVP1-1+Z1+ELEM1*(Z2-1))=Z1+ELEM1*(Z2-1)+ ELNUM0-1
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 + 1
NEK(HERE+5*NE1)=S + N1 + 2
NEK(HERE+6*NE1)=S + 2 *N1 + 1
NEK(HERE+7*NE1)=S + 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** 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
C** line elements generated on the process, where the
C** elements on boundary 1/3 are only generated on process 1 and
C** NPROC. HERE gives the address of the element in NEK, which is
C** a boundary element of the quadrilateral element with lowest
C** node id S.
C**
ADGEO2=ADGEO1+8*NE1
ADIVP2=ADIVP1+NE1
NE2=2*ELEM2
IF (MYPROC.EQ.1) NE2=NE2+ELEM1
IF (MYPROC.EQ.IVEM(200)) NE2=NE2+ELEM1
C**
C** these are the line elements on boundary 1:
C** only on process 1. NE0 counts the already generated line
C** elements
C**
NE0=0
IF (MYPROC.EQ.1) THEN
DO 31 Z1=1,ELEM1
HERE=Z1+NE0+ADGEO2-1
S =2*(Z1-1) + NDNUM0
IPARM(ADIVP2-1+Z1+NE0)=Z1+NE0+ELEM1*ELEM2+ELNUM0-1
NEK(HERE )=S
NEK(HERE+ NE2)=S + 2
NEK(HERE+2*NE2)=S + 1
31 CONTINUE
NE0=NE0+ELEM1
ENDIF
C**
C** these are the line elements on boundary 2:
C**
DO 32 Z2=1,ELEM2
HERE=Z2+NE0+ADGEO2-1
S = 2*(Z2-1) * N1 + NDNUM0
IPARM(ADIVP2-1+Z2+NE0)=Z2+NE0+ELEM1*ELEM2+ELNUM0-1
NEK(HERE )=S + 2 *N1
NEK(HERE+ NE2)=S
NEK(HERE+2*NE2)=S + N1
32 CONTINUE
NE0=NE0+ELEM2
C**
C** these are the line elements on boundary 4:
C**
DO 33 Z2=1,ELEM2
HERE=Z2+NE0+ADGEO2-1
S =2*(ELEM1-1) + 2*(Z2-1) * N1 + NDNUM0
IPARM(ADIVP2-1+Z2+NE0)=Z2+NE0+ELEM1*ELEM2+ELNUM0-1
NEK(HERE )=S + 2
NEK(HERE+ NE2)=S + 2 *N1 + 2
NEK(HERE+2*NE2)=S + N1 + 2
33 CONTINUE
NE0=NE0+ELEM2
C**
C** these are the line elements on boundary 3:
C**
IF (MYPROC.EQ.IVEM(200)) THEN
DO 34 Z1=1,ELEM1
HERE=Z1+NE0+ADGEO2-1
S =2*(Z1-1) + 2*(ELEM2-1) * N1 + NDNUM0
IPARM(ADIVP2-1+Z1+NE0)=Z1+NE0+ELEM1*ELEM2+ELNUM0-1
NEK(HERE )=S + 2 *N1 + 2
NEK(HERE+ NE2)=S + 2 *N1
NEK(HERE+2*NE2)=S + 2 *N1 + 1
34 CONTINUE
ENDIF
C**
C**-----------------------------------------------------------------
C**
C** the start addresses, etc are written to IVEM:
C**
C** group 1: quadrilateral elements
C**
IVEM(MESH+GINFO ) = NE1
IVEM(MESH+GINFO+ 2) = 4
IVEM(MESH+GINFO+ 3) = 2
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) = 8
C**
C** group 2: line elements
C**
IVEM(MESH+GINFO+GINFO1 ) = NE2
IVEM(MESH+GINFO+GINFO1+ 2) = 2
IVEM(MESH+GINFO+GINFO1+ 3) = 1
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) = 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 id in DNOD and the vector integer parameter in IPARM,
C** which is the id number of the boundary of the node.
C**
NDC1=0
ADDCG1=1
NDC2=0
ADDCG2=2*N1+1
C**
C** for component 1 the boundary 1 gets Dirichlet conditions:
C** (only on processor 1)
C**
IF (MYPROC.EQ.1) THEN
DO 41 Z1=1,N1
DNOD (ADDCG1+NDC1-1+Z1)=Z1+NDNUM0-1
IDPARM(ADDCG1+NDC1-1+Z1)=1
41 CONTINUE
NDC1=NDC1+N1
ENDIF
C**
C** for component 2 the boundary 2 gets Dirichlet conditions:
C**
DO 42 Z2=1,N2
DNOD (ADDCG2+NDC2-1+Z2)= Z2*N1+NDNUM0-1
IDPARM(ADDCG2+NDC2-1+Z2)= 2
42 CONTINUE
NDC2=NDC2+N2
C**
C** for component 2 the boundary 4 gets Dirichlet conditions:
C**
DO 43 Z2=1,N2
DNOD (ADDCG2+NDC2-1+Z2)= (Z2-1)*N1+NDNUM0
IDPARM(ADDCG2+NDC2-1+Z2)= 4
43 CONTINUE
NDC2=NDC2+N2
C**
C** for component 1 the boundary 3 gets Dirichlet conditions:
C** (only on processor 1)
C**
IF (MYPROC.EQ.IVEM(200)) THEN
DO 44 Z1=1,N1
DNOD (ADDCG1+NDC1-1+Z1)=N1*(N2-1)+Z1+NDNUM0-1
IDPARM(ADDCG1+NDC1-1+Z1)=3
44 CONTINUE
NDC1=NDC1+N1
ENDIF
C**
C**-----------------------------------------------------------------
C**
C** the start addresses, etc are written to IVEM:
C**
C** component 1:
C**
IVEM(MESH+DINFO ) = NDC1
IVEM(MESH+DINFO+ 2) = ADDCG1
IVEM(MESH+DINFO+ 4) = 0
IVEM(MESH+DINFO+ 7) = 0
IVEM(MESH+DINFO+ 9) = 0
IVEM(MESH+DINFO+10) = ADDCG1
IVEM(MESH+DINFO+11) = NDC1
IVEM(MESH+DINFO+12) = 1
C**
C** component 2:
C**
IVEM(MESH+DINFO+DINFO1 ) = NDC2
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+10) = ADDCG2
IVEM(MESH+DINFO+DINFO1+11) = NDC2
IVEM(MESH+DINFO+DINFO1+12) = 1
C**
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**** 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
T=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**** call of VECFEM :
C** --------------
C**
OPEN(10,FORM='UNFORMATTED',STATUS='SCRATCH')
OPEN(11,FORM='UNFORMATTED',STATUS='SCRATCH')
OPEN(12,FORM='UNFORMATTED',STATUS='SCRATCH')
LVEM(1)=LSYM
LVEM(4)=.FALSE.
LVEM(6)=.TRUE.
LVEM(7)=.TRUE.
LVEM(8)=.TRUE.
LVEM(9)=.FALSE.
LVEM(10)=.TRUE.
LVEM(11)=.FALSE.
LVEM(15)=.FALSE.
LVEM(16)=.TRUE.
RVEM(3)=1.D-2
RVEM(10)=1.D-3
RVEM(11)=T
RVEM(12)=5.
RVEM(13)=0.01
RVEM(14)=1.D-8
RVEM(15)=0
IVEM(3)=0
IVEM(10)=10
IVEM(11)=11
IVEM(12)=12
IVEM(40)=LOUT
IVEM(41)=50*OUTFLG
IVEM(45)=500
IVEM(46)=0
IVEM(60)=10
IVEM(70)=123
IVEM(71)=1
IVEM(72)=5000
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)=.TRUE.
MASKF(2,1)=.TRUE.
MASKF(1,2)=.TRUE.
MASKF(2,2)=.TRUE.
C**
C** the solution is returned after T+.5 is reached :
C**
9998 T=T+.5
CALL VEMP02 (T,LU,U,EEST,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,USRFUT,USRFU,USERF,
& VEM500,VEM630)
STEP=IVEM(3)
IF (IVEM(2).NE.0) GOTO 9999
C**
C**
C**-----------------------------------------------------------------
C**
C**** compute the error on the geometrical nodes :
C** ------------------------------------------
C**
SPACE=IVEM(8)
LSPACE=IVEM(9)
IVEM(4)=30
IVEM(30)=LOUT
IVEM(31)=OUTFLG*0
IVEM(32)=NN
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,LSPACE,
& RBIG(SPACE),IBIG(RPI*(SPACE-1)+1),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)=1
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,
& LSPACE,RBIG(SPACE),IBIG(RPI*(SPACE-1)+1))
IF (IVEM(2).NE.0) GOTO 9999
C**
C**-----------------------------------------------------------------
C**
C** If step is equal to 1 the T-integration is continued :
C**
IF (STEP.EQ.1) GOTO 9998
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** the routine USERU0 sets the initial solution, see vemu08.
C**
C*******************************************************************
C**
INTEGER NE,L,DIM,NOP,COMPU
DOUBLE PRECISION T,X(L,DIM),NOPARM(L,NOP),U0(NE)
C**
C**-----------------------------------------------------------------
C**
INTEGER Z
C**
C**-----------------------------------------------------------------
C**
C**** start of calculation :
C** --------------------
C**
IF (COMPU.EQ.1) THEN
DO 10 Z=1,NE
U0(Z) = X(Z,2)**2 * X(Z,1) * EXP(T)
10 CONTINUE
ENDIF
IF (COMPU.EQ.2) THEN
DO 20 Z=1,NE
U0(Z)= X(Z,1) * (1.-EXP(-10*T))
20 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 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.
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**
C** on boundary 1 u1 is equal to 0, so it has not to be set
C** but on boundary 2 (marked my IVDPARM(.,1)=3) u1=x1*exp(t).
C**
IF (COMPU.EQ.1) THEN
DO 10 Z=1,NDC
IF (IVDPRM(Z,1).EQ.3) B(Z) = X(Z,1) * EXP(T)
10 CONTINUE
ENDIF
C**
C** on boundary 4 u2 is equal to 0, so it has not to be set
C** but on boundary 3 (marked my IVDPARM(.,1)=3)
C** u2=(1.-exp(-10*t)).
C**
IF (COMPU.EQ.2) THEN
DO 20 Z=1,NDC
IF (IVDPRM(Z,1).EQ.2) B(Z) = (1.-EXP(-10*T))
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 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,
C** see userf:
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**
C** the coefficients for the area integration :
C**
IF (CLASS.EQ.2) THEN
IF (COMPV.EQ.1) THEN
DO 12 Z=1,NELIS
F1(Z,1)=DUDX(Z,1,1)
F1(Z,2)=DUDX(Z,1,2)
F0(Z)=UT(Z,1)+10.*U(Z,1)+U(Z,2)
& -((11.*X(Z,2)**2-2.)*X(Z,1)*EXP(T)+X(Z,1)*(1.-EXP(-10*T)))
12 CONTINUE
ENDIF
IF (COMPV.EQ.2) THEN
DO 22 Z=1,NELIS
F1(Z,1)=DUDX(Z,2,1)
F1(Z,2)=DUDX(Z,2,2)
F0(Z)=UT(Z,2)+U(Z,1)+10.*U(Z,2)
& -(X(Z,1)*X(Z,2)**2*EXP(T)+10.*X(Z,1))
22 CONTINUE
ENDIF
ENDIF
C**
C**-----------------------------------------------------------------
C**
C** the coefficients for the line integration :
C**
IF (CLASS.EQ.1) THEN
IF (COMPV.EQ.1) THEN
DO 11 Z=1,NELIS
F0(Z)= -(TAU(Z,2,1)*X(Z,2)**2 - 2.*TAU(Z,1,1) *X(Z,1))
& *EXP(T)
11 CONTINUE
ENDIF
IF (COMPV.EQ.2) THEN
DO 21 Z=1,NELIS
F0(Z)= -TAU(Z,2,1)*(1.-EXP(-10*T))
21 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 USRFU(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,
& F1UX,F1U,F0UX,F0U)
C**
C*******************************************************************
C**
C** the routine USRFU sets the Frechet derivative of F with
C** respect of u, see usrfu:
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),
& F1UX(L,CLASS,CLASS),F1U(L,CLASS),F0UX(L,CLASS),
& F0U(L)
INTEGER ISPARM(NISP),IVPARM(IVP1,NIVP)
C**
C**-----------------------------------------------------------------
C**
INTEGER Z
C**
C**-----------------------------------------------------------------
C**
C**** start of calculation :
C** ---------------------
C**
C** the coefficients for the area integration :
C**
IF (CLASS.EQ.2) THEN
IF ((COMPV.EQ.1).AND.(COMPU.EQ.1)) THEN
DO 112 Z=1,NELIS
F1UX(Z,1,1)=1.
F1UX(Z,2,2)=1.
F0U(Z)=10.
112 CONTINUE
ENDIF
IF ((COMPV.EQ.1).AND.(COMPU.EQ.2)) THEN
DO 122 Z=1,NELIS
F0U(Z)=1.
122 CONTINUE
ENDIF
IF ((COMPV.EQ.2).AND.(COMPU.EQ.1)) THEN
DO 212 Z=1,NELIS
F0U(Z)=1.
212 CONTINUE
ENDIF
IF ((COMPV.EQ.2).AND.(COMPU.EQ.2)) THEN
DO 222 Z=1,NELIS
F1UX(Z,1,1)=1.
F1UX(Z,2,2)=1.
F0U(Z)=10.
222 CONTINUE
ENDIF
ENDIF
C**
C**-----------------------------------------------------------------
C**
C**** end of calculation
C** ------------------
C**
R E T U R N
C**---end of USRFU--------------------------------------------------
E N D
SUBROUTINE USRFUT(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,
& F1UTX,F1UT,F0UTX,F0UT)
C**
C*******************************************************************
C**
C** the routine USRFU sets the Frechet derivative of F with
C** respect of ut, see usrfu:
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),
& F1UTX(L,CLASS,CLASS),F1UT(L,CLASS),
& F0UTX(L,CLASS),F0UT(L)
INTEGER ISPARM(NISP),IVPARM(IVP1,NIVP)
C**
C**-----------------------------------------------------------------
C**
INTEGER Z
C**
C**-----------------------------------------------------------------
C**
C**** start of calculation :
C** ---------------------
C**
C** the coefficients for the area integration :
C**
IF (CLASS.EQ.2) THEN
IF ((COMPV.EQ.1).AND.(COMPU.EQ.1)) THEN
DO 112 Z=1,NELIS
F0UT(Z)=1.
112 CONTINUE
ENDIF
IF ((COMPV.EQ.2).AND.(COMPU.EQ.2)) THEN
DO 222 Z=1,NELIS
F0UT(Z)=1.
222 CONTINUE
ENDIF
ENDIF
C**
C**-----------------------------------------------------------------
C**
C**** end of calculation
C** ------------------
C**
R E T U R N
C**---end of USRFUT-------------------------------------------------
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 relative error of
C** the 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)*EXP(-T) - X(Z,2)**2 * X(Z,1) )
CU(Z,2) = ABS( U(Z,2)/(1.-EXP(-10*T)) - X(Z,1) )
10 CONTINUE
C**
C**-----------------------------------------------------------------
C**
C**** end of calculation
C** ------------------
C**
R E T U R N
C**---end of USERC--------------------------------------------------
E N D