18980d4a7Sjeremylt!----------------------------------------------------------------------- 28980d4a7Sjeremylt! 38980d4a7Sjeremylt! Header with common subroutine 48980d4a7Sjeremylt! 58980d4a7Sjeremylt include 't310-basis-f.h' 68980d4a7Sjeremylt!----------------------------------------------------------------------- 78980d4a7Sjeremylt subroutine feval(x1,x2,val) 88980d4a7Sjeremylt real*8 x1,x2,val 98980d4a7Sjeremylt 108980d4a7Sjeremylt val=x1*x1+x2*x2+x1*x2+1 118980d4a7Sjeremylt 128980d4a7Sjeremylt end 138980d4a7Sjeremylt!----------------------------------------------------------------------- 148980d4a7Sjeremylt subroutine dfeval(x1,x2,val) 158980d4a7Sjeremylt real*8 x1,x2,val 168980d4a7Sjeremylt 178980d4a7Sjeremylt val=2*x1+x2 188980d4a7Sjeremylt 198980d4a7Sjeremylt end 208980d4a7Sjeremylt!----------------------------------------------------------------------- 218980d4a7Sjeremylt program test 228980d4a7Sjeremylt 238980d4a7Sjeremylt include 'ceedf.h' 248980d4a7Sjeremylt 258980d4a7Sjeremylt integer ceed,err 268980d4a7Sjeremylt integer input,output 278980d4a7Sjeremylt integer p,q,d 288980d4a7Sjeremylt parameter(p=6) 298980d4a7Sjeremylt parameter(q=4) 308980d4a7Sjeremylt parameter(d=2) 318980d4a7Sjeremylt 328980d4a7Sjeremylt real*8 qref(d*q) 338980d4a7Sjeremylt real*8 qweight(q) 348980d4a7Sjeremylt real*8 interp(p*q) 358980d4a7Sjeremylt real*8 grad(d*p*q) 368980d4a7Sjeremylt real*8 xq(d*q) 378980d4a7Sjeremylt real*8 xr(d*p) 388980d4a7Sjeremylt real*8 iinput(p) 398980d4a7Sjeremylt real*8 ooutput(d*q) 408980d4a7Sjeremylt real*8 val,diff 418980d4a7Sjeremylt real*8 x1,x2 42c8b9fe72Sjeremylt integer*8 ioffset,ooffset 438980d4a7Sjeremylt 448980d4a7Sjeremylt integer b 458980d4a7Sjeremylt 468980d4a7Sjeremylt character arg*32 478980d4a7Sjeremylt 488980d4a7Sjeremylt xq=(/2.d-1,6.d-1,1.d0/3.d0,2.d-1,2.d-1,2.d-1, 1.d0/3.d0,6.d-1/) 498980d4a7Sjeremylt xr=(/0.d0,5.d-1,1.d0,0.d0,5.d-1,0.d0,0.d0,0.d0, 0.d0,5.d-1,5.d-1,1.d0/) 508980d4a7Sjeremylt 518980d4a7Sjeremylt call getarg(1,arg) 528980d4a7Sjeremylt 538980d4a7Sjeremylt call buildmats(qref,qweight,interp,grad) 548980d4a7Sjeremylt 558980d4a7Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 568980d4a7Sjeremylt 578980d4a7Sjeremylt call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,& 588980d4a7Sjeremylt & b,err) 598980d4a7Sjeremylt 608980d4a7Sjeremylt do i=1,p 618980d4a7Sjeremylt x1=xr(0*p+i) 628980d4a7Sjeremylt x2=xr(1*p+i) 638980d4a7Sjeremylt call feval(x1,x2,val) 648980d4a7Sjeremylt iinput(i)=val 658980d4a7Sjeremylt enddo 668980d4a7Sjeremylt 678980d4a7Sjeremylt call ceedvectorcreate(ceed,p,input,err) 68c8b9fe72Sjeremylt ioffset=0 69c8b9fe72Sjeremylt call ceedvectorsetarray(input,ceed_mem_host,ceed_use_pointer,iinput,& 70c8b9fe72Sjeremylt & ioffset,err) 718980d4a7Sjeremylt call ceedvectorcreate(ceed,q*d,output,err) 728980d4a7Sjeremylt call ceedvectorsetvalue(output,0.d0,err) 738980d4a7Sjeremylt 748980d4a7Sjeremylt call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_grad,input,output,err) 758980d4a7Sjeremylt 76c8b9fe72Sjeremylt call ceedvectorgetarrayread(output,ceed_mem_host,ooutput,ooffset,err) 778980d4a7Sjeremylt do i=1,q 788980d4a7Sjeremylt x1=xq(0*q+i) 798980d4a7Sjeremylt x2=xq(1*q+i) 808980d4a7Sjeremylt call dfeval(x1,x2,val) 81c8b9fe72Sjeremylt diff=val-ooutput(0*q+i+ooffset) 828980d4a7Sjeremylt if (abs(diff)>1.0d-10) then 83a2546046Sjeremylt! LCOV_EXCL_START 84c8b9fe72Sjeremylt write(*,'(A,I1,A,F12.8,A,F12.8)') '[',i,'] ',ooutput(i+ooffset),& 858980d4a7Sjeremylt & ' != ',val 86*de996c55Sjeremylt! LCOV_EXCL_STOP 878980d4a7Sjeremylt endif 888980d4a7Sjeremylt call dfeval(x2,x1,val) 89c8b9fe72Sjeremylt diff=val-ooutput(1*q+i+ooffset) 908980d4a7Sjeremylt if (abs(diff)>1.0d-10) then 91a2546046Sjeremylt! LCOV_EXCL_START 92c8b9fe72Sjeremylt write(*,'(A,I1,A,F12.8,A,F12.8)') '[',i,'] ',ooutput(i+ooffset),& 938980d4a7Sjeremylt & ' != ',val 94*de996c55Sjeremylt! LCOV_EXCL_STOP 958980d4a7Sjeremylt endif 968980d4a7Sjeremylt enddo 97c8b9fe72Sjeremylt call ceedvectorrestorearrayread(output,ooutput,ooffset,err) 988980d4a7Sjeremylt 998980d4a7Sjeremylt call ceedvectordestroy(input,err) 1008980d4a7Sjeremylt call ceedvectordestroy(output,err) 1018980d4a7Sjeremylt call ceedbasisdestroy(b,err) 1028980d4a7Sjeremylt call ceeddestroy(ceed,err) 1038980d4a7Sjeremylt 1048980d4a7Sjeremylt end 1058980d4a7Sjeremylt!----------------------------------------------------------------------- 106