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 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 call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,err) 46 call ceedvectorcreate(ceed,q,xq,err) 47 call ceedvectorsetvalue(xq,0.d0,err) 48 call ceedvectorcreate(ceed,q,u,err) 49 call ceedvectorsetvalue(u,0.d0,err) 50 call ceedvectorcreate(ceed,q,uq,err) 51 call ceedvectorsetvalue(uq,0.d0,err) 52 53 call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss_lobatto,& 54 & bxl,err) 55 call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss_lobatto,& 56 & bul,err) 57 58 call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 59 60 call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 61 do i=1,q 62 call polyeval(xxq(i+offset1),6,p,uuq(i)) 63 enddo 64 call ceedvectorrestorearrayread(xq,xxq,offset1,err) 65 call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,uuq,err) 66 67 call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,uq,u,err) 68 69 call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bxg,err) 70 call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss,bug,err) 71 72 call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 73 call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,u,uq,err) 74 75 call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 76 call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err) 77 do i=1,q 78 call polyeval(xxq(i+offset1),6,p,px) 79 if (abs(uuq(i+offset2)-px) > 1e-14) then 80 write(*,*) uuq(i+offset2),' not eqaul to ',px,'=p(',xxq(i+offset1),')' 81 endif 82 enddo 83 call ceedvectorrestorearrayread(xq,xxq,offset1,err) 84 call ceedvectorrestorearrayread(uq,uuq,offest2,err) 85 86 call ceedvectordestroy(x,err) 87 call ceedvectordestroy(xq,err) 88 call ceedvectordestroy(u,err) 89 call ceedvectordestroy(uq,err) 90 call ceedbasisdestroy(bxl,err) 91 call ceedbasisdestroy(bul,err) 92 call ceedbasisdestroy(bxg,err) 93 call ceedbasisdestroy(bug,err) 94 call ceeddestroy(ceed,err) 95 end 96!----------------------------------------------------------------------- 97