18980d4a7Sjeremylt!----------------------------------------------------------------------- 252bfb9bbSJeremy L Thompson subroutine eval(dimn,x,rslt) 352bfb9bbSJeremy L Thompson integer dimn 452bfb9bbSJeremy L Thompson real*8 x(1) 552bfb9bbSJeremy L Thompson real*8 rslt 652bfb9bbSJeremy L Thompson real*8 center 78980d4a7Sjeremylt 852bfb9bbSJeremy L Thompson integer d 98980d4a7Sjeremylt 1052bfb9bbSJeremy L Thompson rslt=1 1152bfb9bbSJeremy L Thompson center=0.1 128980d4a7Sjeremylt 1352bfb9bbSJeremy L Thompson do d=1,dimn 1452bfb9bbSJeremy L Thompson rslt=rslt*tanh(x(d)-center) 1552bfb9bbSJeremy L Thompson center=center+0.1 1652bfb9bbSJeremy L Thompson enddo 178980d4a7Sjeremylt 188980d4a7Sjeremylt end 198980d4a7Sjeremylt!----------------------------------------------------------------------- 208980d4a7Sjeremylt program test 211f9a83abSJed Brown implicit none 22ec3da8bcSJed Brown include 'ceed/fortran.h' 238980d4a7Sjeremylt 248980d4a7Sjeremylt integer ceed,err 2552bfb9bbSJeremy L Thompson integer x,xq,u,uq 2652bfb9bbSJeremy L Thompson integer bxl,bul,bxg,bug 2752bfb9bbSJeremy L Thompson integer dimn,d 2852bfb9bbSJeremy L Thompson integer i 2952bfb9bbSJeremy L Thompson integer q 3052bfb9bbSJeremy L Thompson parameter(q=10) 3152bfb9bbSJeremy L Thompson integer maxdim 3252bfb9bbSJeremy L Thompson parameter(maxdim=3) 3352bfb9bbSJeremy L Thompson integer qdimmax 3452bfb9bbSJeremy L Thompson parameter(qdimmax=q**maxdim) 3552bfb9bbSJeremy L Thompson integer xdimmax 3652bfb9bbSJeremy L Thompson parameter(xdimmax=2**maxdim) 3752bfb9bbSJeremy L Thompson integer qdim,xdim 388980d4a7Sjeremylt 3952bfb9bbSJeremy L Thompson real*8 xx(xdimmax*maxdim) 4052bfb9bbSJeremy L Thompson real*8 xxx(maxdim) 4152bfb9bbSJeremy L Thompson real*8 xxq(qdimmax*maxdim) 4252bfb9bbSJeremy L Thompson real*8 uuq(qdimmax) 4352bfb9bbSJeremy L Thompson real*8 fx 4452bfb9bbSJeremy L Thompson integer*8 uqoffset,xoffset,offset1,offset2 458980d4a7Sjeremylt 468980d4a7Sjeremylt character arg*32 478980d4a7Sjeremylt 488980d4a7Sjeremylt call getarg(1,arg) 498980d4a7Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 508980d4a7Sjeremylt 5152bfb9bbSJeremy L Thompson do dimn=1,maxdim 5252bfb9bbSJeremy L Thompson qdim=q**dimn 5352bfb9bbSJeremy L Thompson xdim=2**dimn 548980d4a7Sjeremylt 5552bfb9bbSJeremy L Thompson do d=0,dimn-1 5652bfb9bbSJeremy L Thompson do i=1,xdim 57*3c9d155aSZach Atkins if ((mod(i-1,2**(d+1))/(2**(d))).ne.0) then 5852bfb9bbSJeremy L Thompson xx(d*xdim+i)=1 5952bfb9bbSJeremy L Thompson else 6052bfb9bbSJeremy L Thompson xx(d*xdim+i)=-1 6152bfb9bbSJeremy L Thompson endif 6252bfb9bbSJeremy L Thompson enddo 638980d4a7Sjeremylt enddo 648980d4a7Sjeremylt 6552bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,xdim*dimn,x,err) 6652bfb9bbSJeremy L Thompson xoffset=0 6752bfb9bbSJeremy L Thompson call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,xoffset,err) 6852bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,qdim*dimn,xq,err) 6952bfb9bbSJeremy L Thompson call ceedvectorsetvalue(xq,0.d0,err) 7052bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,qdim,u,err) 7152bfb9bbSJeremy L Thompson call ceedvectorsetvalue(u,0.d0,err) 7252bfb9bbSJeremy L Thompson call ceedvectorcreate(ceed,qdim,uq,err) 738980d4a7Sjeremylt 7452bfb9bbSJeremy L Thompson call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,q,& 7552bfb9bbSJeremy L Thompson & ceed_gauss_lobatto,bxl,err) 7652bfb9bbSJeremy L Thompson call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,q,q,& 7752bfb9bbSJeremy L Thompson & ceed_gauss_lobatto,bul,err) 788980d4a7Sjeremylt 7952bfb9bbSJeremy L Thompson call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 8052bfb9bbSJeremy L Thompson 8152bfb9bbSJeremy L Thompson call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 8252bfb9bbSJeremy L Thompson do i=1,qdim 8352bfb9bbSJeremy L Thompson do d=0,dimn-1 8452bfb9bbSJeremy L Thompson xxx(d+1)=xxq(d*qdim+i+offset1) 8552bfb9bbSJeremy L Thompson enddo 8652bfb9bbSJeremy L Thompson call eval(dimn,xxx,uuq(i)) 8752bfb9bbSJeremy L Thompson enddo 8852bfb9bbSJeremy L Thompson call ceedvectorrestorearrayread(xq,xxq,offset1,err) 8952bfb9bbSJeremy L Thompson uqoffset=0 9052bfb9bbSJeremy L Thompson call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,uuq,uqoffset,& 9152bfb9bbSJeremy L Thompson & err) 9252bfb9bbSJeremy L Thompson 9352bfb9bbSJeremy L Thompson call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,uq,u,err) 9452bfb9bbSJeremy L Thompson 9552bfb9bbSJeremy L Thompson call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,q,ceed_gauss,bxg,& 9652bfb9bbSJeremy L Thompson & err) 9752bfb9bbSJeremy L Thompson call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,q,q,ceed_gauss,bug,err) 9852bfb9bbSJeremy L Thompson 9952bfb9bbSJeremy L Thompson call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 10052bfb9bbSJeremy L Thompson call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,u,uq,err) 10152bfb9bbSJeremy L Thompson 10252bfb9bbSJeremy L Thompson call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 10352bfb9bbSJeremy L Thompson call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err) 10452bfb9bbSJeremy L Thompson do i=1,qdim 10552bfb9bbSJeremy L Thompson do d=0,dimn-1 10652bfb9bbSJeremy L Thompson xxx(d+1)=xxq(d*qdim+i+offset1) 10752bfb9bbSJeremy L Thompson enddo 10852bfb9bbSJeremy L Thompson call eval(dimn,xxx,fx) 10952bfb9bbSJeremy L Thompson 11052bfb9bbSJeremy L Thompson if(dabs(uuq(i+offset2)-fx) > 1.0D-4) then 111a2546046Sjeremylt! LCOV_EXCL_START 11252bfb9bbSJeremy L Thompson write(*,*) uuq(i+offset2),' not equal to ',fx,dimn,i 113de996c55Sjeremylt! LCOV_EXCL_STOP 1148980d4a7Sjeremylt endif 1158980d4a7Sjeremylt enddo 11652bfb9bbSJeremy L Thompson call ceedvectorrestorearrayread(xq,xxq,offset1,err) 1171f9a83abSJed Brown call ceedvectorrestorearrayread(uq,uuq,offset2,err) 1188980d4a7Sjeremylt 11952bfb9bbSJeremy L Thompson call ceedvectordestroy(x,err) 12052bfb9bbSJeremy L Thompson call ceedvectordestroy(xq,err) 12152bfb9bbSJeremy L Thompson call ceedvectordestroy(u,err) 12252bfb9bbSJeremy L Thompson call ceedvectordestroy(uq,err) 12352bfb9bbSJeremy L Thompson call ceedbasisdestroy(bxl,err) 12452bfb9bbSJeremy L Thompson call ceedbasisdestroy(bul,err) 12552bfb9bbSJeremy L Thompson call ceedbasisdestroy(bxg,err) 12652bfb9bbSJeremy L Thompson call ceedbasisdestroy(bug,err) 12752bfb9bbSJeremy L Thompson enddo 12852bfb9bbSJeremy L Thompson 1298980d4a7Sjeremylt call ceeddestroy(ceed,err) 1308980d4a7Sjeremylt end 1318980d4a7Sjeremylt!----------------------------------------------------------------------- 132