| File: | /home/sbrandt/cactus/Cactus/configs/sim2/build/SummationByParts/Derivatives_6_3.f90 |
| 1 | :# 5 "/home/sbrandt/cactus/Cactus/arrangements/LSUThorns/SummationByParts/src/Derivatives_6_3.F90"
|
| 2 | :subroutine deriv_gf_6_3 ( var, ni, nj, nk, dir, bb, gsize, offset, delta, dvar )
|
| 3 | :
|
| 4 | : use All_Coeffs_mod
|
| 5 | :
|
| 6 | : implicit none
|
| 7 | :
|
| 8 | : external CCTK_PointerTo
|
| 9 | :# 11
|
| 10 | : integer*8 CCTK_PointerTo
|
| 11 | :# 11
|
| 12 | : interface
|
| 13 | :# 11
|
| 14 | : integer function CCTK_Equals (arg1, arg2)
|
| 15 | :# 11
|
| 16 | : implicit none
|
| 17 | :# 11
|
| 18 | : integer*8 arg1
|
| 19 | :# 11
|
| 20 | : character(*) arg2
|
| 21 | :# 11
|
| 22 | : end function CCTK_Equals
|
| 23 | :# 11
|
| 24 | : integer function CCTK_MyProc (cctkGH)
|
| 25 | :# 11
|
| 26 | : implicit none
|
| 27 | :# 11
|
| 28 | : integer*8 cctkGH
|
| 29 | :# 11
|
| 30 | : end function CCTK_MyProc
|
| 31 | :# 11
|
| 32 | : integer function CCTK_nProcs (cctkGH)
|
| 33 | :# 11
|
| 34 | : implicit none
|
| 35 | :# 11
|
| 36 | : integer*8 cctkGH
|
| 37 | :# 11
|
| 38 | : end function CCTK_nProcs
|
| 39 | :# 11
|
| 40 | : integer function CCTK_IsThornActive (name)
|
| 41 | :# 11
|
| 42 | : implicit none
|
| 43 | :# 11
|
| 44 | : character(*) name
|
| 45 | :# 11
|
| 46 | : end function CCTK_IsThornActive
|
| 47 | :# 11
|
| 48 | : integer*8 function CCTK_NullPointer ()
|
| 49 | :# 11
|
| 50 | : implicit none
|
| 51 | :# 11
|
| 52 | : end function CCTK_NullPointer
|
| 53 | :# 11
|
| 54 | : end interface
|
| 55 | :# 11
|
| 56 | : interface
|
| 57 | :# 11
|
| 58 | : subroutine Diff2_coeff (cctkGH, dir, nsize, imin, imax, q, table_handle)
|
| 59 | :# 11
|
| 60 | : implicit none
|
| 61 | :# 11
|
| 62 | : integer*8 cctkGH
|
| 63 | :# 11
|
| 64 | : INTEGER*4 dir
|
| 65 | :# 11
|
| 66 | : INTEGER*4 nsize
|
| 67 | :# 11
|
| 68 | : INTEGER*4 imin(*)
|
| 69 | :# 11
|
| 70 | : INTEGER*4 imax(*)
|
| 71 | :# 11
|
| 72 | : REAL*8 q(*)
|
| 73 | :# 11
|
| 74 | : INTEGER*4 table_handle
|
| 75 | :# 11
|
| 76 | : end subroutine Diff2_coeff
|
| 77 | :# 11
|
| 78 | : end interface
|
| 79 | :# 11
|
| 80 | : interface
|
| 81 | :# 11
|
| 82 | : subroutine Diff2_gv (cctkGH, dir1, dir2, var, dvar, table_handle)
|
| 83 | :# 11
|
| 84 | : implicit none
|
| 85 | :# 11
|
| 86 | : integer*8 cctkGH
|
| 87 | :# 11
|
| 88 | : INTEGER*4 dir1
|
| 89 | :# 11
|
| 90 | : INTEGER*4 dir2
|
| 91 | :# 11
|
| 92 | : REAL*8 var(*)
|
| 93 | :# 11
|
| 94 | : REAL*8 dvar(*)
|
| 95 | :# 11
|
| 96 | : INTEGER*4 table_handle
|
| 97 | :# 11
|
| 98 | : end subroutine Diff2_gv
|
| 99 | :# 11
|
| 100 | : end interface
|
| 101 | :# 11
|
| 102 | : interface
|
| 103 | :# 11
|
| 104 | : subroutine Diff_coeff (cctkGH, dir, nsize, imin, imax, q, table_handle)
|
| 105 | :# 11
|
| 106 | : implicit none
|
| 107 | :# 11
|
| 108 | : integer*8 cctkGH
|
| 109 | :# 11
|
| 110 | : INTEGER*4 dir
|
| 111 | :# 11
|
| 112 | : INTEGER*4 nsize
|
| 113 | :# 11
|
| 114 | : INTEGER*4 imin(*)
|
| 115 | :# 11
|
| 116 | : INTEGER*4 imax(*)
|
| 117 | :# 11
|
| 118 | : REAL*8 q(*)
|
| 119 | :# 11
|
| 120 | : INTEGER*4 table_handle
|
| 121 | :# 11
|
| 122 | : end subroutine Diff_coeff
|
| 123 | :# 11
|
| 124 | : end interface
|
| 125 | :# 11
|
| 126 | : interface
|
| 127 | :# 11
|
| 128 | : subroutine Diff_gf (cctkGH, dir, var_name, dvar_name)
|
| 129 | :# 11
|
| 130 | : implicit none
|
| 131 | :# 11
|
| 132 | : integer*8 cctkGH
|
| 133 | :# 11
|
| 134 | : INTEGER*4 dir
|
| 135 | :# 11
|
| 136 | : character(*) var_name
|
| 137 | :# 11
|
| 138 | : character(*) dvar_name
|
| 139 | :# 11
|
| 140 | : end subroutine Diff_gf
|
| 141 | :# 11
|
| 142 | : end interface
|
| 143 | :# 11
|
| 144 | : interface
|
| 145 | :# 11
|
| 146 | : subroutine Diff_gv (cctkGH, dir, var, dvar, table_handle)
|
| 147 | :# 11
|
| 148 | : implicit none
|
| 149 | :# 11
|
| 150 | : integer*8 cctkGH
|
| 151 | :# 11
|
| 152 | : INTEGER*4 dir
|
| 153 | :# 11
|
| 154 | : REAL*8 var(*)
|
| 155 | :# 11
|
| 156 | : REAL*8 dvar(*)
|
| 157 | :# 11
|
| 158 | : INTEGER*4 table_handle
|
| 159 | :# 11
|
| 160 | : end subroutine Diff_gv
|
| 161 | :# 11
|
| 162 | : end interface
|
| 163 | :# 11
|
| 164 | : interface
|
| 165 | :# 11
|
| 166 | : subroutine Diff_up_coeff (cctkGH, dir, nsize, imin, imax, q, up, table_handle)
|
| 167 | :# 11
|
| 168 | : implicit none
|
| 169 | :# 11
|
| 170 | : integer*8 cctkGH
|
| 171 | :# 11
|
| 172 | : INTEGER*4 dir
|
| 173 | :# 11
|
| 174 | : INTEGER*4 nsize
|
| 175 | :# 11
|
| 176 | : INTEGER*4 imin(*)
|
| 177 | :# 11
|
| 178 | : INTEGER*4 imax(*)
|
| 179 | :# 11
|
| 180 | : REAL*8 q(*)
|
| 181 | :# 11
|
| 182 | : INTEGER*4 up
|
| 183 | :# 11
|
| 184 | : INTEGER*4 table_handle
|
| 185 | :# 11
|
| 186 | : end subroutine Diff_up_coeff
|
| 187 | :# 11
|
| 188 | : end interface
|
| 189 | :# 11
|
| 190 | : interface
|
| 191 | :# 11
|
| 192 | : subroutine Diff_up_gv (cctkGH, dir, var, dvar, up, table_handle)
|
| 193 | :# 11
|
| 194 | : implicit none
|
| 195 | :# 11
|
| 196 | : integer*8 cctkGH
|
| 197 | :# 11
|
| 198 | : INTEGER*4 dir
|
| 199 | :# 11
|
| 200 | : REAL*8 var(*)
|
| 201 | :# 11
|
| 202 | : REAL*8 dvar(*)
|
| 203 | :# 11
|
| 204 | : REAL*8 up(*)
|
| 205 | :# 11
|
| 206 | : INTEGER*4 table_handle
|
| 207 | :# 11
|
| 208 | : end subroutine Diff_up_gv
|
| 209 | :# 11
|
| 210 | : end interface
|
| 211 | :# 11
|
| 212 | : interface
|
| 213 | :# 11
|
| 214 | : subroutine GetBoundWidth (cctkGH, bsize, table_handle)
|
| 215 | :# 11
|
| 216 | : implicit none
|
| 217 | :# 11
|
| 218 | : integer*8 cctkGH
|
| 219 | :# 11
|
| 220 | : INTEGER*4 bsize(*)
|
| 221 | :# 11
|
| 222 | : INTEGER*4 table_handle
|
| 223 | :# 11
|
| 224 | : end subroutine GetBoundWidth
|
| 225 | :# 11
|
| 226 | : end interface
|
| 227 | :# 11
|
| 228 | : interface
|
| 229 | :# 11
|
| 230 | : INTEGER*4 function GetBoundarySpecification (size, nboundaryzones, is_internal, is_staggered, shiftout)
|
| 231 | :# 11
|
| 232 | : implicit none
|
| 233 | :# 11
|
| 234 | : INTEGER*4 size
|
| 235 | :# 11
|
| 236 | : INTEGER*4 nboundaryzones(*)
|
| 237 | :# 11
|
| 238 | : INTEGER*4 is_internal(*)
|
| 239 | :# 11
|
| 240 | : INTEGER*4 is_staggered(*)
|
| 241 | :# 11
|
| 242 | : INTEGER*4 shiftout(*)
|
| 243 | :# 11
|
| 244 | : end function GetBoundarySpecification
|
| 245 | :# 11
|
| 246 | : end interface
|
| 247 | :# 11
|
| 248 | : interface
|
| 249 | :# 11
|
| 250 | : INTEGER*4 function GetDomainSpecification (size, physical_min, physical_max, interior_min, interior_max, exterior_min, exterior_m&
|
| 251 | :# 11
|
| 252 | : &ax, spacing)
|
| 253 | :# 11
|
| 254 | : implicit none
|
| 255 | :# 11
|
| 256 | : INTEGER*4 size
|
| 257 | :# 11
|
| 258 | : REAL*8 physical_min(*)
|
| 259 | :# 11
|
| 260 | : REAL*8 physical_max(*)
|
| 261 | :# 11
|
| 262 | : REAL*8 interior_min(*)
|
| 263 | :# 11
|
| 264 | : REAL*8 interior_max(*)
|
| 265 | :# 11
|
| 266 | : REAL*8 exterior_min(*)
|
| 267 | :# 11
|
| 268 | : REAL*8 exterior_max(*)
|
| 269 | :# 11
|
| 270 | : REAL*8 spacing(*)
|
| 271 | :# 11
|
| 272 | : end function GetDomainSpecification
|
| 273 | :# 11
|
| 274 | : end interface
|
| 275 | :# 11
|
| 276 | : interface
|
| 277 | :# 11
|
| 278 | : subroutine GetLshIndexRanges (cctkGH, imin, imax)
|
| 279 | :# 11
|
| 280 | : implicit none
|
| 281 | :# 11
|
| 282 | : integer*8 cctkGH
|
| 283 | :# 11
|
| 284 | : INTEGER*4 imin(*)
|
| 285 | :# 11
|
| 286 | : INTEGER*4 imax(*)
|
| 287 | :# 11
|
| 288 | : end subroutine GetLshIndexRanges
|
| 289 | :# 11
|
| 290 | : end interface
|
| 291 | :# 11
|
| 292 | : interface
|
| 293 | :# 11
|
| 294 | : REAL*8 function GetScalProdCoeff ()
|
| 295 | :# 11
|
| 296 | : implicit none
|
| 297 | :# 11
|
| 298 | : end function GetScalProdCoeff
|
| 299 | :# 11
|
| 300 | : end interface
|
| 301 | :# 11
|
| 302 | : interface
|
| 303 | :# 11
|
| 304 | : subroutine GetScalProdDiag (cctkGH, dir, nsize, sigmad)
|
| 305 | :# 11
|
| 306 | : implicit none
|
| 307 | :# 11
|
| 308 | : integer*8 cctkGH
|
| 309 | :# 11
|
| 310 | : INTEGER*4 dir
|
| 311 | :# 11
|
| 312 | : INTEGER*4 nsize
|
| 313 | :# 11
|
| 314 | : REAL*8 sigmad(*)
|
| 315 | :# 11
|
| 316 | : end subroutine GetScalProdDiag
|
| 317 | :# 11
|
| 318 | : end interface
|
| 319 | :# 11
|
| 320 | : interface
|
| 321 | :# 11
|
| 322 | : INTEGER*4 function MoLQueryEvolvedRHS (EvolvedIndex)
|
| 323 | :# 11
|
| 324 | : implicit none
|
| 325 | :# 11
|
| 326 | : INTEGER*4 EvolvedIndex
|
| 327 | :# 11
|
| 328 | : end function MoLQueryEvolvedRHS
|
| 329 | :# 11
|
| 330 | : end interface
|
| 331 | :# 11
|
| 332 | : interface
|
| 333 | :# 11
|
| 334 | : INTEGER*4 function MultiPatch_GetBbox (cctkGH, size, bbox)
|
| 335 | :# 11
|
| 336 | : implicit none
|
| 337 | :# 11
|
| 338 | : integer*8 cctkGH
|
| 339 | :# 11
|
| 340 | : INTEGER*4 size
|
| 341 | :# 11
|
| 342 | : INTEGER*4 bbox(*)
|
| 343 | :# 11
|
| 344 | : end function MultiPatch_GetBbox
|
| 345 | :# 11
|
| 346 | : end interface
|
| 347 | :# 11
|
| 348 | : interface
|
| 349 | :# 11
|
| 350 | : INTEGER*4 function MultiPatch_GetBoundarySpecification (map, size, nboundaryzones, is_internal, is_staggered, shiftout)
|
| 351 | :# 11
|
| 352 | : implicit none
|
| 353 | :# 11
|
| 354 | : INTEGER*4 map
|
| 355 | :# 11
|
| 356 | : INTEGER*4 size
|
| 357 | :# 11
|
| 358 | : INTEGER*4 nboundaryzones(*)
|
| 359 | :# 11
|
| 360 | : INTEGER*4 is_internal(*)
|
| 361 | :# 11
|
| 362 | : INTEGER*4 is_staggered(*)
|
| 363 | :# 11
|
| 364 | : INTEGER*4 shiftout(*)
|
| 365 | :# 11
|
| 366 | : end function MultiPatch_GetBoundarySpecification
|
| 367 | :# 11
|
| 368 | : end interface
|
| 369 | :# 11
|
| 370 | : interface
|
| 371 | :# 11
|
| 372 | : INTEGER*4 function MultiPatch_GetMap (cctkGH)
|
| 373 | :# 11
|
| 374 | : implicit none
|
| 375 | :# 11
|
| 376 | : integer*8 cctkGH
|
| 377 | :# 11
|
| 378 | : end function MultiPatch_GetMap
|
| 379 | :# 11
|
| 380 | : end interface
|
| 381 | :# 11
|
| 382 | : interface
|
| 383 | :# 11
|
| 384 | : INTEGER*4 function MultiPatch_GetMaps (cctkGH)
|
| 385 | :# 11
|
| 386 | : implicit none
|
| 387 | :# 11
|
| 388 | : integer*8 cctkGH
|
| 389 | :# 11
|
| 390 | : end function MultiPatch_GetMaps
|
| 391 | :# 11
|
| 392 | : end interface
|
| 393 | :# 11
|
| 394 | : interface
|
| 395 | :# 11
|
| 396 | : INTEGER*4 function SymmetryHandleOfName (sym_name)
|
| 397 | :# 11
|
| 398 | : implicit none
|
| 399 | :# 11
|
| 400 | : character(*) sym_name
|
| 401 | :# 11
|
| 402 | : end function SymmetryHandleOfName
|
| 403 | :# 11
|
| 404 | : end interface
|
| 405 | :# 11
|
| 406 | : interface
|
| 407 | :# 11
|
| 408 | : INTEGER*4 function SymmetryTableHandleForGrid (cctkGH)
|
| 409 | :# 11
|
| 410 | : implicit none
|
| 411 | :# 11
|
| 412 | : integer*8 cctkGH
|
| 413 | :# 11
|
| 414 | : end function SymmetryTableHandleForGrid
|
| 415 | :# 11
|
| 416 | : end interface
|
| 417 | :# 11
|
| 418 | :
|
| 419 | : REAL*8 diss_fraction (3)
|
| 420 | :# 12
|
| 421 | : integer, parameter :: cctki_use_diss_fraction = kind(diss_fraction)
|
| 422 | :# 12
|
| 423 | : REAL*8 epsdis
|
| 424 | :# 12
|
| 425 | : integer, parameter :: cctki_use_epsdis = kind(epsdis)
|
| 426 | :# 12
|
| 427 | : REAL*8 h_scaling (3)
|
| 428 | :# 12
|
| 429 | : integer, parameter :: cctki_use_h_scaling = kind(h_scaling)
|
| 430 | :# 12
|
| 431 | : REAL*8 poison_value
|
| 432 | :# 12
|
| 433 | : integer, parameter :: cctki_use_poison_value = kind(poison_value)
|
| 434 | :# 12
|
| 435 | : integer*8 dissipation_type
|
| 436 | :# 12
|
| 437 | : integer, parameter :: cctki_use_dissipation_type = kind(dissipation_type)
|
| 438 | :# 12
|
| 439 | : integer*8 norm_type
|
| 440 | :# 12
|
| 441 | : integer, parameter :: cctki_use_norm_type = kind(norm_type)
|
| 442 | :# 12
|
| 443 | : integer*8 operator_type
|
| 444 | :# 12
|
| 445 | : integer, parameter :: cctki_use_operator_type = kind(operator_type)
|
| 446 | :# 12
|
| 447 | : integer*8 vars
|
| 448 | :# 12
|
| 449 | : integer, parameter :: cctki_use_vars = kind(vars)
|
| 450 | :# 12
|
| 451 | : INTEGER*4 check_grid_sizes
|
| 452 | :# 12
|
| 453 | : integer, parameter :: cctki_use_check_grid_sizes = kind(check_grid_sizes)
|
| 454 | :# 12
|
| 455 | : INTEGER*4 onesided_interpatch_boundaries
|
| 456 | :# 12
|
| 457 | : integer, parameter :: cctki_use_onesided_interpatch_boundaries = kind(onesided_interpatch_boundaries)
|
| 458 | :# 12
|
| 459 | : INTEGER*4 onesided_outer_boundaries
|
| 460 | :# 12
|
| 461 | : integer, parameter :: cctki_use_onesided_outer_boundaries = kind(onesided_outer_boundaries)
|
| 462 | :# 12
|
| 463 | : INTEGER*4 order
|
| 464 | :# 12
|
| 465 | : integer, parameter :: cctki_use_order = kind(order)
|
| 466 | :# 12
|
| 467 | : INTEGER*4 poison_derivatives
|
| 468 | :# 12
|
| 469 | : integer, parameter :: cctki_use_poison_derivatives = kind(poison_derivatives)
|
| 470 | :# 12
|
| 471 | : INTEGER*4 poison_dissipation
|
| 472 | :# 12
|
| 473 | : integer, parameter :: cctki_use_poison_dissipation = kind(poison_dissipation)
|
| 474 | :# 12
|
| 475 | : INTEGER*4 sbp_1st_deriv
|
| 476 | :# 12
|
| 477 | : integer, parameter :: cctki_use_sbp_1st_deriv = kind(sbp_1st_deriv)
|
| 478 | :# 12
|
| 479 | : INTEGER*4 sbp_2nd_deriv
|
| 480 | :# 12
|
| 481 | : integer, parameter :: cctki_use_sbp_2nd_deriv = kind(sbp_2nd_deriv)
|
| 482 | :# 12
|
| 483 | : INTEGER*4 sbp_upwind_deriv
|
| 484 | :# 12
|
| 485 | : integer, parameter :: cctki_use_sbp_upwind_deriv = kind(sbp_upwind_deriv)
|
| 486 | :# 12
|
| 487 | : INTEGER*4 scale_with_h
|
| 488 | :# 12
|
| 489 | : integer, parameter :: cctki_use_scale_with_h = kind(scale_with_h)
|
| 490 | :# 12
|
| 491 | : INTEGER*4 use_dissipation
|
| 492 | :# 12
|
| 493 | : integer, parameter :: cctki_use_use_dissipation = kind(use_dissipation)
|
| 494 | :# 12
|
| 495 | : INTEGER*4 use_shiftout
|
| 496 | :# 12
|
| 497 | : integer, parameter :: cctki_use_use_shiftout = kind(use_shiftout)
|
| 498 | :# 12
|
| 499 | : INTEGER*4 use_variable_deltas
|
| 500 | :# 12
|
| 501 | : integer, parameter :: cctki_use_use_variable_deltas = kind(use_variable_deltas)
|
| 502 | :# 12
|
| 503 | : INTEGER*4 zero_derivs_y
|
| 504 | :# 12
|
| 505 | : integer, parameter :: cctki_use_zero_derivs_y = kind(zero_derivs_y)
|
| 506 | :# 12
|
| 507 | : INTEGER*4 zero_derivs_z
|
| 508 | :# 12
|
| 509 | : integer, parameter :: cctki_use_zero_derivs_z = kind(zero_derivs_z)
|
| 510 | :# 12
|
| 511 | : COMMON /SummationByPartsrest/diss_fraction, epsdis, h_scaling, poison_value, dissipation_type, norm_type, operator_type, vars, ch&
|
| 512 | :# 12
|
| 513 | : &eck_grid_sizes, onesided_interpatch_boundaries, onesided_outer_boundaries, order, poison_derivatives, poison_dissipation, sbp_1s&
|
| 514 | :# 12
|
| 515 | : &t_deriv, sbp_2nd_deriv, sbp_upwind_deriv, scale_with_h, use_dissipation, use_shiftout, use_variable_deltas, zero_derivs_y, zero_&
|
| 516 | :# 12
|
| 517 | : &derivs_z
|
| 518 | :# 12
|
| 519 | :
|
| 520 | :
|
| 521 | : INTEGER*4, intent(IN) :: ni, nj, nk
|
| 522 | : REAL*8, dimension(ni,nj,nk), intent(IN) :: var
|
| 523 | : INTEGER*4, intent(IN) :: dir
|
| 524 | : INTEGER*4, intent(IN) :: bb(2)
|
| 525 | : INTEGER*4, intent(IN) :: gsize
|
| 526 | : INTEGER*4, intent(IN) :: offset(2)
|
| 527 | : REAL*8, intent(IN) :: delta
|
| 528 | : REAL*8, dimension(ni,nj,nk), intent(OUT) :: dvar
|
| 529 | :
|
| 530 | : REAL*8, dimension(3), save :: a
|
| 531 | : REAL*8, dimension(9,6), save :: q
|
| 532 | : REAL*8 :: idel
|
| 533 | :
|
| 534 | : INTEGER*4 :: il, ir, jl, jr, kl, kr, ol, or
|
| 535 | :
|
| 536 | : logical, save :: first = .true.
|
| 537 | :
|
| 538 | : if ( first ) then
|
| 539 | : call coeffs_1_6_3 ( a, q )
|
| 540 | : first = .false.
|
| 541 | : end if
|
| 542 | :
|
| 543 | : idel = 1.0_wp / delta
|
| 544 | :
|
| 545 | : if (gsize < 3) call CCTK_Warn(0,38,"Derivatives_6_3.F90","SummationByParts", "not enough ghostzones")
|
| 546 | :
|
| 547 | : direction: select case (dir)
|
| 548 | : case (0) direction
|
| 549 | : if ( bb(1) == 0 ) then
|
| 550 | : il = 1 + gsize
|
| 551 | : else
|
| 552 | : ol = offset(1)
|
| 553 | : dvar(1+ol,:,:) = ( q(1,1) * var(1+ol,:,:) + q(2,1) * var(2+ol,:,:) + &
|
| 554 | : q(3,1) * var(3+ol,:,:) + q(4,1) * var(4+ol,:,:) + &
|
| 555 | : q(5,1) * var(5+ol,:,:) ) * idel
|
| 556 | : dvar(2+ol,:,:) = ( q(1,2) * var(1+ol,:,:) + q(3,2) * var(3+ol,:,:) + &
|
| 557 | : q(4,2) * var(4+ol,:,:) + q(5,2) * var(5+ol,:,:) + &
|
| 558 | : q(6,2) * var(6+ol,:,:) ) * idel
|
| 559 | : dvar(3+ol,:,:) = ( q(1,3) * var(1+ol,:,:) + q(2,3) * var(2+ol,:,:) + &
|
| 560 | : q(4,3) * var(4+ol,:,:) + q(5,3) * var(5+ol,:,:) + &
|
| 561 | : q(6,3) * var(6+ol,:,:) ) * idel
|
| 562 | : dvar(4+ol,:,:) = ( q(1,4) * var(1+ol,:,:) + q(2,4) * var(2+ol,:,:) + &
|
| 563 | : q(3,4) * var(3+ol,:,:) + q(5,4) * var(5+ol,:,:) + &
|
| 564 | : q(6,4) * var(6+ol,:,:) + q(7,4) * var(7+ol,:,:) ) * idel
|
| 565 | : dvar(5+ol,:,:) = ( q(1,5) * var(1+ol,:,:) + q(2,5) * var(2+ol,:,:) + &
|
| 566 | : q(3,5) * var(3+ol,:,:) + q(4,5) * var(4+ol,:,:) + &
|
| 567 | : q(6,5) * var(6+ol,:,:) + q(7,5) * var(7+ol,:,:) + &
|
| 568 | : q(8,5) * var(8+ol,:,:) ) * idel
|
| 569 | : dvar(6+ol,:,:) = ( q(2,6) * var(2+ol,:,:) + q(3,6) * var(3+ol,:,:) + &
|
| 570 | : q(4,6) * var(4+ol,:,:) + q(5,6) * var(5+ol,:,:) + &
|
| 571 | : q(7,6) * var(7+ol,:,:) + q(8,6) * var(8+ol,:,:) + &
|
| 572 | : q(9,6) * var(9+ol,:,:) ) * idel
|
| 573 | : il = 7 + ol
|
| 574 | : end if
|
| 575 | : if ( bb(2) == 0 ) then
|
| 576 | : ir = ni - gsize
|
| 577 | : else
|
| 578 | : or = ni - offset(2)
|
| 579 | : dvar(or,:,:) = - ( q(1,1) * var(or,:,:) + q(2,1) * var(or-1,:,:) + &
|
| 580 | : q(3,1) * var(or-2,:,:) + q(4,1) * var(or-3,:,:) + &
|
| 581 | : q(5,1) * var(or-4,:,:) ) * idel
|
| 582 | : dvar(or-1,:,:) = - ( q(1,2) * var(or,:,:) + q(3,2) * var(or-2,:,:) + &
|
| 583 | : q(4,2) * var(or-3,:,:) + q(5,2) * var(or-4,:,:) + &
|
| 584 | : q(6,2) * var(or-5,:,:) ) * idel
|
| 585 | : dvar(or-2,:,:) = - ( q(1,3) * var(or,:,:) + q(2,3) * var(or-1,:,:) + &
|
| 586 | : q(4,3) * var(or-3,:,:) + q(5,3) * var(or-4,:,:) + &
|
| 587 | : q(6,3) * var(or-5,:,:) ) * idel
|
| 588 | : dvar(or-3,:,:) = - ( q(1,4) * var(or,:,:) + q(2,4) * var(or-1,:,:) + &
|
| 589 | : q(3,4) * var(or-2,:,:) + q(5,4) * var(or-4,:,:) + &
|
| 590 | : q(6,4) * var(or-5,:,:) + &
|
| 591 | : q(7,4) * var(or-6,:,:) ) * idel
|
| 592 | : dvar(or-4,:,:) = - ( q(1,5) * var(or,:,:) + q(2,5) * var(or-1,:,:) + &
|
| 593 | : q(3,5) * var(or-2,:,:) + q(4,5) * var(or-3,:,:) + &
|
| 594 | : q(6,5) * var(or-5,:,:) + q(7,5) * var(or-6,:,:) + &
|
| 595 | : q(8,5) * var(or-7,:,:) ) * idel
|
| 596 | : dvar(or-5,:,:) = - ( q(2,6) * var(or-1,:,:) + q(3,6) * var(or-2,:,:) + &
|
| 597 | : q(4,6) * var(or-3,:,:) + q(5,6) * var(or-4,:,:) + &
|
| 598 | : q(7,6) * var(or-6,:,:) + q(8,6) * var(or-7,:,:) + &
|
| 599 | : q(9,6) * var(or-8,:,:) ) * idel
|
| 600 | : ir = or - 6
|
| 601 | : end if
|
| 602 | : if (il > ir+1) call CCTK_Warn(0,95,"Derivatives_6_3.F90","SummationByParts", "domain too small")
|
| 603 | : dvar(il:ir,:,:) = ( a(1) * ( var(il+1:ir+1,:,:) - &
|
| 604 | : var(il-1:ir-1,:,:) ) + &
|
| 605 | : a(2) * ( var(il+2:ir+2,:,:) - &
|
| 606 | : var(il-2:ir-2,:,:) ) + &
|
| 607 | : a(3) * ( var(il+3:ir+3,:,:) - &
|
| 608 | : var(il-3:ir-3,:,:) ) ) * idel
|
| 609 | : case (1) direction
|
| 610 | : if ( zero_derivs_y /= 0 ) then
|
| 611 | : dvar = zero
|
| 612 | : else
|
| 613 | : if ( bb(1) == 0 ) then
|
| 614 | : jl = 1 + gsize
|
| 615 | : else
|
| 616 | : ol = offset(1)
|
| 617 | : dvar(:,1+ol,:) = ( q(1,1) * var(:,1+ol,:) + q(2,1) * var(:,2+ol,:) + &
|
| 618 | : q(3,1) * var(:,3+ol,:) + q(4,1) * var(:,4+ol,:) + &
|
| 619 | : q(5,1) * var(:,5+ol,:) ) * idel
|
| 620 | : dvar(:,2+ol,:) = ( q(1,2) * var(:,1+ol,:) + q(3,2) * var(:,3+ol,:) + &
|
| 621 | : q(4,2) * var(:,4+ol,:) + q(5,2) * var(:,5+ol,:) + &
|
| 622 | : q(6,2) * var(:,6+ol,:) ) * idel
|
| 623 | : dvar(:,3+ol,:) = ( q(1,3) * var(:,1+ol,:) + q(2,3) * var(:,2+ol,:) + &
|
| 624 | : q(4,3) * var(:,4+ol,:) + q(5,3) * var(:,5+ol,:) + &
|
| 625 | : q(6,3) * var(:,6+ol,:) ) * idel
|
| 626 | : dvar(:,4+ol,:) = ( q(1,4) * var(:,1+ol,:) + q(2,4) * var(:,2+ol,:) + &
|
| 627 | : q(3,4) * var(:,3+ol,:) + q(5,4) * var(:,5+ol,:) + &
|
| 628 | : q(6,4) * var(:,6+ol,:) + q(7,4) * var(:,7+ol,:) ) * idel
|
| 629 | : dvar(:,5+ol,:) = ( q(1,5) * var(:,1+ol,:) + q(2,5) * var(:,2+ol,:) + &
|
| 630 | : q(3,5) * var(:,3+ol,:) + q(4,5) * var(:,4+ol,:) + &
|
| 631 | : q(6,5) * var(:,6+ol,:) + q(7,5) * var(:,7+ol,:) + &
|
| 632 | : q(8,5) * var(:,8+ol,:) ) * idel
|
| 633 | : dvar(:,6+ol,:) = ( q(2,6) * var(:,2+ol,:) + q(3,6) * var(:,3+ol,:) + &
|
| 634 | : q(4,6) * var(:,4+ol,:) + q(5,6) * var(:,5+ol,:) + &
|
| 635 | : q(7,6) * var(:,7+ol,:) + q(8,6) * var(:,8+ol,:) + &
|
| 636 | : q(9,6) * var(:,9+ol,:) ) * idel
|
| 637 | : jl = 7 + ol
|
| 638 | : end if
|
| 639 | : if ( bb(2) == 0 ) then
|
| 640 | : jr = nj - gsize
|
| 641 | : else
|
| 642 | : or = nj - offset(2)
|
| 643 | : dvar(:,or,:) = - ( q(1,1) * var(:,or,:) + q(2,1) * var(:,or-1,:) + &
|
| 644 | : q(3,1) * var(:,or-2,:) + q(4,1) * var(:,or-3,:) + &
|
| 645 | : q(5,1) * var(:,or-4,:) ) * idel
|
| 646 | : dvar(:,or-1,:) = - ( q(1,2) * var(:,or,:) + q(3,2) * var(:,or-2,:) + &
|
| 647 | : q(4,2) * var(:,or-3,:) + q(5,2) * var(:,or-4,:) + &
|
| 648 | : q(6,2) * var(:,or-5,:) ) * idel
|
| 649 | : dvar(:,or-2,:) = - ( q(1,3) * var(:,or,:) + q(2,3) * var(:,or-1,:) + &
|
| 650 | : q(4,3) * var(:,or-3,:) + q(5,3) * var(:,or-4,:) + &
|
| 651 | : q(6,3) * var(:,or-5,:) ) * idel
|
| 652 | : dvar(:,or-3,:) = - ( q(1,4) * var(:,or,:) + q(2,4) * var(:,or-1,:) + &
|
| 653 | : q(3,4) * var(:,or-2,:) + q(5,4) * var(:,or-4,:) + &
|
| 654 | : q(6,4) * var(:,or-5,:) + &
|
| 655 | : q(7,4) * var(:,or-6,:) ) * idel
|
| 656 | : dvar(:,or-4,:) = - ( q(1,5) * var(:,or,:) + q(2,5) * var(:,or-1,:) + &
|
| 657 | : q(3,5) * var(:,or-2,:) + q(4,5) * var(:,or-3,:) + &
|
| 658 | : q(6,5) * var(:,or-5,:) + q(7,5) * var(:,or-6,:) + &
|
| 659 | : q(8,5) * var(:,or-7,:) ) * idel
|
| 660 | : dvar(:,or-5,:) = - ( q(2,6) * var(:,or-1,:) + q(3,6) * var(:,or-2,:) + &
|
| 661 | : q(4,6) * var(:,or-3,:) + q(5,6) * var(:,or-4,:) + &
|
| 662 | : q(7,6) * var(:,or-6,:) + q(8,6) * var(:,or-7,:) + &
|
| 663 | : q(9,6) * var(:,or-8,:) ) * idel
|
| 664 | : jr = or - 6
|
| 665 | : end if
|
| 666 | : if (jl > jr+1) call CCTK_Warn(0,159,"Derivatives_6_3.F90","SummationByParts", "domain too small")
|
| 667 | : dvar(:,jl:jr,:) = ( a(1) * ( var(:,jl+1:jr+1,:) - &
|
| 668 | : var(:,jl-1:jr-1,:) ) + &
|
| 669 | : a(2) * ( var(:,jl+2:jr+2,:) - &
|
| 670 | : var(:,jl-2:jr-2,:) ) + &
|
| 671 | : a(3) * ( var(:,jl+3:jr+3,:) - &
|
| 672 | : var(:,jl-3:jr-3,:) ) ) * idel
|
| 673 | : end if
|
| 674 | : case (2) direction
|
| 675 | : if ( zero_derivs_z /= 0 ) then
|
| 676 | : dvar = zero
|
| 677 | : else
|
| 678 | : if ( bb(1) == 0 ) then
|
| 679 | : kl = 1 + gsize
|
| 680 | : else
|
| 681 | : ol = offset(1)
|
| 682 | : dvar(:,:,1+ol) = ( q(1,1) * var(:,:,1+ol) + q(2,1) * var(:,:,2+ol) + &
|
| 683 | : q(3,1) * var(:,:,3+ol) + q(4,1) * var(:,:,4+ol) + &
|
| 684 | : q(5,1) * var(:,:,5+ol) ) * idel
|
| 685 | : dvar(:,:,2+ol) = ( q(1,2) * var(:,:,1+ol) + q(3,2) * var(:,:,3+ol) + &
|
| 686 | : q(4,2) * var(:,:,4+ol) + q(5,2) * var(:,:,5+ol) + &
|
| 687 | : q(6,2) * var(:,:,6+ol) ) * idel
|
| 688 | : dvar(:,:,3+ol) = ( q(1,3) * var(:,:,1+ol) + q(2,3) * var(:,:,2+ol) + &
|
| 689 | : q(4,3) * var(:,:,4+ol) + q(5,3) * var(:,:,5+ol) + &
|
| 690 | : q(6,3) * var(:,:,6+ol) ) * idel
|
| 691 | : dvar(:,:,4+ol) = ( q(1,4) * var(:,:,1+ol) + q(2,4) * var(:,:,2+ol) + &
|
| 692 | : q(3,4) * var(:,:,3+ol) + q(5,4) * var(:,:,5+ol) + &
|
| 693 | : q(6,4) * var(:,:,6+ol) + q(7,4) * var(:,:,7+ol) ) * idel
|
| 694 | : dvar(:,:,5+ol) = ( q(1,5) * var(:,:,1+ol) + q(2,5) * var(:,:,2+ol) + &
|
| 695 | : q(3,5) * var(:,:,3+ol) + q(4,5) * var(:,:,4+ol) + &
|
| 696 | : q(6,5) * var(:,:,6+ol) + q(7,5) * var(:,:,7+ol) + &
|
| 697 | : q(8,5) * var(:,:,8+ol) ) * idel
|
| 698 | : dvar(:,:,6+ol) = ( q(2,6) * var(:,:,2+ol) + q(3,6) * var(:,:,3+ol) + &
|
| 699 | : q(4,6) * var(:,:,4+ol) + q(5,6) * var(:,:,5+ol) + &
|
| 700 | : q(7,6) * var(:,:,7+ol) + q(8,6) * var(:,:,8+ol) + &
|
| 701 | : q(9,6) * var(:,:,9+ol) ) * idel
|
| 702 | : kl = 7 + ol
|
| 703 | : end if
|
| 704 | : if ( bb(2) == 0 ) then
|
| 705 | : kr = nk - gsize
|
| 706 | : else
|
| 707 | : or = nk - offset(2)
|
| 708 | : dvar(:,:,or) = - ( q(1,1) * var(:,:,or) + q(2,1) * var(:,:,or-1) + &
|
| 709 | : q(3,1) * var(:,:,or-2) + q(4,1) * var(:,:,or-3) + &
|
| 710 | : q(5,1) * var(:,:,or-4) ) * idel
|
| 711 | : dvar(:,:,or-1) = - ( q(1,2) * var(:,:,or) + q(3,2) * var(:,:,or-2) + &
|
| 712 | : q(4,2) * var(:,:,or-3) + q(5,2) * var(:,:,or-4) + &
|
| 713 | : q(6,2) * var(:,:,or-5) ) * idel
|
| 714 | : dvar(:,:,or-2) = - ( q(1,3) * var(:,:,or) + q(2,3) * var(:,:,or-1) + &
|
| 715 | : q(4,3) * var(:,:,or-3) + q(5,3) * var(:,:,or-4) + &
|
| 716 | : q(6,3) * var(:,:,or-5) ) * idel
|
| 717 | : dvar(:,:,or-3) = - ( q(1,4) * var(:,:,or) + q(2,4) * var(:,:,or-1) + &
|
| 718 | : q(3,4) * var(:,:,or-2) + q(5,4) * var(:,:,or-4) + &
|
| 719 | : q(6,4) * var(:,:,or-5) + &
|
| 720 | : q(7,4) * var(:,:,or-6) ) * idel
|
| 721 | : dvar(:,:,or-4) = - ( q(1,5) * var(:,:,or) + q(2,5) * var(:,:,or-1) + &
|
| 722 | : q(3,5) * var(:,:,or-2) + q(4,5) * var(:,:,or-3) + &
|
| 723 | : q(6,5) * var(:,:,or-5) + q(7,5) * var(:,:,or-6) + &
|
| 724 | : q(8,5) * var(:,:,or-7) ) * idel
|
| 725 | : dvar(:,:,or-5) = - ( q(2,6) * var(:,:,or-1) + q(3,6) * var(:,:,or-2) + &
|
| 726 | : q(4,6) * var(:,:,or-3) + q(5,6) * var(:,:,or-4) + &
|
| 727 | : q(7,6) * var(:,:,or-6) + q(8,6) * var(:,:,or-7) + &
|
| 728 | : q(9,6) * var(:,:,or-8) ) * idel
|
| 729 | : kr = or - 6
|
| 730 | : end if
|
| 731 | : if (kl > kr+1) call CCTK_Warn(0,224,"Derivatives_6_3.F90","SummationByParts", "domain too small")
|
| 732 | : dvar(:,:,kl:kr) = ( a(1) * ( var(:,:,kl+1:kr+1) - &
|
| 733 | : var(:,:,kl-1:kr-1) ) + &
|
| 734 | : a(2) * ( var(:,:,kl+2:kr+2) - &
|
| 735 | : var(:,:,kl-2:kr-2) ) + &
|
| 736 | : a(3) * ( var(:,:,kl+3:kr+3) - &
|
| 737 | : var(:,:,kl-3:kr-3) ) ) * idel
|
| 738 | : end if
|
| 739 | : end select direction
|
| 740 | :end subroutine deriv_gf_6_3
|