C*******************************************************************
C**
C** v e m e 0 2 e x m 1 0 :
C**
C** System of three nonlinear patrial differential equations of
C** the Navier-Stokes type on a 3-dimensional domain. The examples
C** demonstrates the usage of restarts. The mesh is read from a
C** VECFEM input file.
C**
C** by L. Grosz Karlsruhe, Mar. 1995
C**
C**
C*******************************************************************
C**
C** The problem is a system of three partial differential
C** equations, which are a simplification of the Navier-Stokes
C** equations (it is assummed that the pressure is constant).
C** The domain is the 3-dimensional cube with length pi. An all
C** boundaries Neuman boundary conditions are prescribed and for
C** all components a Dirichlet condition at the origin is set.
C** Using the notations in equation the problem is given by
C** the functional equation:
C**
C** Dirichlet conditions:
C** u1=0
C** u2=0
C** u3=0
C**
C** linear functional equation: F{u}(v)=0
C**
C** with F{u}(v)=
C** volume{v1x1*u1x1+v1x2*u1x2+v1x3*u1x3+
C** Re*v1*(u1*u1x1+u2*u1x2+u3*u1x3-f1)
C** + v2x1*u2x1+v2x2*u2x2+v2x3*u2x3+
C** Re*v2*(u1*u2x1+u2*u2x2+u3*u2x3-f2)
C** + v3x1*u3x1+v3x2*u3x2+v3x3*u3x3+
C** Re*v3*(u1*u3x1+u2*u3x2+u3*u3x3-f3)}
C** + area{v1*g1+v2*g2+v3*g3}
C**
C** The functions f and g are selected so that
C**
C** u1=cos(x1)*sin(x2)*sin(x3)
C** u2=sin(x1)*cos(x2)*sin(x3)
C** u3=sin(x1)*sin(x2)*cos(x3)
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 is read from the vecfem input file wurf.vem.
C** It uses hexahedron elements of order 2 for the subdivision
C** of the cube and quadrilateral elements for its boundary.
C**
C**-----------------------------------------------------------------
C**
PROGRAM VEMEXM
C**
C**-----------------------------------------------------------------
C**
IMPLICIT NONE
include 'bytes.h'
C**
C**-----------------------------------------------------------------
C**
C** some parameters which may be chanced:
C**
C** MAXNG = maximal number of groups
C** INPUT = name of the vecfem input file
C** STORE = total storage of process in Mbytes.
C**
INTEGER NPROC,MAXNG,STORE
CHARACTER*80 INPUT
PARAMETER (MAXNG=5,
& INPUT='wurf.vem',
& STORE=65)
C**
C**-----------------------------------------------------------------
C**
C** the parameters are explained in mesh.
C**
INTEGER NK,DIM,MESH,LOUT
PARAMETER (NK=3,
& DIM=3,
& MESH=500,
& LOUT=6)
C**
C**-----------------------------------------------------------------
C**
C** the length of the array for the mesh are set:
C**
INTEGER LU,LNODN,LNOD,LNOPRM,LNEK,LRPARM,LIPARM,
& LDNOD,LIDPRM,LRDPRM,LIVEM,LRVEM,LLVEM,LBIG
PARAMETER (LU =30 000,
& LNODN =10 000,
& LNOD =30 000,
& LNOPRM=1,
& LNEK=64 000,
& LIPARM=6800,
& LRPARM=1,
& LDNOD =6,
& LIDPRM=3,
& LRDPRM=3,
& LIVEM =MESH+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
& - (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,MAXNG),MASKF(NK,MAXNG),LVEM(LLVEM)
C***
INTEGER MYPROC,INFO,OUTFLG,GINFO,GINFO1,CLASS,NGROUP,G,
& J,I,RUNIT,ERR
CHARACTER*80 NAME,RFILE
LOGICAL RSTRT
DOUBLE PRECISION RE
C***
EXTERNAL VEM630,VEM500
EXTERNAL DUMMY,USRFU,USERF,USERC,USERB
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=0.0
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)
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**** read the restart file :
C** ---------------------
C**
WRITE(RFILE,9000) MYPROC
RUNIT=99
9000 FORMAT('restart.p',I3.3)
C**
C**** If the restart file 'restart.p<NPROC>' exists, the file
C** is read an the calculation is continued with veme02:
C**
INQUIRE(FILE=RFILE,EXIST=RSTRT)
IF (RSTRT) THEN
OPEN(UNIT=RUNIT,FILE=RFILE,STATUS= 'UNKNOWN',
& FORM='UNFORMATTED')
CALL VEM680 (RUNIT,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,
& LOUT,ERR)
CLOSE(RUNIT)
IF (ERR.GT.0) GOTO 9999
GOTO 5000
ENDIF
C**
C**-----------------------------------------------------------------
C**
C**** the parameters are copied into IVEM :
C** -----------------------------------
C**
IVEM(1)=MESH
IVEM(MESH+ 2)=NK
IVEM(MESH+ 3)=DIM
C**
C**-----------------------------------------------------------------
C**
C**** read the mesh from a universal file :
C** -----------------------------------
C**
IVEM(27)=LOUT
IVEM(28)=OUTFLG
IVEM(29)=9
IF (MYPROC.EQ.1) OPEN(9,FILE=INPUT,STATUS= 'UNKNOWN',
& FORM='FORMATTED')
CALL VEMU02 (LIVEM,IVEM,LNEK,NEK,LRPARM,RPARM,LIPARM,IPARM,
& LDNOD,DNOD,LRDPRM,RDPARM,LIDPRM,IDPARM,LNODN,
& NODNUM,LNOD,NOD,LNOPRM,NOPARM,LBIG,RBIG,IBIG)
CLOSE(9)
IF (IVEM(2).NE.0) GOTO 9999
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)=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**** set masks :
C** ---------
C**
NGROUP=IVEM(IVEM(1)+4)
GINFO=IVEM(IVEM(1)+21)+IVEM(1)
GINFO1=IVEM(IVEM(1)+22)
DO 400 G=1,NGROUP
DO 410 I=1,NK
MASKF(I,G)=.FALSE.
DO 410 J=1,NK
410 MASKL(I,J,G)=.FALSE.
CLASS=IVEM(GINFO+GINFO1*(G-1)+3)
IF (CLASS.EQ.DIM) THEN
DO 420 I=1,NK
MASKF(I,G)=.TRUE.
DO 420 J=1,NK
420 MASKL(I,J,G)=.TRUE.
ELSEIF (CLASS.EQ.DIM-1) THEN
DO 430 I=1,NK
430 MASKF(I,G)=.TRUE.
ENDIF
400 CONTINUE
C**
C**-----------------------------------------------------------------
C**
C**** call of VECFEM :
C** --------------
C**
5000 CONTINUE
OPEN(10,FORM='UNFORMATTED',STATUS='SCRATCH')
OPEN(11,FORM='UNFORMATTED',STATUS='SCRATCH')
OPEN(12,FORM='UNFORMATTED',STATUS='SCRATCH')
LVEM(1)=.FALSE.
LVEM(4)=.FALSE.
LVEM(5)=.FALSE.
LVEM(6)=.TRUE.
LVEM(7)=.TRUE.
LVEM(8)=.TRUE.
LVEM(9)=.FALSE.
LVEM(10)=.TRUE.
LVEM(11)=.FALSE.
RVEM(1)=10.
RVEM(3)=1.D-2
RVEM(10)=1.D-8
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)=0
IVEM(70)=10
IVEM(71)=11
IVEM(72)=10 000
CALL VEME02 (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,USRFU,USERF,VEM500,VEM630)
IF (IVEM(2).GT.1) GOTO 9999
C**
C**-----------------------------------------------------------------
C**
C**** save the mash files for restart :
C** -------------------------------
C**
IF (IVEM(2).EQ.1) THEN
OPEN(UNIT=RUNIT,FILE=RFILE,FORM='UNFORMATTED')
CALL VEM681 (RUNIT,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,
& LOUT,ERR)
CLOSE(RUNIT)
GOTO 9999
ENDIF
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 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**
DO 10 Z=1,NDC
B(Z) = 0
10 CONTINUE
C**
C**-----------------------------------------------------------------
C**
C**** end of calculation
C** ------------------
C**
R E T U R N
C**---end of USERB--------------------------------------------------
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 the linear
C** form F, 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
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
F0U(Z)=RE*DUDX(Z,1,1)
F0UX(Z,1)=RE*U(Z,1)
F0UX(Z,2)=RE*U(Z,2)
F0UX(Z,3)=RE*U(Z,3)
F1UX(Z,1,1)=1
F1UX(Z,2,2)=1
F1UX(Z,3,3)=1
4 CONTINUE
ENDIF
IF ((COMPV.EQ.1).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
DO 8 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,1,2)
8 CONTINUE
ENDIF
IF ((COMPV.EQ.1).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
DO 12 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,1,3)
12 CONTINUE
ENDIF
IF ((COMPV.EQ.2).AND.(COMPU.EQ.1).AND.(CLASS.EQ.3)) THEN
DO 16 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,2,1)
16 CONTINUE
ENDIF
IF ((COMPV.EQ.2).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
DO 20 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,2,2)
F0UX(Z,1)=RE*U(Z,1)
F0UX(Z,2)=RE*U(Z,2)
F0UX(Z,3)=RE*U(Z,3)
F1UX(Z,1,1)=1
F1UX(Z,2,2)=1
F1UX(Z,3,3)=1
20 CONTINUE
ENDIF
IF ((COMPV.EQ.2).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
DO 24 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,2,3)
24 CONTINUE
ENDIF
IF ((COMPV.EQ.3).AND.(COMPU.EQ.1).AND.(CLASS.EQ.3)) THEN
DO 28 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,3,1)
28 CONTINUE
ENDIF
IF ((COMPV.EQ.3).AND.(COMPU.EQ.2).AND.(CLASS.EQ.3)) THEN
DO 32 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,3,2)
32 CONTINUE
ENDIF
IF ((COMPV.EQ.3).AND.(COMPU.EQ.3).AND.(CLASS.EQ.3)) THEN
DO 36 Z=1,NELIS
F0U(Z)=RE*DUDX(Z,3,3)
F0UX(Z,1)=RE*U(Z,1)
F0UX(Z,2)=RE*U(Z,2)
F0UX(Z,3)=RE*U(Z,3)
F1UX(Z,1,1)=1
F1UX(Z,2,2)=1
F1UX(Z,3,3)=1
36 CONTINUE
ENDIF
C**
C**-----------------------------------------------------------------
C**
C**** end of calculation
C** ------------------
C**
R E T U R N
C**---end of USRFU--------------------------------------------------
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*******************************************************************
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
F1(Z,1)=DUDX(Z,1,1)
F1(Z,2)=DUDX(Z,1,2)
F1(Z,3)=DUDX(Z,1,3)
F0(Z)=RE*(U(Z,1)*DUDX(Z,1,1)+
& U(Z,2)*DUDX(Z,1,2)+U(Z,3)*DUDX(Z,1,3))
& +RE*COS(X(Z,1))*SIN(X(Z,1))
& -2*RE*COS(X(Z,1))*SIN(X(Z,1))*COS(X(Z,3))**2
& -2*RE*COS(X(Z,1))*SIN(X(Z,1))*COS(X(Z,2))**2
& +3*RE*COS(X(Z,1))*SIN(X(Z,1))*COS(X(Z,2))**2*COS(X(Z,3))**2
& -3*COS(X(Z,1))*SIN(X(Z,2))*SIN(X(Z,3))
4 CONTINUE
ENDIF
IF (COMPV.EQ.2) THEN
DO 8 Z=1,NELIS
F1(Z,1)=DUDX(Z,2,1)
F1(Z,2)=DUDX(Z,2,2)
F1(Z,3)=DUDX(Z,2,3)
F0(Z)=RE*(U(Z,1)*DUDX(Z,2,1)+
& U(Z,2)*DUDX(Z,2,2)+U(Z,3)*DUDX(Z,2,3))
& +RE*COS(X(Z,2))*SIN(X(Z,2))
& -2*RE*COS(X(Z,1))**2*SIN(X(Z,2))*COS(X(Z,2))
& -2*RE*COS(X(Z,2))*SIN(X(Z,2))*COS(X(Z,3))**2
& +3*RE*COS(X(Z,1))**2*SIN(X(Z,2))*COS(X(Z,2))*COS(X(Z,3))**2
& -3*SIN(X(Z,1))*COS(X(Z,2))*SIN(X(Z,3))
8 CONTINUE
ENDIF
IF (COMPV.EQ.3) THEN
DO 12 Z=1,NELIS
F1(Z,1)=DUDX(Z,3,1)
F1(Z,2)=DUDX(Z,3,2)
F1(Z,3)=DUDX(Z,3,3)
F0(Z)=RE*(U(Z,1)*DUDX(Z,3,1)+
& U(Z,2)*DUDX(Z,3,2)+U(Z,3)*DUDX(Z,3,3))
& +RE*COS(X(Z,3))*SIN(X(Z,3))
& -2*RE*COS(X(Z,1))**2*SIN(X(Z,3))*COS(X(Z,3))
& -2*RE*COS(X(Z,2))**2*SIN(X(Z,3))*COS(X(Z,3))
& +3*RE*COS(X(Z,1))**2*SIN(X(Z,3))*COS(X(Z,3))*COS(X(Z,2))**2
& -3*SIN(X(Z,1))*SIN(X(Z,2))*COS(X(Z,3))
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.1.D-2) F0(Z)=COS(X(Z,1))*SIN(X(Z,3))
IF (X(Z,2).GT.3.14) F0(Z)=COS(X(Z,1))*SIN(X(Z,3))
IF (X(Z,3).LT.1.D-2) F0(Z)=COS(X(Z,1))*SIN(X(Z,2))
IF (X(Z,3).GT.3.14) F0(Z)=COS(X(Z,1))*SIN(X(Z,2))
3 CONTINUE
ENDIF
IF (COMPV.EQ.2) THEN
DO 7 Z=1,NELIS
IF (X(Z,1).LT.1.D-2) F0(Z)=COS(X(Z,2))*SIN(X(Z,3))
IF (X(Z,1).GT.3.14) F0(Z)=COS(X(Z,2))*SIN(X(Z,3))
IF (X(Z,3).LT.1.D-2) F0(Z)=SIN(X(Z,1))*COS(X(Z,2))
IF (X(Z,3).GT.3.14) F0(Z)=SIN(X(Z,1))*COS(X(Z,2))
7 CONTINUE
ENDIF
IF (COMPV.EQ.3) THEN
DO 11 Z=1,NELIS
IF (X(Z,1).LT.1.D-2) F0(Z)=SIN(X(Z,2))*COS(X(Z,3))
IF (X(Z,1).GT.3.14) F0(Z)=SIN(X(Z,2))*COS(X(Z,3))
IF (X(Z,2).LT.1.D-2) F0(Z)=SIN(X(Z,1))*COS(X(Z,3))
IF (X(Z,2).GT.3.14) F0(Z)=SIN(X(Z,1))*COS(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 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) - COS(X(Z,1))*SIN(X(Z,2))*SIN(X(Z,3)))
CU(Z,2) = ABS( U(Z,2) - SIN(X(Z,1))*COS(X(Z,2))*SIN(X(Z,3)))
CU(Z,3) = ABS( U(Z,3) - SIN(X(Z,1))*SIN(X(Z,2))*COS(X(Z,3)))
10 CONTINUE
C**
C**-----------------------------------------------------------------
C**
C**** end of calculation
C** ------------------
C**
R E T U R N
C**---end of USERC--------------------------------------------------
E N D