1!----------------------------------------------------------------------- 2! 3! Header with common subroutine 4! 5 include 't320-basis-f.h' 6!----------------------------------------------------------------------- 7 subroutine setup(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 8& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 9! LCOV_EXCL_START 10 real*8 ctx 11 real*8 u1(1) 12 real*8 u2(1) 13 real*8 v1(1) 14 integer q,ierr 15 16 do i=1,q 17 v1(i)=u1(i)*(u2(i+q*0)*u2(i+q*3)-u2(i+q*1)*u2(i+q*2)) 18 enddo 19 20 ierr=0 21 end 22! LCOV_EXCL_STOP 23!----------------------------------------------------------------------- 24 subroutine mass(ctx,q,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,& 25& u15,u16,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,ierr) 26! LCOV_EXCL_START 27 real*8 ctx 28 real*8 u1(1) 29 real*8 u2(1) 30 real*8 v1(1) 31 integer q,ierr 32 33 do i=1,q 34 v1(i)=u2(i)*u1(i) 35 enddo 36 37 ierr=0 38 end 39! LCOV_EXCL_STOP 40!----------------------------------------------------------------------- 41 program test 42 implicit none 43 include 'ceedf.h' 44 45 integer ceed,err,i,j,k 46 integer stridesutet(3),stridesuhex(3) 47 integer erestrictxtet,erestrictutet,erestrictuitet,& 48& erestrictxhex,erestrictuhex,erestrictuihex 49 integer bxtet,butet,bxhex,buhex 50 integer qf_setuptet,qf_masstet,qf_setuphex,qf_masshex 51 integer op_setuptet,op_masstet,op_setuphex,op_masshex,op_setup,op_mass 52 integer qdatatet,qdatahex,x 53 integer nelemtet,nelemhex,ptet,phex,qtet,qhex,d 54 integer row,col,offset 55 parameter(nelemtet=6) 56 parameter(ptet=6) 57 parameter(qtet=4) 58 parameter(nelemhex=6) 59 parameter(phex=3) 60 parameter(qhex=4) 61 parameter(d=2) 62 integer ndofs,nqptstet,nqptshex,nqpts,nx,ny,nxtet,nytet,nxhex 63 parameter(nx=3) 64 parameter(ny=3) 65 parameter(nxtet=3) 66 parameter(nytet=1) 67 parameter(nxhex=3) 68 parameter(ndofs=(nx*2+1)*(ny*2+1)) 69 parameter(nqptstet=nelemtet*qtet) 70 parameter(nqptshex=nelemhex*qhex*qhex) 71 parameter(nqpts=nqptstet+nqptshex) 72 integer indxtet(nelemtet*ptet),indxhex(nelemhex*phex*phex) 73 74 real*8 qref(d*qtet) 75 real*8 qweight(qtet) 76 real*8 interp(ptet*qtet) 77 real*8 grad(d*ptet*qtet) 78 79 character arg*32 80 81! LCOV_EXCL_START 82 external setup,mass 83! LCOV_EXCL_STOP 84 85 call getarg(1,arg) 86 87 call ceedinit(trim(arg)//char(0),ceed,err) 88 89! DoF Coordinates 90 call ceedvectorcreate(ceed,d*ndofs,x,err) 91 92! Qdata Vectors 93 call ceedvectorcreate(ceed,nqptstet,qdatatet,err) 94 call ceedvectorcreate(ceed,nqptshex,qdatahex,err) 95 96! Tet Elements 97 do i=0,2 98 col=mod(i,nx) 99 row=i/nx 100 offset=col*2+row*(nx*2+1)*2 101 102 indxtet(i*2*ptet+1)=2+offset 103 indxtet(i*2*ptet+2)=9+offset 104 indxtet(i*2*ptet+3)=16+offset 105 indxtet(i*2*ptet+4)=1+offset 106 indxtet(i*2*ptet+5)=8+offset 107 indxtet(i*2*ptet+6)=0+offset 108 109 indxtet(i*2*ptet+7)=14+offset 110 indxtet(i*2*ptet+8)=7+offset 111 indxtet(i*2*ptet+9)=0+offset 112 indxtet(i*2*ptet+10)=15+offset 113 indxtet(i*2*ptet+11)=8+offset 114 indxtet(i*2*ptet+12)=16+offset 115 enddo 116 117! -- Restrictions 118 call ceedelemrestrictioncreate(ceed,nelemtet,ptet,d,ndofs,d*ndofs,& 119 & ceed_mem_host,ceed_use_pointer,indxtet,erestrictxtet,err) 120 121 call ceedelemrestrictioncreate(ceed,nelemtet,ptet,1,1,ndofs,& 122 & ceed_mem_host,ceed_use_pointer,indxtet,erestrictutet,err) 123 stridesutet=[1,qtet,qtet] 124 call ceedelemrestrictioncreatestrided(ceed,nelemtet,qtet,1,nqptstet,& 125 & stridesutet,erestrictuitet,err) 126 127! -- Bases 128 call buildmats(qref,qweight,interp,grad) 129 call ceedbasiscreateh1(ceed,ceed_triangle,d,ptet,qtet,interp,grad,qref,& 130 & qweight,bxtet,err) 131 call buildmats(qref,qweight,interp,grad) 132 call ceedbasiscreateh1(ceed,ceed_triangle,1,ptet,qtet,interp,grad,qref,& 133 & qweight,butet,err) 134 135! -- QFunctions 136 call ceedqfunctioncreateinterior(ceed,1,setup,& 137 &SOURCE_DIR& 138 &//'t510-operator.h:setup'//char(0),qf_setuptet,err) 139 call ceedqfunctionaddinput(qf_setuptet,'_weight',1,ceed_eval_weight,err) 140 call ceedqfunctionaddinput(qf_setuptet,'dx',d*d,ceed_eval_grad,err) 141 call ceedqfunctionaddoutput(qf_setuptet,'rho',1,ceed_eval_none,err) 142 143 call ceedqfunctioncreateinterior(ceed,1,mass,& 144 &SOURCE_DIR& 145 &//'t510-operator.h:mass'//char(0),qf_masstet,err) 146 call ceedqfunctionaddinput(qf_masstet,'rho',1,ceed_eval_none,err) 147 call ceedqfunctionaddinput(qf_masstet,'u',1,ceed_eval_interp,err) 148 call ceedqfunctionaddoutput(qf_masstet,'v',1,ceed_eval_interp,err) 149 150! -- Operators 151! ---- Setup Tet 152 call ceedoperatorcreate(ceed,qf_setuptet,ceed_qfunction_none,& 153 & ceed_qfunction_none,op_setuptet,err) 154 call ceedoperatorsetfield(op_setuptet,'_weight',& 155 & ceed_elemrestriction_none,bxtet,ceed_vector_none,err) 156 call ceedoperatorsetfield(op_setuptet,'dx',erestrictxtet,& 157 & bxtet,ceed_vector_active,err) 158 call ceedoperatorsetfield(op_setuptet,'rho',erestrictuitet,& 159 & ceed_basis_collocated,qdatatet,err) 160! ---- Mass Tet 161 call ceedoperatorcreate(ceed,qf_masstet,ceed_qfunction_none,& 162 & ceed_qfunction_none,op_masstet,err) 163 call ceedoperatorsetfield(op_masstet,'rho',erestrictuitet,& 164 & ceed_basis_collocated,qdatatet,err) 165 call ceedoperatorsetfield(op_masstet,'u',erestrictutet,& 166 & butet,ceed_vector_active,err) 167 call ceedoperatorsetfield(op_masstet,'v',erestrictutet,& 168 & butet,ceed_vector_active,err) 169 170! Hex Elements 171 do i=0,nelemhex-1 172 col=mod(i,nx) 173 row=i/nx 174 offset=(nxtet*2+1)*(nytet*2)*(1+row)+col*2 175 do j=0,phex-1 176 do k=0,phex-1 177 indxhex(phex*(phex*i+k)+j+1)=offset+k*(nxhex*2+1)+j 178 enddo 179 enddo 180 enddo 181 182! -- Restrictions 183 call ceedelemrestrictioncreate(ceed,nelemhex,phex*phex,d,ndofs,d*ndofs,& 184 & ceed_mem_host,ceed_use_pointer,indxhex,erestrictxhex,err) 185 186 call ceedelemrestrictioncreate(ceed,nelemhex,phex*phex,1,1,ndofs,& 187 & ceed_mem_host,ceed_use_pointer,indxhex,erestrictuhex,err) 188 stridesuhex=[1,qhex*qhex,qhex*qhex] 189 call ceedelemrestrictioncreatestrided(ceed,nelemhex,qhex*qhex,& 190 & 1,nqptshex,stridesuhex,erestrictuihex,err) 191 192! -- Bases 193 call ceedbasiscreatetensorh1lagrange(ceed,d,d,phex,qhex,ceed_gauss,& 194 & bxhex,err) 195 call ceedbasiscreatetensorh1lagrange(ceed,d,1,phex,qhex,ceed_gauss,& 196 & buhex,err) 197 198! -- QFunctions 199 call ceedqfunctioncreateinterior(ceed,1,setup,& 200 &SOURCE_DIR& 201 &//'t510-operator.h:setup'//char(0),qf_setuphex,err) 202 call ceedqfunctionaddinput(qf_setuphex,'_weight',1,ceed_eval_weight,err) 203 call ceedqfunctionaddinput(qf_setuphex,'dx',d*d,ceed_eval_grad,err) 204 call ceedqfunctionaddoutput(qf_setuphex,'rho',1,ceed_eval_none,err) 205 206 call ceedqfunctioncreateinterior(ceed,1,mass,& 207 &SOURCE_DIR& 208 &//'t510-operator.h:mass'//char(0),qf_masshex,err) 209 call ceedqfunctionaddinput(qf_masshex,'rho',1,ceed_eval_none,err) 210 call ceedqfunctionaddinput(qf_masshex,'u',1,ceed_eval_interp,err) 211 call ceedqfunctionaddoutput(qf_masshex,'v',1,ceed_eval_interp,err) 212 213! -- Operators 214! ---- Setup Hex 215 call ceedoperatorcreate(ceed,qf_setuphex,ceed_qfunction_none,& 216 & ceed_qfunction_none,op_setuphex,err) 217 call ceedoperatorsetfield(op_setuphex,'_weight',& 218 & ceed_elemrestriction_none,bxhex,ceed_vector_none,err) 219 call ceedoperatorsetfield(op_setuphex,'dx',erestrictxhex,& 220 & bxhex,ceed_vector_active,err) 221 call ceedoperatorsetfield(op_setuphex,'rho',erestrictuihex,& 222 & ceed_basis_collocated,qdatahex,err) 223! ---- Mass Hex 224 call ceedoperatorcreate(ceed,qf_masshex,ceed_qfunction_none,& 225 & ceed_qfunction_none,op_masshex,err) 226 call ceedoperatorsetfield(op_masshex,'rho',erestrictuihex,& 227 & ceed_basis_collocated,qdatahex,err) 228 call ceedoperatorsetfield(op_masshex,'u',erestrictuhex,& 229 & buhex,ceed_vector_active,err) 230 call ceedoperatorsetfield(op_masshex,'v',erestrictuhex,& 231 & buhex,ceed_vector_active,err) 232 233! Composite Operators 234 call ceedcompositeoperatorcreate(ceed,op_setup,err) 235 call ceedcompositeoperatoraddsub(op_setup,op_setuptet,err) 236 call ceedcompositeoperatoraddsub(op_setup,op_setuphex,err) 237 238 call ceedcompositeoperatorcreate(ceed,op_mass,err) 239 call ceedcompositeoperatoraddsub(op_mass,op_masstet,err) 240 call ceedcompositeoperatoraddsub(op_mass,op_masshex,err) 241 242! View 243 call ceedoperatorview(op_setup,err) 244 call ceedoperatorview(op_mass,err) 245 246! Cleanup 247 call ceedqfunctiondestroy(qf_setuptet,err) 248 call ceedqfunctiondestroy(qf_masstet,err) 249 call ceedoperatordestroy(op_setuptet,err) 250 call ceedoperatordestroy(op_masstet,err) 251 call ceedqfunctiondestroy(qf_setuphex,err) 252 call ceedqfunctiondestroy(qf_masshex,err) 253 call ceedoperatordestroy(op_setuphex,err) 254 call ceedoperatordestroy(op_masshex,err) 255 call ceedoperatordestroy(op_setup,err) 256 call ceedoperatordestroy(op_mass,err) 257 call ceedelemrestrictiondestroy(erestrictutet,err) 258 call ceedelemrestrictiondestroy(erestrictxtet,err) 259 call ceedelemrestrictiondestroy(erestrictuitet,err) 260 call ceedelemrestrictiondestroy(erestrictuhex,err) 261 call ceedelemrestrictiondestroy(erestrictxhex,err) 262 call ceedelemrestrictiondestroy(erestrictuihex,err) 263 call ceedbasisdestroy(butet,err) 264 call ceedbasisdestroy(bxtet,err) 265 call ceedbasisdestroy(buhex,err) 266 call ceedbasisdestroy(bxhex,err) 267 call ceedvectordestroy(x,err) 268 call ceedvectordestroy(qdatatet,err) 269 call ceedvectordestroy(qdatahex,err) 270 call ceeddestroy(ceed,err) 271 end 272!----------------------------------------------------------------------- 273