1 // Fortran interface 2 #include <ceed.h> 3 #include <ceed-impl.h> 4 #include <ceed-fortran-name.h> 5 6 #include <stdlib.h> 7 #include <string.h> 8 9 #define FORTRAN_REQUEST_IMMEDIATE -1 10 #define FORTRAN_REQUEST_ORDERED -2 11 #define FORTRAN_NULL -3 12 #define FORTRAN_BASIS_COLOCATED -1 13 #define FORTRAN_QDATA_NONE -1 14 #define FORTRAN_VECTOR_ACTIVE -1 15 #define FORTRAN_VECTOR_NONE -2 16 17 static Ceed *Ceed_dict = NULL; 18 static int Ceed_count = 0; 19 static int Ceed_n = 0; 20 static int Ceed_count_max = 0; 21 22 #define fCeedInit FORTRAN_NAME(ceedinit,CEEDINIT) 23 void fCeedInit(const char* resource, int *ceed, int *err) { 24 if (Ceed_count == Ceed_count_max) { 25 Ceed_count_max += Ceed_count_max/2 + 1; 26 CeedRealloc(Ceed_count_max, &Ceed_dict); 27 } 28 29 Ceed *ceed_ = &Ceed_dict[Ceed_count]; 30 *err = CeedInit(resource, ceed_); 31 32 if (*err == 0) { 33 *ceed = Ceed_count++; 34 Ceed_n++; 35 } 36 } 37 38 #define fCeedDestroy FORTRAN_NAME(ceeddestroy,CEEDDESTROY) 39 void fCeedDestroy(int *ceed, int *err) { 40 *err = CeedDestroy(&Ceed_dict[*ceed]); 41 42 if (*err == 0) { 43 Ceed_n--; 44 if (Ceed_n == 0) { 45 CeedFree(&Ceed_dict); 46 Ceed_count = 0; 47 Ceed_count_max = 0; 48 } 49 } 50 } 51 52 static CeedVector *CeedVector_dict = NULL; 53 static int CeedVector_count = 0; 54 static int CeedVector_n = 0; 55 static int CeedVector_count_max = 0; 56 57 #define fCeedVectorCreate FORTRAN_NAME(ceedvectorcreate,CEEDVECTORCREATE) 58 void fCeedVectorCreate(int *ceed, int *length, int *vec, int *err) { 59 if (CeedVector_count == CeedVector_count_max) { 60 CeedVector_count_max += CeedVector_count_max/2 + 1; 61 CeedRealloc(CeedVector_count_max, &CeedVector_dict); 62 } 63 64 CeedVector* vec_ = &CeedVector_dict[CeedVector_count]; 65 *err = CeedVectorCreate(Ceed_dict[*ceed], *length, vec_); 66 67 if (*err == 0) { 68 *vec = CeedVector_count++; 69 CeedVector_n++; 70 } 71 } 72 73 #define fCeedVectorSetArray FORTRAN_NAME(ceedvectorsetarray,CEEDVECTORSETARRAY) 74 void fCeedVectorSetArray(int *vec, int *memtype, int *copymode, 75 CeedScalar *array, int *err) { 76 *err = CeedVectorSetArray(CeedVector_dict[*vec], *memtype, *copymode, array); 77 } 78 79 #define fCeedVectorSetValue FORTRAN_NAME(ceedvectorsetvalue,CEEDVECTORSETVALUE) 80 void fCeedVectorSetValue(int *vec, CeedScalar *value, int *err) { 81 *err = CeedVectorSetValue(CeedVector_dict[*vec], *value); 82 } 83 84 #define fCeedVectorGetArray FORTRAN_NAME(ceedvectorgetarray,CEEDVECTORGETARRAY) 85 //TODO Need Fixing, double pointer 86 void fCeedVectorGetArray(int *vec, int *memtype, CeedScalar *array, int *err) { 87 CeedScalar *b; 88 CeedVector vec_ = CeedVector_dict[*vec]; 89 *err = CeedVectorGetArray(vec_, *memtype, &b); 90 if (*err == 0) 91 memcpy(array, b, sizeof(CeedScalar)*vec_->length); 92 } 93 94 #define fCeedVectorGetArrayRead \ 95 FORTRAN_NAME(ceedvectorgetarrayread,CEEDVECTORGETARRAYREAD) 96 //TODO Need Fixing, double pointer 97 void fCeedVectorGetArrayRead(int *vec, int *memtype, CeedScalar *array, 98 int *err) { 99 const CeedScalar *b; 100 *err = CeedVectorGetArrayRead(CeedVector_dict[*vec], *memtype, &b); 101 CeedVector vec_ = CeedVector_dict[*vec]; 102 if (*err == 0) 103 memcpy(array, b, sizeof(CeedScalar)*vec_->length); 104 } 105 106 #define fCeedVectorRestoreArray \ 107 FORTRAN_NAME(ceedvectorrestorearray,CEEDVECTORRESTOREARRAY) 108 void fCeedVectorRestoreArray(int *vec, CeedScalar *array, int *err) { 109 *err = CeedVectorRestoreArray(CeedVector_dict[*vec], &array); 110 } 111 112 #define fCeedVectorRestoreArrayRead \ 113 FORTRAN_NAME(ceedvectorrestorearrayread,CEEDVECTORRESTOREARRAYREAD) 114 void fCeedVectorRestoreArrayRead(int *vec, const CeedScalar *array, int *err) { 115 *err = CeedVectorRestoreArrayRead(CeedVector_dict[*vec], &array); 116 } 117 118 #define fCeedVectorView FORTRAN_NAME(ceedvectorview,CEEDVECTORVIEW) 119 void fCeedVectorView(int *vec, int *err) { 120 *err = CeedVectorView(CeedVector_dict[*vec], "%12.8f", stdout); 121 } 122 123 #define fCeedVectorDestroy FORTRAN_NAME(ceedvectordestroy,CEEDVECTORDESTROY) 124 void fCeedVectorDestroy(int *vec, int *err) { 125 *err = CeedVectorDestroy(&CeedVector_dict[*vec]); 126 127 if (*err == 0) { 128 CeedVector_n--; 129 if (CeedVector_n == 0) { 130 CeedFree(&CeedVector_dict); 131 CeedVector_count = 0; 132 CeedVector_count_max = 0; 133 } 134 } 135 } 136 137 static CeedElemRestriction *CeedElemRestriction_dict = NULL; 138 static int CeedElemRestriction_count = 0; 139 static int CeedElemRestriction_n = 0; 140 static int CeedElemRestriction_count_max = 0; 141 142 #define fCeedElemRestrictionCreate \ 143 FORTRAN_NAME(ceedelemrestrictioncreate, CEEDELEMRESTRICTIONCREATE) 144 void fCeedElemRestrictionCreate(int *ceed, int *nelements, 145 int *esize, int *ndof, int *ncomp, int *memtype, int *copymode, 146 const int *indices, int *elemrestriction, int *err) { 147 if (CeedElemRestriction_count == CeedElemRestriction_count_max) { 148 CeedElemRestriction_count_max += CeedElemRestriction_count_max/2 + 1; 149 CeedRealloc(CeedElemRestriction_count_max, &CeedElemRestriction_dict); 150 } 151 152 const int *indices_ = indices; 153 154 CeedElemRestriction *elemrestriction_ = 155 &CeedElemRestriction_dict[CeedElemRestriction_count]; 156 *err = CeedElemRestrictionCreate(Ceed_dict[*ceed], *nelements, *esize, *ndof, 157 *ncomp, 158 *memtype, *copymode, indices_, elemrestriction_); 159 160 if (*err == 0) { 161 *elemrestriction = CeedElemRestriction_count++; 162 CeedElemRestriction_n++; 163 } 164 } 165 166 #define fCeedElemRestrictionCreateIdentity \ 167 FORTRAN_NAME(ceedelemrestrictioncreateidentity, CEEDELEMRESTRICTIONCREATEIDENTITY) 168 void fCeedElemRestrictionCreateIdentity(int *ceed, int *nelements, 169 int *esize, int *ndof, int *ncomp, 170 int *elemrestriction, int *err) { 171 if (CeedElemRestriction_count == CeedElemRestriction_count_max) { 172 CeedElemRestriction_count_max += CeedElemRestriction_count_max/2 + 1; 173 CeedRealloc(CeedElemRestriction_count_max, &CeedElemRestriction_dict); 174 } 175 176 CeedElemRestriction *elemrestriction_ = 177 &CeedElemRestriction_dict[CeedElemRestriction_count]; 178 *err = CeedElemRestrictionCreateIdentity(Ceed_dict[*ceed], *nelements, *esize, 179 *ndof, 180 *ncomp, elemrestriction_); 181 182 if (*err == 0) { 183 *elemrestriction = CeedElemRestriction_count++; 184 CeedElemRestriction_n++; 185 } 186 } 187 188 #define fCeedElemRestrictionCreateBlocked \ 189 FORTRAN_NAME(ceedelemrestrictioncreateblocked,CEEDELEMRESTRICTIONCREATEBLOCKED) 190 void fCeedElemRestrictionCreateBlocked(int *ceed, int *nelements, 191 int *esize, int *blocksize, int *ndof, int *ncomp, 192 int *mtype, int *cmode, 193 int *blkindices, int *elemrestriction, int *err) { 194 195 if (CeedElemRestriction_count == CeedElemRestriction_count_max) { 196 CeedElemRestriction_count_max += CeedElemRestriction_count_max/2 + 1; 197 CeedRealloc(CeedElemRestriction_count_max, &CeedElemRestriction_dict); 198 } 199 200 CeedElemRestriction *elemrestriction_ = 201 &CeedElemRestriction_dict[CeedElemRestriction_count]; 202 *err = CeedElemRestrictionCreateBlocked(Ceed_dict[*ceed], *nelements, *esize, 203 *blocksize, *ndof, *ncomp, *mtype, *cmode, blkindices, 204 elemrestriction_); 205 206 if (*err == 0) { 207 *elemrestriction = CeedElemRestriction_count++; 208 CeedElemRestriction_n++; 209 } 210 } 211 212 static CeedRequest *CeedRequest_dict = NULL; 213 static int CeedRequest_count = 0; 214 static int CeedRequest_n = 0; 215 static int CeedRequest_count_max = 0; 216 217 #define fCeedElemRestrictionApply \ 218 FORTRAN_NAME(ceedelemrestrictionapply,CEEDELEMRESTRICTIONAPPLY) 219 void fCeedElemRestrictionApply(int *elemr, int *tmode, int *lmode, 220 int *uvec, int *ruvec, int *rqst, int *err) { 221 int createRequest = 1; 222 // Check if input is CEED_REQUEST_ORDERED(-2) or CEED_REQUEST_IMMEDIATE(-1) 223 if (*rqst == FORTRAN_REQUEST_IMMEDIATE || *rqst == FORTRAN_REQUEST_ORDERED) 224 createRequest = 0; 225 226 if (createRequest && CeedRequest_count == CeedRequest_count_max) { 227 CeedRequest_count_max += CeedRequest_count_max/2 + 1; 228 CeedRealloc(CeedRequest_count_max, &CeedRequest_dict); 229 } 230 231 CeedRequest *rqst_; 232 if (*rqst == FORTRAN_REQUEST_IMMEDIATE) rqst_ = CEED_REQUEST_IMMEDIATE; 233 else if (*rqst == FORTRAN_REQUEST_ORDERED ) rqst_ = CEED_REQUEST_ORDERED; 234 else rqst_ = &CeedRequest_dict[CeedRequest_count]; 235 236 *err = CeedElemRestrictionApply(CeedElemRestriction_dict[*elemr], *tmode, 237 *lmode, CeedVector_dict[*uvec], CeedVector_dict[*ruvec], rqst_); 238 239 if (*err == 0 && createRequest) { 240 *rqst = CeedRequest_count++; 241 CeedRequest_n++; 242 } 243 } 244 245 #define fCeedRequestWait FORTRAN_NAME(ceedrequestwait, CEEDREQUESTWAIT) 246 void fCeedRequestWait(int *rqst, int *err) { 247 // TODO Uncomment this once CeedRequestWait is implemented 248 //*err = CeedRequestWait(&CeedRequest_dict[*rqst]); 249 250 if (*err == 0) { 251 CeedRequest_n--; 252 if (CeedRequest_n == 0) { 253 CeedFree(&CeedRequest_dict); 254 CeedRequest_count = 0; 255 CeedRequest_count_max = 0; 256 } 257 } 258 } 259 260 #define fCeedElemRestrictionDestroy \ 261 FORTRAN_NAME(ceedelemrestrictiondestroy,CEEDELEMRESTRICTIONDESTROY) 262 void fCeedElemRestrictionDestroy(int *elem, int *err) { 263 *err = CeedElemRestrictionDestroy(&CeedElemRestriction_dict[*elem]); 264 265 if (*err == 0) { 266 CeedElemRestriction_n--; 267 if (CeedElemRestriction_n == 0) { 268 CeedFree(&CeedElemRestriction_dict); 269 CeedElemRestriction_count = 0; 270 CeedElemRestriction_count_max = 0; 271 } 272 } 273 } 274 275 static CeedBasis *CeedBasis_dict = NULL; 276 static int CeedBasis_count = 0; 277 static int CeedBasis_n = 0; 278 static int CeedBasis_count_max = 0; 279 280 #define fCeedBasisCreateTensorH1Lagrange \ 281 FORTRAN_NAME(ceedbasiscreatetensorh1lagrange, CEEDBASISCREATETENSORH1LAGRANGE) 282 void fCeedBasisCreateTensorH1Lagrange(int *ceed, int *dim, 283 int *ndof, int *P, int *Q, int *quadmode, int *basis, 284 int *err) { 285 if (CeedBasis_count == CeedBasis_count_max) { 286 CeedBasis_count_max += CeedBasis_count_max/2 + 1; 287 CeedRealloc(CeedBasis_count_max, &CeedBasis_dict); 288 } 289 290 *err = CeedBasisCreateTensorH1Lagrange(Ceed_dict[*ceed], *dim, *ndof, *P, *Q, 291 *quadmode, &CeedBasis_dict[CeedBasis_count]); 292 293 if (*err == 0) { 294 *basis = CeedBasis_count++; 295 CeedBasis_n++; 296 } 297 } 298 299 #define fCeedBasisCreateTensorH1 \ 300 FORTRAN_NAME(ceedbasiscreatetensorh1, CEEDBASISCREATETENSORH1) 301 void fCeedBasisCreateTensorH1(int *ceed, int *dim, int *ndof, int *P1d, 302 int *Q1d, const CeedScalar *interp1d, const CeedScalar *grad1d, 303 const CeedScalar *qref1d, const CeedScalar *qweight1d, int *basis, int *err) { 304 if (CeedBasis_count == CeedBasis_count_max) { 305 CeedBasis_count_max += CeedBasis_count_max/2 + 1; 306 CeedRealloc(CeedBasis_count_max, &CeedBasis_dict); 307 } 308 309 *err = CeedBasisCreateTensorH1(Ceed_dict[*ceed], *dim, *ndof, *P1d, *Q1d, 310 interp1d, grad1d, 311 qref1d, qweight1d, &CeedBasis_dict[CeedBasis_count]); 312 313 if (*err == 0) { 314 *basis = CeedBasis_count++; 315 CeedBasis_n++; 316 } 317 } 318 319 #define fCeedBasisView FORTRAN_NAME(ceedbasisview, CEEDBASISVIEW) 320 void fCeedBasisView(int *basis, int *err) { 321 *err = CeedBasisView(CeedBasis_dict[*basis], stdout); 322 } 323 324 #define fCeedQRFactorization \ 325 FORTRAN_NAME(ceedqrfactorization, CEEDQRFACTORIZATION) 326 void fCeedQRFactorization(CeedScalar *mat, CeedScalar *tau, int *m, int *n, 327 int *err) { 328 *err = CeedQRFactorization(mat, tau, *m, *n); 329 } 330 331 #define fCeedBasisGetColocatedGrad \ 332 FORTRAN_NAME(ceedbasisgetcolocatedgrad, CEEDBASISGETCOLOCATEDGRAD) 333 void fCeedBasisGetColocatedGrad(int *basis, CeedScalar *colograd1d, 334 int *err) { 335 *err = CeedBasisGetColocatedGrad(CeedBasis_dict[*basis], colograd1d); 336 } 337 338 #define fCeedBasisApply FORTRAN_NAME(ceedbasisapply, CEEDBASISAPPLY) 339 void fCeedBasisApply(int *basis, int *nelem, int *tmode, int *emode, 340 const CeedScalar *u, CeedScalar *v, int *err) { 341 *err = CeedBasisApply(CeedBasis_dict[*basis], *nelem, *tmode, *emode, u, v); 342 } 343 344 #define fCeedBasisGetNumNodes \ 345 FORTRAN_NAME(ceedbasisgetnumnodes, CEEDBASISGETNUMNODES) 346 void fCeedBasisGetNumNodes(int *basis, int *P, int *err) { 347 *err = CeedBasisGetNumNodes(CeedBasis_dict[*basis], P); 348 } 349 350 #define fCeedBasisGetNumQuadraturePoints \ 351 FORTRAN_NAME(ceedbasisgetnumquadraturepoints, CEEDBASISGETNUMQUADRATUREPOINTS) 352 void fCeedBasisGetNumQuadraturePoints(int *basis, int *Q, int *err) { 353 *err = CeedBasisGetNumQuadraturePoints(CeedBasis_dict[*basis], Q); 354 } 355 356 #define fCeedBasisDestroy FORTRAN_NAME(ceedbasisdestroy,CEEDBASISDESTROY) 357 void fCeedBasisDestroy(int *basis, int *err) { 358 *err = CeedBasisDestroy(&CeedBasis_dict[*basis]); 359 360 if (*err == 0) { 361 CeedBasis_n--; 362 if (CeedBasis_n == 0) { 363 CeedFree(&CeedBasis_dict); 364 CeedBasis_count = 0; 365 CeedBasis_count_max = 0; 366 } 367 } 368 } 369 370 #define fCeedGaussQuadrature FORTRAN_NAME(ceedgaussquadrature, CEEDGAUSSQUADRATURE) 371 void fCeedGaussQuadrature(int *Q, CeedScalar *qref1d, CeedScalar *qweight1d, 372 int *err) { 373 *err = CeedGaussQuadrature(*Q, qref1d, qweight1d); 374 } 375 376 #define fCeedLobattoQuadrature \ 377 FORTRAN_NAME(ceedlobattoquadrature, CEEDLOBATTOQUADRATURE) 378 void fCeedLobattoQuadrature(int *Q, CeedScalar *qref1d, CeedScalar *qweight1d, 379 int *err) { 380 *err = CeedLobattoQuadrature(*Q, qref1d, qweight1d); 381 } 382 383 static CeedQFunction *CeedQFunction_dict = NULL; 384 static int CeedQFunction_count = 0; 385 static int CeedQFunction_n = 0; 386 static int CeedQFunction_count_max = 0; 387 388 struct fContext { 389 void (*f)(void *ctx, int *nq, 390 const CeedScalar *u,const CeedScalar *u1,const CeedScalar *u2, 391 const CeedScalar *u3, 392 const CeedScalar *u4,const CeedScalar *u5,const CeedScalar *u6, 393 const CeedScalar *u7, 394 const CeedScalar *u8,const CeedScalar *u9,const CeedScalar *u10, 395 const CeedScalar *u11, 396 const CeedScalar *u12,const CeedScalar *u13,const CeedScalar *u14, 397 const CeedScalar *u15, 398 CeedScalar *v,CeedScalar *v1, CeedScalar *v2,CeedScalar *v3, 399 CeedScalar *v4,CeedScalar *v5, CeedScalar *v6,CeedScalar *v7, 400 CeedScalar *v8,CeedScalar *v9, CeedScalar *v10,CeedScalar *v11, 401 CeedScalar *v12,CeedScalar *v13, CeedScalar *v14,CeedScalar *v15, int *err); 402 void *innerctx; 403 }; 404 405 static int CeedQFunctionFortranStub(void *ctx, int nq, 406 const CeedScalar *const *u, CeedScalar *const *v) { 407 struct fContext *fctx = ctx; 408 int ierr; 409 410 CeedScalar ctx_=1.0; 411 fctx->f((void*)&ctx_,&nq,u[0],u[1],u[2],u[3],u[4],u[5],u[6],u[7], 412 u[8],u[9],u[10],u[11],u[12],u[13],u[14],u[15], 413 v[0],v[1],v[2],v[3],v[4],v[5],v[6],v[7], 414 v[8],v[9],v[10],v[11],v[12],v[13],v[14],v[15],&ierr); 415 return ierr; 416 } 417 418 #define fCeedQFunctionCreateInterior \ 419 FORTRAN_NAME(ceedqfunctioncreateinterior, CEEDQFUNCTIONCREATEINTERIOR) 420 void fCeedQFunctionCreateInterior(int* ceed, int* vlength, 421 void (*f)(void *ctx, int *nq, 422 const CeedScalar *u,const CeedScalar *u1,const CeedScalar *u2, 423 const CeedScalar *u3, 424 const CeedScalar *u4,const CeedScalar *u5,const CeedScalar *u6, 425 const CeedScalar *u7, 426 const CeedScalar *u8,const CeedScalar *u9,const CeedScalar *u10, 427 const CeedScalar *u11, 428 const CeedScalar *u12,const CeedScalar *u13,const CeedScalar *u14, 429 const CeedScalar *u15, 430 CeedScalar *v,CeedScalar *v1, CeedScalar *v2,CeedScalar *v3, 431 CeedScalar *v4,CeedScalar *v5, CeedScalar *v6,CeedScalar *v7, 432 CeedScalar *v8,CeedScalar *v9, CeedScalar *v10,CeedScalar *v11, 433 CeedScalar *v12,CeedScalar *v13, CeedScalar *v14,CeedScalar *v15, 434 int *err), 435 const char *focca, int *qf, int *err) { 436 if (CeedQFunction_count == CeedQFunction_count_max) { 437 CeedQFunction_count_max += CeedQFunction_count_max/2 + 1; 438 CeedRealloc(CeedQFunction_count_max, &CeedQFunction_dict); 439 } 440 441 CeedQFunction *qf_ = &CeedQFunction_dict[CeedQFunction_count]; 442 *err = CeedQFunctionCreateInterior(Ceed_dict[*ceed], *vlength, 443 CeedQFunctionFortranStub,focca, qf_); 444 445 if (*err == 0) { 446 *qf = CeedQFunction_count++; 447 CeedQFunction_n++; 448 } 449 450 struct fContext *fctx; 451 *err = CeedMalloc(1, &fctx); 452 if (*err) return; 453 fctx->f = f; fctx->innerctx = NULL; 454 455 *err = CeedQFunctionSetContext(*qf_, fctx, sizeof(struct fContext)); 456 457 } 458 459 #define fCeedQFunctionAddInput \ 460 FORTRAN_NAME(ceedqfunctionaddinput,CEEDQFUNCTIONADDINPUT) 461 void fCeedQFunctionAddInput(int *qf, const char *fieldname, 462 CeedInt *ncomp, CeedEvalMode *emode, int *err) { 463 CeedQFunction qf_ = CeedQFunction_dict[*qf]; 464 465 *err = CeedQFunctionAddInput(qf_, fieldname, *ncomp, *emode); 466 } 467 468 #define fCeedQFunctionAddOutput \ 469 FORTRAN_NAME(ceedqfunctionaddoutput,CEEDQFUNCTIONADDOUTPUT) 470 void fCeedQFunctionAddOutput(int *qf, const char *fieldname, 471 CeedInt *ncomp, CeedEvalMode *emode, int *err) { 472 CeedQFunction qf_ = CeedQFunction_dict[*qf]; 473 474 *err = CeedQFunctionAddOutput(qf_, fieldname, *ncomp, *emode); 475 } 476 477 #define fCeedQFunctionApply \ 478 FORTRAN_NAME(ceedqfunctionapply,CEEDQFUNCTIONAPPLY) 479 //TODO Need Fixing, double pointer 480 void fCeedQFunctionApply(int *qf, int *Q, 481 const CeedScalar *u,const CeedScalar *u1,const CeedScalar *u2, 482 const CeedScalar *u3, 483 const CeedScalar *u4,const CeedScalar *u5,const CeedScalar *u6, 484 const CeedScalar *u7, 485 const CeedScalar *u8,const CeedScalar *u9,const CeedScalar *u10, 486 const CeedScalar *u11, 487 const CeedScalar *u12,const CeedScalar *u13,const CeedScalar *u14, 488 const CeedScalar *u15, 489 CeedScalar *v,CeedScalar *v1, CeedScalar *v2,CeedScalar *v3, 490 CeedScalar *v4,CeedScalar *v5, CeedScalar *v6,CeedScalar *v7, 491 CeedScalar *v8,CeedScalar *v9, CeedScalar *v10,CeedScalar *v11, 492 CeedScalar *v12,CeedScalar *v13, CeedScalar *v14,CeedScalar *v15, int *err) { 493 CeedQFunction qf_ = CeedQFunction_dict[*qf]; 494 const CeedScalar **in; 495 *err = CeedCalloc(16, &in); 496 if (*err) return; 497 in[0] = u; 498 in[1] = u1; 499 in[2] = u2; 500 in[3] = u3; 501 in[4] = u4; 502 in[5] = u5; 503 in[6] = u6; 504 in[7] = u7; 505 in[8] = u8; 506 in[9] = u9; 507 in[10] = u10; 508 in[11] = u11; 509 in[12] = u12; 510 in[13] = u13; 511 in[14] = u14; 512 in[15] = u15; 513 CeedScalar **out; 514 *err = CeedCalloc(16, &out); 515 if (*err) return; 516 out[0] = v; 517 out[1] = v1; 518 out[2] = v2; 519 out[3] = v3; 520 out[4] = v4; 521 out[5] = v5; 522 out[6] = v6; 523 out[7] = v7; 524 out[8] = v8; 525 out[9] = v9; 526 out[10] = v10; 527 out[11] = v11; 528 out[12] = v12; 529 out[13] = v13; 530 out[14] = v14; 531 out[15] = v15; 532 *err = CeedQFunctionApply(qf_, *Q, (const CeedScalar * const*)in, out); 533 if (*err) return; 534 535 *err = CeedFree(&in); 536 if (*err) return; 537 *err = CeedFree(&out); 538 } 539 540 #define fCeedQFunctionDestroy \ 541 FORTRAN_NAME(ceedqfunctiondestroy,CEEDQFUNCTIONDESTROY) 542 void fCeedQFunctionDestroy(int *qf, int *err) { 543 CeedFree(&CeedQFunction_dict[*qf]->ctx); 544 *err = CeedQFunctionDestroy(&CeedQFunction_dict[*qf]); 545 546 if (*err) return; 547 CeedQFunction_n--; 548 if (CeedQFunction_n == 0) { 549 *err = CeedFree(&CeedQFunction_dict); 550 CeedQFunction_count = 0; 551 CeedQFunction_count_max = 0; 552 } 553 } 554 555 static CeedOperator *CeedOperator_dict = NULL; 556 static int CeedOperator_count = 0; 557 static int CeedOperator_n = 0; 558 static int CeedOperator_count_max = 0; 559 560 #define fCeedOperatorCreate \ 561 FORTRAN_NAME(ceedoperatorcreate, CEEDOPERATORCREATE) 562 void fCeedOperatorCreate(int* ceed, 563 int* qf, int* dqf, int* dqfT, int *op, int *err) { 564 if (CeedOperator_count == CeedOperator_count_max) 565 CeedOperator_count_max += CeedOperator_count_max/2 + 1, 566 CeedOperator_dict = 567 realloc(CeedOperator_dict, sizeof(CeedOperator)*CeedOperator_count_max); 568 569 CeedOperator *op_ = &CeedOperator_dict[CeedOperator_count]; 570 571 CeedQFunction dqf_ = NULL, dqfT_ = NULL; 572 if (*dqf != FORTRAN_NULL) dqf_ = CeedQFunction_dict[*dqf ]; 573 if (*dqfT != FORTRAN_NULL) dqfT_ = CeedQFunction_dict[*dqfT]; 574 575 *err = CeedOperatorCreate(Ceed_dict[*ceed], CeedQFunction_dict[*qf], dqf_, 576 dqfT_, op_); 577 if (*err) return; 578 *op = CeedOperator_count++; 579 CeedOperator_n++; 580 } 581 582 #define fCeedOperatorSetField \ 583 FORTRAN_NAME(ceedoperatorsetfield,CEEDOPERATORSETFIELD) 584 void fCeedOperatorSetField(int *op, const char *fieldname, 585 int *r, int *b, int *v, int *err) { 586 CeedElemRestriction r_; 587 CeedBasis b_; 588 CeedVector v_; 589 590 CeedOperator op_ = CeedOperator_dict[*op]; 591 592 if (*r == FORTRAN_NULL) { 593 r_ = NULL; 594 } else { 595 r_ = CeedElemRestriction_dict[*r]; 596 } 597 if (*b == FORTRAN_NULL) { 598 b_ = NULL; 599 } else if (*b == FORTRAN_BASIS_COLOCATED) { 600 b_ = CEED_BASIS_COLOCATED; 601 } else { 602 b_ = CeedBasis_dict[*b]; 603 } 604 if (*v == FORTRAN_NULL) { 605 v_ = NULL; 606 } else if (*v == FORTRAN_VECTOR_ACTIVE) { 607 v_ = CEED_VECTOR_ACTIVE; 608 } else if (*v == FORTRAN_VECTOR_NONE) { 609 v_ = CEED_VECTOR_NONE; 610 } else { 611 v_ = CeedVector_dict[*v]; 612 } 613 614 *err = CeedOperatorSetField(op_, fieldname, r_, b_, v_); 615 } 616 617 #define fCeedOperatorApply FORTRAN_NAME(ceedoperatorapply, CEEDOPERATORAPPLY) 618 void fCeedOperatorApply(int *op, int *ustatevec, 619 int *resvec, int *rqst, int *err) { 620 // TODO What vector arguments can be NULL? 621 CeedVector resvec_; 622 if (*resvec == FORTRAN_NULL) resvec_ = NULL; 623 else resvec_ = CeedVector_dict[*resvec]; 624 625 int createRequest = 1; 626 // Check if input is CEED_REQUEST_ORDERED(-2) or CEED_REQUEST_IMMEDIATE(-1) 627 if (*rqst == -1 || *rqst == -2) { 628 createRequest = 0; 629 } 630 631 if (createRequest && CeedRequest_count == CeedRequest_count_max) { 632 CeedRequest_count_max += CeedRequest_count_max/2 + 1; 633 CeedRealloc(CeedRequest_count_max, &CeedRequest_dict); 634 } 635 636 CeedRequest *rqst_; 637 if (*rqst == -1) rqst_ = CEED_REQUEST_IMMEDIATE; 638 else if (*rqst == -2) rqst_ = CEED_REQUEST_ORDERED; 639 else rqst_ = &CeedRequest_dict[CeedRequest_count]; 640 641 *err = CeedOperatorApply(CeedOperator_dict[*op], 642 CeedVector_dict[*ustatevec], resvec_, rqst_); 643 if (*err) return; 644 if (createRequest) { 645 *rqst = CeedRequest_count++; 646 CeedRequest_n++; 647 } 648 } 649 650 #define fCeedOperatorApplyJacobian \ 651 FORTRAN_NAME(ceedoperatorapplyjacobian, CEEDOPERATORAPPLYJACOBIAN) 652 void fCeedOperatorApplyJacobian(int *op, int *qdatavec, int *ustatevec, 653 int *dustatevec, int *dresvec, int *rqst, int *err) { 654 // TODO Uncomment this when CeedOperatorApplyJacobian is implemented 655 // *err = CeedOperatorApplyJacobian(CeedOperator_dict[*op], CeedVector_dict[*qdatavec], 656 // CeedVector_dict[*ustatevec], CeedVector_dict[*dustatevec], 657 // CeedVector_dict[*dresvec], &CeedRequest_dict[*rqst]); 658 } 659 660 #define fCeedOperatorDestroy \ 661 FORTRAN_NAME(ceedoperatordestroy, CEEDOPERATORDESTROY) 662 void fCeedOperatorDestroy(int *op, int *err) { 663 *err = CeedOperatorDestroy(&CeedOperator_dict[*op]); 664 if (*err) return; 665 CeedOperator_n--; 666 if (CeedOperator_n == 0) { 667 *err = CeedFree(&CeedOperator_dict); 668 CeedOperator_count = 0; 669 CeedOperator_count_max = 0; 670 } 671 } 672