18980d4a7Sjeremylt!----------------------------------------------------------------------- 28980d4a7Sjeremylt subroutine polyeval(x,n,p,uq) 38980d4a7Sjeremylt real*8 x,y 48980d4a7Sjeremylt integer n,i 58980d4a7Sjeremylt real*8 p(1) 68980d4a7Sjeremylt real*8 uq 78980d4a7Sjeremylt 88980d4a7Sjeremylt y=p(n) 98980d4a7Sjeremylt 108980d4a7Sjeremylt do i=n-1,1,-1 118980d4a7Sjeremylt y=y*x+p(i) 128980d4a7Sjeremylt enddo 138980d4a7Sjeremylt 148980d4a7Sjeremylt uq=y 158980d4a7Sjeremylt 168980d4a7Sjeremylt end 178980d4a7Sjeremylt!----------------------------------------------------------------------- 188980d4a7Sjeremylt program test 198980d4a7Sjeremylt 208980d4a7Sjeremylt include 'ceedf.h' 218980d4a7Sjeremylt 228980d4a7Sjeremylt integer ceed,err 238980d4a7Sjeremylt integer x,xq,u,uq 248980d4a7Sjeremylt integer bxl,bul,bxg,bug 258980d4a7Sjeremylt integer i 268980d4a7Sjeremylt integer q 278980d4a7Sjeremylt parameter(q=6) 288980d4a7Sjeremylt 298980d4a7Sjeremylt real*8 p(6) 308980d4a7Sjeremylt real*8 xx(2) 318980d4a7Sjeremylt real*8 xxq(q) 328980d4a7Sjeremylt real*8 uuq(q) 338980d4a7Sjeremylt real*8 px 34*c8b9fe72Sjeremylt integer*8 uqoffset,xoffset,offset1,offset2 358980d4a7Sjeremylt 368980d4a7Sjeremylt character arg*32 378980d4a7Sjeremylt 388980d4a7Sjeremylt data p/1,2,3,4,5,6/ 398980d4a7Sjeremylt data xx/-1,1/ 408980d4a7Sjeremylt 418980d4a7Sjeremylt call getarg(1,arg) 428980d4a7Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 438980d4a7Sjeremylt 448980d4a7Sjeremylt call ceedvectorcreate(ceed,2,x,err) 45*c8b9fe72Sjeremylt xoffset=0 46*c8b9fe72Sjeremylt call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,xoffset,err) 478980d4a7Sjeremylt call ceedvectorcreate(ceed,q,xq,err) 488980d4a7Sjeremylt call ceedvectorsetvalue(xq,0.d0,err) 498980d4a7Sjeremylt call ceedvectorcreate(ceed,q,u,err) 508980d4a7Sjeremylt call ceedvectorsetvalue(u,0.d0,err) 518980d4a7Sjeremylt call ceedvectorcreate(ceed,q,uq,err) 528980d4a7Sjeremylt call ceedvectorsetvalue(uq,0.d0,err) 538980d4a7Sjeremylt 548980d4a7Sjeremylt call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss_lobatto,& 558980d4a7Sjeremylt & bxl,err) 568980d4a7Sjeremylt call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss_lobatto,& 578980d4a7Sjeremylt & bul,err) 588980d4a7Sjeremylt 598980d4a7Sjeremylt call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 608980d4a7Sjeremylt 618980d4a7Sjeremylt call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 628980d4a7Sjeremylt do i=1,q 638980d4a7Sjeremylt call polyeval(xxq(i+offset1),6,p,uuq(i)) 648980d4a7Sjeremylt enddo 658980d4a7Sjeremylt call ceedvectorrestorearrayread(xq,xxq,offset1,err) 66*c8b9fe72Sjeremylt uqoffset=0 67*c8b9fe72Sjeremylt call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,uuq,uqoffset,& 68*c8b9fe72Sjeremylt & err) 698980d4a7Sjeremylt 708980d4a7Sjeremylt call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,uq,u,err) 718980d4a7Sjeremylt 728980d4a7Sjeremylt call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bxg,err) 738980d4a7Sjeremylt call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss,bug,err) 748980d4a7Sjeremylt 758980d4a7Sjeremylt call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 768980d4a7Sjeremylt call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,u,uq,err) 778980d4a7Sjeremylt 788980d4a7Sjeremylt call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 798980d4a7Sjeremylt call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err) 808980d4a7Sjeremylt do i=1,q 818980d4a7Sjeremylt call polyeval(xxq(i+offset1),6,p,px) 828980d4a7Sjeremylt if (abs(uuq(i+offset2)-px) > 1e-14) then 838980d4a7Sjeremylt write(*,*) uuq(i+offset2),' not eqaul to ',px,'=p(',xxq(i+offset1),')' 848980d4a7Sjeremylt endif 858980d4a7Sjeremylt enddo 868980d4a7Sjeremylt call ceedvectorrestorearrayread(xq,xxq,offset1,err) 878980d4a7Sjeremylt call ceedvectorrestorearrayread(uq,uuq,offest2,err) 888980d4a7Sjeremylt 898980d4a7Sjeremylt call ceedvectordestroy(x,err) 908980d4a7Sjeremylt call ceedvectordestroy(xq,err) 918980d4a7Sjeremylt call ceedvectordestroy(u,err) 928980d4a7Sjeremylt call ceedvectordestroy(uq,err) 938980d4a7Sjeremylt call ceedbasisdestroy(bxl,err) 948980d4a7Sjeremylt call ceedbasisdestroy(bul,err) 958980d4a7Sjeremylt call ceedbasisdestroy(bxg,err) 968980d4a7Sjeremylt call ceedbasisdestroy(bug,err) 978980d4a7Sjeremylt call ceeddestroy(ceed,err) 988980d4a7Sjeremylt end 998980d4a7Sjeremylt!----------------------------------------------------------------------- 100