1!----------------------------------------------------------------------- 2 subroutine polyeval(x,n,p,uq) 3 real*8 x,y 4 integer n,i 5 real*8 p(1) 6 real*8 uq 7 8 y=p(n) 9 10 do i=n-1,1,-1 11 y=y*x+p(i) 12 enddo 13 14 uq=y 15 16 end 17!----------------------------------------------------------------------- 18 program test 19 20 include 'ceedf.h' 21 22 integer ceed,err 23 integer x,xq,u,uq 24 integer bxl,bul,bxg,bug 25 integer i 26 integer q 27 parameter(q=6) 28 29 real*8 p(6) 30 real*8 xx(2) 31 real*8 xxq(q) 32 real*8 uuq(q) 33 real*8 px 34 integer*8 uqoffset,xoffset,offset1,offset2 35 36 character arg*32 37 38 data p/1,2,3,4,5,6/ 39 data xx/-1,1/ 40 41 call getarg(1,arg) 42 call ceedinit(trim(arg)//char(0),ceed,err) 43 44 call ceedvectorcreate(ceed,2,x,err) 45 xoffset=0 46 call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,xoffset,err) 47 call ceedvectorcreate(ceed,q,xq,err) 48 call ceedvectorsetvalue(xq,0.d0,err) 49 call ceedvectorcreate(ceed,q,u,err) 50 call ceedvectorsetvalue(u,0.d0,err) 51 call ceedvectorcreate(ceed,q,uq,err) 52 call ceedvectorsetvalue(uq,0.d0,err) 53 54 call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss_lobatto,& 55 & bxl,err) 56 call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss_lobatto,& 57 & bul,err) 58 59 call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 60 61 call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 62 do i=1,q 63 call polyeval(xxq(i+offset1),6,p,uuq(i)) 64 enddo 65 call ceedvectorrestorearrayread(xq,xxq,offset1,err) 66 uqoffset=0 67 call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,uuq,uqoffset,& 68 & err) 69 70 call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,uq,u,err) 71 72 call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bxg,err) 73 call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss,bug,err) 74 75 call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 76 call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,u,uq,err) 77 78 call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 79 call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err) 80 do i=1,q 81 call polyeval(xxq(i+offset1),6,p,px) 82 if (abs(uuq(i+offset2)-px) > 1e-14) then 83! LCOV_EXCL_START 84 write(*,*) uuq(i+offset2),' not eqaul to ',px,'=p(',xxq(i+offset1),')' 85! LCOV_EXCL_STOP 86 endif 87 enddo 88 call ceedvectorrestorearrayread(xq,xxq,offset1,err) 89 call ceedvectorrestorearrayread(uq,uuq,offest2,err) 90 91 call ceedvectordestroy(x,err) 92 call ceedvectordestroy(xq,err) 93 call ceedvectordestroy(u,err) 94 call ceedvectordestroy(uq,err) 95 call ceedbasisdestroy(bxl,err) 96 call ceedbasisdestroy(bul,err) 97 call ceedbasisdestroy(bxg,err) 98 call ceedbasisdestroy(bug,err) 99 call ceeddestroy(ceed,err) 100 end 101!----------------------------------------------------------------------- 102