1*8980d4a7Sjeremylt!----------------------------------------------------------------------- 2*8980d4a7Sjeremylt subroutine setup(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 3*8980d4a7Sjeremylt& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 4*8980d4a7Sjeremylt real*8 ctx(1) 5*8980d4a7Sjeremylt real*8 u1(8) 6*8980d4a7Sjeremylt real*8 v1(8) 7*8980d4a7Sjeremylt integer q,ierr 8*8980d4a7Sjeremylt 9*8980d4a7Sjeremylt do i=1,q 10*8980d4a7Sjeremylt v1(i)=u1(i) 11*8980d4a7Sjeremylt enddo 12*8980d4a7Sjeremylt 13*8980d4a7Sjeremylt ierr=0 14*8980d4a7Sjeremylt end 15*8980d4a7Sjeremylt!----------------------------------------------------------------------- 16*8980d4a7Sjeremylt subroutine mass(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 17*8980d4a7Sjeremylt& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 18*8980d4a7Sjeremylt real*8 ctx(5) 19*8980d4a7Sjeremylt real*8 u1(8) 20*8980d4a7Sjeremylt real*8 u2(8) 21*8980d4a7Sjeremylt real*8 v1(8) 22*8980d4a7Sjeremylt integer q,ierr 23*8980d4a7Sjeremylt 24*8980d4a7Sjeremylt do i=1,q 25*8980d4a7Sjeremylt v1(i)=ctx(5)*u1(i)*u2(i) 26*8980d4a7Sjeremylt enddo 27*8980d4a7Sjeremylt 28*8980d4a7Sjeremylt ierr=0 29*8980d4a7Sjeremylt end 30*8980d4a7Sjeremylt!----------------------------------------------------------------------- 31*8980d4a7Sjeremylt program test 32*8980d4a7Sjeremylt 33*8980d4a7Sjeremylt include 'ceedf.h' 34*8980d4a7Sjeremylt 35*8980d4a7Sjeremylt integer ceed,err 36*8980d4a7Sjeremylt integer qdata,w,u,v 37*8980d4a7Sjeremylt integer qf_setup,qf_mass 38*8980d4a7Sjeremylt integer q,i 39*8980d4a7Sjeremylt parameter(q=8) 40*8980d4a7Sjeremylt real*8 ww(q) 41*8980d4a7Sjeremylt real*8 uu(q) 42*8980d4a7Sjeremylt real*8 vv(q) 43*8980d4a7Sjeremylt real*8 vvv(q) 44*8980d4a7Sjeremylt integer ctxsize 45*8980d4a7Sjeremylt parameter(ctxsize=5) 46*8980d4a7Sjeremylt real*8 ctx(5) 47*8980d4a7Sjeremylt real*8 x 48*8980d4a7Sjeremylt character arg*32 49*8980d4a7Sjeremylt integer*8 offset 50*8980d4a7Sjeremylt 51*8980d4a7Sjeremylt external setup,mass 52*8980d4a7Sjeremylt 53*8980d4a7Sjeremylt ctx=(/1.d0,2.d0,3.d0,4.d0,5.d0/) 54*8980d4a7Sjeremylt 55*8980d4a7Sjeremylt call getarg(1,arg) 56*8980d4a7Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 57*8980d4a7Sjeremylt 58*8980d4a7Sjeremylt call ceedqfunctioncreateinterior(ceed,1,setup,& 59*8980d4a7Sjeremylt &__FILE__& 60*8980d4a7Sjeremylt &//':setup'//char(0),qf_setup,err) 61*8980d4a7Sjeremylt call ceedqfunctionaddinput(qf_setup,'w', 1,ceed_eval_interp,err) 62*8980d4a7Sjeremylt call ceedqfunctionaddoutput(qf_setup,'qdata',1,ceed_eval_interp,err) 63*8980d4a7Sjeremylt 64*8980d4a7Sjeremylt call ceedqfunctioncreateinterior(ceed,1,mass,& 65*8980d4a7Sjeremylt &__FILE__& 66*8980d4a7Sjeremylt &//':mass'//char(0),qf_mass,err) 67*8980d4a7Sjeremylt call ceedqfunctionaddinput(qf_mass,'qdata',1,ceed_eval_interp,err) 68*8980d4a7Sjeremylt call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err) 69*8980d4a7Sjeremylt call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err) 70*8980d4a7Sjeremylt 71*8980d4a7Sjeremylt call ceedqfunctionsetcontext(qf_mass,ctx,ctxsize,err) 72*8980d4a7Sjeremylt 73*8980d4a7Sjeremylt do i=0,q-1 74*8980d4a7Sjeremylt x=2.0*i/(q-1)-1 75*8980d4a7Sjeremylt ww(i+1)=1-x*x 76*8980d4a7Sjeremylt uu(i+1)=2+3*x+5*x*x 77*8980d4a7Sjeremylt vvv(i+1)=ww(i+1)*uu(i+1) 78*8980d4a7Sjeremylt enddo 79*8980d4a7Sjeremylt 80*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,w,err) 81*8980d4a7Sjeremylt call ceedvectorsetarray(w,ceed_mem_host,ceed_use_pointer,ww,err) 82*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,u,err) 83*8980d4a7Sjeremylt call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,err) 84*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,v,err) 85*8980d4a7Sjeremylt call ceedvectorsetvalue(v,0.d0,err) 86*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,qdata,err) 87*8980d4a7Sjeremylt call ceedvectorsetvalue(qdata,0.d0,err) 88*8980d4a7Sjeremylt 89*8980d4a7Sjeremylt call ceedqfunctionapply(qf_setup,q,w,ceed_null,ceed_null,ceed_null,& 90*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 91*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 92*8980d4a7Sjeremylt &qdata,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 93*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 94*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,err) 95*8980d4a7Sjeremylt 96*8980d4a7Sjeremylt call ceedqfunctionapply(qf_mass,q,u,qdata,ceed_null,ceed_null,& 97*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 98*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 99*8980d4a7Sjeremylt &v,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 100*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 101*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,err) 102*8980d4a7Sjeremylt 103*8980d4a7Sjeremylt call ceedvectorgetarrayread(v,ceed_mem_host,vv,offset,err) 104*8980d4a7Sjeremylt do i=1,q 105*8980d4a7Sjeremylt if (abs(vv(i+offset)-ctx(5)*vvv(i)) > 1.0D-14) then 106*8980d4a7Sjeremylt write(*,*) 'v(i)=',vv(i+offset),', 5*vv(i)=',ctx(5)*vvv(i) 107*8980d4a7Sjeremylt endif 108*8980d4a7Sjeremylt enddo 109*8980d4a7Sjeremylt call ceedvectorrestorearrayread(v,vv,offset,err) 110*8980d4a7Sjeremylt 111*8980d4a7Sjeremylt call ceedvectordestroy(u,err) 112*8980d4a7Sjeremylt call ceedvectordestroy(v,err) 113*8980d4a7Sjeremylt call ceedvectordestroy(w,err) 114*8980d4a7Sjeremylt call ceedvectordestroy(qdata,err) 115*8980d4a7Sjeremylt call ceedqfunctiondestroy(qf_setup,err) 116*8980d4a7Sjeremylt call ceedqfunctiondestroy(qf_mass,err) 117*8980d4a7Sjeremylt call ceeddestroy(ceed,err) 118*8980d4a7Sjeremylt end 119*8980d4a7Sjeremylt!----------------------------------------------------------------------- 120