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, *ndof, 179 *ncomp, elemrestriction_); 180 181 if (*err == 0) { 182 *elemrestriction = CeedElemRestriction_count++; 183 CeedElemRestriction_n++; 184 } 185 } 186 187 #define fCeedElemRestrictionCreateBlocked \ 188 FORTRAN_NAME(ceedelemrestrictioncreateblocked,CEEDELEMRESTRICTIONCREATEBLOCKED) 189 void fCeedElemRestrictionCreateBlocked(int *ceed, int *nelements, 190 int *esize, int *blocksize, int *ndof, int *ncomp, 191 int *mtype, int *cmode, 192 int *blkindices, int *elemrestriction, int *err) { 193 194 if (CeedElemRestriction_count == CeedElemRestriction_count_max) { 195 CeedElemRestriction_count_max += CeedElemRestriction_count_max/2 + 1; 196 CeedRealloc(CeedElemRestriction_count_max, &CeedElemRestriction_dict); 197 } 198 199 CeedElemRestriction *elemrestriction_ = 200 &CeedElemRestriction_dict[CeedElemRestriction_count]; 201 *err = CeedElemRestrictionCreateBlocked(Ceed_dict[*ceed], *nelements, *esize, 202 *blocksize, *ndof, *ncomp, *mtype, *cmode, blkindices, 203 elemrestriction_); 204 205 if (*err == 0) { 206 *elemrestriction = CeedElemRestriction_count++; 207 CeedElemRestriction_n++; 208 } 209 } 210 211 static CeedRequest *CeedRequest_dict = NULL; 212 static int CeedRequest_count = 0; 213 static int CeedRequest_n = 0; 214 static int CeedRequest_count_max = 0; 215 216 #define fCeedElemRestrictionApply \ 217 FORTRAN_NAME(ceedelemrestrictionapply,CEEDELEMRESTRICTIONAPPLY) 218 void fCeedElemRestrictionApply(int *elemr, int *tmode, int *lmode, 219 int *uvec, int *ruvec, int *rqst, int *err) { 220 int createRequest = 1; 221 // Check if input is CEED_REQUEST_ORDERED(-2) or CEED_REQUEST_IMMEDIATE(-1) 222 if (*rqst == FORTRAN_REQUEST_IMMEDIATE || *rqst == FORTRAN_REQUEST_ORDERED) 223 createRequest = 0; 224 225 if (createRequest && CeedRequest_count == CeedRequest_count_max) { 226 CeedRequest_count_max += CeedRequest_count_max/2 + 1; 227 CeedRealloc(CeedRequest_count_max, &CeedRequest_dict); 228 } 229 230 CeedRequest *rqst_; 231 if (*rqst == FORTRAN_REQUEST_IMMEDIATE) rqst_ = CEED_REQUEST_IMMEDIATE; 232 else if (*rqst == FORTRAN_REQUEST_ORDERED ) rqst_ = CEED_REQUEST_ORDERED; 233 else rqst_ = &CeedRequest_dict[CeedRequest_count]; 234 235 *err = CeedElemRestrictionApply(CeedElemRestriction_dict[*elemr], *tmode, 236 *lmode, CeedVector_dict[*uvec], CeedVector_dict[*ruvec], rqst_); 237 238 if (*err == 0 && createRequest) { 239 *rqst = CeedRequest_count++; 240 CeedRequest_n++; 241 } 242 } 243 244 #define fCeedRequestWait FORTRAN_NAME(ceedrequestwait, CEEDREQUESTWAIT) 245 void fCeedRequestWait(int *rqst, int *err) { 246 // TODO Uncomment this once CeedRequestWait is implemented 247 //*err = CeedRequestWait(&CeedRequest_dict[*rqst]); 248 249 if (*err == 0) { 250 CeedRequest_n--; 251 if (CeedRequest_n == 0) { 252 CeedFree(&CeedRequest_dict); 253 CeedRequest_count = 0; 254 CeedRequest_count_max = 0; 255 } 256 } 257 } 258 259 #define fCeedElemRestrictionDestroy \ 260 FORTRAN_NAME(ceedelemrestrictiondestroy,CEEDELEMRESTRICTIONDESTROY) 261 void fCeedElemRestrictionDestroy(int *elem, int *err) { 262 *err = CeedElemRestrictionDestroy(&CeedElemRestriction_dict[*elem]); 263 264 if (*err == 0) { 265 CeedElemRestriction_n--; 266 if (CeedElemRestriction_n == 0) { 267 CeedFree(&CeedElemRestriction_dict); 268 CeedElemRestriction_count = 0; 269 CeedElemRestriction_count_max = 0; 270 } 271 } 272 } 273 274 static CeedBasis *CeedBasis_dict = NULL; 275 static int CeedBasis_count = 0; 276 static int CeedBasis_n = 0; 277 static int CeedBasis_count_max = 0; 278 279 #define fCeedBasisCreateTensorH1Lagrange \ 280 FORTRAN_NAME(ceedbasiscreatetensorh1lagrange, CEEDBASISCREATETENSORH1LAGRANGE) 281 void fCeedBasisCreateTensorH1Lagrange(int *ceed, int *dim, 282 int *ndof, int *P, int *Q, int *quadmode, int *basis, 283 int *err) { 284 if (CeedBasis_count == CeedBasis_count_max) { 285 CeedBasis_count_max += CeedBasis_count_max/2 + 1; 286 CeedRealloc(CeedBasis_count_max, &CeedBasis_dict); 287 } 288 289 *err = CeedBasisCreateTensorH1Lagrange(Ceed_dict[*ceed], *dim, *ndof, *P, *Q, 290 *quadmode, &CeedBasis_dict[CeedBasis_count]); 291 292 if (*err == 0) { 293 *basis = CeedBasis_count++; 294 CeedBasis_n++; 295 } 296 } 297 298 #define fCeedBasisCreateTensorH1 \ 299 FORTRAN_NAME(ceedbasiscreatetensorh1, CEEDBASISCREATETENSORH1) 300 void fCeedBasisCreateTensorH1(int *ceed, int *dim, int *ndof, int *P1d, 301 int *Q1d, const CeedScalar *interp1d, const CeedScalar *grad1d, 302 const CeedScalar *qref1d, const CeedScalar *qweight1d, int *basis, int *err) { 303 if (CeedBasis_count == CeedBasis_count_max) { 304 CeedBasis_count_max += CeedBasis_count_max/2 + 1; 305 CeedRealloc(CeedBasis_count_max, &CeedBasis_dict); 306 } 307 308 *err = CeedBasisCreateTensorH1(Ceed_dict[*ceed], *dim, *ndof, *P1d, *Q1d, 309 interp1d, grad1d, 310 qref1d, qweight1d, &CeedBasis_dict[CeedBasis_count]); 311 312 if (*err == 0) { 313 *basis = CeedBasis_count++; 314 CeedBasis_n++; 315 } 316 } 317 318 #define fCeedBasisView FORTRAN_NAME(ceedbasisview, CEEDBASISVIEW) 319 void fCeedBasisView(int *basis, int *err) { 320 *err = CeedBasisView(CeedBasis_dict[*basis], stdout); 321 } 322 323 #define fCeedQRFactorization \ 324 FORTRAN_NAME(ceedqrfactorization, CEEDQRFACTORIZATION) 325 void fCeedQRFactorization(CeedScalar *mat, CeedScalar *tau, int *m, int *n, 326 int *err) { 327 *err = CeedQRFactorization(mat, tau, *m, *n); 328 } 329 330 #define fCeedBasisGetColocatedGrad \ 331 FORTRAN_NAME(ceedbasisgetcolocatedgrad, CEEDBASISGETCOLOCATEDGRAD) 332 void fCeedBasisGetColocatedGrad(int *basis, CeedScalar *colograd1d, 333 int *err) { 334 *err = CeedBasisGetColocatedGrad(CeedBasis_dict[*basis], colograd1d); 335 } 336 337 #define fCeedBasisApply FORTRAN_NAME(ceedbasisapply, CEEDBASISAPPLY) 338 void fCeedBasisApply(int *basis, int *nelem, int *tmode, int *emode, 339 const CeedScalar *u, CeedScalar *v, int *err) { 340 *err = CeedBasisApply(CeedBasis_dict[*basis], *nelem, *tmode, *emode, u, v); 341 } 342 343 #define fCeedBasisGetNumNodes \ 344 FORTRAN_NAME(ceedbasisgetnumnodes, CEEDBASISGETNUMNODES) 345 void fCeedBasisGetNumNodes(int *basis, int *P, int *err) { 346 *err = CeedBasisGetNumNodes(CeedBasis_dict[*basis], P); 347 } 348 349 #define fCeedBasisGetNumQuadraturePoints \ 350 FORTRAN_NAME(ceedbasisgetnumquadraturepoints, CEEDBASISGETNUMQUADRATUREPOINTS) 351 void fCeedBasisGetNumQuadraturePoints(int *basis, int *Q, int *err) { 352 *err = CeedBasisGetNumQuadraturePoints(CeedBasis_dict[*basis], Q); 353 } 354 355 #define fCeedBasisDestroy FORTRAN_NAME(ceedbasisdestroy,CEEDBASISDESTROY) 356 void fCeedBasisDestroy(int *basis, int *err) { 357 *err = CeedBasisDestroy(&CeedBasis_dict[*basis]); 358 359 if (*err == 0) { 360 CeedBasis_n--; 361 if (CeedBasis_n == 0) { 362 CeedFree(&CeedBasis_dict); 363 CeedBasis_count = 0; 364 CeedBasis_count_max = 0; 365 } 366 } 367 } 368 369 #define fCeedGaussQuadrature FORTRAN_NAME(ceedgaussquadrature, CEEDGAUSSQUADRATURE) 370 void fCeedGaussQuadrature(int *Q, CeedScalar *qref1d, CeedScalar *qweight1d, 371 int *err) { 372 *err = CeedGaussQuadrature(*Q, qref1d, qweight1d); 373 } 374 375 #define fCeedLobattoQuadrature \ 376 FORTRAN_NAME(ceedlobattoquadrature, CEEDLOBATTOQUADRATURE) 377 void fCeedLobattoQuadrature(int *Q, CeedScalar *qref1d, CeedScalar *qweight1d, 378 int *err) { 379 *err = CeedLobattoQuadrature(*Q, qref1d, qweight1d); 380 } 381 382 static CeedQFunction *CeedQFunction_dict = NULL; 383 static int CeedQFunction_count = 0; 384 static int CeedQFunction_n = 0; 385 static int CeedQFunction_count_max = 0; 386 387 struct fContext { 388 void (*f)(void *ctx, int *nq, 389 const CeedScalar *u,const CeedScalar *u1,const CeedScalar *u2, 390 const CeedScalar *u3, 391 const CeedScalar *u4,const CeedScalar *u5,const CeedScalar *u6, 392 const CeedScalar *u7, 393 const CeedScalar *u8,const CeedScalar *u9,const CeedScalar *u10, 394 const CeedScalar *u11, 395 const CeedScalar *u12,const CeedScalar *u13,const CeedScalar *u14, 396 const CeedScalar *u15, 397 CeedScalar *v,CeedScalar *v1, CeedScalar *v2,CeedScalar *v3, 398 CeedScalar *v4,CeedScalar *v5, CeedScalar *v6,CeedScalar *v7, 399 CeedScalar *v8,CeedScalar *v9, CeedScalar *v10,CeedScalar *v11, 400 CeedScalar *v12,CeedScalar *v13, CeedScalar *v14,CeedScalar *v15, int *err); 401 void *innerctx; 402 }; 403 404 static int CeedQFunctionFortranStub(void *ctx, int nq, 405 const CeedScalar *const *u, CeedScalar *const *v) { 406 struct fContext *fctx = ctx; 407 int ierr; 408 409 CeedScalar ctx_=1.0; 410 fctx->f((void*)&ctx_,&nq,u[0],u[1],u[2],u[3],u[4],u[5],u[6],u[7], 411 u[8],u[9],u[10],u[11],u[12],u[13],u[14],u[15], 412 v[0],v[1],v[2],v[3],v[4],v[5],v[6],v[7], 413 v[8],v[9],v[10],v[11],v[12],v[13],v[14],v[15],&ierr); 414 return ierr; 415 } 416 417 #define fCeedQFunctionCreateInterior \ 418 FORTRAN_NAME(ceedqfunctioncreateinterior, CEEDQFUNCTIONCREATEINTERIOR) 419 void fCeedQFunctionCreateInterior(int* ceed, int* vlength, 420 void (*f)(void *ctx, int *nq, 421 const CeedScalar *u,const CeedScalar *u1,const CeedScalar *u2, 422 const CeedScalar *u3, 423 const CeedScalar *u4,const CeedScalar *u5,const CeedScalar *u6, 424 const CeedScalar *u7, 425 const CeedScalar *u8,const CeedScalar *u9,const CeedScalar *u10, 426 const CeedScalar *u11, 427 const CeedScalar *u12,const CeedScalar *u13,const CeedScalar *u14, 428 const CeedScalar *u15, 429 CeedScalar *v,CeedScalar *v1, CeedScalar *v2,CeedScalar *v3, 430 CeedScalar *v4,CeedScalar *v5, CeedScalar *v6,CeedScalar *v7, 431 CeedScalar *v8,CeedScalar *v9, CeedScalar *v10,CeedScalar *v11, 432 CeedScalar *v12,CeedScalar *v13, CeedScalar *v14,CeedScalar *v15, 433 int *err), 434 const char *focca, int *qf, int *err) { 435 if (CeedQFunction_count == CeedQFunction_count_max) { 436 CeedQFunction_count_max += CeedQFunction_count_max/2 + 1; 437 CeedRealloc(CeedQFunction_count_max, &CeedQFunction_dict); 438 } 439 440 CeedQFunction *qf_ = &CeedQFunction_dict[CeedQFunction_count]; 441 *err = CeedQFunctionCreateInterior(Ceed_dict[*ceed], *vlength, 442 CeedQFunctionFortranStub,focca, qf_); 443 444 if (*err == 0) { 445 *qf = CeedQFunction_count++; 446 CeedQFunction_n++; 447 } 448 449 struct fContext *fctx; 450 *err = CeedMalloc(1, &fctx); 451 if (*err) return; 452 fctx->f = f; fctx->innerctx = NULL; 453 454 *err = CeedQFunctionSetContext(*qf_, fctx, sizeof(struct fContext)); 455 456 } 457 458 #define fCeedQFunctionAddInput \ 459 FORTRAN_NAME(ceedqfunctionaddinput,CEEDQFUNCTIONADDINPUT) 460 void fCeedQFunctionAddInput(int *qf, const char *fieldname, 461 CeedInt *ncomp, CeedEvalMode *emode, int *err) { 462 CeedQFunction qf_ = CeedQFunction_dict[*qf]; 463 464 *err = CeedQFunctionAddInput(qf_, fieldname, *ncomp, *emode); 465 } 466 467 #define fCeedQFunctionAddOutput \ 468 FORTRAN_NAME(ceedqfunctionaddoutput,CEEDQFUNCTIONADDOUTPUT) 469 void fCeedQFunctionAddOutput(int *qf, const char *fieldname, 470 CeedInt *ncomp, CeedEvalMode *emode, int *err) { 471 CeedQFunction qf_ = CeedQFunction_dict[*qf]; 472 473 *err = CeedQFunctionAddOutput(qf_, fieldname, *ncomp, *emode); 474 } 475 476 #define fCeedQFunctionApply \ 477 FORTRAN_NAME(ceedqfunctionapply,CEEDQFUNCTIONAPPLY) 478 //TODO Need Fixing, double pointer 479 void fCeedQFunctionApply(int *qf, int *Q, 480 const CeedScalar *u,const CeedScalar *u1,const CeedScalar *u2, 481 const CeedScalar *u3, 482 const CeedScalar *u4,const CeedScalar *u5,const CeedScalar *u6, 483 const CeedScalar *u7, 484 const CeedScalar *u8,const CeedScalar *u9,const CeedScalar *u10, 485 const CeedScalar *u11, 486 const CeedScalar *u12,const CeedScalar *u13,const CeedScalar *u14, 487 const CeedScalar *u15, 488 CeedScalar *v,CeedScalar *v1, CeedScalar *v2,CeedScalar *v3, 489 CeedScalar *v4,CeedScalar *v5, CeedScalar *v6,CeedScalar *v7, 490 CeedScalar *v8,CeedScalar *v9, CeedScalar *v10,CeedScalar *v11, 491 CeedScalar *v12,CeedScalar *v13, CeedScalar *v14,CeedScalar *v15, int *err) { 492 CeedQFunction qf_ = CeedQFunction_dict[*qf]; 493 const CeedScalar **in; 494 *err = CeedCalloc(16, &in); 495 if (*err) return; 496 in[0] = u; 497 in[1] = u1; 498 in[2] = u2; 499 in[3] = u3; 500 in[4] = u4; 501 in[5] = u5; 502 in[6] = u6; 503 in[7] = u7; 504 in[8] = u8; 505 in[9] = u9; 506 in[10] = u10; 507 in[11] = u11; 508 in[12] = u12; 509 in[13] = u13; 510 in[14] = u14; 511 in[15] = u15; 512 CeedScalar **out; 513 *err = CeedCalloc(16, &out); 514 if (*err) return; 515 out[0] = v; 516 out[1] = v1; 517 out[2] = v2; 518 out[3] = v3; 519 out[4] = v4; 520 out[5] = v5; 521 out[6] = v6; 522 out[7] = v7; 523 out[8] = v8; 524 out[9] = v9; 525 out[10] = v10; 526 out[11] = v11; 527 out[12] = v12; 528 out[13] = v13; 529 out[14] = v14; 530 out[15] = v15; 531 *err = CeedQFunctionApply(qf_, *Q, (const CeedScalar * const*)in, out); 532 if (*err) return; 533 534 *err = CeedFree(&in); 535 if (*err) return; 536 *err = CeedFree(&out); 537 } 538 539 #define fCeedQFunctionDestroy \ 540 FORTRAN_NAME(ceedqfunctiondestroy,CEEDQFUNCTIONDESTROY) 541 void fCeedQFunctionDestroy(int *qf, int *err) { 542 CeedFree(&CeedQFunction_dict[*qf]->ctx); 543 *err = CeedQFunctionDestroy(&CeedQFunction_dict[*qf]); 544 545 if (*err) return; 546 CeedQFunction_n--; 547 if (CeedQFunction_n == 0) { 548 *err = CeedFree(&CeedQFunction_dict); 549 CeedQFunction_count = 0; 550 CeedQFunction_count_max = 0; 551 } 552 } 553 554 static CeedOperator *CeedOperator_dict = NULL; 555 static int CeedOperator_count = 0; 556 static int CeedOperator_n = 0; 557 static int CeedOperator_count_max = 0; 558 559 #define fCeedOperatorCreate \ 560 FORTRAN_NAME(ceedoperatorcreate, CEEDOPERATORCREATE) 561 void fCeedOperatorCreate(int* ceed, 562 int* qf, int* dqf, int* dqfT, int *op, int *err) { 563 if (CeedOperator_count == CeedOperator_count_max) 564 CeedOperator_count_max += CeedOperator_count_max/2 + 1, 565 CeedOperator_dict = 566 realloc(CeedOperator_dict, sizeof(CeedOperator)*CeedOperator_count_max); 567 568 CeedOperator *op_ = &CeedOperator_dict[CeedOperator_count]; 569 570 CeedQFunction dqf_ = NULL, dqfT_ = NULL; 571 if (*dqf != FORTRAN_NULL) dqf_ = CeedQFunction_dict[*dqf ]; 572 if (*dqfT != FORTRAN_NULL) dqfT_ = CeedQFunction_dict[*dqfT]; 573 574 *err = CeedOperatorCreate(Ceed_dict[*ceed], CeedQFunction_dict[*qf], dqf_, 575 dqfT_, op_); 576 if (*err) return; 577 *op = CeedOperator_count++; 578 CeedOperator_n++; 579 } 580 581 #define fCeedOperatorSetField \ 582 FORTRAN_NAME(ceedoperatorsetfield,CEEDOPERATORSETFIELD) 583 void fCeedOperatorSetField(int *op, const char *fieldname, 584 int *r, int *b, int *v, int *err) { 585 CeedElemRestriction r_; 586 CeedBasis b_; 587 CeedVector v_; 588 589 CeedOperator op_ = CeedOperator_dict[*op]; 590 591 if (*r == FORTRAN_NULL) { 592 r_ = NULL; 593 } else { 594 r_ = CeedElemRestriction_dict[*r]; 595 } 596 if (*b == FORTRAN_NULL) { 597 b_ = NULL; 598 } else if (*b == FORTRAN_BASIS_COLOCATED) { 599 b_ = CEED_BASIS_COLOCATED; 600 } else { 601 b_ = CeedBasis_dict[*b]; 602 } 603 if (*v == FORTRAN_NULL) { 604 v_ = NULL; 605 } else if (*v == FORTRAN_VECTOR_ACTIVE) { 606 v_ = CEED_VECTOR_ACTIVE; 607 } else if (*v == FORTRAN_VECTOR_NONE) { 608 v_ = CEED_VECTOR_NONE; 609 } else { 610 v_ = CeedVector_dict[*v]; 611 } 612 613 *err = CeedOperatorSetField(op_, fieldname, r_, b_, v_); 614 } 615 616 #define fCeedOperatorApply FORTRAN_NAME(ceedoperatorapply, CEEDOPERATORAPPLY) 617 void fCeedOperatorApply(int *op, int *ustatevec, 618 int *resvec, int *rqst, int *err) { 619 // TODO What vector arguments can be NULL? 620 CeedVector resvec_; 621 if (*resvec == FORTRAN_NULL) resvec_ = NULL; 622 else resvec_ = CeedVector_dict[*resvec]; 623 624 int createRequest = 1; 625 // Check if input is CEED_REQUEST_ORDERED(-2) or CEED_REQUEST_IMMEDIATE(-1) 626 if (*rqst == -1 || *rqst == -2) { 627 createRequest = 0; 628 } 629 630 if (createRequest && CeedRequest_count == CeedRequest_count_max) { 631 CeedRequest_count_max += CeedRequest_count_max/2 + 1; 632 CeedRealloc(CeedRequest_count_max, &CeedRequest_dict); 633 } 634 635 CeedRequest *rqst_; 636 if (*rqst == -1) rqst_ = CEED_REQUEST_IMMEDIATE; 637 else if (*rqst == -2) rqst_ = CEED_REQUEST_ORDERED; 638 else rqst_ = &CeedRequest_dict[CeedRequest_count]; 639 640 *err = CeedOperatorApply(CeedOperator_dict[*op], 641 CeedVector_dict[*ustatevec], resvec_, rqst_); 642 if (*err) return; 643 if (createRequest) { 644 *rqst = CeedRequest_count++; 645 CeedRequest_n++; 646 } 647 } 648 649 #define fCeedOperatorApplyJacobian \ 650 FORTRAN_NAME(ceedoperatorapplyjacobian, CEEDOPERATORAPPLYJACOBIAN) 651 void fCeedOperatorApplyJacobian(int *op, int *qdatavec, int *ustatevec, 652 int *dustatevec, int *dresvec, int *rqst, int *err) { 653 // TODO Uncomment this when CeedOperatorApplyJacobian is implemented 654 // *err = CeedOperatorApplyJacobian(CeedOperator_dict[*op], CeedVector_dict[*qdatavec], 655 // CeedVector_dict[*ustatevec], CeedVector_dict[*dustatevec], 656 // CeedVector_dict[*dresvec], &CeedRequest_dict[*rqst]); 657 } 658 659 #define fCeedOperatorDestroy \ 660 FORTRAN_NAME(ceedoperatordestroy, CEEDOPERATORDESTROY) 661 void fCeedOperatorDestroy(int *op, int *err) { 662 *err = CeedOperatorDestroy(&CeedOperator_dict[*op]); 663 if (*err) return; 664 CeedOperator_n--; 665 if (CeedOperator_n == 0) { 666 *err = CeedFree(&CeedOperator_dict); 667 CeedOperator_count = 0; 668 CeedOperator_count_max = 0; 669 } 670 } 671