1!----------------------------------------------------------------------- 2! 3! Header with common subroutine 4! 5 include 't320-basis-f.h' 6!----------------------------------------------------------------------- 7 subroutine feval(x1,x2,val) 8 real*8 x1,x2,val 9 10 val=x1*x1+x2*x2+x1*x2+1 11 12 end 13!----------------------------------------------------------------------- 14 program test 15 implicit none 16 include 'ceed/fortran.h' 17 18 integer ceed,err 19 integer input,output,weights 20 integer p,q,d 21 parameter(p=6) 22 parameter(q=4) 23 parameter(d=2) 24 25 real*8 qref(d*q) 26 real*8 qweight(q) 27 real*8 interp(p*q) 28 real*8 grad(d*p*q) 29 real*8 xr(d*p) 30 real*8 iinput(p) 31 real*8 ooutput(q) 32 real*8 wweights(q) 33 real*8 val,diff 34 real*8 x1,x2 35 integer*8 ioffset,offset1,offset2 36 37 integer b,i 38 39 character arg*32 40 41 xr=(/0.0d0,5.0d-1,1.0d0,0.0d0,5.0d-1,0.0d0,0.0d0,0.0d0,0.0d0,5.0d-1,& 42 & 5.0d-1,1.0d0/) 43 44 call getarg(1,arg) 45 46 call buildmats(qref,qweight,interp,grad) 47 48 call ceedinit(trim(arg)//char(0),ceed,err) 49 50 call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,& 51 & b,err) 52 53 do i=1,p 54 x1=xr(0*p+i) 55 x2=xr(1*p+i) 56 call feval(x1,x2,val) 57 iinput(i)=val 58 enddo 59 60 call ceedvectorcreate(ceed,p,input,err) 61 ioffset=0 62 call ceedvectorsetarray(input,ceed_mem_host,ceed_use_pointer,iinput,& 63 & ioffset,err) 64 call ceedvectorcreate(ceed,q,output,err) 65 call ceedvectorsetvalue(output,0.d0,err) 66 call ceedvectorcreate(ceed,q,weights,err) 67 call ceedvectorsetvalue(weights,0.d0,err) 68 69 call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_interp,input,output,& 70 & err) 71 call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_weight,& 72 & ceed_vector_none,weights,err) 73 74 call ceedvectorgetarrayread(output,ceed_mem_host,ooutput,offset1,err) 75 call ceedvectorgetarrayread(weights,ceed_mem_host,wweights,offset2,err) 76 val=0 77 do i=1,q 78 val=val+ooutput(i+offset1)*wweights(i+offset2) 79 enddo 80 call ceedvectorrestorearrayread(output,ooutput,offset1,err) 81 call ceedvectorrestorearrayread(weights,wweights,offset2,err) 82 83 diff=val-17.d0/24.d0 84 if (abs(diff)>1.0d-10) then 85! LCOV_EXCL_START 86 write(*,'(A,I1,A,F12.8,A,F12.8)')'[',i,'] ',val,' != ',17.d0/24.d0 87! LCOV_EXCL_STOP 88 endif 89 90 call ceedvectordestroy(input,err) 91 call ceedvectordestroy(output,err) 92 call ceedvectordestroy(weights,err) 93 call ceedbasisdestroy(b,err) 94 call ceeddestroy(ceed,err) 95 96 end 97!----------------------------------------------------------------------- 98