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