1!----------------------------------------------------------------------- 2 subroutine eval(dimn,x,rslt) 3 integer dimn 4 real*8 x(1) 5 real*8 rslt 6 real*8 center 7 8 integer d 9 10 rslt=1 11 center=0.1 12 13 do d=1,dimn 14 rslt=rslt*tanh(x(d)-center) 15 center=center+0.1 16 enddo 17 18 end 19!----------------------------------------------------------------------- 20 program test 21 implicit none 22 include 'ceed/fortran.h' 23 24 integer ceed,err 25 integer x,xq,u,uq 26 integer bxl,bul,bxg,bug 27 integer dimn,d 28 integer i 29 integer q 30 parameter(q=10) 31 integer maxdim 32 parameter(maxdim=3) 33 integer qdimmax 34 parameter(qdimmax=q**maxdim) 35 integer xdimmax 36 parameter(xdimmax=2**maxdim) 37 integer qdim,xdim 38 39 real*8 xx(xdimmax*maxdim) 40 real*8 xxx(maxdim) 41 real*8 xxq(qdimmax*maxdim) 42 real*8 uuq(qdimmax) 43 real*8 fx 44 integer*8 uqoffset,xoffset,offset1,offset2 45 46 character arg*32 47 48 call getarg(1,arg) 49 call ceedinit(trim(arg)//char(0),ceed,err) 50 51 do dimn=1,maxdim 52 qdim=q**dimn 53 xdim=2**dimn 54 55 do d=0,dimn-1 56 do i=1,xdim 57 if ((mod(i-1,2**(dimn-d))/(2**(dimn-d-1))).ne.0) then 58 xx(d*xdim+i)=1 59 else 60 xx(d*xdim+i)=-1 61 endif 62 enddo 63 enddo 64 65 call ceedvectorcreate(ceed,xdim*dimn,x,err) 66 xoffset=0 67 call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,xoffset,err) 68 call ceedvectorcreate(ceed,qdim*dimn,xq,err) 69 call ceedvectorsetvalue(xq,0.d0,err) 70 call ceedvectorcreate(ceed,qdim,u,err) 71 call ceedvectorsetvalue(u,0.d0,err) 72 call ceedvectorcreate(ceed,qdim,uq,err) 73 74 call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,q,& 75 & ceed_gauss_lobatto,bxl,err) 76 call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,q,q,& 77 & ceed_gauss_lobatto,bul,err) 78 79 call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 80 81 call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 82 do i=1,qdim 83 do d=0,dimn-1 84 xxx(d+1)=xxq(d*qdim+i+offset1) 85 enddo 86 call eval(dimn,xxx,uuq(i)) 87 enddo 88 call ceedvectorrestorearrayread(xq,xxq,offset1,err) 89 uqoffset=0 90 call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,uuq,uqoffset,& 91 & err) 92 93 call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,uq,u,err) 94 95 call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,q,ceed_gauss,bxg,& 96 & err) 97 call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,q,q,ceed_gauss,bug,err) 98 99 call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,x,xq,err) 100 call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,u,uq,err) 101 102 call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err) 103 call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err) 104 do i=1,qdim 105 do d=0,dimn-1 106 xxx(d+1)=xxq(d*qdim+i+offset1) 107 enddo 108 call eval(dimn,xxx,fx) 109 110 if(dabs(uuq(i+offset2)-fx) > 1.0D-4) then 111! LCOV_EXCL_START 112 write(*,*) uuq(i+offset2),' not equal to ',fx,dimn,i 113! LCOV_EXCL_STOP 114 endif 115 enddo 116 call ceedvectorrestorearrayread(xq,xxq,offset1,err) 117 call ceedvectorrestorearrayread(uq,uuq,offset2,err) 118 119 call ceedvectordestroy(x,err) 120 call ceedvectordestroy(xq,err) 121 call ceedvectordestroy(u,err) 122 call ceedvectordestroy(uq,err) 123 call ceedbasisdestroy(bxl,err) 124 call ceedbasisdestroy(bul,err) 125 call ceedbasisdestroy(bxg,err) 126 call ceedbasisdestroy(bug,err) 127 enddo 128 129 call ceeddestroy(ceed,err) 130 end 131!----------------------------------------------------------------------- 132