18980d4a7Sjeremylt!----------------------------------------------------------------------- 28980d4a7Sjeremylt subroutine setup(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 38980d4a7Sjeremylt& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 48980d4a7Sjeremylt real*8 ctx(1) 58980d4a7Sjeremylt real*8 u1(8) 68980d4a7Sjeremylt real*8 v1(8) 78980d4a7Sjeremylt integer q,ierr 88980d4a7Sjeremylt 98980d4a7Sjeremylt do i=1,q 108980d4a7Sjeremylt v1(i)=u1(i) 118980d4a7Sjeremylt enddo 128980d4a7Sjeremylt 138980d4a7Sjeremylt ierr=0 148980d4a7Sjeremylt end 158980d4a7Sjeremylt!----------------------------------------------------------------------- 168980d4a7Sjeremylt subroutine mass(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 178980d4a7Sjeremylt& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 188980d4a7Sjeremylt real*8 ctx(1) 198980d4a7Sjeremylt real*8 u1(8) 208980d4a7Sjeremylt real*8 u2(8) 218980d4a7Sjeremylt real*8 v1(8) 228980d4a7Sjeremylt integer q,ierr 238980d4a7Sjeremylt 248980d4a7Sjeremylt do i=1,q 258980d4a7Sjeremylt v1(i)=u1(i)*u2(i) 268980d4a7Sjeremylt enddo 278980d4a7Sjeremylt 288980d4a7Sjeremylt ierr=0 298980d4a7Sjeremylt end 308980d4a7Sjeremylt!----------------------------------------------------------------------- 318980d4a7Sjeremylt program test 328980d4a7Sjeremylt 338980d4a7Sjeremylt include 'ceedf.h' 348980d4a7Sjeremylt 358980d4a7Sjeremylt integer ceed,err 368980d4a7Sjeremylt integer qdata,w,u,v 378980d4a7Sjeremylt integer qf_setup,qf_mass 388980d4a7Sjeremylt integer q,i 398980d4a7Sjeremylt parameter(q=8) 408980d4a7Sjeremylt real*8 ww(q) 418980d4a7Sjeremylt real*8 uu(q) 428980d4a7Sjeremylt real*8 vv(q) 438980d4a7Sjeremylt real*8 vvv(q) 448980d4a7Sjeremylt real*8 x 458980d4a7Sjeremylt character arg*32 46*c8b9fe72Sjeremylt integer*8 uoffset,voffset,woffset 478980d4a7Sjeremylt 488980d4a7Sjeremylt external setup,mass 498980d4a7Sjeremylt 508980d4a7Sjeremylt call getarg(1,arg) 518980d4a7Sjeremylt call ceedinit(trim(arg)//char(0),ceed,err) 528980d4a7Sjeremylt 538980d4a7Sjeremylt call ceedqfunctioncreateinterior(ceed,1,setup,& 548980d4a7Sjeremylt &__FILE__& 558980d4a7Sjeremylt &//':setup'//char(0),qf_setup,err) 568980d4a7Sjeremylt call ceedqfunctionaddinput(qf_setup,'w', 1,ceed_eval_interp,err) 578980d4a7Sjeremylt call ceedqfunctionaddoutput(qf_setup,'qdata',1,ceed_eval_interp,err) 588980d4a7Sjeremylt 598980d4a7Sjeremylt call ceedqfunctioncreateinterior(ceed,1,mass,& 608980d4a7Sjeremylt &__FILE__& 618980d4a7Sjeremylt &//':mass'//char(0),qf_mass,err) 628980d4a7Sjeremylt call ceedqfunctionaddinput(qf_mass,'qdata',1,ceed_eval_interp,err) 638980d4a7Sjeremylt call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err) 648980d4a7Sjeremylt call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err) 658980d4a7Sjeremylt 668980d4a7Sjeremylt do i=0,q-1 678980d4a7Sjeremylt x=2.0*i/(q-1)-1 688980d4a7Sjeremylt ww(i+1)=1-x*x 698980d4a7Sjeremylt uu(i+1)=2+3*x+5*x*x 708980d4a7Sjeremylt vvv(i+1)=ww(i+1)*uu(i+1) 718980d4a7Sjeremylt enddo 728980d4a7Sjeremylt 738980d4a7Sjeremylt call ceedvectorcreate(ceed,q,w,err) 74*c8b9fe72Sjeremylt woffset=0 75*c8b9fe72Sjeremylt call ceedvectorsetarray(w,ceed_mem_host,ceed_use_pointer,ww,woffset,err) 768980d4a7Sjeremylt call ceedvectorcreate(ceed,q,u,err) 77*c8b9fe72Sjeremylt uoffset=0 78*c8b9fe72Sjeremylt call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,uoffset,err) 798980d4a7Sjeremylt call ceedvectorcreate(ceed,q,v,err) 808980d4a7Sjeremylt call ceedvectorsetvalue(v,0.d0,err) 818980d4a7Sjeremylt call ceedvectorcreate(ceed,q,qdata,err) 828980d4a7Sjeremylt call ceedvectorsetvalue(qdata,0.d0,err) 838980d4a7Sjeremylt 848980d4a7Sjeremylt call ceedqfunctionapply(qf_setup,q,w,ceed_null,ceed_null,ceed_null,& 858980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 868980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 878980d4a7Sjeremylt &qdata,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 888980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 898980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,err) 908980d4a7Sjeremylt 918980d4a7Sjeremylt call ceedqfunctionapply(qf_mass,q,u,qdata,ceed_null,ceed_null,& 928980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 938980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 948980d4a7Sjeremylt &v,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 958980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,& 968980d4a7Sjeremylt &ceed_null,ceed_null,ceed_null,ceed_null,err) 978980d4a7Sjeremylt 98*c8b9fe72Sjeremylt call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err) 998980d4a7Sjeremylt do i=1,q 100*c8b9fe72Sjeremylt if (abs(vv(i+voffset)-vvv(i)) > 1.0D-14) then 101*c8b9fe72Sjeremylt write(*,*) 'v(i)=',vv(i+voffset),', vv(i)=',vvv(i) 1028980d4a7Sjeremylt endif 1038980d4a7Sjeremylt enddo 104*c8b9fe72Sjeremylt call ceedvectorrestorearrayread(v,vv,voffset,err) 1058980d4a7Sjeremylt 1068980d4a7Sjeremylt call ceedvectordestroy(u,err) 1078980d4a7Sjeremylt call ceedvectordestroy(v,err) 1088980d4a7Sjeremylt call ceedvectordestroy(w,err) 1098980d4a7Sjeremylt call ceedvectordestroy(qdata,err) 1108980d4a7Sjeremylt call ceedqfunctiondestroy(qf_setup,err) 1118980d4a7Sjeremylt call ceedqfunctiondestroy(qf_mass,err) 1128980d4a7Sjeremylt call ceeddestroy(ceed,err) 1138980d4a7Sjeremylt end 1148980d4a7Sjeremylt!----------------------------------------------------------------------- 115