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(1) 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)=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 real*8 x 45*8980d4a7Sjeremylt character arg*32 46*8980d4a7Sjeremylt integer*8 offset 47*8980d4a7Sjeremylt 48*8980d4a7Sjeremylt external setup,mass 49*8980d4a7Sjeremylt 50*8980d4a7Sjeremylt call getarg(1,arg) 51*8980d4a7Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 52*8980d4a7Sjeremylt 53*8980d4a7Sjeremylt call ceedqfunctioncreateinterior(ceed,1,setup,& 54*8980d4a7Sjeremylt &__FILE__& 55*8980d4a7Sjeremylt &//':setup'//char(0),qf_setup,err) 56*8980d4a7Sjeremylt call ceedqfunctionaddinput(qf_setup,'w', 1,ceed_eval_interp,err) 57*8980d4a7Sjeremylt call ceedqfunctionaddoutput(qf_setup,'qdata',1,ceed_eval_interp,err) 58*8980d4a7Sjeremylt 59*8980d4a7Sjeremylt call ceedqfunctioncreateinterior(ceed,1,mass,& 60*8980d4a7Sjeremylt &__FILE__& 61*8980d4a7Sjeremylt &//':mass'//char(0),qf_mass,err) 62*8980d4a7Sjeremylt call ceedqfunctionaddinput(qf_mass,'qdata',1,ceed_eval_interp,err) 63*8980d4a7Sjeremylt call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err) 64*8980d4a7Sjeremylt call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err) 65*8980d4a7Sjeremylt 66*8980d4a7Sjeremylt do i=0,q-1 67*8980d4a7Sjeremylt x=2.0*i/(q-1)-1 68*8980d4a7Sjeremylt ww(i+1)=1-x*x 69*8980d4a7Sjeremylt uu(i+1)=2+3*x+5*x*x 70*8980d4a7Sjeremylt vvv(i+1)=ww(i+1)*uu(i+1) 71*8980d4a7Sjeremylt enddo 72*8980d4a7Sjeremylt 73*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,w,err) 74*8980d4a7Sjeremylt call ceedvectorsetarray(w,ceed_mem_host,ceed_use_pointer,ww,err) 75*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,u,err) 76*8980d4a7Sjeremylt call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,err) 77*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,v,err) 78*8980d4a7Sjeremylt call ceedvectorsetvalue(v,0.d0,err) 79*8980d4a7Sjeremylt call ceedvectorcreate(ceed,q,qdata,err) 80*8980d4a7Sjeremylt call ceedvectorsetvalue(qdata,0.d0,err) 81*8980d4a7Sjeremylt 82*8980d4a7Sjeremylt call ceedqfunctionapply(qf_setup,q,w,ceed_null,ceed_null,ceed_null,& 83*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 84*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 85*8980d4a7Sjeremylt &qdata,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 86*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 87*8980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,err) 88*8980d4a7Sjeremylt 89*8980d4a7Sjeremylt call ceedqfunctionapply(qf_mass,q,u,qdata,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 &v,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 ceedvectorgetarrayread(v,ceed_mem_host,vv,offset,err) 97*8980d4a7Sjeremylt do i=1,q 98*8980d4a7Sjeremylt if (abs(vv(i+offset)-vvv(i)) > 1.0D-14) then 99*8980d4a7Sjeremylt write(*,*) 'v(i)=',vv(i+offset),', vv(i)=',vvv(i) 100*8980d4a7Sjeremylt endif 101*8980d4a7Sjeremylt enddo 102*8980d4a7Sjeremylt call ceedvectorrestorearrayread(v,vv,offset,err) 103*8980d4a7Sjeremylt 104*8980d4a7Sjeremylt call ceedvectordestroy(u,err) 105*8980d4a7Sjeremylt call ceedvectordestroy(v,err) 106*8980d4a7Sjeremylt call ceedvectordestroy(w,err) 107*8980d4a7Sjeremylt call ceedvectordestroy(qdata,err) 108*8980d4a7Sjeremylt call ceedqfunctiondestroy(qf_setup,err) 109*8980d4a7Sjeremylt call ceedqfunctiondestroy(qf_mass,err) 110*8980d4a7Sjeremylt call ceeddestroy(ceed,err) 111*8980d4a7Sjeremylt end 112*8980d4a7Sjeremylt!----------------------------------------------------------------------- 113