1!----------------------------------------------------------------------- 2! 3! Header with QFunctions 4! 5 include 't401-qfunction-f.h' 6!----------------------------------------------------------------------- 7 program test 8 implicit none 9 include 'ceed/fortran.h' 10 11 integer ceed,err 12 integer qdata,w,u,v 13 integer qf_setup,qf_mass 14 integer ctx 15 integer q,i 16 parameter(q=8) 17 real*8 ww(q) 18 real*8 uu(q) 19 real*8 vv(q) 20 real*8 vvv(q) 21 integer ctxsize 22 parameter(ctxsize=5) 23 real*8 ctxdata(5) 24 real*8 x 25 character arg*32 26 integer*8 uoffset,voffset,woffset,coffset 27 28 external setup,mass 29 30 ctxdata=(/1.d0,2.d0,3.d0,4.d0,5.d0/) 31 32 call getarg(1,arg) 33 call ceedinit(trim(arg)//char(0),ceed,err) 34 35 call ceedqfunctioncreateinterior(ceed,1,setup,& 36 &SOURCE_DIR& 37 &//'t401-qfunction.h:setup'//char(0),qf_setup,err) 38 call ceedqfunctionaddinput(qf_setup,'w', 1,ceed_eval_weight,err) 39 call ceedqfunctionaddoutput(qf_setup,'qdata',1,ceed_eval_none,err) 40 41 call ceedqfunctioncreateinterior(ceed,1,mass,& 42 &SOURCE_DIR& 43 &//'t401-qfunction.h:mass'//char(0),qf_mass,err) 44 call ceedqfunctionaddinput(qf_mass,'qdata',1,ceed_eval_none,err) 45 call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err) 46 call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err) 47 48 call ceedqfunctioncontextcreate(ceed,ctx,err) 49 coffset=0 50 call ceedqfunctioncontextsetdata(ctx,ceed_mem_host,ceed_use_pointer,ctxsize,& 51 & ctxdata,coffset,err) 52 call ceedqfunctionsetcontext(qf_mass,ctx,err) 53 54 do i=0,q-1 55 x=2.0*i/(q-1)-1 56 ww(i+1)=1-x*x 57 uu(i+1)=2+3*x+5*x*x 58 vvv(i+1)=ww(i+1)*uu(i+1) 59 enddo 60 61 call ceedvectorcreate(ceed,q,w,err) 62 woffset=0 63 call ceedvectorsetarray(w,ceed_mem_host,ceed_use_pointer,ww,woffset,err) 64 call ceedvectorcreate(ceed,q,u,err) 65 uoffset=0 66 call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,uoffset,err) 67 call ceedvectorcreate(ceed,q,v,err) 68 call ceedvectorsetvalue(v,0.d0,err) 69 call ceedvectorcreate(ceed,q,qdata,err) 70 call ceedvectorsetvalue(qdata,0.d0,err) 71 72 call ceedqfunctionapply(qf_setup,q,w,ceed_null,ceed_null,ceed_null,& 73 &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 74 &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 75 &qdata,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 76 &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 77 &ceed_null,ceed_null,ceed_null,ceed_null,err) 78 79 call ceedqfunctionapply(qf_mass,q,u,qdata,ceed_null,ceed_null,& 80 &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 81 &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 82 &v,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 83 &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 84 &ceed_null,ceed_null,ceed_null,ceed_null,err) 85 86 call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err) 87 do i=1,q 88 if (abs(vv(i+voffset)-ctxdata(5)*vvv(i)) > 1.0D-14) then 89! LCOV_EXCL_START 90 write(*,*) 'v(i)=',vv(i+voffset),', 5*vv(i)=',ctxdata(5)*vvv(i) 91! LCOV_EXCL_STOP 92 endif 93 enddo 94 call ceedvectorrestorearrayread(v,vv,voffset,err) 95 96 call ceedvectordestroy(u,err) 97 call ceedvectordestroy(v,err) 98 call ceedvectordestroy(w,err) 99 call ceedvectordestroy(qdata,err) 100 call ceedqfunctiondestroy(qf_setup,err) 101 call ceedqfunctiondestroy(qf_mass,err) 102 call ceedqfunctioncontextdestroy(ctx,err) 103 call ceeddestroy(ceed,err) 104 end 105!----------------------------------------------------------------------- 106