1*2ebaca42Sjeremylt!----------------------------------------------------------------------- 2*2ebaca42Sjeremylt subroutine setup(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 3*2ebaca42Sjeremylt& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 4*2ebaca42Sjeremylt real*8 ctx 5*2ebaca42Sjeremylt real*8 u1(1) 6*2ebaca42Sjeremylt real*8 u2(1) 7*2ebaca42Sjeremylt real*8 v1(1) 8*2ebaca42Sjeremylt integer q,ierr 9*2ebaca42Sjeremylt 10*2ebaca42Sjeremylt do i=1,q 11*2ebaca42Sjeremylt v1(i)=u1(i)*u2(i) 12*2ebaca42Sjeremylt enddo 13*2ebaca42Sjeremylt 14*2ebaca42Sjeremylt ierr=0 15*2ebaca42Sjeremylt end 16*2ebaca42Sjeremylt!----------------------------------------------------------------------- 17*2ebaca42Sjeremylt subroutine mass(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 18*2ebaca42Sjeremylt& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 19*2ebaca42Sjeremylt real*8 ctx 20*2ebaca42Sjeremylt real*8 u1(1) 21*2ebaca42Sjeremylt real*8 u2(1) 22*2ebaca42Sjeremylt real*8 v1(1) 23*2ebaca42Sjeremylt integer q,ierr 24*2ebaca42Sjeremylt 25*2ebaca42Sjeremylt do i=1,q 26*2ebaca42Sjeremylt v1(i)=u2(i)*u1(i) 27*2ebaca42Sjeremylt enddo 28*2ebaca42Sjeremylt 29*2ebaca42Sjeremylt ierr=0 30*2ebaca42Sjeremylt end 31*2ebaca42Sjeremylt!----------------------------------------------------------------------- 32*2ebaca42Sjeremylt program test 33*2ebaca42Sjeremylt 34*2ebaca42Sjeremylt include 'ceedf.h' 35*2ebaca42Sjeremylt 36*2ebaca42Sjeremylt integer ceed,err,i,j 37*2ebaca42Sjeremylt integer erestrictx,erestrictu,erestrictxi,erestrictui 38*2ebaca42Sjeremylt integer bx,bu 39*2ebaca42Sjeremylt integer qf_setup,qf_mass 40*2ebaca42Sjeremylt integer op_setup,op_mass 41*2ebaca42Sjeremylt integer qdata 42*2ebaca42Sjeremylt integer nelem,p,q 43*2ebaca42Sjeremylt parameter(nelem=15) 44*2ebaca42Sjeremylt parameter(p=5) 45*2ebaca42Sjeremylt parameter(q=8) 46*2ebaca42Sjeremylt integer nx,nu 47*2ebaca42Sjeremylt parameter(nx=nelem+1) 48*2ebaca42Sjeremylt parameter(nu=nelem*(p-1)+1) 49*2ebaca42Sjeremylt integer indx(nelem*2) 50*2ebaca42Sjeremylt integer indu(nelem*p) 51*2ebaca42Sjeremylt 52*2ebaca42Sjeremylt character arg*32 53*2ebaca42Sjeremylt 54*2ebaca42Sjeremylt external setup,mass 55*2ebaca42Sjeremylt 56*2ebaca42Sjeremylt call getarg(1,arg) 57*2ebaca42Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 58*2ebaca42Sjeremylt 59*2ebaca42Sjeremylt do i=0,nelem-1 60*2ebaca42Sjeremylt indx(2*i+1)=i 61*2ebaca42Sjeremylt indx(2*i+2)=i+1 62*2ebaca42Sjeremylt enddo 63*2ebaca42Sjeremylt 64*2ebaca42Sjeremylt call ceedelemrestrictioncreate(ceed,nelem,2,nx,1,ceed_mem_host,& 65*2ebaca42Sjeremylt & ceed_use_pointer,indx,erestrictx,err) 66*2ebaca42Sjeremylt call ceedelemrestrictioncreateidentity(ceed,nelem,2,2*nelem,1,& 67*2ebaca42Sjeremylt & erestrictxi,err) 68*2ebaca42Sjeremylt 69*2ebaca42Sjeremylt do i=0,nelem-1 70*2ebaca42Sjeremylt do j=0,p-1 71*2ebaca42Sjeremylt indu(p*i+j+1)=i*(p-1)+j 72*2ebaca42Sjeremylt enddo 73*2ebaca42Sjeremylt enddo 74*2ebaca42Sjeremylt 75*2ebaca42Sjeremylt call ceedelemrestrictioncreate(ceed,nelem,p,nu,1,ceed_mem_host,& 76*2ebaca42Sjeremylt & ceed_use_pointer,indu,erestrictu,err) 77*2ebaca42Sjeremylt call ceedelemrestrictioncreateidentity(ceed,nelem,q,q*nelem,1,& 78*2ebaca42Sjeremylt & erestrictui,err) 79*2ebaca42Sjeremylt 80*2ebaca42Sjeremylt call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bx,err) 81*2ebaca42Sjeremylt call ceedbasiscreatetensorh1lagrange(ceed,1,1,p,q,ceed_gauss,bu,err) 82*2ebaca42Sjeremylt 83*2ebaca42Sjeremylt call ceedqfunctioncreateinterior(ceed,1,setup,& 84*2ebaca42Sjeremylt &SOURCE_DIR& 85*2ebaca42Sjeremylt &//'t500-operator.h:setup'//char(0),qf_setup,err) 86*2ebaca42Sjeremylt call ceedqfunctionaddinput(qf_setup,'_weight',1,ceed_eval_weight,err) 87*2ebaca42Sjeremylt call ceedqfunctionaddinput(qf_setup,'dx',1,ceed_eval_grad,err) 88*2ebaca42Sjeremylt call ceedqfunctionaddoutput(qf_setup,'rho',1,ceed_eval_none,err) 89*2ebaca42Sjeremylt 90*2ebaca42Sjeremylt call ceedqfunctioncreateinterior(ceed,1,mass,& 91*2ebaca42Sjeremylt &SOURCE_DIR& 92*2ebaca42Sjeremylt &//'t500-operator.h:mass'//char(0),qf_mass,err) 93*2ebaca42Sjeremylt call ceedqfunctionaddinput(qf_mass,'rho',1,ceed_eval_none,err) 94*2ebaca42Sjeremylt call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err) 95*2ebaca42Sjeremylt call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err) 96*2ebaca42Sjeremylt 97*2ebaca42Sjeremylt call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,& 98*2ebaca42Sjeremylt & ceed_qfunction_none,op_setup,err) 99*2ebaca42Sjeremylt call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,& 100*2ebaca42Sjeremylt & ceed_qfunction_none,op_mass,err) 101*2ebaca42Sjeremylt 102*2ebaca42Sjeremylt call ceedvectorcreate(ceed,nx,x,err) 103*2ebaca42Sjeremylt xoffset=0 104*2ebaca42Sjeremylt call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err) 105*2ebaca42Sjeremylt call ceedvectorcreate(ceed,nelem*q,qdata,err) 106*2ebaca42Sjeremylt 107*2ebaca42Sjeremylt call ceedoperatorsetfield(op_setup,'_weight',erestrictxi,& 108*2ebaca42Sjeremylt & ceed_notranspose,bx,ceed_vector_none,err) 109*2ebaca42Sjeremylt call ceedoperatorsetfield(op_setup,'dx',erestrictx,& 110*2ebaca42Sjeremylt & ceed_notranspose,bx,ceed_vector_active,err) 111*2ebaca42Sjeremylt call ceedoperatorsetfield(op_setup,'rho',erestrictui,& 112*2ebaca42Sjeremylt & ceed_notranspose,ceed_basis_collocated,ceed_vector_active,err) 113*2ebaca42Sjeremylt call ceedoperatorsetfield(op_mass,'rho',erestrictui,& 114*2ebaca42Sjeremylt & ceed_notranspose,ceed_basis_collocated,qdata,err) 115*2ebaca42Sjeremylt call ceedoperatorsetfield(op_mass,'u',erestrictu,& 116*2ebaca42Sjeremylt & ceed_notranspose,bu,ceed_vector_active,err) 117*2ebaca42Sjeremylt call ceedoperatorsetfield(op_mass,'v',erestrictu,& 118*2ebaca42Sjeremylt & ceed_notranspose,bu,ceed_vector_active,err) 119*2ebaca42Sjeremylt 120*2ebaca42Sjeremylt call ceedoperatorview(op_setup,err) 121*2ebaca42Sjeremylt call ceedoperatorview(op_mass,err) 122*2ebaca42Sjeremylt 123*2ebaca42Sjeremylt call ceedvectordestroy(qdata,err) 124*2ebaca42Sjeremylt call ceedoperatordestroy(op_mass,err) 125*2ebaca42Sjeremylt call ceedoperatordestroy(op_setup,err) 126*2ebaca42Sjeremylt call ceedqfunctiondestroy(qf_mass,err) 127*2ebaca42Sjeremylt call ceedqfunctiondestroy(qf_setup,err) 128*2ebaca42Sjeremylt call ceedbasisdestroy(bu,err) 129*2ebaca42Sjeremylt call ceedbasisdestroy(bx,err) 130*2ebaca42Sjeremylt call ceedelemrestrictiondestroy(erestrictu,err) 131*2ebaca42Sjeremylt call ceedelemrestrictiondestroy(erestrictx,err) 132*2ebaca42Sjeremylt call ceedelemrestrictiondestroy(erestrictui,err) 133*2ebaca42Sjeremylt call ceedelemrestrictiondestroy(erestrictxi,err) 134*2ebaca42Sjeremylt call ceeddestroy(ceed,err) 135*2ebaca42Sjeremylt end 136*2ebaca42Sjeremylt!----------------------------------------------------------------------- 137