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