152bfb9bbSJeremy L Thompson!----------------------------------------------------------------------- 252bfb9bbSJeremy L Thompson! 352bfb9bbSJeremy L Thompson! Header with common subroutine 452bfb9bbSJeremy L Thompson! 552bfb9bbSJeremy L Thompson include 't320-basis-f.h' 652bfb9bbSJeremy L Thompson!----------------------------------------------------------------------- 752bfb9bbSJeremy L Thompson subroutine feval(x1,x2,val) 852bfb9bbSJeremy L Thompson real*8 x1,x2,val 952bfb9bbSJeremy L Thompson 1052bfb9bbSJeremy L Thompson val=x1*x1+x2*x2+x1*x2+1 1152bfb9bbSJeremy L Thompson 1252bfb9bbSJeremy L Thompson end 1352bfb9bbSJeremy L Thompson!----------------------------------------------------------------------- 1452bfb9bbSJeremy L Thompson program test 151f9a83abSJed Brown implicit none 16*ec3da8bcSJed Brown include 'ceed/fortran.h' 1752bfb9bbSJeremy L Thompson 1852bfb9bbSJeremy L Thompson integer ceed,err 1952bfb9bbSJeremy L Thompson integer input,output,weights 2052bfb9bbSJeremy L Thompson integer p,q,d 2152bfb9bbSJeremy L Thompson parameter(p=6) 2252bfb9bbSJeremy L Thompson parameter(q=4) 2352bfb9bbSJeremy L Thompson parameter(d=2) 2452bfb9bbSJeremy L Thompson 2552bfb9bbSJeremy L Thompson real*8 qref(d*q) 2652bfb9bbSJeremy L Thompson real*8 qweight(q) 2752bfb9bbSJeremy L Thompson real*8 interp(p*q) 2852bfb9bbSJeremy L Thompson real*8 grad(d*p*q) 2952bfb9bbSJeremy L Thompson real*8 xr(d*p) 3052bfb9bbSJeremy L Thompson real*8 iinput(p) 3152bfb9bbSJeremy L Thompson real*8 ooutput(q) 3252bfb9bbSJeremy L Thompson real*8 wweights(q) 3352bfb9bbSJeremy L Thompson real*8 val,diff 3452bfb9bbSJeremy L Thompson real*8 x1,x2 3552bfb9bbSJeremy L Thompson integer*8 ioffset,offset1,offset2 3652bfb9bbSJeremy L Thompson 371f9a83abSJed Brown integer b,i 3852bfb9bbSJeremy L Thompson 3952bfb9bbSJeremy L Thompson character arg*32 4052bfb9bbSJeremy L Thompson 4152bfb9bbSJeremy L Thompson xr=(/0.0d0,5.0d-1,1.0d0,0.0d0,5.0d-1,0.0d0,0.0d0,0.0d0,0.0d0,5.0d-1,& 4252bfb9bbSJeremy L Thompson & 5.0d-1,1.0d0/) 4352bfb9bbSJeremy L Thompson 4452bfb9bbSJeremy L Thompson call getarg(1,arg) 4552bfb9bbSJeremy L Thompson 4652bfb9bbSJeremy L Thompson call buildmats(qref,qweight,interp,grad) 4752bfb9bbSJeremy L Thompson 4852bfb9bbSJeremy L Thompson call ceedinit(trim(arg)//char(0),ceed,err) 4952bfb9bbSJeremy L Thompson 5052bfb9bbSJeremy L Thompson call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,& 5152bfb9bbSJeremy L Thompson & b,err) 5252bfb9bbSJeremy L Thompson 5352bfb9bbSJeremy L Thompson do i=1,p 5452bfb9bbSJeremy L Thompson x1=xr(0*p+i) 5552bfb9bbSJeremy L Thompson x2=xr(1*p+i) 5652bfb9bbSJeremy L Thompson call feval(x1,x2,val) 5752bfb9bbSJeremy L Thompson iinput(i)=val 5852bfb9bbSJeremy L Thompson enddo 5952bfb9bbSJeremy L Thompson 6052bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,p,input,err) 6152bfb9bbSJeremy L Thompson ioffset=0 6252bfb9bbSJeremy L Thompson call ceedvectorsetarray(input,ceed_mem_host,ceed_use_pointer,iinput,& 6352bfb9bbSJeremy L Thompson & ioffset,err) 6452bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,q,output,err) 6552bfb9bbSJeremy L Thompson call ceedvectorsetvalue(output,0.d0,err) 6652bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,q,weights,err) 6752bfb9bbSJeremy L Thompson call ceedvectorsetvalue(weights,0.d0,err) 6852bfb9bbSJeremy L Thompson 6952bfb9bbSJeremy L Thompson call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_interp,input,output,& 7052bfb9bbSJeremy L Thompson & err) 71a7b7f929Sjeremylt call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_weight,& 72a7b7f929Sjeremylt & ceed_vector_none,weights,err) 7352bfb9bbSJeremy L Thompson 7452bfb9bbSJeremy L Thompson call ceedvectorgetarrayread(output,ceed_mem_host,ooutput,offset1,err) 7552bfb9bbSJeremy L Thompson call ceedvectorgetarrayread(weights,ceed_mem_host,wweights,offset2,err) 7652bfb9bbSJeremy L Thompson val=0 7752bfb9bbSJeremy L Thompson do i=1,q 7852bfb9bbSJeremy L Thompson val=val+ooutput(i+offset1)*wweights(i+offset2) 7952bfb9bbSJeremy L Thompson enddo 8052bfb9bbSJeremy L Thompson call ceedvectorrestorearrayread(output,ooutput,offset1,err) 8152bfb9bbSJeremy L Thompson call ceedvectorrestorearrayread(weights,wweights,offset2,err) 8252bfb9bbSJeremy L Thompson 8352bfb9bbSJeremy L Thompson diff=val-17.d0/24.d0 8452bfb9bbSJeremy L Thompson if (abs(diff)>1.0d-10) then 8552bfb9bbSJeremy L Thompson! LCOV_EXCL_START 8652bfb9bbSJeremy L Thompson write(*,'(A,I1,A,F12.8,A,F12.8)')'[',i,'] ',val,' != ',17.d0/24.d0 8752bfb9bbSJeremy L Thompson! LCOV_EXCL_STOP 8852bfb9bbSJeremy L Thompson endif 8952bfb9bbSJeremy L Thompson 9052bfb9bbSJeremy L Thompson call ceedvectordestroy(input,err) 9152bfb9bbSJeremy L Thompson call ceedvectordestroy(output,err) 9252bfb9bbSJeremy L Thompson call ceedvectordestroy(weights,err) 9352bfb9bbSJeremy L Thompson call ceedbasisdestroy(b,err) 9452bfb9bbSJeremy L Thompson call ceeddestroy(ceed,err) 9552bfb9bbSJeremy L Thompson 9652bfb9bbSJeremy L Thompson end 9752bfb9bbSJeremy L Thompson!----------------------------------------------------------------------- 98