• Home
  • Features
  • Pricing
  • Docs
  • Announcements
  • Sign In

gyrokinetics / gs2 / 1633935514

21 Jan 2025 09:35AM UTC coverage: 7.943% (-0.001%) from 7.944%
1633935514

push

gitlab-ci

David Dickinson
Merged in bugfix/out_of_bounds_in_collisions (pull request #1059)

3694 of 46506 relevant lines covered (7.94%)

100054.0 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

0.0
/src/collisions.fpp
1
!> Routines for implementing the model collision operator defined by
2
!> [Barnes, Abel et
3
!> al. 2009](https://pubs.aip.org/aip/pop/article/16/7/072107/263154/Linearized-model-Fokker-Planck-collision-operators)
4
!> or on [arxiv](https://arxiv.org/abs/0809.3945v2).
5
!> The collision operator causes physically motivated smoothing of
6
!> structure in velocity space which is necessary to prevent buildup
7
!> of structure at fine scales in velocity space, while conserving
8
!> energy and momentum.
9
module collisions
10
  use abstract_config, only: abstract_config_type, CONFIG_MAX_NAME_LEN
11
  use redistribute, only: redist_type
12

13
  implicit none
14

15
  private 
16

17
  public :: init_collisions, finish_collisions, reset_init, adjust_vnmult
18
  public :: read_parameters, wnml_collisions, check_collisions, set_heating, nxi_lim
19
  public :: dtot, fdf, fdb, vnmult, ncheck, vary_vnew, init_lorentz_error, set_vnmult
20
  public :: colls, hyper_colls, heating, adjust, split_collisions,use_le_layout, solfp1
21
  public :: collision_model_switch, collision_model_lorentz, collision_model_none
22
  public :: collision_model_lorentz_test, collision_model_full, collision_model_ediffuse
23
  public :: collisions_config_type, set_collisions_config, get_collisions_config
24
  
25
  interface solfp1
26
     module procedure solfp1_le_layout
27
     module procedure solfp1_standard_layout
28
  end interface
29

30
  interface solfp_lorentz
31
     module procedure solfp_lorentz_le_layout
32
     module procedure solfp_lorentz_standard_layout
33
  end interface
34

35
  interface conserve_lorentz
36
     module procedure conserve_lorentz_le_layout
37
     module procedure conserve_lorentz_standard_layout
38
  end interface
39

40
  interface conserve_diffuse
41
     module procedure conserve_diffuse_le_layout
42
     module procedure conserve_diffuse_standard_layout
43
  end interface 
44

45
  ! knobs
46
  logical :: use_le_layout
47
  logical :: const_v, conserve_moments
48
  logical :: conservative, resistivity
49
  integer :: collision_model_switch
50
  integer :: lorentz_switch, ediff_switch
51
  logical :: adjust
52
  logical :: heating
53
  logical :: hyper_colls
54
  logical :: ei_coll_only
55
  logical :: test
56
  logical :: special_wfb_lorentz
57
  logical :: vpar_zero_mean
58
  logical :: conserve_forbid_zero
59
  
60
  integer, parameter :: collision_model_lorentz = 1      ! if this changes, check gs2_diagnostics
61
  integer, parameter :: collision_model_none = 3
62
  integer, parameter :: collision_model_lorentz_test = 5 ! if this changes, check gs2_diagnostics
63
  integer, parameter :: collision_model_full = 6
64
  integer, parameter :: collision_model_ediffuse = 7
65

66
  integer, parameter :: lorentz_scheme_default = 1
67
  integer, parameter :: lorentz_scheme_old = 2
68

69
  integer, parameter :: ediff_scheme_default = 1
70
  integer, parameter :: ediff_scheme_old = 2
71

72
  real, dimension (2) :: vnmult = -1.0
73
  integer :: ncheck
74
  logical :: vary_vnew
75
  real :: vnfac, vnslow
76
  real :: etol, ewindow, etola, ewindowa
77
  integer :: timesteps_between_collisions
78
  logical :: force_collisions, has_lorentz, has_diffuse
79
  real, dimension (2) :: vnm_init = 1.0
80

81
  real, dimension (:,:,:), allocatable :: dtot
82
  ! (-ntgrid:ntgrid,nlambda,max(ng2,nlambda-ng2)) lagrange coefficients for derivative error estimate
83

84
  real, dimension (:,:), allocatable :: fdf, fdb
85
  ! (-ntgrid:ntgrid,nlambda) finite difference coefficients for derivative error estimate
86

87
  real, dimension (:,:,:), allocatable :: vnew, vnew_s, vnew_D, vnew_E, delvnew
88
  ! (naky,negrid,nspec) replicated
89

90
  real, dimension (:,:), allocatable :: vpdiffle
91
  real, dimension (:,:,:), allocatable :: vpdiff
92
  ! (-ntgrid:ntgrid,2,nlambda) replicated
93

94
  ! only for hyper-diffusive collisions
95
  real, dimension (:,:,:,:), allocatable :: vnewh
96
  ! (-ntgrid:ntgrid,ntheta0,naky,nspec) replicated
97

98
  ! only for momentum conservation due to Lorentz operator (8.06)
99
  real, dimension(:,:,:), allocatable :: s0, w0, z0
100
  ! The following (between the start and finish comments) are only used for LE layout
101
  ! start
102
  real, dimension (:,:,:), allocatable :: s0le, w0le, z0le
103
  ! Copies of aj0, aj1 and vpa from dist_fn_arrays stored in
104
  ! le layout shaped arrays.
105
  real, dimension (:,:,:), allocatable :: aj0le, vperp_aj1le, vpa_aj0_le
106
  ! finish
107

108
  ! needed for momentum and energy conservation due to energy diffusion (3.08)
109
  real, dimension(:,:,:), allocatable :: bs0, bw0, bz0
110

111
  ! The following (between the start and finish comments) are only used for LE layout
112
  ! start
113
  real, dimension (:,:,:), allocatable :: bs0le, bw0le, bz0le
114
  ! finish
115

116
  real :: cfac
117
  integer :: nxi_lim !< Sets the upper xi index which we consider in loops
118
  ! The following (between the start and finish comments) are only used for LE layout
119
  ! start
120
  ! only for lorentz
121
  real, dimension (:,:,:), allocatable :: c1le, betaale, qle, d1le, h1le
122
  ! only for energy diffusion
123
  real, dimension (:,:,:), allocatable :: ec1le, ebetaale, eqle
124
  ! finish
125
  ! The following (between the start and finish comments) are only used for none LE layout
126
  ! start
127
  ! only for lorentz
128
  real, dimension (:,:), allocatable :: c1, betaa, ql, d1, h1
129
  ! only for energy diffusion
130
  real, dimension (:,:), allocatable :: ec1, ebetaa, eql
131
  ! finish
132

133
  real, dimension (:, :), allocatable :: pitch_weights
134

135
  logical :: drag = .false.
136
  logical :: colls = .true.
137
  logical :: split_collisions
138

139
  logical :: hypermult
140
  logical :: initialized = .false.
141

142
  !> Used to represent the input configuration of collisions
143
  type, extends(abstract_config_type) :: collisions_config_type
144
     ! namelist : collisions_knobs
145
     ! indexed : false
146
     !> If true (default) then transform from the gyro-averaged
147
     !> distribution function \(g\) evolved by GS2 to the
148
     !> non-Boltzmann part of \(\delta f\), (\(h\)), when applying the
149
     !> collision operator. This is the physically appropriate choice,
150
     !> this parameter is primarily for numerical testing.
151
     logical :: adjust = .true.
152
     !> Factor multipyling the finite Larmor radius terms in the
153
     !> collision operator. This term is essentially just classical
154
     !> diffusion. Set `cfac` to 0 to turn off this diffusion.
155
     !>
156
     !> @note Default changed to 1.0 in order to include classical
157
     !> diffusion April 18 2006
158
     real :: cfac = 1.0
159
     !> Selects the collision model used in the simulation. Can be one
160
     !> of
161
     !>
162
     !> - `'default'` : Include both pitch angle scattering and energy
163
     !> diffusion.
164
     !> - `'collisionless'` : Disable the collision operator.
165
     !> - `'none'` : Equivalent to `'collisionless'`.
166
     !> - `'lorentz'` : Only pitch angle scattering.
167
     !> - `'lorentz-test'` : Only pitch angle scattering. For testing,
168
     !> disables some components of the operator.
169
     !> - `'ediffuse'` : Only energy diffusion.
170
     !>
171
     !> If no species have a non-zero collision frequency, `vnewk`, then
172
     !> the collision operator is also automatically disabled.
173
     character(len = 20) :: collision_model = 'default'
174
     !> If true (default) then guarantee exact conservation
175
     !> properties.
176
     logical :: conservative = .true.
177
     !> If true (default) then forces conservation corrections to zero
178
     !> in the forbidden region to avoid introducing unphysical
179
     !> non-zero values for the distribution function in the forbidden
180
     !> region of trapped particles.
181
     !>
182
     !> @todo Confirm above documentation is accurate.
183
     !>
184
     !> @note The conserving terms calculated as part of the field
185
     !> particle collision operator should respect the forbidden of
186
     !> the distribution function for trapped particles. This is a
187
     !> cosmetic change, but has the result that plots of the
188
     !> distribution function for trapped particles makes sense. Note
189
     !> that terms involving vpa do not need to be modified Because
190
     !> vpa = 0 in the forbidden region because of this explicit
191
     !> forbid statements have not been added to the drag term
192
     !> involving apar.
193
     logical :: conserve_forbid_zero = .true.
194
     !> If true (default) then guarantee collision operator conserves
195
     !> momentum and energy.
196
     !>
197
     !> @todo Clarify the difference with [[collisions_knobs:conservative]].
198
     !>
199
     !> @note Default changed to reflect improved momentum and energy
200
     !> conversation 07/08
201
     logical :: conserve_moments = .true.  
202
     !> If true (not the default) then use the thermal velocity to
203
     !> evaluate the collision frequencies to be used. This results in
204
     !> an energy independent collision frequency being used for all
205
     !> species.
206
     logical :: const_v = .false.
207
     !> Controls how the coefficients in the matrix representing the
208
     !> energy diffusion operator are obtained. Can be one of
209
     !>
210
     !> - `'default'` : Use a conservative scheme.
211
     !> - `'old'` : Use the original non-conservative scheme.
212
     !>
213
     !> @todo Consider deprecating/removing the `'old'` option.
214
     character(len = 20) :: ediff_scheme = 'default'
215
     !> If true (not the default) then force the collision frequency
216
     !> used for all non-electron species to zero and force all
217
     !> electron-electron terms to zero.
218
     logical :: ei_coll_only = .false.
219
     !> Only used in [[get_verr]] as a part of the adaptive
220
     !> collisionality algorithm. Sets the maximum relative error
221
     !> allowed, above which the collision frequency must be
222
     !> increased.
223
     !>
224
     !> @todo Confirm this is really to set the relative error limit.
225
     real :: etol = 2.e-2
226
     !> Only used in [[get_verr]] as a part of the adaptive
227
     !> collisionality algorithm. Sets the maximum absolute error
228
     !> allowed, above which the collision frequency must be
229
     !> increased.
230
     !>
231
     !> @todo Confirm this is really to set the absolute error limit.     
232
     real :: etola = 2.e-2
233
     !> Only used in [[get_verr]] as a part of the adaptive
234
     !> collisionality algorithm. Sets an offset to apply to the
235
     !> relative error limit set by [[collisions_knobs:etol]]. This is used to provide
236
     !> hysteresis is the adaptive collisionality algorithm so to
237
     !> avoid adjusting the collision frequency up and down every step
238
     !> (similar to [[reinit_knobs:delt_cushion]]).
239
     !>
240
     !> @todo Confirm the above description.
241
     real :: ewindow = 1.e-2
242
     !> Only used in [[get_verr]] as a part of the adaptive
243
     !> collisionality algorithm. Sets an offset to apply to the
244
     !> absolute error limit set by [[collisions_knobs:etola]]. This is used to provide
245
     !> hysteresis is the adaptive collisionality algorithm so to
246
     !> avoid adjusting the collision frequency up and down every step
247
     !> (similar to the [[reinit_knobs:delt_cushion]]).
248
     !>
249
     !> @todo Confirm the above description.     
250
     real :: ewindowa = 1.e-2
251
     !> Currently we skip the application of the selected collision
252
     !> operator for species with zero collision frequency and disable
253
     !> collisions entirely if no species have non-zero collision
254
     !> frequency. This is generally sensible, but it can be useful to
255
     !> force the use of the collisional code path in some situations
256
     !> such as in code testing. Setting this flag to `.true.` forces
257
     !> the selected collision model operator to be applied even if
258
     !> the collision frequency is zero.
259
     logical :: force_collisions = .false.
260
     !> If true (not the default) then calculate collisional heating
261
     !> when applying the collion operator. This is purely a
262
     !> diagnostic calculation. It should not change the evolution.
263
     !>
264
     !> @todo : Verify this does not influence the evolution.
265
     logical :: heating = .false.
266
     !> If true (not the default) then multiply the hyper collision
267
     !> frequency by the species' collision frequency
268
     !> [[species_parameters:nu_h]]. This only impacts the pitch
269
     !> angle scattering operator.
270
     !>
271
     !> @note The hyper collision frequency is only non-zero if any
272
     !> species have a non-zero `nu_h` value set in the input. If any
273
     !> are set then the hyper collision frequency is simply `nu_h *
274
     !> kperp2 * kperp2` (where `kperp2` here is normalised to the
275
     !> maximum `kperp2`).
276
     logical :: hypermult = .false.
277
     !> Controls how the coefficients in the matrix representing the
278
     !> pitch angle scattering operator are obtained. Can be one of
279
     !>
280
     !> - `'default'` : Use a conservative scheme.
281
     !> - `'old'` : Use the original non-conservative scheme.
282
     !>
283
     !> @todo Consider deprecating/removing the `'old'` option.
284
     character(len = 20) :: lorentz_scheme = 'default'
285
     !> Used as a part of the adaptive collisionality algorithm. When
286
     !> active we check the velocity space error with [[get_verr]]
287
     !> every `ncheck` time steps. This check can be relatively
288
     !> expensive so it is recommended to avoid small values of
289
     !> `ncheck`.
290
     !>
291
     !> @warning The new diagnostics module currently ignores this
292
     !> value and instead uses its own input variable named `ncheck`
293
     !> (which has a different default). See [this
294
     !> bug](https://bitbucket.org/gyrokinetics/gs2/issues/88).
295
     integer :: ncheck = 100
296
     !> If true (default) then potentially include the drag term in
297
     !> the pitch angle scattering operator. This is a necessary but
298
     !> not sufficient criteria. For the drag term to be included we
299
     !> also require \(\beta\neq 0\), more than one simulated species
300
     !> and finite \(A_\|\) perturbations included in the simulation
301
     !> (i.e. `fapar /= 0`).
302
     logical :: resistivity = .true.
303
     !> If true (not the default) then use special handling for the
304
     !> wfb particle in the pitch angle scattering operator.
305
     !>
306
     !> @note MRH changed default 16/08/2018. Previous default of true
307
     !> seemed to cause a numerical issue in flux tube simulations for
308
     !> the zonal modes at large \(k_x\).
309
     !>
310
     !> @todo Improve this documentation
311
     logical :: special_wfb_lorentz = .false.
312
     !> If true (not the default) then remove the collision operator
313
     !> from the usual time advance algorithm. Instead the collision
314
     !> operator is only applied every
315
     !> [[collisions_knobs:timesteps_between_collisions]]
316
     !> timesteps. This can potentially substantially speed up
317
     !> collisional simulations, both in the initialisation and
318
     !> advance phases.
319
     !>
320
     !> @warning Currently the input
321
     !> [[collisions_knobs:timesteps_between_collisions]] is ignored
322
     !> so collisions are applied every time step. The primary result
323
     !> of `split_collision = .true.` currently is that collisions are
324
     !> not applied in the first linear solve used as a part of a
325
     !> single time step. Hence the cost of collisions in advance are
326
     !> roughly halved. The full saving in the initialisation phase is
327
     !> still realised.
328
     logical :: split_collisions = .false.
329
     !> If true (not the default) then performs some additional checks
330
     !> of the data redistribution routines associated with
331
     !> transforming being the standard and collisional data
332
     !> decompositions.
333
     logical :: test = .false.
334
     !> Should set the number of timesteps between application of the
335
     !> collision operator if [[collisions_knobs:split_collisions]] is
336
     !> true. Currently this is ignored.
337
     !>
338
     !> @warning This value is currently ignored.
339
     integer :: timesteps_between_collisions = 1
340
     !> If true (default) then use a data decomposition for collisions
341
     !> that brings both pitch angle and energy local to a
342
     !> processor. This is typically the most efficient option,
343
     !> however for collisional simulations that only use part of the
344
     !> collision operator (either energy diffusion or pitch angle
345
     !> scattering) then it may be beneficial to set this flag to
346
     !> false such that we use a decomposition that only brings either
347
     !> energy or pitch angle local.
348
     logical :: use_le_layout = .true.
349
     !> Set to true (not the default) to activate the adaptive
350
     !> collisionality algorithm.
351
     !>
352
     !> @todo Provide more documentation on the adaptive
353
     !> collisionality algorithm.
354
     logical :: vary_vnew = .false.
355
     !> If the collisionality is to be increased as a part of the
356
     !> adaptive collisionality algorithm then increase it by this
357
     !> factor.
358
     real :: vnfac = 1.1
359
     !> If the collisionality is to be decreased as a part of the
360
     !> adaptive collisionality algorithm then decrease it by this
361
     !> factor.
362
     real :: vnslow = 0.9
363
     !> Controls how the duplicate `vpar = 0` point is handled.  When
364
     !> `vpar_zero_mean = .true.` (the default) the average of `g(vpar
365
     !> = 0)` for both signs of the parallel velcoity (`isgn`) is used
366
     !> in the collision operator instead of just `g(vpar = 0)` at
367
     !> `isgn=2`.  This is seen to suppress a numerical instability
368
     !> when `special_wfb_lorentz =.false.`. With these defaults pitch
369
     !> angle scattering at \(\theta = \pm \pi \) is now being handled
370
     !> physically i.e. `vpar = 0` at this theta location is no longer
371
     !> being skipped.
372
     !>
373
     !> @todo Consider removing this option.
374
     logical :: vpar_zero_mean = .true.
375
   contains
376
     procedure, public :: read => read_collisions_config
377
     procedure, public :: write => write_collisions_config
378
     procedure, public :: reset => reset_collisions_config
379
     procedure, public :: broadcast => broadcast_collisions_config
380
     procedure, public, nopass :: get_default_name => get_default_name_collisions_config
381
     procedure, public, nopass :: get_default_requires_index => get_default_requires_index_collisions_config
382
  end type collisions_config_type
383

384
  type(collisions_config_type) :: collisions_config
385
contains
386

387
  subroutine set_vnmult(vnmult_in)
×
388
    real, dimension(2), intent(in) :: vnmult_in
389
    vnmult = vnmult_in
×
390
  end subroutine set_vnmult
×
391

392
  subroutine set_heating(heating_in)
×
393
    logical, intent(in) :: heating_in
394
    heating = heating_in
×
395
  end subroutine set_heating
×
396
  
397
  !> FIXME : Add documentation
398
  subroutine check_collisions(report_unit)
×
399
    implicit none
400
    integer, intent(in) :: report_unit
401
    select case (collision_model_switch)
×
402
    case (collision_model_lorentz,collision_model_lorentz_test)
403
       write (report_unit, fmt="('A Lorentz collision operator has been selected.')")
×
404
       if (cfac > 0) write (report_unit, fmt="('This has both terms of the Lorentz collision operator: cfac=',e12.4)") cfac
×
405
       if (cfac == 0) write (report_unit, fmt="('This is only a partial Lorentz collision operator (cfac=0.0)')")
×
406
       if (const_v) write (report_unit, fmt="('This is an energy independent Lorentz collision operator (const_v=true)')")  
×
407
!          if (hypercoll) call init_hyper_lorentz
408
    case (collision_model_full)
409
       write (report_unit, fmt="('Full GS2 collision operator has been selected.')")
×
410
    end select
411
  end subroutine check_collisions
×
412

413
  !> FIXME : Add documentation
414
  subroutine wnml_collisions(unit)
×
415
    implicit none
416
    integer, intent(in) :: unit
417
    write (unit, *)
×
418
    write (unit, fmt="(' &',a)") "collisions_knobs"
×
419
    select case (collision_model_switch)
×
420
    case (collision_model_lorentz)
421
       write (unit, fmt="(' collision_model = ',a)") '"lorentz"'
×
422
       if (hypermult) write (unit, fmt="(' hypermult = ',L1)") hypermult
×
423
    case (collision_model_lorentz_test)
424
       write (unit, fmt="(' collision_model = ',a)") '"lorentz-test"'
×
425
    case (collision_model_none)
426
       write (unit, fmt="(' collision_model = ',a)") '"collisionless"'
×
427
    end select
428
    write (unit, fmt="(' cfac = ',f6.3)") cfac
×
429
    write (unit, fmt="(' heating = ',L1)") heating
×
430
    write (unit, fmt="(' /')")
×
431
  end subroutine wnml_collisions
×
432

433
  !> FIXME : Add documentation
434
  subroutine init_collisions(collisions_config_in)
×
435
    use species, only: init_species, nspec, spec
436
    use theta_grid, only: init_theta_grid, ntgrid
437
    use kt_grids, only: init_kt_grids, naky, ntheta0
438
    use le_grids, only: init_le_grids, nlambda, negrid
439
    use run_parameters, only: init_run_parameters
440
    use gs2_layouts, only: init_dist_fn_layouts, init_gs2_layouts
441
    use mp, only: nproc, iproc
442
    implicit none
443
    type(collisions_config_type), intent(in), optional :: collisions_config_in
444
    if (initialized) return
×
445
    initialized = .true.
×
446
    call init_gs2_layouts
×
447
    call init_species
×
448

449
    hyper_colls = .false.
×
450
    if (any(spec%nu_h > epsilon(0.0))) hyper_colls = .true.
×
451

452
    call init_theta_grid
×
453
    call init_kt_grids
×
454
    call init_le_grids
×
455
    call init_run_parameters
×
456
    call init_dist_fn_layouts (ntgrid, naky, ntheta0, nlambda, negrid, nspec, nproc, iproc)
×
457
    call read_parameters(collisions_config_in)
×
458

459
    call init_arrays
×
460

461
  end subroutine init_collisions
462

463
  !> FIXME : Add documentation
464
  subroutine read_parameters(collisions_config_in)
×
465
    use file_utils, only: error_unit
466
    use text_options, only: text_option, get_option_value
467
    use run_parameters, only: beta, fapar
468
    use species, only: nspec
469
    use le_grids, only: nxi, ng2
470
    implicit none
471
    type(collisions_config_type), intent(in), optional :: collisions_config_in
472
    
473
    type (text_option), dimension (6), parameter :: modelopts = &
474
         (/ text_option('default', collision_model_full), &
475
            text_option('lorentz', collision_model_lorentz), &
476
            text_option('ediffuse', collision_model_ediffuse), &
477
            text_option('lorentz-test', collision_model_lorentz_test), &
478
            text_option('none', collision_model_none), &
479
            text_option('collisionless', collision_model_none) /)
480
    type (text_option), dimension (2), parameter :: schemeopts = &
481
         (/ text_option('default', lorentz_scheme_default), &
482
            text_option('old', lorentz_scheme_old) /)
483
    type (text_option), dimension (2), parameter :: eschemeopts = &
484
         (/ text_option('default', ediff_scheme_default), &
485
            text_option('old', ediff_scheme_old) /)
486
    character(20) :: collision_model, lorentz_scheme, ediff_scheme
487
    integer :: ierr
488

489
    if (present(collisions_config_in)) collisions_config = collisions_config_in
×
490

491
    call collisions_config%init(name = 'collisions_knobs', requires_index = .false.)
×
492

493
    ! Copy out internal values into module level parameters
494
    associate(self => collisions_config)
495
#include "collisions_copy_out_auto_gen.inc"
496
    end associate
497

498
    ierr = error_unit()
×
499
    call get_option_value &
500
         (collision_model, modelopts, collision_model_switch, &
501
         ierr, "collision_model in collisions_knobs",.true.)
×
502

503
    call get_option_value &
504
         (lorentz_scheme, schemeopts, lorentz_switch, &
505
         ierr, "lorentz_scheme in collisions_knobs",.true.)
×
506
    
507
    call get_option_value &
508
         (ediff_scheme, eschemeopts, ediff_switch, &
509
         ierr, "ediff_scheme in collisions_knobs",.true.)
×
510

511
    select case (collision_model_switch)
×
512
    case (collision_model_full)
513
       has_lorentz = .true.  ; has_diffuse = .true.
×
514
    case (collision_model_lorentz,collision_model_lorentz_test)
515
       has_lorentz = .true.  ; has_diffuse = .false.
×
516
    case (collision_model_ediffuse)
517
       has_lorentz = .false. ; has_diffuse = .true.
×
518
    case default
519
       has_lorentz = .false. ; has_diffuse = .false.
×
520
    end select
521

522
    drag = has_lorentz .and. resistivity .and. (beta > epsilon(0.0)) &
523
         .and. (nspec > 1) .and. (fapar.gt.0)
×
524

525
    ! The nxi > 2 * ng2 check appears to be checking if we have
526
    ! trapped particles or not so could be replaced with grid_has_trapped_particles()
527
    if (nxi > 2 * ng2 ) then
×
528
       nxi_lim = nxi + 1
×
529
    else
530
       nxi_lim = nxi
×
531
    end if
532
  end subroutine read_parameters
×
533

534
  !> A wrapper to sqrt which replaces -ve values with 0.0 to avoid
535
  !> NaNs arising from slight floating point discrepancies. We could
536
  !> consider adding a debug check to abort/warn if the passed value
537
  !> is too negative (i.e. if it looks like an error rather than small
538
  !> round off).
539
  elemental real function safe_sqrt(arg)
×
540
    implicit none
541
    real, intent(in) :: arg
542
    safe_sqrt = sqrt(max(0.0, arg))
×
543
  end function safe_sqrt
×
544

545
  !> FIXME : Add documentation
546
  subroutine init_arrays
×
547
    use species, only: nspec
548
    use le_grids, only: init_map
549
    use kt_grids, only: naky, ntheta0
550
    use theta_grid, only: ntgrid
551
    use dist_fn_arrays, only: c_rate
552
    use array_utils, only: zero_array
553
    implicit none
554
    logical :: use_lz_layout, use_e_layout
555

556
    use_lz_layout = .false. ; use_e_layout = .false.
×
557

558
    if (collision_model_switch == collision_model_none) then
×
559
       colls = .false.
×
560
       return
×
561
    end if
562

563
    call init_vnew
×
564
    if (all(abs(vnew(:,1,:)) <= 2.0*epsilon(0.0)) .and. .not. force_collisions) then
×
565
       collision_model_switch = collision_model_none
×
566
       colls = .false.
×
567
       return
×
568
    end if
569

570
    if (heating .and. .not. allocated(c_rate)) then
×
571
       allocate (c_rate(-ntgrid:ntgrid, ntheta0, naky, nspec, 3))
×
572
       call zero_array(c_rate)
×
573
    end if
574

575
    use_lz_layout = has_lorentz .and. .not. use_le_layout
×
576
    use_e_layout = has_diffuse .and. .not. use_le_layout
×
577
    call init_map (use_lz_layout, use_e_layout, use_le_layout, test)
×
578

579
    if (has_lorentz) then
×
580
       call init_lorentz
×
581
       if (conserve_moments) call init_lorentz_conserve
×
582
    end if
583

584
    if (has_diffuse) then
×
585
       call init_ediffuse
×
586
       if (conserve_moments) call init_diffuse_conserve
×
587
    end if
588

589
    if (use_le_layout .and. (conserve_moments .or. drag)) call init_le_bessel
×
590
  end subroutine init_arrays
591

592
  !> Communicate Bessel functions from g_lo to le_lo
593
  subroutine init_le_bessel
×
594
    use gs2_layouts, only: g_lo, le_lo, ig_idx
595
    use dist_fn_arrays, only: aj0, aj1, vpa
596
    use le_grids, only: negrid, g2le, ixi_to_il, energy => energy_maxw, al
597
    use theta_grid, only: ntgrid
598
    use redistribute, only: gather, scatter
599
    use array_utils, only: zero_array
600
    implicit none
601
    complex, dimension (:,:,:), allocatable :: ctmp, z_big
×
602
    integer :: ile, ig, ie, ixi, il
603

604
    allocate (z_big(-ntgrid:ntgrid, 2, g_lo%llim_proc:g_lo%ulim_alloc))
×
605
    allocate (ctmp(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
606
    ! We need to initialise ctmp as it is used as receiving buffer in
607
    ! g2le redistribute, which doesn't populate all elements
608
    call zero_array(ctmp)
×
609

610
    ! next set aj0le & aj1l
611
    z_big(:,1,:) = cmplx(aj0,aj1)
×
612
    z_big(:,2,:) = z_big(:,1,:)
×
613

614
    call gather (g2le, z_big, ctmp)
×
615

616
    if (.not. allocated(aj0le)) then
×
617
       allocate (aj0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
618
       allocate (vperp_aj1le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
619
    end if
620

621
    aj0le = real(ctmp)
×
622
    vperp_aj1le = aimag(ctmp) !< Currently just aj1
×
623

624
    !$OMP PARALLEL DO DEFAULT(none) &
625
    !$OMP PRIVATE(ile, ig, ixi, ie, il) &
626
    !$OMP SHARED(le_lo, negrid, nxi_lim, ixi_to_il, vperp_aj1le, energy, al) &
627
    !$OMP SCHEDULE(static)
628
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
629
       ig = ig_idx(le_lo, ile)
×
630
       do ie = 1, negrid
×
631
          do ixi = 1, nxi_lim
×
632
             il = ixi_to_il(ixi, ig)
×
633
             vperp_aj1le(ixi, ie, ile) = vperp_aj1le(ixi, ie, ile) * energy(ie) * al(il)
×
634
          end do
635
       end do
636
    end do
637
    !$OMP END PARALLEL DO
638

639
    z_big = vpa
×
640
    call gather (g2le, z_big, ctmp)
×
641
    deallocate(z_big)
×
642
    if (.not. allocated(vpa_aj0_le)) then
×
643
       allocate (vpa_aj0_le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
644
    end if
645
    vpa_aj0_le = real(ctmp) * aj0le
×
646
  end subroutine init_le_bessel
×
647

648
  !> Precompute three quantities needed for momentum and energy conservation:
649
  !> z0, w0, s0 (z0le, w0le, s0le if use_le_layout chosen in the input file defined)
650
  subroutine init_lorentz_conserve
×
651
    use gs2_layouts, only: g_lo, ie_idx, is_idx, ik_idx, il_idx, it_idx
652
    use species, only: nspec, spec, is_electron_species
653
    use kt_grids, only: kperp2, naky, ntheta0
654
    use theta_grid, only: ntgrid, bmag
655
    use le_grids, only: energy => energy_maxw, speed => speed_maxw, al, &
656
         integrate_moment, negrid, forbid
657
    use gs2_time, only: code_dt, tunits
658
    use dist_fn_arrays, only: aj0, aj1, vpa
659
    use le_grids, only: g2le
660
    use gs2_layouts, only: le_lo
661
    use redistribute, only: gather, scatter
662
    use array_utils, only: zero_array
663
    implicit none
664
    complex, dimension (1,1,1) :: dum1, dum2
665
    real, dimension (:,:,:), allocatable :: gtmp
×
666
    real, dimension (:,:,:,:), allocatable :: duinv, dtmp, vns
×
667
    integer :: ie, il, ik, is, isgn, iglo,  it, ig
668
    complex, dimension (:,:,:), allocatable :: ctmp, z_big
×
669
    complex, dimension(:,:,:), allocatable :: s0tmp, w0tmp, z0tmp
×
670
    logical, parameter :: all_procs = .true.
671

672
    if(use_le_layout) then
×
673
       allocate (ctmp(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
674
       ! We need to initialise ctmp as it is used as receiving buffer in
675
       ! g2le redistribute, which doesn't populate all elements
676
       call zero_array(ctmp)
×
677
    end if
678

679
    dum1 = 0. ; dum2 = 0.
×
680
    allocate(s0tmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
681
    allocate(w0tmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
682
    allocate(z0tmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
683

684
    allocate (gtmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
685
    allocate (duinv(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
686
    allocate (dtmp(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
687
    allocate (vns(naky,negrid,nspec,3))
×
688

689
    call zero_array(duinv)
×
690
    call zero_array(dtmp)
×
691

692
    vns(:,:,:,1) = vnmult(1)*vnew_D
×
693
    vns(:,:,:,2) = vnmult(1)*vnew_s
×
694
    vns(:,:,:,3) = 0.0
×
695

696
    if (drag) then
×
697
       do is = 1, nspec
×
698
          if (.not. is_electron_species(spec(is))) cycle
×
699
          do ik = 1, naky
×
700
             vns(ik,:,is,3) = vnmult(1)*spec(is)%vnewk*tunits(ik)/energy**1.5
×
701
          end do
702
       end do
703

704
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
705
! Now get z0 (first form)
706
       !$OMP PARALLEL DO DEFAULT(none) &
707
       !$OMP PRIVATE(iglo, ik, ie, il, is, isgn) &
708
       !$OMP SHARED(g_lo, conservative, z0tmp, code_dt, vns, vpdiff, speed, aj0, vpa) &
709
       !$OMP SCHEDULE(static)
710
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
711
          ik = ik_idx(g_lo,iglo)
×
712
          ie = ie_idx(g_lo,iglo)
×
713
          il = il_idx(g_lo,iglo)
×
714
          is = is_idx(g_lo,iglo)
×
715
          do isgn = 1, 2
×
716
             ! u0 = -2 nu_D^{ei} vpa J0 dt f0
717
             if (conservative) then
×
718
                z0tmp(:,isgn,iglo) = -2.0*code_dt*vns(ik,ie,is,3)*vpdiff(:,isgn,il) &
×
719
                     * speed(ie)*aj0(:,iglo)
×
720
             else
721
                z0tmp(:,isgn,iglo) = -2.0*code_dt*vns(ik,ie,is,3)*vpa(:,isgn,iglo)*aj0(:,iglo)
×
722
             end if
723
          end do
724
       end do
725
       !$OMP END PARALLEL DO
726

727
       call zero_out_passing_hybrid_electrons(z0tmp)
×
728

729
       if(use_le_layout) then
×
730
          call gather (g2le, z0tmp, ctmp)
×
731
          call solfp_lorentz (ctmp)
×
732
          call scatter (g2le, ctmp, z0tmp)   ! z0 is redefined below
×
733
       else
734
          call solfp_lorentz (z0tmp,dum1,dum2)   ! z0 is redefined below
×
735
       end if
736

737
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
738
! Now get v0z0
739

740
       !$OMP PARALLEL DO DEFAULT(none) &
741
       !$OMP PRIVATE(iglo, isgn) &
742
       !$OMP SHARED(g_lo, vpa, gtmp, aj0, z0tmp) &
743
       !$OMP COLLAPSE(2) &
744
       !$OMP SCHEDULE(static)
745
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
746
          do isgn = 1, 2
×
747
             ! v0 = vpa J0 f0
748
             gtmp(:,isgn,iglo) = vpa(:,isgn,iglo) * aj0(:,iglo) * real(z0tmp(:,isgn,iglo))
×
749
          end do
750
       end do
751
       !$OMP END PARALLEL DO
752

753
       call integrate_moment (gtmp, dtmp, all_procs) ! v0z0
×
754

755
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
756
! Redefine z0 = z0 / (1 + v0z0)
757

758
       !$OMP PARALLEL DO DEFAULT(none) &
759
       !$OMP PRIVATE(iglo, ik, it, is, isgn) &
760
       !$OMP SHARED(g_lo, z0tmp, dtmp) &
761
       !$OMP SCHEDULE(static)
762
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
763
          it = it_idx(g_lo,iglo)
×
764
          ik = ik_idx(g_lo,iglo)
×
765
          is = is_idx(g_lo,iglo)
×
766
          do isgn = 1, 2
×
767
             z0tmp(:,isgn,iglo) = z0tmp(:,isgn,iglo) / (1.0 + dtmp(:,it,ik,is))
×
768
          end do
769
       end do
770
       !$OMP END PARALLEL DO
771

772
    else
773
       !If drag is false vns(...,3) is zero and hence z0tmp is zero here.
774
       call zero_array(z0tmp)
×
775
    end if
776

777
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
778

779
    ! du == int (E nu_s f_0);  du = du(z, kx, ky, s)
780
    ! duinv = 1/du
781
    if (conservative) then
×
782
       !$OMP PARALLEL DO DEFAULT(none) &
783
       !$OMP PRIVATE(iglo, ik, ie, il, is, isgn) &
784
       !$OMP SHARED(g_lo, gtmp, vns, vpa, vpdiff, speed) &
785
       !$OMP SCHEDULE(static)
786
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
787
          ik = ik_idx(g_lo,iglo)
×
788
          ie = ie_idx(g_lo,iglo)
×
789
          il = il_idx(g_lo,iglo)
×
790
          is = is_idx(g_lo,iglo)
×
791
          do isgn = 1, 2
×
792
             gtmp(:,isgn,iglo)  = vns(ik,ie,is,1)*vpa(:,isgn,iglo) &
×
793
                  * vpdiff(:,isgn,il)*speed(ie)
×
794
          end do
795
       end do
796
       !$OMP END PARALLEL DO
797
    else
798
       !$OMP PARALLEL DO DEFAULT(none) &
799
       !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
800
       !$OMP SHARED(g_lo, gtmp, vpa, vns) &
801
       !$OMP SCHEDULE(static)
802
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
803
          ik = ik_idx(g_lo,iglo)
×
804
          ie = ie_idx(g_lo,iglo)
×
805
          is = is_idx(g_lo,iglo)
×
806
          do isgn = 1, 2
×
807
             gtmp(:,isgn,iglo)  = vns(ik,ie,is,1)*vpa(:,isgn,iglo)**2
×
808
          end do
809
       end do
810
       !$OMP END PARALLEL DO
811
    end if
812

813
    call integrate_moment (gtmp, duinv, all_procs)  ! not 1/du yet
×
814

815
    ! Could replace this with OpenMP using an explicit loop. TAG
816
    where (abs(duinv) > epsilon(0.0))  ! necessary b/c some species may have vnewk=0
×
817
       !duinv=0 iff vnew=0 so ok to keep duinv=0.
818
       duinv = 1./duinv  ! now it is 1/du
×
819
    end where
820

821
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
822
! Now get s0 (first form)
823
    !$OMP PARALLEL DO DEFAULT(none) &
824
    !$OMP PRIVATE(iglo, ik, it, ie, il, is, isgn, ig) &
825
    !$OMP SHARED(g_lo, conservative, s0tmp, vns, vpdiff, speed, aj0, code_dt, duinv, vpa) &
826
    !$OMP SCHEDULE(static)
827
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
828
       it = it_idx(g_lo,iglo)
×
829
       ik = ik_idx(g_lo,iglo)
×
830
       ie = ie_idx(g_lo,iglo)
×
831
       il = il_idx(g_lo,iglo)
×
832
       is = is_idx(g_lo,iglo)
×
833
       do isgn = 1, 2
×
834
          ! u1 = -3 nu_s vpa dt J0 f_0 / du
835
          if (conservative) then
×
836
             s0tmp(:,isgn,iglo) = -vns(ik,ie,is,1)*vpdiff(:,isgn,il)*speed(ie) &
×
837
                  * aj0(:,iglo)*code_dt*duinv(:,it,ik,is)
×
838
          else
839
             s0tmp(:,isgn,iglo) = -vns(ik,ie,is,1)*vpa(:,isgn,iglo) &
×
840
                  * aj0(:,iglo)*code_dt*duinv(:,it,ik,is)
×
841
          end if
842
       end do
843
    end do
844
    !$OMP END PARALLEL DO
845

846
    call zero_out_passing_hybrid_electrons(s0tmp)
×
847

848
    if(use_le_layout) then
×
849
       call gather (g2le, s0tmp, ctmp)
×
850
       call solfp_lorentz (ctmp)
×
851
       call scatter (g2le, ctmp, s0tmp)   ! s0
×
852
    else
853
       call solfp_lorentz (s0tmp,dum1,dum2)   ! s0
×
854
    end if
855

856
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
857
! Now get v0s0
858

859
    !$OMP PARALLEL DO DEFAULT(none) &
860
    !$OMP PRIVATE(iglo, isgn) &
861
    !$OMP SHARED(g_lo, gtmp, vpa, aj0, s0tmp) &
862
    !$OMP COLLAPSE(2) &
863
    !$OMP SCHEDULE(static)
864
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
865
       do isgn = 1, 2
×
866
          ! v0 = vpa J0 f0
867
          gtmp(:,isgn,iglo) = vpa(:,isgn,iglo) * aj0(:,iglo) * real(s0tmp(:,isgn,iglo))
×
868
       end do
869
    end do
870
    !OMP END PARALLEL DO
871

872
    call integrate_moment (gtmp, dtmp, all_procs)    ! v0s0
×
873

874
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
875
! Redefine s0 = s0 - v0s0 * z0 / (1 + v0z0)
876

877
    !$OMP PARALLEL DO DEFAULT(none) &
878
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
879
    !$OMP SHARED(g_lo, s0tmp, dtmp, z0tmp) &
880
    !$OMP SCHEDULE(static)
881
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
882
       ik = ik_idx(g_lo,iglo)
×
883
       it = it_idx(g_lo,iglo)
×
884
       is = is_idx(g_lo,iglo)
×
885
       do isgn=1,2
×
886
          s0tmp(:,isgn,iglo) = s0tmp(:,isgn,iglo) - dtmp(:,it,ik,is) * z0tmp(:,isgn,iglo)
×
887
       end do
888
    end do
889
    !$OMP END PARALLEL DO
890

891
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
892
! Now get v1s0
893

894
    !$OMP PARALLEL DO DEFAULT(none) &
895
    !$OMP PRIVATE(iglo, ik, ie, il, is, isgn) &
896
    !$OMP SHARED(g_lo, conservative, gtmp, vns, speed, vpdiff, aj0, s0tmp, vpa) &
897
    !$OMP SCHEDULE(static)
898
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
899
       ik = ik_idx(g_lo,iglo)
×
900
       ie = ie_idx(g_lo,iglo)
×
901
       il = il_idx(g_lo,iglo)
×
902
       is = is_idx(g_lo,iglo)
×
903
       do isgn = 1, 2
×
904
          ! v1 = nu_D vpa J0
905
          if (conservative) then
×
906
             gtmp(:,isgn,iglo) = vns(ik,ie,is,1)*speed(ie)*vpdiff(:,isgn,il) &
×
907
                  * aj0(:,iglo) * real(s0tmp(:,isgn,iglo))
×
908
          else
909
             gtmp(:,isgn,iglo) = vns(ik,ie,is,1)*vpa(:,isgn,iglo)*aj0(:,iglo) &
×
910
                  * real(s0tmp(:,isgn,iglo))
×
911
          end if
912
       end do
913
    end do
914
    !$OMP END PARALLEL DO
915

916
    call integrate_moment (gtmp, dtmp, all_procs)    ! v1s0
×
917

918
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
919
! Redefine s0 = s0 / (1 + v0s0)
920

921
    !$OMP PARALLEL DO DEFAULT(none) &
922
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
923
    !$OMP SHARED(g_lo, s0tmp, dtmp) &
924
    !$OMP SCHEDULE(static)
925
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
926
       ik = ik_idx(g_lo,iglo)
×
927
       it = it_idx(g_lo,iglo)
×
928
       is = is_idx(g_lo,iglo)
×
929
       do isgn=1,2
×
930
          s0tmp(:,isgn,iglo) = s0tmp(:,isgn,iglo) / (1.0 + dtmp(:,it,ik,is))
×
931
       end do
932
    end do
933
    !$OMP END PARALLEL DO
934

935
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
936
! Now get w0
937
    !$OMP PARALLEL DO DEFAULT(none) &
938
    !$OMP PRIVATE(iglo, ik, it, ie, il, is, isgn, ig) &
939
    !$OMP SHARED(g_lo, ntgrid, forbid, w0tmp, vns, energy, al , aj1, code_dt, &
940
    !$OMP spec, kperp2, duinv, bmag, conserve_forbid_zero) &
941
    !$OMP SCHEDULE(static)
942
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
943
       it = it_idx(g_lo,iglo)
×
944
       ik = ik_idx(g_lo,iglo)
×
945
       ie = ie_idx(g_lo,iglo)
×
946
       il = il_idx(g_lo,iglo)
×
947
       is = is_idx(g_lo,iglo)
×
948
       do isgn = 1, 2
×
949
          do ig=-ntgrid,ntgrid
×
950
             ! u2 = -3 dt J1 vperp vus a f0 / du
951
             if ( .not. (forbid(ig,il) .and. conserve_forbid_zero) ) then
×
952
                ! Note no conservative branch here, is that right?
953
                ! Note: energy * al * smz^2 * kperp2 / bmag is alpha^2 where
954
                ! alpha is the argument to the Bessel function, i.e. aj1 = J1(alpha) / alpha
955
                ! This appears to leave us with alpha * J1(alpha) whilst Barnes' paper
956
                ! only includes terms with J1(alpha). Note that alpha = vperp kperp smz/B
957
                ! so alpha * J1(alpha) = (kperp * smz / B) * vperp J1
958
                w0tmp(ig, isgn, iglo) = -vns(ik, ie, is, 1) * energy(ie) * al(il) &
×
959
                     * aj1(ig, iglo) * code_dt * spec(is)%smz**2 * kperp2(ig, it, ik) * &
×
960
                     duinv(ig, it, ik, is) / bmag(ig)
×
961
             else
962
                w0tmp(ig,isgn,iglo) = 0.
×
963
             endif
964
          end do
965
       end do
966
    end do
967
    !$OMP END PARALLEL DO
968

969
    call zero_out_passing_hybrid_electrons(w0tmp)
×
970

971
    if(use_le_layout) then
×
972
       call gather (g2le, w0tmp, ctmp)
×
973
       call solfp_lorentz (ctmp)
×
974
       call scatter (g2le, ctmp, w0tmp)
×
975
    else
976
       call solfp_lorentz (w0tmp,dum1,dum2)
×
977
    end if
978

979
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
980
! Now get v0w0
981

982
    !$OMP PARALLEL DO DEFAULT(none) &
983
    !$OMP PRIVATE(iglo, isgn) &
984
    !$OMP SHARED(g_lo, gtmp, vpa, aj0, w0tmp) &
985
    !$OMP COLLAPSE(2) &
986
    !$OMP SCHEDULE(static)
987
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
988
       do isgn = 1, 2
×
989
          ! v0 = vpa J0 f0
990
          gtmp(:,isgn,iglo) = vpa(:,isgn,iglo) * aj0(:,iglo) * real(w0tmp(:,isgn,iglo))
×
991
       end do
992
    end do
993
    !$OMP END PARALLEL DO
994

995
    call integrate_moment (gtmp, dtmp, all_procs)    ! v0w0
×
996

997
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
998
! Redefine w0 = w0 - v0w0 * z0 / (1 + v0z0) (this is w1 from MAB notes)
999

1000
    !$OMP PARALLEL DO DEFAULT(none) &
1001
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1002
    !$OMP SHARED(g_lo, w0tmp, z0tmp, dtmp) &
1003
    !$OMP SCHEDULE(static)
1004
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1005
       ik = ik_idx(g_lo,iglo)
×
1006
       it = it_idx(g_lo,iglo)
×
1007
       is = is_idx(g_lo,iglo)
×
1008
       do isgn=1,2
×
1009
          w0tmp(:,isgn,iglo) = w0tmp(:,isgn,iglo) - z0tmp(:,isgn,iglo)*dtmp(:,it,ik,is)
×
1010
       end do
1011
    end do
1012
    !$OMP END PARALLEL DO
1013

1014
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1015
! Get v1w1
1016

1017
    !$OMP PARALLEL DO DEFAULT(none) &
1018
    !$OMP PRIVATE(iglo, ik, ie, il, is, isgn) &
1019
    !$OMP SHARED(g_lo, conservative, gtmp, vns, speed, vpdiff, aj0, w0tmp, vpa) &
1020
    !$OMP SCHEDULE(static)
1021
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1022
       ik = ik_idx(g_lo,iglo)
×
1023
       ie = ie_idx(g_lo,iglo)
×
1024
       il = il_idx(g_lo,iglo)
×
1025
       is = is_idx(g_lo,iglo)
×
1026
       do isgn = 1, 2
×
1027
          ! v1 = nud vpa J0 f0
1028
          if (conservative) then
×
1029
             gtmp(:,isgn,iglo) = vns(ik,ie,is,1)*speed(ie)*vpdiff(:,isgn,il) &
×
1030
                  * aj0(:,iglo) * real(w0tmp(:,isgn,iglo))
×
1031
          else
1032
             gtmp(:,isgn,iglo) = vns(ik,ie,is,1)*vpa(:,isgn,iglo)*aj0(:,iglo) &
×
1033
                  * real(w0tmp(:,isgn,iglo))
×
1034
          end if
1035
       end do
1036
    end do
1037
    !$OMP END PARALLEL DO
1038

1039
    call integrate_moment (gtmp, dtmp, all_procs)    ! v1w1
×
1040

1041
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1042
! Redefine w0 = w1 - v1w1 * s1 / (1 + v1s1) (this is w2 from MAB notes)
1043

1044
    !$OMP PARALLEL DO DEFAULT(none) &
1045
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1046
    !$OMP SHARED(g_lo, w0tmp, s0tmp, dtmp) &
1047
    !$OMP SCHEDULE(static)
1048
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1049
       ik = ik_idx(g_lo,iglo)
×
1050
       it = it_idx(g_lo,iglo)
×
1051
       is = is_idx(g_lo,iglo)
×
1052
       do isgn=1,2
×
1053
          w0tmp(:,isgn,iglo) = w0tmp(:,isgn,iglo) - s0tmp(:,isgn,iglo)*dtmp(:,it,ik,is)
×
1054
       end do
1055
    end do
1056
    !$OMP END PARALLEL DO
1057

1058
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1059
! Get v2w2
1060

1061
    !$OMP PARALLEL DO DEFAULT(none) &
1062
    !$OMP PRIVATE(iglo, ik, ie, il, is, isgn) &
1063
    !$OMP SHARED(g_lo, gtmp, vns, energy, al, aj1, w0tmp) &
1064
    !$OMP SCHEDULE(static)
1065
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1066
       ik = ik_idx(g_lo,iglo)
×
1067
       ie = ie_idx(g_lo,iglo)
×
1068
       il = il_idx(g_lo,iglo)
×
1069
       is = is_idx(g_lo,iglo)
×
1070
       do isgn = 1, 2
×
1071
          ! v2 = nud vperp J1 f0
1072
          ! Note : aj1 = J1(alpha) / alpha, where we have
1073
          ! alpha^2 = energy * al * smz^2 * kperp2 / bmag = vperp^2 smz^2 kperp2 / bmag^2
1074
          ! so energy * al * aj1 = (B / [kperp2 * smz^2]) alpha^2 aj1
1075
          ! = (B / [kperp2 * smz^2]) alpha J1 = vperp J1 / (kperp * smz). As w0tmp
1076
          ! appears to have an extra factor of kperp * smz / B this _may_ work out to
1077
          ! (vperp J1 / B) * ... Is there an extra factor of 1 / B here?
1078
          gtmp(:, isgn, iglo) = vns(ik, ie, is, 1) * energy(ie) * al(il) * aj1(:, iglo) &
×
1079
               * real(w0tmp(:, isgn, iglo))
×
1080
       end do
1081
    end do
1082
    !$OMP END PARALLEL DO
1083

1084
    call integrate_moment (gtmp, dtmp, all_procs)   ! v2w2
×
1085

1086
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1087
! Redefine w0 = w2 / (1 + v2w2)
1088

1089
    !$OMP PARALLEL DO DEFAULT(none) &
1090
    !$OMP PRIVATE(iglo, ik, it, is, isgn, ig) &
1091
    !$OMP SHARED(g_lo, w0tmp, dtmp) &
1092
    !$OMP SCHEDULE(static)
1093
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1094
       ik = ik_idx(g_lo,iglo)
×
1095
       it = it_idx(g_lo,iglo)
×
1096
       is = is_idx(g_lo,iglo)
×
1097
       do isgn=1,2
×
1098
          w0tmp(:,isgn,iglo) = w0tmp(:,isgn,iglo) / (1.0 + dtmp(:,it,ik,is))
×
1099
       end do
1100
    end do
1101
    !$OMP END PARALLEL DO
1102

1103
    deallocate (gtmp, duinv, dtmp, vns)
×
1104

1105
    if(use_le_layout) then
×
1106
       allocate (z_big(-ntgrid:ntgrid, 2, g_lo%llim_proc:g_lo%ulim_alloc))
×
1107

1108
       ! first set s0le, w0le & z0le
1109
       z_big = cmplx(real(s0tmp), real(w0tmp))
×
1110

1111
       ! get rid of z0, s0, w0 now that we've converted to z0le, s0le, w0le
1112
       if (allocated(s0tmp)) deallocate(s0tmp)
×
1113
       if (allocated(w0tmp)) deallocate(w0tmp)
×
1114

1115
       call gather (g2le, z_big, ctmp)
×
1116

1117
       if (.not. allocated(s0le)) then
×
1118
          allocate (s0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1119
          allocate (w0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1120
       end if
1121

1122
       s0le = real(ctmp)
×
1123
       w0le = aimag(ctmp)
×
1124

1125
       ! set z0le
1126
       call gather (g2le, z0tmp, ctmp)
×
1127
       if (allocated(z0tmp)) deallocate(z0tmp)
×
1128
       if (.not. allocated(z0le)) allocate (z0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1129
       z0le = real(ctmp)
×
1130

1131
       deallocate (ctmp, z_big)
×
1132
    else
1133
       !Only need the real components (imaginary part should be zero, just
1134
       !use complex arrays to allow reuse of existing integrate routines etc.)
1135
       if (.not. allocated(s0)) then
×
1136
          allocate (s0(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1137
          s0=real(s0tmp)
×
1138
          deallocate(s0tmp)
×
1139
       endif
1140

1141
       if (.not. allocated(w0)) then
×
1142
          allocate (w0(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1143
          w0=real(w0tmp)
×
1144
          deallocate(w0tmp)
×
1145
       endif
1146

1147
       if (.not. allocated(z0)) then
×
1148
          allocate (z0(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1149
          z0=real(z0tmp)
×
1150
          deallocate(z0tmp)
×
1151
       endif
1152
    end if
1153

1154
  end subroutine init_lorentz_conserve
×
1155

1156
  !> Precompute three quantities needed for momentum and energy conservation:
1157
  !> bz0, bw0, bs0
1158
  subroutine init_diffuse_conserve
×
1159
    use gs2_layouts, only: g_lo, ie_idx, is_idx, ik_idx, il_idx, it_idx
1160
    use species, only: nspec, spec
1161
    use kt_grids, only: naky, ntheta0, kperp2
1162
    use theta_grid, only: ntgrid, bmag
1163
    use le_grids, only: energy => energy_maxw, al, integrate_moment, negrid, forbid
1164
    use gs2_time, only: code_dt
1165
    use dist_fn_arrays, only: aj0, aj1, vpa
1166
    use le_grids, only: g2le
1167
    use gs2_layouts, only: le_lo
1168
    use redistribute, only: gather, scatter
1169
    use array_utils, only: zero_array
1170
    implicit none
1171
    real, dimension (:,:,:), allocatable :: gtmp
×
1172
    real, dimension (:,:,:,:), allocatable :: duinv, dtmp, vns
×
1173
    integer :: ie, il, ik, is, isgn, iglo, it, ig
1174
    complex, dimension (:,:,:), allocatable :: ctmp, z_big
×
1175
    complex, dimension (:,:,:), allocatable :: bs0tmp, bw0tmp, bz0tmp
×
1176
    logical, parameter :: all_procs = .true.
1177

1178
    if(use_le_layout) then
×
1179
       allocate (ctmp(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1180
       ! We need to initialise ctmp as it is used as receiving buffer in
1181
       ! g2le redistribute, which doesn't populate all elements
1182
       call zero_array(ctmp)
×
1183
    end  if
1184

1185
    allocate(bs0tmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1186
    allocate(bw0tmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1187
    allocate(bz0tmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1188

1189
    allocate (gtmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1190
    allocate (duinv(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
1191
    allocate (dtmp(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
1192
    allocate (vns(naky,negrid,nspec,2))
×
1193

1194
    ! Following might only be needed if any kwork_filter
1195
    call zero_array(duinv)
×
1196
    call zero_array(dtmp)
×
1197

1198
    vns(:,:,:,1) = vnmult(2)*delvnew
×
1199
    vns(:,:,:,2) = vnmult(2)*vnew_s
×
1200

1201
    ! first obtain 1/du
1202
    !$OMP PARALLEL DO DEFAULT(none) &
1203
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1204
    !$OMP SHARED(g_lo, gtmp, energy, vnmult, vnew_E) &
1205
    !$OMP SCHEDULE(static)
1206
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1207
       ik = ik_idx(g_lo,iglo)
×
1208
       ie = ie_idx(g_lo,iglo)
×
1209
       is = is_idx(g_lo,iglo)
×
1210
       do isgn = 1, 2
×
1211
          gtmp(:,isgn,iglo) = energy(ie)*vnmult(2)*vnew_E(ik,ie,is)
×
1212
       end do
1213
    end do
1214
    !$OMP END PARALLEL DO
1215

1216
    call integrate_moment (gtmp, duinv, all_procs)  ! not 1/du yet
×
1217

1218
    ! Could replace this with OpenMP using an explicit loop. TAG
1219
    where (abs(duinv) > epsilon(0.0))  ! necessary b/c some species may have vnewk=0
×
1220
       !  duinv=0 iff vnew=0 so ok to keep duinv=0.
1221
       duinv = 1 / duinv  ! now it is 1/du
×
1222
    end where
1223

1224
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1225
    ! Now get z0 (first form)
1226
    !$OMP PARALLEL DO DEFAULT(none) &
1227
    !$OMP PRIVATE(iglo, ik, it, ie, il, is, isgn, ig) &
1228
    !$OMP SHARED(g_lo, ntgrid, forbid, bz0tmp, code_dt, vnmult, vnew_E, &
1229
    !$OMP aj0, duinv, conserve_forbid_zero) &
1230
    !$OMP SCHEDULE(static)
1231
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1232
       it = it_idx(g_lo,iglo)
×
1233
       ik = ik_idx(g_lo,iglo)
×
1234
       ie = ie_idx(g_lo,iglo)
×
1235
       is = is_idx(g_lo,iglo)
×
1236
       il = il_idx(g_lo,iglo)
×
1237
       do isgn = 1, 2
×
1238
          do ig=-ntgrid,ntgrid
×
1239
             ! u0 = -nu_E E dt J0 f_0 / du
1240
             if ( .not. (forbid(ig,il) .and. conserve_forbid_zero) ) then
×
1241
                bz0tmp(ig,isgn,iglo) = -code_dt*vnmult(2)*vnew_E(ik,ie,is) &
×
1242
                     * aj0(ig,iglo)*duinv(ig,it,ik,is)
×
1243
             else
1244
                bz0tmp(ig,isgn,iglo) = 0.
×
1245
             endif
1246
          end do
1247
       end do
1248
    end do
1249
    !$OMP END PARALLEL DO
1250

1251
    call zero_out_passing_hybrid_electrons(bz0tmp)
×
1252

1253
    if(use_le_layout) then
×
1254
       call gather (g2le, bz0tmp, ctmp)
×
1255
       call solfp_ediffuse_le_layout (ctmp)
×
1256
       call scatter (g2le, ctmp, bz0tmp)   ! bz0 is redefined below
×
1257
    else
1258
       call solfp_ediffuse_standard_layout (bz0tmp)   ! bz0 is redefined below
×
1259
    end if
1260

1261
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1262
! Now get v0z0
1263

1264
    !$OMP PARALLEL DO DEFAULT(none) &
1265
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1266
    !$OMP SHARED(g_lo, gtmp, vnmult, vnew_E, aj0, bz0tmp) &
1267
    !$OMP SCHEDULE(static)
1268
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1269
       ik = ik_idx(g_lo,iglo)
×
1270
       ie = ie_idx(g_lo,iglo)
×
1271
       is = is_idx(g_lo,iglo)
×
1272
       do isgn = 1, 2
×
1273
          ! v0 = nu_E E J0 f_0
1274
          gtmp(:,isgn,iglo) = vnmult(2) * vnew_E(ik,ie,is) * aj0(:,iglo) &
×
1275
               * real(bz0tmp(:,isgn,iglo))
×
1276
       end do
1277
    end do
1278
    !$OMP END PARALLEL DO
1279

1280
    call integrate_moment (gtmp, dtmp, all_procs) ! v0z0
×
1281

1282
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1283
! Redefine z0 = z0 / (1 + v0z0)
1284

1285
    !$OMP PARALLEL DO DEFAULT(none) &
1286
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1287
    !$OMP SHARED(g_lo, bz0tmp, dtmp) &
1288
    !$OMP SCHEDULE(static)
1289
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1290
       it = it_idx(g_lo,iglo)
×
1291
       ik = ik_idx(g_lo,iglo)
×
1292
       is = is_idx(g_lo,iglo)
×
1293
       do isgn = 1, 2
×
1294
          bz0tmp(:,isgn,iglo) = bz0tmp(:,isgn,iglo) / (1.0 + dtmp(:,it,ik,is))
×
1295
       end do
1296
    end do
1297
    !$OMP END PARALLEL DO
1298

1299
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1300

1301
    ! redefine dq = du (for momentum-conserving terms)
1302
    ! du == int (E nu_s f_0);  du = du(z, kx, ky, s)
1303
    ! duinv = 1/du
1304
    !$OMP PARALLEL DO DEFAULT(none) &
1305
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1306
    !$OMP SHARED(g_lo, gtmp, vns, vpa) &
1307
    !$OMP SCHEDULE(static)
1308
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1309
       ik = ik_idx(g_lo,iglo)
×
1310
       ie = ie_idx(g_lo,iglo)
×
1311
       is = is_idx(g_lo,iglo)
×
1312
       do isgn = 1, 2
×
1313
          gtmp(:, isgn, iglo)  = vns(ik, ie, is, 1) * vpa(:, isgn, iglo)**2
×
1314
       end do
1315
    end do
1316
    !$OMP END PARALLEL DO
1317

1318
    call integrate_moment (gtmp, duinv, all_procs)  ! not 1/du yet
×
1319

1320
    ! Could replace this with OpenMP using an explicit loop. TAG
1321
    where (abs(duinv) > epsilon(0.0))  ! necessary b/c some species may have vnewk=0
×
1322
       !  duinv=0 iff vnew=0 so ok to keep duinv=0.
1323
       duinv = 1 / duinv  ! now it is 1/du
×
1324
    end where
1325

1326
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1327
! Now get s0 (first form)
1328
    !$OMP PARALLEL DO DEFAULT(none) &
1329
    !$OMP PRIVATE(iglo, ik, it, ie, is, isgn) &
1330
    !$OMP SHARED(g_lo, bs0tmp, vns, vpa, aj0, code_dt, duinv) &
1331
    !$OMP SCHEDULE(static)
1332
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1333
       it = it_idx(g_lo,iglo)
×
1334
       ik = ik_idx(g_lo,iglo)
×
1335
       ie = ie_idx(g_lo,iglo)
×
1336
       is = is_idx(g_lo,iglo)
×
1337
       do isgn = 1, 2
×
1338
          ! u1 = -3 nu_s vpa dt J0 f_0 / du
1339
          bs0tmp(:, isgn, iglo) = -vns(ik, ie, is, 1) * vpa(:, isgn, iglo) &
×
1340
               * aj0(:, iglo) * code_dt * duinv(:, it, ik, is)
×
1341
       end do
1342
    end do
1343
    !$OMP END PARALLEL DO
1344

1345
    call zero_out_passing_hybrid_electrons(bs0tmp)
×
1346

1347
    if(use_le_layout) then
×
1348
       call gather (g2le, bs0tmp, ctmp)
×
1349
       call solfp_ediffuse_le_layout (ctmp)
×
1350
       call scatter (g2le, ctmp, bs0tmp)   ! bs0
×
1351
    else
1352
       call solfp_ediffuse_standard_layout (bs0tmp)    ! s0
×
1353
    end if
1354

1355
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1356
! Now get v0s0
1357

1358
    !$OMP PARALLEL DO DEFAULT(none) &
1359
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1360
    !$OMP SHARED(g_lo, gtmp, vnmult, vnew_E, aj0, bs0tmp) &
1361
    !$OMP SCHEDULE(static)
1362
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1363
       ik = ik_idx(g_lo,iglo)
×
1364
       ie = ie_idx(g_lo,iglo)
×
1365
       is = is_idx(g_lo,iglo)
×
1366
       do isgn = 1, 2
×
1367
          ! v0 = nu_E E J0
1368
          gtmp(:, isgn, iglo) = vnmult(2) * vnew_E(ik, ie, is) * aj0(:, iglo) &
×
1369
               * real(bs0tmp(:, isgn, iglo))
×
1370
       end do
1371
    end do
1372
    !$OMP END PARALLEL DO
1373

1374
    call integrate_moment (gtmp, dtmp, all_procs)    ! v0s0
×
1375

1376
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1377
! Redefine s0 = s0 - v0s0 * z0 / (1 + v0z0)
1378

1379
    !$OMP PARALLEL DO DEFAULT(none) &
1380
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1381
    !$OMP SHARED(g_lo, bs0tmp, dtmp, bz0tmp) &
1382
    !$OMP SCHEDULE(static)
1383
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1384
       ik = ik_idx(g_lo,iglo)
×
1385
       it = it_idx(g_lo,iglo)
×
1386
       is = is_idx(g_lo,iglo)
×
1387
       do isgn=1,2
×
1388
          bs0tmp(:, isgn, iglo) = bs0tmp(:, isgn, iglo) - dtmp(:, it, ik, is) &
×
1389
               * bz0tmp(:, isgn, iglo)
×
1390
       end do
1391
    end do
1392
    !$OMP END PARALLEL DO
1393

1394
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1395
! Now get v1s0
1396

1397
    !$OMP PARALLEL DO DEFAULT(none) &
1398
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1399
    !$OMP SHARED(g_lo, gtmp, vns, vpa, aj0, bs0tmp) &
1400
    !$OMP SCHEDULE(static)
1401
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1402
       ik = ik_idx(g_lo,iglo)
×
1403
       ie = ie_idx(g_lo,iglo)
×
1404
       is = is_idx(g_lo,iglo)
×
1405
       do isgn = 1, 2
×
1406
          ! v1 = (nu_s - nu_D) vpa J0
1407
          gtmp(:, isgn, iglo) = vns(ik, ie, is, 1) * vpa(:, isgn, iglo) * aj0(:, iglo) &
×
1408
               * real(bs0tmp(:, isgn, iglo))
×
1409
       end do
1410
    end do
1411
    !$OMP END PARALLEL DO
1412

1413
    call integrate_moment (gtmp, dtmp, all_procs)    ! v1s0
×
1414

1415
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1416
! Redefine s0 = s0 / (1 + v0s0)
1417

1418
    !$OMP PARALLEL DO DEFAULT(none) &
1419
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1420
    !$OMP SHARED(g_lo, bs0tmp, dtmp) &
1421
    !$OMP SCHEDULE(static)
1422
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1423
       ik = ik_idx(g_lo,iglo)
×
1424
       it = it_idx(g_lo,iglo)
×
1425
       is = is_idx(g_lo,iglo)
×
1426
       do isgn=1,2
×
1427
          bs0tmp(:, isgn, iglo) = bs0tmp(:, isgn, iglo) / (1.0 + dtmp(:, it, ik, is))
×
1428
       end do
1429
    end do
1430
    !$OMP END PARALLEL DO
1431

1432
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1433
! Now get w0
1434
    !$OMP PARALLEL DO DEFAULT(none) &
1435
    !$OMP PRIVATE(iglo, ik, it, ie, il, is, isgn, ig) &
1436
    !$OMP SHARED(g_lo, ntgrid, forbid, bw0tmp, vns, energy, al, aj1, code_dt, &
1437
    !$OMP spec, kperp2, duinv, bmag, conserve_forbid_zero) &
1438
    !$OMP SCHEDULE(static)
1439
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1440
       it = it_idx(g_lo,iglo)
×
1441
       ik = ik_idx(g_lo,iglo)
×
1442
       ie = ie_idx(g_lo,iglo)
×
1443
       il = il_idx(g_lo,iglo)
×
1444
       is = is_idx(g_lo,iglo)
×
1445
       do isgn = 1, 2
×
1446
          do ig=-ntgrid,ntgrid
×
1447
             ! u0 = -3 dt J1 vperp vus a f0 / du
1448
             if ( .not. (forbid(ig,il) .and. conserve_forbid_zero)) then
×
1449
                ! Note: energy * al * smz^2 * kperp2 / bmag is alpha^2 where
1450
                ! alpha is the argument to the Bessel function, i.e. aj1 = J1(alpha) / alpha
1451
                ! This appears to leave us with alpha * J1(alpha) whilst Barnes' paper
1452
                ! only includes terms with J1(alpha). Note that alpha = vperp kperp smz/B
1453
                ! so alpha * J1(alpha) = (kperp * smz / B) * vperp J1
1454
                bw0tmp(ig, isgn, iglo) = -vns(ik, ie, is, 1) * energy(ie) * al(il) &
×
1455
                     * aj1(ig, iglo) * code_dt * spec(is)%smz**2 * kperp2(ig, it, ik) * &
×
1456
                     duinv(ig, it, ik, is) / bmag(ig)
×
1457
             else
1458
                bw0tmp(ig, isgn, iglo) = 0.
×
1459
             endif
1460
          end do
1461
       end do
1462
    end do
1463
    !$OMP END PARALLEL DO
1464

1465
    call zero_out_passing_hybrid_electrons(bw0tmp)
×
1466

1467
    if(use_le_layout) then
×
1468
       call gather (g2le, bw0tmp, ctmp)
×
1469
       call solfp_ediffuse_le_layout (ctmp)
×
1470
       call scatter (g2le, ctmp, bw0tmp)
×
1471
    else
1472
       call solfp_ediffuse_standard_layout (bw0tmp)
×
1473
    end if
1474

1475
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1476
! Now get v0w0
1477

1478
    !$OMP PARALLEL DO DEFAULT(none) &
1479
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1480
    !$OMP SHARED(g_lo, gtmp, vnmult, vnew_E, aj0, bw0tmp) &
1481
    !$OMP SCHEDULE(static)
1482
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1483
       ik = ik_idx(g_lo,iglo)
×
1484
       ie = ie_idx(g_lo,iglo)
×
1485
       is = is_idx(g_lo,iglo)
×
1486
       do isgn = 1, 2
×
1487
          ! v0 = nu_E E J0
1488
          gtmp(:, isgn, iglo) = vnmult(2) * vnew_E(ik, ie, is) * aj0(:, iglo) &
×
1489
               * real(bw0tmp(:, isgn, iglo))
×
1490
       end do
1491
    end do
1492
    !$OMP END PARALLEL DO
1493

1494
    call integrate_moment (gtmp, dtmp, all_procs)    ! v0w0
×
1495

1496
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1497
! Redefine w0 = w0 - v0w0 * z0 / (1 + v0z0) (this is w1 from MAB notes)
1498

1499
    !$OMP PARALLEL DO DEFAULT(none) &
1500
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1501
    !$OMP SHARED(g_lo, bw0tmp, bz0tmp, dtmp) &
1502
    !$OMP SCHEDULE(static)
1503
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1504
       ik = ik_idx(g_lo,iglo)
×
1505
       it = it_idx(g_lo,iglo)
×
1506
       is = is_idx(g_lo,iglo)
×
1507
       do isgn = 1, 2
×
1508
          bw0tmp(:, isgn, iglo) = bw0tmp(:, isgn, iglo) - bz0tmp(:, isgn, iglo) &
×
1509
               * dtmp(:, it, ik, is)
×
1510
       end do
1511
    end do
1512
    !$OMP END PARALLEL DO
1513

1514
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1515
! Get v1w1
1516

1517
    !$OMP PARALLEL DO DEFAULT(none) &
1518
    !$OMP PRIVATE(iglo, ik, ie, is, isgn) &
1519
    !$OMP SHARED(g_lo, gtmp, vns, vpa, aj0, bw0tmp) &
1520
    !$OMP SCHEDULE(static)
1521
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1522
       ik = ik_idx(g_lo,iglo)
×
1523
       ie = ie_idx(g_lo,iglo)
×
1524
       is = is_idx(g_lo,iglo)
×
1525
       do isgn = 1, 2
×
1526
          ! v1 = (nus-nud) vpa J0 f0
1527
          gtmp(:, isgn, iglo) = vns(ik, ie, is, 1) * vpa(:, isgn, iglo) * aj0(:, iglo) &
×
1528
               * real(bw0tmp(:, isgn, iglo))
×
1529
       end do
1530
    end do
1531
    !$OMP END PARALLEL DO
1532

1533
    call integrate_moment (gtmp, dtmp, all_procs)    ! v1w1
×
1534

1535
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1536
! Redefine w0 = w1 - v1w1 * s1 / (1 + v1s1) (this is w2 from MAB notes)
1537

1538
    !$OMP PARALLEL DO DEFAULT(none) &
1539
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1540
    !$OMP SHARED(g_lo, bw0tmp, bs0tmp, dtmp) &
1541
    !$OMP SCHEDULE(static)
1542
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1543
       ik = ik_idx(g_lo,iglo)
×
1544
       it = it_idx(g_lo,iglo)
×
1545
       is = is_idx(g_lo,iglo)
×
1546
       do isgn = 1, 2
×
1547
          bw0tmp(:, isgn, iglo) = bw0tmp(:, isgn, iglo) - bs0tmp(:, isgn, iglo) &
×
1548
               * dtmp(:, it, ik, is)
×
1549
       end do
1550
    end do
1551
    !$OMP END PARALLEL DO
1552

1553
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1554
! Get v2w2
1555

1556
    !$OMP PARALLEL DO DEFAULT(none) &
1557
    !$OMP PRIVATE(iglo, ik, ie, il, is, isgn) &
1558
    !$OMP SHARED(g_lo, gtmp, vns, energy, al, aj1, bw0tmp) &
1559
    !$OMP SCHEDULE(static)
1560
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1561
       ik = ik_idx(g_lo,iglo)
×
1562
       ie = ie_idx(g_lo,iglo)
×
1563
       il = il_idx(g_lo,iglo)
×
1564
       is = is_idx(g_lo,iglo)
×
1565
       do isgn = 1, 2
×
1566
          ! v2 = (nus-nud) vperp J1 f0
1567
          ! Note : aj1 = J1(alpha) / alpha, where we have
1568
          ! alpha^2 = energy * al * smz^2 * kperp2 / bmag = vperp^2 smz^2 kperp2 / bmag^2
1569
          ! so energy * al * aj1 = (B / [kperp2 * smz^2]) alpha^2 aj1
1570
          ! = (B / [kperp2 * smz^2]) alpha J1 = vperp J1 / (kperp * smz). As w0tmp
1571
          ! appears to have an extra factor of kperp * smz / B this _may_ work out to
1572
          ! (vperp J1 / B) * ... Is there an extra factor of 1 / B here?
1573
          gtmp(:, isgn, iglo) = vns(ik, ie, is, 1) * energy(ie) * al(il) * aj1(:, iglo) &
×
1574
               * real(bw0tmp(:, isgn, iglo))
×
1575
       end do
1576
    end do
1577
    !$OMP END PARALLEL DO
1578

1579
    call integrate_moment (gtmp, dtmp, all_procs)   ! v2w2
×
1580

1581
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1582
! Redefine w0 = w2 / (1 + v2w2)
1583

1584
    !$OMP PARALLEL DO DEFAULT(none) &
1585
    !$OMP PRIVATE(iglo, ik, it, is, isgn) &
1586
    !$OMP SHARED(g_lo, bw0tmp, dtmp) &
1587
    !$OMP SCHEDULE(static)
1588
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1589
       ik = ik_idx(g_lo,iglo)
×
1590
       it = it_idx(g_lo,iglo)
×
1591
       is = is_idx(g_lo,iglo)
×
1592
       do isgn=1,2
×
1593
          bw0tmp(:, isgn, iglo) = bw0tmp(:, isgn, iglo) / (1.0 + dtmp(:, it, ik, is))
×
1594
       end do
1595
    end do
1596
    !$OMP END PARALLEL DO
1597

1598
    deallocate (gtmp, duinv, dtmp, vns)
×
1599

1600
    if(use_le_layout) then
×
1601
       allocate (z_big(-ntgrid:ntgrid, 2, g_lo%llim_proc:g_lo%ulim_alloc))
×
1602
       z_big=cmplx(real(bs0tmp),real(bw0tmp))
×
1603
       deallocate (bs0tmp)
×
1604
       deallocate (bw0tmp)
×
1605
       call gather (g2le, z_big, ctmp)
×
1606
       deallocate(z_big)
×
1607
       if (.not. allocated(bs0le)) allocate (bs0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1608
       if (.not. allocated(bw0le)) allocate (bw0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1609
       bs0le = real(ctmp)
×
1610
       bw0le = aimag(ctmp)
×
1611

1612
       call gather (g2le, bz0tmp, ctmp)
×
1613
       deallocate (bz0tmp)
×
1614
       if (.not. allocated(bz0le)) allocate (bz0le(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
1615
       bz0le = real(ctmp)
×
1616
       deallocate (ctmp)
×
1617
    else
1618
       !Only need the real components (imaginary part should be zero, just
1619
       !use complex arrays to allow reuse of existing integrate routines etc.)
1620
       if (.not. allocated(bs0)) then
×
1621
          allocate (bs0(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1622
          bs0=real(bs0tmp)
×
1623
          deallocate(bs0tmp)
×
1624
       endif
1625

1626
       if (.not. allocated(bw0)) then
×
1627
          allocate (bw0(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1628
          bw0=real(bw0tmp)
×
1629
          deallocate(bw0tmp)
×
1630
       endif
1631

1632
       if (.not. allocated(bz0)) then
×
1633
          allocate (bz0(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
1634
          bz0=real(bz0tmp)
×
1635
          deallocate(bz0tmp)
×
1636
       endif
1637
    end if
1638

1639
  end subroutine init_diffuse_conserve
×
1640
  
1641
  !> If we have hybrid electrons then we need to remove the
1642
  !> contribution to the conservation terms from the adiabatic
1643
  !> passing part. This routine does this for us.
1644
  subroutine zero_out_passing_hybrid_electrons(arr)
×
1645
    use gs2_layouts, only: g_lo, ik_idx, il_idx, is_idx
1646
    use species, only: has_hybrid_electron_species, spec
1647
    use le_grids, only: is_passing_hybrid_electron
1648
    implicit none
1649
    complex, dimension(:, :, g_lo%llim_proc:), intent(in out) :: arr
1650
    integer :: iglo, is, ik, il
1651
    if (has_hybrid_electron_species(spec)) then
×
1652
       !$OMP PARALLEL DO DEFAULT(none) &
1653
       !$OMP PRIVATE(iglo, ik, il, is) &
1654
       !$OMP SHARED(g_lo, arr) &
1655
       !$OMP SCHEDULE(static)
1656
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
1657
          ik = ik_idx(g_lo,iglo)
×
1658
          il = il_idx(g_lo,iglo)
×
1659
          is = is_idx(g_lo,iglo)
×
1660
          if (is_passing_hybrid_electron(is, ik, il)) arr(:, :, iglo) = 0.0
×
1661
       end do
1662
       !$OMP END PARALLEL DO
1663
    end if
1664
  end subroutine zero_out_passing_hybrid_electrons
×
1665

1666
  !> FIXME : Add documentation
1667
  subroutine init_vnew
×
1668
    use species, only: nspec, spec, is_electron_species
1669
    use le_grids, only: negrid, energy => energy_maxw, w => w_maxw
1670
    use kt_grids, only: naky, ntheta0, kperp2
1671
    use theta_grid, only: ntgrid
1672
    use run_parameters, only: zeff, delt_option_switch, delt_option_auto
1673
    use gs2_time, only: tunits
1674
    use constants, only: pi, sqrt_pi
1675
    use gs2_save, only: init_vnm
1676
    real, dimension(negrid):: hee, hsg, local_energy
×
1677
    integer :: ik, ie, is, it
1678
    integer :: istatus
1679
    real :: k4max
1680
    real :: vl, vr, dv2l, dv2r
1681
    real, dimension (2) :: vnm_saved
1682

1683
    if (delt_option_switch == delt_option_auto) then
×
1684
       call init_vnm (vnm_saved, istatus)
×
1685
       if (istatus == 0) vnm_init = vnm_saved
×
1686
    endif
1687

1688
    ! Initialise vnmult from the values in run_parameters. This is
1689
    ! either what has been restored from the restart file  if
1690
    ! `delt_option == 'check_restart'` or 1 otherwise.
1691
    if (all(vnmult == -1)) then
×
1692
       vnmult = vnm_init
×
1693
    end if
1694

1695
    if (const_v) then
×
1696
       local_energy = 1.0
×
1697
    else
1698
       local_energy = energy
×
1699
    end if
1700

1701
    do ie = 1, negrid
×
1702
       hee(ie) = exp(-local_energy(ie))/sqrt(pi*local_energy(ie)) &
×
1703
            + (1.0 - 0.5/local_energy(ie))*erf(sqrt(local_energy(ie)))
×
1704
       !>MAB
1705
       ! hsg is the G of Hirshman and Sigmar
1706
       ! added to allow for momentum conservation with energy diffusion
1707
       hsg(ie) = hsg_func(sqrt(local_energy(ie)))
×
1708
       !<MAB
1709
    end do
1710

1711
    if (.not.allocated(vnew)) then
×
1712
       ! Here the ky dependence is just to allow us to scale by tunits.
1713
       ! This saves some operations in later use at expense of more memory
1714
       allocate (vnew(naky,negrid,nspec))
×
1715
       allocate (vnew_s(naky,negrid,nspec))
×
1716
       allocate (vnew_D(naky,negrid,nspec))
×
1717
       allocate (vnew_E(naky,negrid,nspec))
×
1718
       allocate (delvnew(naky,negrid,nspec))
×
1719
    end if
1720

1721
    if (ei_coll_only) then
×
1722
       vnew_s = 0 ; vnew_D = 0 ; vnew_E = 0 ; delvnew = 0.
×
1723
       do is = 1, nspec
×
1724
          if (is_electron_species(spec(is))) then
×
1725
             do ie = 1, negrid
×
1726
                vnew(:, ie, is) = spec(is)%vnewk / local_energy(ie)**1.5 &
×
1727
                        * zeff * 0.5 * tunits(:)
×
1728
             end do
1729
          else
1730
             vnew(:, :, is) = 0.0
×
1731
          end if
1732
       end do
1733
    else
1734
       do is = 1, nspec
×
1735
          ! Don't include following lines, as haven't yet accounted for possibility of timestep changing.
1736
          ! Correct collision frequency if applying collisions only every nth timestep:
1737
          !spec(is)%vnewk = spec(is)%vnewk * float(timesteps_between_collisions)
1738

1739
          do ie = 1, negrid
×
1740
             vnew_s(:, ie, is) = spec(is)%vnewk / sqrt(local_energy(ie)) &
×
1741
                  * hsg(ie) * 4.0 * tunits(:)
×
1742
          end do
1743

1744
          if (is_electron_species(spec(is))) then
×
1745
             do ie = 1, negrid
×
1746
                vnew(:, ie, is) = spec(is)%vnewk / local_energy(ie)**1.5 &
×
1747
                     * (zeff + hee(ie)) * 0.5 * tunits(:)
×
1748
                vnew_D(:, ie, is) = spec(is)%vnewk / local_energy(ie)**1.5 &
×
1749
                     * hee(ie) * tunits(:)
×
1750
             end do
1751
          else
1752
             do ie = 1, negrid
×
1753
                vnew(:, ie, is) = spec(is)%vnewk / local_energy(ie)**1.5 &
×
1754
                     * hee(ie) * 0.5 * tunits(:)
×
1755
                vnew_D(:, ie, is) = 2.0 * vnew(:, ie, is)
×
1756
             end do
1757
          end if
1758
       end do
1759
    end if
1760

1761
    if (conservative) then !Presumably not compatible with const_v so we use energy
×
1762
       do is = 1, nspec
×
1763
          do ie = 2, negrid-1
×
1764
             vr = 0.5*(sqrt(energy(ie+1)) + sqrt(energy(ie)))
×
1765
             vl = 0.5*(sqrt(energy(ie  )) + sqrt(energy(ie-1)))
×
1766
             dv2r = (energy(ie+1) - energy(ie)) / (sqrt(energy(ie+1)) - sqrt(energy(ie)))
×
1767
             dv2l = (energy(ie) - energy(ie-1)) / (sqrt(energy(ie)) - sqrt(energy(ie-1)))
×
1768

1769
             vnew_E(:, ie, is) =  spec(is)%vnewk * tunits * &
×
1770
                  vnew_E_conservative(vr, vl, dv2r, dv2l) / (sqrt_pi * w(ie))
×
1771
             delvnew(:, ie, is) = spec(is)%vnewk * tunits * &
×
1772
                  delvnew_conservative(vr, vl) / (sqrt_pi * sqrt(energy(ie)) * w(ie))
×
1773
          end do
1774

1775
          ! boundary at v = 0
1776
          ie = 1
×
1777
          vr = 0.5 * (sqrt(energy(ie+1)) + sqrt(energy(ie)))
×
1778
          vl = 0.0
×
1779
          dv2r = (energy(ie+1) - energy(ie)) / (sqrt(energy(ie+1)) - sqrt(energy(ie)))
×
1780
          dv2l = 0.0
×
1781
          vnew_E(:, ie, is) =  spec(is)%vnewk * tunits * &
×
1782
               vnew_E_conservative(vr, vl, dv2r, dv2l) / (sqrt_pi * w(ie))
×
1783
          delvnew(:, ie, is) = spec(is)%vnewk * tunits * &
×
1784
               delvnew_conservative(vr, vl) / (sqrt_pi * sqrt(energy(ie)) * w(ie))
×
1785

1786
          ! boundary at v -> infinity
1787
          ie = negrid
×
1788
          vr = 0.0
×
1789
          vl = 0.5 * (sqrt(energy(ie)) + sqrt(energy(ie-1)))
×
1790
          dv2r = 0.0
×
1791
          dv2l = (energy(ie) - energy(ie-1)) / (sqrt(energy(ie)) - sqrt(energy(ie-1)))
×
1792
          vnew_E(:, ie, is) =  spec(is)%vnewk * tunits * &
×
1793
               vnew_E_conservative(vr, vl, dv2r, dv2l) / (sqrt_pi * w(ie))
×
1794
          delvnew(:, ie, is) = spec(is)%vnewk * tunits * &
×
1795
               delvnew_conservative(vr, vl) / (sqrt_pi * sqrt(energy(ie)) * w(ie))
×
1796
       end do
1797
    else
1798
       do is = 1, nspec
×
1799
          do ie = 2, negrid-1
×
1800
             vnew_E(:, ie, is) = local_energy(ie) * (vnew_s(:, ie, is) * &
×
1801
                  (2.0 - 0.5 / local_energy(ie)) - 2.0 * vnew_D(:, ie, is))
×
1802
             delvnew(:, ie, is) = vnew_s(:, ie, is) - vnew_D(:, ie, is)
×
1803
          end do
1804
       end do
1805
    end if
1806

1807
       ! add hyper-terms inside collision operator
1808
!BD: Warning!
1809
!BD: For finite magnetic shear, this is different in form from what appears in hyper.f90
1810
!BD: because kperp2 /= akx**2 + aky**2;  there are cross terms that are dropped in hyper.f90
1811
!BD: Warning!
1812
!BD: Also: there is no "grid_norm" option here and the exponent is fixed to 4 for now
1813
    if (hyper_colls) then
×
1814
       if (.not. allocated(vnewh)) allocate (vnewh(-ntgrid:ntgrid,ntheta0,naky,nspec))
×
1815
       k4max = (maxval(kperp2))**2
×
1816
       do is = 1, nspec
×
1817
          do ik = 1, naky
×
1818
             do it = 1, ntheta0
×
1819
                vnewh(:,it,ik,is) = spec(is)%nu_h * kperp2(:,it,ik)**2/k4max
×
1820
             end do
1821
          end do
1822
       end do
1823
    end if
1824

1825
  contains
1826
    elemental real function vnew_E_conservative(vr, vl, dv2r, dv2l) result(vnE)
×
1827
      real, intent(in) :: vr, vl, dv2l, dv2r
1828
      vnE = (vl * exp(-vl**2) * dv2l * hsg_func(vl) - vr * exp(-vr**2) * dv2r * hsg_func(vr))
×
1829
    end function vnew_E_conservative
×
1830

1831
    elemental real function delvnew_conservative(vr, vl) result(delVn)
×
1832
      real, intent(in) :: vr, vl
1833
      delVn = (vl * exp(-vl**2) * hsg_func(vl) - vr * exp(-vr**2) * hsg_func(vr))
×
1834
    end function delvnew_conservative
×
1835

1836
  end subroutine init_vnew
1837

1838
  !> FIXME : Add documentation  
1839
  elemental real function hsg_func (vel)
×
1840
    use constants, only: sqrt_pi
1841
    implicit none
1842
    real, intent (in) :: vel
1843
    if (abs(vel) <= epsilon(0.0)) then
×
1844
       hsg_func = 0.0
×
1845
    else
1846
       hsg_func = 0.5 * erf(vel) / vel**2 - exp(-vel**2) / (sqrt_pi * vel)
×
1847
    end if
1848
  end function hsg_func
×
1849

1850
  !> Given estimates of the velocity space integration errors adjust the collision
1851
  !> frequency scaling factor vnmult.
1852
  subroutine adjust_vnmult(errest, consider_trapped_error)
×
1853
    implicit none
1854
    real, dimension(5, 2), intent(in) :: errest
1855
    logical, intent(in) :: consider_trapped_error
1856
    real :: vnmult_target
1857
    logical, parameter :: increase = .true., decrease = .false.
1858

1859
    if (vary_vnew) then
×
1860
       ! Energy resolution requirements
1861
       vnmult_target = vnmult(2)
×
1862

1863
       if (errest(1,2) > etol + ewindow .or. errest(4,2) > etola + ewindowa) then
×
1864
          vnmult_target = get_vnewk (vnmult(2), increase)
×
1865
       else if (errest(1,2) < etol - ewindow .and. errest(4,2) < etola - ewindowa) then
×
1866
          vnmult_target = get_vnewk (vnmult(2), decrease)
×
1867
       end if
1868

1869
       call init_ediffuse (vnmult_target)
×
1870
       call init_diffuse_conserve
×
1871

1872
       ! Lambda resolution requirements
1873
       vnmult_target = vnmult(1)
×
1874

1875
       if (errest(2,2) > etol + ewindow .or. errest(3,2) > etol + ewindow &
1876
            .or. errest(5,2) > etola + ewindowa) then
×
1877
          vnmult_target = get_vnewk (vnmult(1), increase)
×
1878
       else if (errest(2,2) < etol - ewindow .and. errest(5,2) < etola - ewindowa .and. &
×
1879
            (errest(3,2) < etol - ewindow .or. .not. consider_trapped_error)) then
1880
          !The last conditional in the above says to ignore the trapped_error if
1881
          !we haven't calculated it. The compute_trapped_error part is probably not needed
1882
          !as errest(3,2) should be zero there anyway.
1883
          vnmult_target = get_vnewk (vnmult(1), decrease)
×
1884
       end if
1885

1886
       call init_lorentz (vnmult_target)
×
1887
       call init_lorentz_conserve
×
1888
    end if
1889

1890
  contains
1891
    !> FIXME : Add documentation
1892
    pure real function get_vnewk (vnm, incr) result(vnm_target)
×
1893
      implicit none
1894
      logical, intent (in) :: incr
1895
      real, intent (in) :: vnm
1896
      if (incr) then
×
1897
         vnm_target = vnm * vnfac
×
1898
      else
1899
         vnm_target =  vnm * vnslow
×
1900
      end if
1901
    end function get_vnewk
×
1902
  end subroutine adjust_vnmult
1903

1904
  !> FIXME : Add documentation
1905
  subroutine init_ediffuse (vnmult_target)
×
1906
    use le_grids, only: negrid, forbid, ixi_to_il, speed => speed_maxw
1907
    use gs2_layouts, only: le_lo, e_lo, il_idx
1908
    use gs2_layouts, only: ig_idx, it_idx, ik_idx, is_idx
1909
    use array_utils, only: zero_array
1910
    implicit none
1911
    real, intent (in), optional :: vnmult_target
1912
    integer :: ie, is, ik, il, ig, it, ile, ixi, ielo
1913
    real, dimension (:), allocatable :: aa, bb, cc, xe
×
1914

1915
    allocate (aa(negrid), bb(negrid), cc(negrid), xe(negrid))
×
1916

1917
    ! want to use x variables instead of e because we want conservative form
1918
    ! for the x-integration
1919
    xe = speed
×
1920

1921
    if (present(vnmult_target)) then
×
1922
       vnmult(2) = max (vnmult_target, 1.0)
×
1923
    end if
1924

1925
    if(use_le_layout) then
×
1926

1927
       if (.not.allocated(ec1le)) then
×
1928
          allocate (ec1le   (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
1929
          allocate (ebetaale(nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
1930
          allocate (eqle    (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
1931
          vnmult(2) = max(1.0, vnmult(2))
×
1932
       end if
1933
       call zero_array(ec1le)
×
1934
       call zero_array(ebetaale)
×
1935
       call zero_array(eqle)
×
1936

1937
       !$OMP PARALLEL DO DEFAULT(none) &
1938
       !$OMP PRIVATE(ile, ik, it, is, ig, ie, ixi, il, aa, bb, cc) &
1939
       !$OMP SHARED(le_lo, nxi_lim, forbid, ec1le, ebetaale, negrid, eqle, ixi_to_il, xe) &
1940
       !$OMP SCHEDULE(static)
1941
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
1942
          ik = ik_idx(le_lo, ile)
×
1943
          it = it_idx(le_lo, ile)
×
1944
          is = is_idx(le_lo, ile)
×
1945
          ig = ig_idx(le_lo, ile)
×
1946
          do ixi = 1, nxi_lim
×
1947
             il = ixi_to_il(ixi, ig)
×
1948
             if (forbid(ig, il)) cycle
×
1949
             call get_ediffuse_matrix (aa, bb, cc, ig, ik, it, il, is, xe)
×
1950
             ec1le(ixi, :, ile) = cc
×
1951
             ebetaale(ixi, 1, ile) = 1.0 / bb(1)
×
1952
             do ie = 1,  negrid - 1
×
1953
                eqle(ixi, ie+1, ile) = aa(ie+1) * ebetaale(ixi, ie, ile)
×
1954
                ebetaale(ixi, ie+1, ile) = 1.0 / ( bb(ie+1) - eqle(ixi, ie+1, ile) &
×
1955
                     * ec1le(ixi, ie, ile) )
×
1956
             end do
1957
          end do
1958
       end do
1959
       !$OMP END PARALLEL DO
1960
    else
1961

1962
       if (.not.allocated(ec1)) then
×
1963
          allocate (ec1    (negrid,e_lo%llim_proc:e_lo%ulim_alloc))
×
1964
          allocate (ebetaa (negrid,e_lo%llim_proc:e_lo%ulim_alloc))
×
1965
          allocate (eql    (negrid,e_lo%llim_proc:e_lo%ulim_alloc))
×
1966
          vnmult(2) = max(1.0, vnmult(2))
×
1967
       endif
1968
       call zero_array(ec1)
×
1969
       call zero_array(ebetaa)
×
1970
       call zero_array(eql)
×
1971

1972
       !$OMP PARALLEL DO DEFAULT(none) &
1973
       !$OMP PRIVATE(ielo, ik, it, is, ig, ie, ixi, il, aa, bb, cc) &
1974
       !$OMP SHARED(e_lo, forbid, xe, ec1, ebetaa, negrid, eql) &
1975
       !$OMP SCHEDULE(static)
1976
       do ielo = e_lo%llim_proc, e_lo%ulim_proc
×
1977
          il = il_idx(e_lo, ielo)
×
1978
          ig = ig_idx(e_lo, ielo)
×
1979
          if (forbid(ig, il)) cycle
×
1980
          is = is_idx(e_lo, ielo)
×
1981
          ik = ik_idx(e_lo, ielo)
×
1982
          it = it_idx(e_lo, ielo)
×
1983
          call get_ediffuse_matrix (aa, bb, cc, ig, ik, it, il, is, xe)
×
1984
          ec1(:, ielo) = cc
×
1985

1986
          ! fill in the arrays for the tridiagonal
1987
          ebetaa(1, ielo) = 1.0 / bb(1)
×
1988
          do ie = 1, negrid - 1
×
1989
             eql(ie+1, ielo) = aa(ie+1) * ebetaa(ie, ielo)
×
1990
             ebetaa(ie+1, ielo) = 1.0 / (bb(ie+1) - eql(ie+1, ielo) * ec1(ie, ielo))
×
1991
          end do
1992
       end do
1993
       !$OMP END PARALLEL DO
1994
    end if
1995

1996
    deallocate(aa, bb, cc, xe)
×
1997

1998
  end subroutine init_ediffuse
×
1999

2000
  !> FIXME : Add documentation
2001
  subroutine get_ediffuse_matrix (aa, bb, cc, ig, ik, it, il, is, xe)
×
2002
    use species, only: spec
2003
    use theta_grid, only: bmag
2004
    use le_grids, only: al, negrid, w=>w_maxw
2005
    use kt_grids, only: kperp2
2006
    use gs2_time, only: code_dt, tunits
2007

2008
    implicit none
2009

2010
    integer, intent (in) :: ig, ik, it, il, is
2011
    real, dimension (:), intent (in) :: xe
2012
    real, dimension (:), intent (out) :: aa, bb, cc
2013

2014
    integer :: ie
2015
    real :: vn, slb1, xe0, xe1, xe2, xel, xer, capgr, capgl, ee
2016

2017
    vn = vnmult(2) * spec(is)%vnewk * tunits(ik)
×
2018

2019
    slb1 = safe_sqrt(1.0 - bmag(ig)*al(il))     ! xi_j
×
2020

2021
    select case (ediff_switch)
×
2022
    case (ediff_scheme_default)
2023
       do ie = 2, negrid - 1
×
2024
          xe0 = xe(ie-1)
×
2025
          xe1 = xe(ie)
×
2026
          xe2 = xe(ie+1)
×
2027

2028
          xel = (xe0 + xe1) * 0.5
×
2029
          xer = (xe1 + xe2) * 0.5
×
2030

2031
          capgr = capg(xer)
×
2032
          capgl = capg(xel)
×
2033

2034
          ee = 0.125 * (1 - slb1**2) * vnew_s(ik,ie,is) * kperp2(ig,it,ik)*cfac &
×
2035
               / (bmag(ig) * spec(is)%zstm)**2
×
2036

2037
          ! coefficients for tridiagonal matrix:
2038
          cc(ie) = -0.25 * vn * code_dt * capgr / (w(ie) * (xe2 - xe1))
×
2039
          aa(ie) = -0.25 * vn * code_dt * capgl / (w(ie) * (xe1 - xe0))
×
2040
          bb(ie) = 1.0 - (aa(ie) + cc(ie)) + ee*code_dt
×
2041
       end do
2042

2043
       ! boundary at v = 0
2044
       xe1 = xe(1)
×
2045
       xe2 = xe(2)
×
2046
       xer = (xe1 + xe2) * 0.5
×
2047

2048
       capgr = capg(xer)
×
2049

2050
       ee = 0.125 * (1 - slb1**2) * vnew_s(ik,1,is) * kperp2(ig,it,ik)*cfac &
×
2051
            / (bmag(ig) * spec(is)%zstm)**2
×
2052

2053
       cc(1) = -0.25 * vn * code_dt * capgr / (w(1) * (xe2 - xe1))
×
2054
       aa(1) = 0.0
×
2055
       bb(1) = 1.0 - cc(1) + ee * code_dt
×
2056

2057
       ! boundary at v = infinity
2058
       xe0 = xe(negrid-1)
×
2059
       xe1 = xe(negrid)
×
2060

2061
       xel = (xe1 + xe0) * 0.5
×
2062

2063
       capgl = capg(xel)
×
2064

2065
       ee = 0.125 * (1.-slb1**2) * vnew_s(ik,negrid,is) * kperp2(ig,it,ik) * cfac &
×
2066
            / (bmag(ig) * spec(is)%zstm)**2
×
2067

2068
       cc(negrid) = 0.0
×
2069
       aa(negrid) = -0.25 * vn * code_dt * capgl / (w(negrid) * (xe1 - xe0))
×
2070
       bb(negrid) = 1.0 - aa(negrid) + ee*code_dt
×
2071

2072
    case (ediff_scheme_old)
2073

2074
       ! non-conservative scheme
2075
       do ie = 2, negrid-1
×
2076
          xe0 = xe(ie-1)
×
2077
          xe1 = xe(ie)
×
2078
          xe2 = xe(ie+1)
×
2079

2080
          xel = (xe0 + xe1) * 0.5
×
2081
          xer = (xe1 + xe2) * 0.5
×
2082

2083
          capgr = capg_old(xe1, xer)
×
2084
          capgl = capg_old(xe1, xel)
×
2085

2086
          ee = 0.125 * (1 - slb1**2) * vnew_s(ik,ie,is) * kperp2(ig,it,ik) * cfac &
×
2087
               / (bmag(ig) * spec(is)%zstm)**2
×
2088

2089
          ! coefficients for tridiagonal matrix:
2090
          cc(ie) = -vn * code_dt * capgr / ((xer-xel) * (xe2 - xe1))
×
2091
          aa(ie) = -vn * code_dt * capgl / ((xer-xel) * (xe1 - xe0))
×
2092
          bb(ie) = 1.0 - (aa(ie) + cc(ie)) + ee * code_dt
×
2093
       end do
2094

2095
       ! boundary at xe = 0
2096
       xe1 = xe(1)
×
2097
       xe2 = xe(2)
×
2098
       xer = (xe1 + xe2) * 0.5
×
2099

2100
       capgr = capg_old(xe1, xer)
×
2101

2102
       ee = 0.125 * (1 - slb1**2) * vnew_s(ik,1,is) * kperp2(ig,it,ik)*cfac &
×
2103
            / (bmag(ig) * spec(is)%zstm)**2
×
2104

2105
       cc(1) = -vn * code_dt * capgr / (xer * (xe2 - xe1))
×
2106
       aa(1) = 0.0
×
2107
       bb(1) = 1.0 - cc(1) + ee * code_dt
×
2108

2109
       ! boundary at xe = 1
2110
       xe0 = xe(negrid-1)
×
2111
       xe1 = xe(negrid)
×
2112
       xel = (xe1 + xe0) * 0.5
×
2113

2114
       capgl = capg_old(xe1, xel)
×
2115

2116
       ee = 0.125 * (1 - slb1**2) * vnew_s(ik,negrid,is) * kperp2(ig,it,ik)*cfac &
×
2117
            / (bmag(ig) * spec(is)%zstm)**2
×
2118

2119
       cc(negrid) = 0.0
×
2120
       aa(negrid) = -vn * code_dt * capgl / ((1.0-xel) * (xe1 - xe0))
×
2121
       bb(negrid) = 1.0 - aa(negrid) + ee * code_dt
×
2122
    end select
2123

2124
  contains
2125
    elemental real function capg_kernel(xe)
×
2126
      use constants, only: sqrt_pi
2127
      real, intent(in) :: xe
2128
      ! This is the same as hsg_func(xe) * 2 * xe**2
2129
      capg_kernel =  erf(xe) - 2 * xe * exp(-xe**2) / sqrt_pi
×
2130
    end function capg_kernel
×
2131

2132
    elemental real function capg(xe)
×
2133
      use constants, only: sqrt_pi
2134
      real, intent(in) :: xe
2135
      capg = 2 * exp(-xe**2) * capg_kernel(xe) / (xe * sqrt_pi)
×
2136
    end function capg
×
2137

2138
    elemental real function capg_old(xeA, xeB)
×
2139
      real, intent(in) :: xeA, xeB
2140
      capg_old = (0.5 * exp(xeA**2-xeB**2) / xeA**2) * capg_kernel(xeB) / xeB
×
2141
    end function capg_old
×
2142
  end subroutine get_ediffuse_matrix
2143

2144
  !> FIXME : Add documentation
2145
  subroutine init_lorentz (vnmult_target)
×
2146
    use le_grids, only: negrid, jend, ng2, nlambda, al, il_is_passing, il_is_wfb
2147
    use le_grids, only: setup_trapped_lambda_grids_old_finite_difference, setup_passing_lambda_grids
2148
    use gs2_layouts, only: ig_idx, ik_idx, ie_idx, is_idx, it_idx, lz_lo, le_lo
2149
    use theta_grid, only: ntgrid
2150
    use species, only: has_hybrid_electron_species, spec
2151
    use array_utils, only: zero_array
2152
    implicit none
2153
    real, intent (in), optional :: vnmult_target
2154
    integer :: ig, ixi, it, ik, ie, is, je, te2, ile, ilz
2155
    real, dimension (:), allocatable :: aa, bb, cc, dd, hh
×
2156
    real, dimension (:, :), allocatable :: local_weights
×
2157
    allocate (aa(nxi_lim), bb(nxi_lim), cc(nxi_lim), dd(nxi_lim), hh(nxi_lim))
×
2158

2159
    if (.not. allocated(pitch_weights)) then
×
2160
       ! Start by just copying the existing weights
2161
       allocate(local_weights(-ntgrid:ntgrid, nlambda))
×
2162
       local_weights = 0.0
×
2163
       ! We have to recaculate the passing weights here as when Radau-Gauss
2164
       ! grids are used the WFB (il=ng2+1) is treated as both passing and
2165
       ! trapped. Otherwise we could just copy the passing weights from wl.
2166
       call setup_passing_lambda_grids(al, local_weights)
×
2167
       call setup_trapped_lambda_grids_old_finite_difference(al, local_weights)
×
2168
       allocate(pitch_weights(nlambda, -ntgrid:ntgrid))
×
2169
       pitch_weights = transpose(local_weights)
×
2170
    end if
2171

2172
    call init_vpdiff
×
2173

2174
    if(use_le_layout) then
×
2175
       if (.not.allocated(c1le)) then
×
2176
          allocate (c1le    (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
2177
          allocate (betaale (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
2178
          allocate (qle     (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
2179
          if (heating) then
×
2180
             allocate (d1le    (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
2181
             allocate (h1le    (nxi_lim, negrid, le_lo%llim_proc:le_lo%ulim_alloc))
×
2182
             call zero_array(d1le)
×
2183
             call zero_array(h1le)
×
2184
          end if
2185
          vnmult(1) = max(1.0, vnmult(1))
×
2186
       endif
2187
       call zero_array(c1le)
×
2188
       call zero_array(betaale)
×
2189
       call zero_array(qle)
×
2190

2191
       if (present(vnmult_target)) then
×
2192
          vnmult(1) = max (vnmult_target, 1.0)
×
2193
       end if
2194

2195
       !$OMP PARALLEL DO DEFAULT(none) &
2196
       !$OMP PRIVATE(ile, ik, it, is, ig, je, te2, ie, aa, bb, cc, dd, hh, ixi) &
2197
       !$OMP SHARED(le_lo, jend, special_wfb_lorentz, ng2, negrid, spec, c1le, &
2198
       !$OMP d1le, h1le, qle, betaale) &
2199
       !$OMP SCHEDULE(static)
2200
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
2201
          ig = ig_idx(le_lo,ile)
×
2202
          ik = ik_idx(le_lo,ile)
×
2203
          it = it_idx(le_lo,ile)
×
2204
          is = is_idx(le_lo,ile)
×
2205
          je = jend(ig)
×
2206
          !if (je <= ng2+1) then
2207
          ! MRH the above line is likely the original cause of the wfb bug in collisions
2208
          ! by treating collisions arrays here as if there are only passing particles
2209
          ! when there are only passing particles plus wfb (and no other trapped particles)
2210
          ! introduced an inconsistency in the tri-diagonal solve for theta =+/- pi
2211
          ! Fixed below.
2212
          ! Here te2 is the total number of unique valid xi at this point.
2213
          ! For passing particles this is 2*ng2 whilst for trapped we subtract one
2214
          ! from the number of valid pitch angles due to the "degenerate" duplicate
2215
          ! vpar = 0 point.
2216
          if (il_is_passing(je) .or. (il_is_wfb(je) .and. special_wfb_lorentz) ) then ! MRH
×
2217
             te2 = 2 * ng2
×
2218
          else
2219
             te2 = 2 * je - 1
×
2220
          end if
2221
          do ie = 1, negrid
×
2222

2223
             call get_lorentz_matrix (aa, bb, cc, dd, hh, ig, ik, it, ie, is)
×
2224

2225
             if (has_hybrid_electron_species(spec)) &
×
2226
                  call set_hzero_lorentz_collisions_matrix(aa, bb, cc, je, ik, is)
×
2227

2228
             c1le(:, ie, ile) = cc
×
2229
             if (allocated(d1le)) then
×
2230
                d1le(:, ie, ile) = dd
×
2231
                h1le(:, ie, ile) = hh
×
2232
             end if
2233

2234
             qle(1, ie, ile) = 0.0
×
2235
             betaale(1, ie, ile) = 1.0 / bb(1)
×
2236
             do ixi = 1, te2-1
×
2237
                qle(ixi+1, ie, ile) = aa(ixi+1) * betaale(ixi, ie, ile)
×
2238
                betaale(ixi+1, ie, ile) = 1.0 / ( bb(ixi+1) - qle(ixi+1, ie, ile) &
×
2239
                     * c1le(ixi, ie, ile) )
×
2240
             end do
2241
             qle(te2+1:, ie, ile) = 0.0
×
2242
             betaale(te2+1:, ie, ile) = 0.0
×
2243
          end do
2244
       end do
2245
       !$OMP END PARALLEL DO
2246
    else
2247

2248
       if (.not.allocated(c1)) then
×
2249
          allocate (c1(nxi_lim,lz_lo%llim_proc:lz_lo%ulim_alloc))
×
2250
          allocate (betaa(nxi_lim,lz_lo%llim_proc:lz_lo%ulim_alloc))
×
2251
          allocate (ql(nxi_lim,lz_lo%llim_proc:lz_lo%ulim_alloc))
×
2252
          if (heating) then
×
2253
             allocate (d1   (nxi_lim,lz_lo%llim_proc:lz_lo%ulim_alloc))
×
2254
             allocate (h1   (nxi_lim,lz_lo%llim_proc:lz_lo%ulim_alloc))
×
2255
             call zero_array(d1)
×
2256
             call zero_array(h1)
×
2257
          end if
2258
          vnmult(1) = max(1.0, vnmult(1))
×
2259
       end if
2260

2261
       call zero_array(c1)
×
2262
       call zero_array(betaa)
×
2263
       call zero_array(ql)
×
2264

2265
       if (present(vnmult_target)) then
×
2266
          vnmult(1) = max (vnmult_target, 1.0)
×
2267
       end if
2268

2269
       !$OMP PARALLEL DO DEFAULT(none) &
2270
       !$OMP PRIVATE(ilz, ik, it, is, ig, je, te2, ie, aa, bb, cc, dd, hh, ixi) &
2271
       !$OMP SHARED(lz_lo, jend, special_wfb_lorentz, spec, c1, d1, h1, betaa, ql, ng2) &
2272
       !$OMP SCHEDULE(static)
2273
       do ilz = lz_lo%llim_proc, lz_lo%ulim_proc
×
2274
          is = is_idx(lz_lo,ilz)
×
2275
          ik = ik_idx(lz_lo,ilz)
×
2276
          it = it_idx(lz_lo,ilz)
×
2277
          ie = ie_idx(lz_lo,ilz)
×
2278
          ig = ig_idx(lz_lo,ilz)
×
2279
          je = jend(ig)
×
2280
          !if (je <= ng2+1) then
2281
          ! MRH the above line is likely the original cause of the wfb bug in collisions
2282
          ! by treating collisions arrays here as if there are only passing particles
2283
          ! when there are only passing particles plus wfb (and no other trapped particles)
2284
          ! introduced an inconsistency in the tri-diagonal solve for theta =+/- pi
2285
          ! Fixed below
2286
          if (il_is_passing(je) .or. (il_is_wfb(je) .and. special_wfb_lorentz) ) then ! MRH
×
2287
             te2 = 2 * ng2
×
2288
          else
2289
             te2 = 2 * je - 1
×
2290
          end if
2291

2292
          call get_lorentz_matrix (aa, bb, cc, dd, hh, ig, ik, it, ie, is)
×
2293

2294
          if (has_hybrid_electron_species(spec)) &
×
2295
               call set_hzero_lorentz_collisions_matrix(aa, bb, cc, je, ik, is)
×
2296

2297
          c1(:, ilz) = cc
×
2298
          if (allocated(d1)) then
×
2299
             d1(:, ilz) = dd
×
2300
             h1(:, ilz) = hh
×
2301
          end if
2302

2303
          ql(1, ilz) = 0.0
×
2304
          betaa(1, ilz) = 1.0 / bb(1)
×
2305
          do ixi = 1, te2-1
×
2306
             ql(ixi+1, ilz) = aa(ixi+1) * betaa(ixi, ilz)
×
2307
             betaa(ixi+1, ilz) = 1.0 / (bb(ixi+1) - ql(ixi+1, ilz) * c1(ixi, ilz))
×
2308
          end do
2309
          ql(te2+1:, ilz) = 0.0
×
2310
          c1(te2+1:, ilz) = 0.0
×
2311
          betaa(te2+1:, ilz) = 0.0
×
2312
       end do
2313
       !$OMP END PARALLEL DO
2314
    end if
2315

2316
    deallocate (aa, bb, cc, dd, hh)
×
2317

2318
  end subroutine init_lorentz
×
2319

2320
  !> Special behaviour when h=0 for passing non-zonal electrons
2321
  !>
2322
  !> The effect of these changes is to exclude passing electrons
2323
  !> From pitch angle scattering, and to enforce 0 passing as a
2324
  !> boundary condition For the trapped particle pitch angle
2325
  !> scattering.
2326
  subroutine set_hzero_lorentz_collisions_matrix(aa, bb, cc, je, ik, is)
×
2327
    use species, only: is_hybrid_electron_species, spec
2328
    use kt_grids, only: aky
2329
    use le_grids, only: ng2, grid_has_trapped_particles
2330
    implicit none
2331
    real, dimension(:), intent(in out) :: aa, bb, cc
2332
    integer, intent(in) :: je, ik, is
2333
    !> il index of 1st non-wfb trapped particle
2334
    integer :: il_llim
2335
    !> il index of last non-wfb trapped particle
2336
    integer :: il_ulim
2337

2338
    il_llim = ng2 + 2
×
2339
    il_ulim = 2*je-1 - (ng2+ 1)
×
2340

2341
    ! If not trapped particles then need to adjust limits
2342
    ! Want to force aa = cc = 0 ; bb = 1
2343
    if (.not. grid_has_trapped_particles()) then
×
2344
       il_llim = ng2 + 1 ; il_ulim = ng2 -1
×
2345
    end if
2346

2347
    if ( is_hybrid_electron_species(spec(is)) .and. aky(ik) /= 0.) then
×
2348
       aa(:il_llim) = 0.
×
2349
       bb(:il_llim-1) = 1.
×
2350
       cc(:il_llim-1) = 0.
×
2351
       aa(il_ulim+1:) = 0.
×
2352
       bb(il_ulim+1:) = 1.
×
2353
       cc(il_ulim:) = 0.
×
2354
    endif
2355
  end subroutine set_hzero_lorentz_collisions_matrix
×
2356

2357
  !> FIXME : Add documentation
2358
  subroutine get_lorentz_matrix (aa, bb, cc, dd, hh, ig, ik, it, ie, is)
×
2359
    use species, only: spec
2360
    use le_grids, only: al, energy => energy_maxw, xi, ng2
2361
    use le_grids, only: jend, al, il_is_passing, il_is_wfb
2362
    use gs2_time, only: code_dt, tunits
2363
    use kt_grids, only: kperp2
2364
    use theta_grid, only: bmag
2365
    implicit none
2366
    real, dimension (:), intent (out) :: aa, bb, cc, dd, hh
2367
    integer, intent (in) :: ig, ik, it, ie, is
2368
    integer :: il, je, te, te2, teh
2369
    real :: slb0, slb1, slb2, slbl, slbr, vhyp, vn, vnh, vnc, ee, deltaxi
2370

2371
    je = jend(ig)
×
2372
!
2373
!CMR, 17/2/2014:
2374
!         te, te2, teh: indices in xi, which runs from +1 -> -1.
2375
!         te   :  index of minimum xi value >= 0.
2376
!         te2  :  total #xi values = index of minimum xi value (= -1)
2377
!         teh  :  index of minimum xi value > 0.
2378
!                 teh = te if no bouncing particle at this location
2379
!              OR teh = te-1 if there is a bouncing particle
2380
!
2381
    if (il_is_passing(je) .or. (il_is_wfb(je) .and. special_wfb_lorentz)) then
×
2382
       !CMRDDGC, 17/2/2014:
2383
       !   This clause is appropriate for Lorentz collisons with
2384
       !         SPECIAL (unphysical) treatment of wfb at its bounce point
2385
       te = ng2
×
2386
       te2 = 2*ng2
×
2387
       teh = ng2
×
2388
    else
2389
       !CMRDDGC, 17/2/2014:
2390
       !   This clause is appropriate for Lorentz collisons with
2391
       !         STANDARD treatment of wfb at its bounce point
2392
       te = je
×
2393
       te2 = 2*je-1
×
2394
       teh = je-1
×
2395
    end if
2396

2397
    if (collision_model_switch == collision_model_lorentz_test) then
×
2398
       vn = vnmult(1) * abs(spec(is)%vnewk) * tunits(ik)
×
2399
       vnc = 0.
×
2400
       vnh = 0.
×
2401
    else
2402
       if (hyper_colls) then
×
2403
          vhyp = vnewh(ig, it, ik, is)
×
2404
       else
2405
          vhyp = 0.0
×
2406
       end if
2407
       ! vnc and vnh only needed when heating is true
2408
       vnc = vnmult(1) * vnew(ik, ie, is)
×
2409
       if (hypermult) then
×
2410
          vn = vnmult(1) * vnew(ik, ie, is) * (1 + vhyp)
×
2411
          vnh = vhyp * vnc
×
2412
       else
2413
          vn = vnmult(1) * vnew(ik, ie, is) + vhyp
×
2414
          vnh = vhyp
×
2415
       end if
2416
    end if
2417

2418
    aa = 0.0 ; bb = 0.0 ; cc = 0.0 ; dd = 0.0 ; hh = 0.0
×
2419

2420
    select case (lorentz_switch)
×
2421
    case (lorentz_scheme_default)
2422

2423
       do il = 2, te-1
×
2424
          slb0 = safe_sqrt(1.0 - bmag(ig) * al(il-1))
×
2425
          slb1 = safe_sqrt(1.0 - bmag(ig) * al(il))
×
2426
          slb2 = safe_sqrt(1.0 - bmag(ig) * al(il+1))
×
2427

2428
          slbl = (slb1 + slb0) * 0.5  ! xi(j-1/2)
×
2429
          slbr = (slb1 + slb2) * 0.5  ! xi(j+1/2)
×
2430

2431
          ee = 0.5 * energy(ie)*(1 + slb1**2) * kperp2(ig,it,ik) * cfac &
×
2432
               / (bmag(ig) * spec(is)%zstm)**2
×
2433

2434
          ! coefficients for tridiagonal matrix:
2435
          cc(il) = 2.0 * vn * code_dt * (1 - slbr**2) / &
×
2436
               (pitch_weights(il, ig) * (slb2 - slb1))
×
2437
          aa(il) = 2.0 * vn * code_dt * (1 - slbl**2) / &
×
2438
               (pitch_weights(il, ig) * (slb1 - slb0))
×
2439
          bb(il) = 1.0 - (aa(il) + cc(il)) + ee * vn * code_dt
×
2440

2441
          ! coefficients for entropy heating calculation
2442
          if (heating) then
×
2443
             dd(il) = vnc * (-2.0 * (1 - slbr**2) / &
×
2444
                  (pitch_weights(il, ig) * (slb2 - slb1)) + ee)
×
2445
             hh(il) = vnh * (-2.0 * (1 - slbr**2) / &
×
2446
                  (pitch_weights(il, ig) * (slb2 - slb1)) + ee)
×
2447
          end if
2448
       end do
2449

2450
       ! boundary at xi = 1
2451
       slb1 = safe_sqrt(1.0 - bmag(ig) * al(1))
×
2452
       slb2 = safe_sqrt(1.0 - bmag(ig) * al(2))
×
2453

2454
       slbr = (slb1 + slb2) * 0.5
×
2455

2456
       ee = 0.5 * energy(ie) * (1 + slb1**2) * kperp2(ig,it,ik) * cfac &
×
2457
            / (bmag(ig) * spec(is)%zstm)**2
×
2458

2459
       cc(1) = 2.0 * vn * code_dt * (1.0 - slbr**2) &
×
2460
            / (pitch_weights(1, ig) * (slb2 - slb1))
×
2461
       aa(1) = 0.0
×
2462
       bb(1) = 1.0 - cc(1) + ee * vn * code_dt
×
2463

2464
       if (heating) then
×
2465
          dd(1) = vnc * (-2.0 * (1 - slbr**2) &
×
2466
               / (pitch_weights(1, ig) * (slb2 - slb1)) + ee)
×
2467
          hh(1) = vnh * (-2.0 * (1 - slbr**2) &
×
2468
               / (pitch_weights(1, ig) * (slb2 - slb1)) + ee)
×
2469
       end if
2470

2471
       ! boundary at xi = 0
2472
       il = te
×
2473
       slb0 = safe_sqrt(1.0 - bmag(ig) * al(il-1))
×
2474
       if (te == ng2) then
×
2475
          slb1 = safe_sqrt(1.0 - bmag(ig) * al(il))
×
2476
          slb2 = -slb1
×
2477
       else
2478
          slb1 = 0.0
×
2479
          slb2 = -slb0
×
2480
       end if
2481

2482
       slbl = (slb1 + slb0) * 0.5
×
2483
       slbr = (slb1 + slb2) * 0.5
×
2484

2485
       ee = 0.5 * energy(ie) * (1 + slb1**2) * kperp2(ig,it,ik) * cfac &
×
2486
            / (bmag(ig) * spec(is)%zstm)**2
×
2487

2488
!CMR, 6/3/2014:
2489
! STANDARD treatment of pitch angle scattering must resolve T-P boundary.
2490
! NEED special_wfb= .false. to resolve T-P boundary at wfb bounce point
2491
!     (special_wfb= .true. AVOIDS TP boundary at wfb bounce point)
2492
!
2493
! Original code (pre-r2766) used eq.(42) Barnes et al, Phys Plasmas 16, 072107
2494
! (2009), with pitch angle weights to enhance accuracy in derivatives.
2495
! NB THIS FAILS at wfb bounce point, giving aa=cc=infinite,
2496
!    because weight wl(ig,il)=0 at wfb bounce point.
2497
!    UNPHYSICAL as d/dxi ((1-xi^2)g) IS NOT resolved numerically for wl=0.
2498
! MUST accept limitations of the grid resolution and USE FINITE coefficients!
2499
! FIX here by setting a FINITE width of the trapped region at wfb B-P
2500
!              deltaxi=xi(ig,ng2)-xi(ig,ng2+2)
2501
! ASIDE: NB    deltaxi=wl is actually 2*spacing in xi !!!
2502
!              which explains upfront factor 2 in definition of aa, cc
2503
       deltaxi = pitch_weights(il, ig)
×
2504
       if (te == je) deltaxi = 2 * deltaxi ! MRH vpar = 0 fix
×
2505
       ! MRH appropriate when endpoint (te) is a vpar = 0 point (je)
2506
       ! factor of 2 required above because xi=0 is a repeated point
2507
       ! on vpar > 0, vpar < 0 grids, and hence has half the weight associated
2508
       ! to it at each appearance compared to what the weight should be
2509
       ! as calculated in the continuum of points xi = (-1,1)
2510
       if ((.not. special_wfb_lorentz) .and. (deltaxi == 0) .and. il_is_wfb(il)) then
×
2511
          deltaxi = xi(ng2, ig) - xi(ng2 + 2, ig)
×
2512
       endif
2513
       cc(il) = 2.0 * vn * code_dt * (1 - slbr**2) / (deltaxi * (slb2 - slb1))
×
2514
       aa(il) = 2.0 * vn * code_dt * (1 - slbl**2) / (deltaxi * (slb1 - slb0))
×
2515
       bb(il) = 1.0 - (aa(il) + cc(il)) + ee * vn * code_dt
×
2516

2517
       if (heating) then
×
2518
          dd(il) = vnc * (-2.0 * (1.0 - slbr**2) / (deltaxi * (slb2 - slb1)) + ee)
×
2519
          hh(il) = vnh * (-2.0 * (1.0 - slbr**2) / (deltaxi * (slb2 - slb1)) + ee)
×
2520
       end if
2521
!CMRend
2522

2523
    case (lorentz_scheme_old)
2524
       do il = 2, te-1
×
2525
          slb0 = safe_sqrt(1.0 - bmag(ig) * al(il-1))
×
2526
          slb1 = safe_sqrt(1.0 - bmag(ig) * al(il))
×
2527
          slb2 = safe_sqrt(1.0 - bmag(ig) * al(il+1))
×
2528

2529
          slbl = (slb1 + slb0) * 0.5  ! xi(j-1/2)
×
2530
          slbr = (slb1 + slb2) * 0.5  ! xi(j+1/2)
×
2531

2532
          ee = 0.5 * energy(ie) * (1 + slb1**2) * kperp2(ig,it,ik) * cfac &
×
2533
               / (bmag(ig) * spec(is)%zstm)**2
×
2534

2535
          ! coefficients for tridiagonal matrix:
2536
          cc(il) = -vn * code_dt * (1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1))
×
2537
          aa(il) = -vn * code_dt * (1 - slbl**2) / ((slbr - slbl) * (slb1 - slb0))
×
2538
          bb(il) = 1.0 - (aa(il) + cc(il)) + ee * vn * code_dt
×
2539

2540
          ! coefficients for entropy heating calculation
2541
          if (heating) then
×
2542
             dd(il) = vnc * ((1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1)) + ee)
×
2543
             hh(il) = vnh * ((1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1)) + ee)
×
2544
          end if
2545
       end do
2546

2547
       ! boundary at xi = 1
2548
       slb0 = 1.0
×
2549
       slb1 = safe_sqrt(1.0 - bmag(ig) * al(1))
×
2550
       slb2 = safe_sqrt(1.0 - bmag(ig) * al(2))
×
2551

2552
       slbl = (slb1 + slb0) * 0.5
×
2553
       slbr = (slb1 + slb2) * 0.5
×
2554

2555
       ee = 0.5 * energy(ie) * (1 + slb1**2) * kperp2(ig,it,ik) * cfac &
×
2556
            / (bmag(ig) * spec(is)%zstm)**2
×
2557

2558
       cc(1) = -vn * code_dt * (-1.0 - slbr) / (slb2 - slb1)
×
2559
       aa(1) = 0.0
×
2560
       bb(1) = 1.0 - (aa(1) + cc(1)) + ee * vn * code_dt
×
2561

2562
       if (heating) then
×
2563
          dd(1) = vnc * ((1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1)) + ee)
×
2564
          hh(1) = vnh * ((1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1)) + ee)
×
2565
       end if
2566

2567
       ! boundary at xi = 0
2568
       il = te
×
2569
       slb0 = safe_sqrt(1.0 - bmag(ig) * al(il-1))
×
2570
       if (te == ng2) then
×
2571
          slb1 = safe_sqrt(1.0 - bmag(ig) * al(il))
×
2572
          slb2 = -slb1
×
2573
       else
2574
          slb1 = 0.0
×
2575
          slb2 = -slb0
×
2576
       end if
2577

2578
       slbl = (slb1 + slb0) * 0.5
×
2579
       slbr = (slb1 + slb2) * 0.5
×
2580

2581
       ee = 0.5 * energy(ie) * (1 + slb1**2) * kperp2(ig,it,ik) * cfac &
×
2582
            / (bmag(ig) * spec(is)%zstm)**2
×
2583

2584
       cc(il) = -vn * code_dt * (1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1))
×
2585
       aa(il) = -vn * code_dt * (1 - slbl**2) / ((slbr - slbl) * (slb1 - slb0))
×
2586
       bb(il) = 1.0 - (aa(il) + cc(il)) + ee * vn * code_dt
×
2587

2588
       if (heating) then
×
2589
          dd(il) = vnc * ((1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1)) + ee)
×
2590
          hh(il) = vnh * ((1 - slbr**2) / ((slbr - slbl) * (slb2 - slb1)) + ee)
×
2591
       end if
2592

2593
    end select
2594

2595
    ! assuming symmetry in xi, fill in the rest of the arrays.
2596
    aa(te+1:te2) = cc(teh:1:-1)
×
2597
    bb(te+1:te2) = bb(teh:1:-1)
×
2598
    cc(te+1:te2) = aa(teh:1:-1)
×
2599

2600
    if (heating) then
×
2601
       dd(te+1:te2) = dd(teh:1:-1)
×
2602
       hh(te+1:te2) = hh(teh:1:-1)
×
2603
    end if
2604

2605
  end subroutine get_lorentz_matrix
×
2606

2607
  !> FIXME : Add documentation
2608
  !>
2609
  !> @note Currently this method doesn't use anything (aside from safe_sqrt)
2610
  !> from the collisions module so _could_ be moved to le_grids or diagnostics.
2611
  !> It _could_ potentially use get_lorentz_matrix so we'll leave here for now.
2612
  subroutine init_lorentz_error
×
2613
    use le_grids, only: jend, al, ng2, nlambda, &
2614
         il_is_wfb, il_is_passing, il_is_trapped
2615
    use theta_grid, only: ntgrid, bmag
2616
    use array_utils, only: zero_array
2617
    implicit none
2618
    
2619
    integer :: je, ig, il, ip, ij, im
2620
    real :: slb0, slb1, slb2, slbr, slbl
2621
    real, dimension (:), allocatable :: slb
×
2622
    real, dimension (:,:), allocatable :: dprod
×
2623
    real, dimension (:,:,:), allocatable :: dlcoef, d2lcoef
×
2624

2625
    allocate(slb(2*nlambda))
×
2626
    allocate (dprod(nlambda,5))
×
2627

2628
    allocate (dlcoef(-ntgrid:ntgrid,nlambda,5))
×
2629
    allocate (d2lcoef(-ntgrid:ntgrid,nlambda,5))
×
2630
    allocate (dtot(-ntgrid:ntgrid,nlambda,5))
×
2631
    allocate (fdf(-ntgrid:ntgrid,nlambda), fdb(-ntgrid:ntgrid,nlambda))
×
2632

2633
    dlcoef = 1.0; call zero_array(d2lcoef); call zero_array(dtot)
×
2634
    call zero_array(fdf); call zero_array(fdb); slb = 0.0
×
2635

2636
    ! This loop appears to be calculating aa and cc of get_lorentz_matrix
2637
    ! when using lorentz_scheme_old and storing fdb = aa/(-vn*code_dt),
2638
    ! fdf = cc/(-vn*code_dt). Given we don't use lorentz_scheme_old by
2639
    ! default is this diagnostic still applicable?
2640
    do ig=-ntgrid,ntgrid
×
2641
       je = jend(ig)
×
2642
       
2643
       if (il_is_passing(je) .or. il_is_wfb(je)) then            ! no trapped particles
×
2644

2645
! calculation of xi and finite difference coefficients for non-boundary points
2646
          do il=2,ng2-1
×
2647
             slb(il) = safe_sqrt(1.0-al(il)*bmag(ig))   ! xi_{j}
×
2648
             
2649
             slb2 = safe_sqrt(1.0-al(il+1)*bmag(ig))    ! xi_{j+1}
×
2650
             slb1 = slb(il)
×
2651
             slb0 = safe_sqrt(1.0-al(il-1)*bmag(ig))    ! xi_{j-1}
×
2652
             
2653
             slbr = (slb2+slb1)*0.5                     ! xi_{j+1/2}
×
2654
             slbl = (slb1+slb0)*0.5                     ! xi_{j-1/2}
×
2655

2656
! finite difference coefficients
2657
             fdf(ig,il) = (1.0 - slbr*slbr)/(slbr - slbl)/(slb2 - slb1)
×
2658
             fdb(ig,il) = (1.0 - slbl*slbl)/(slbr - slbl)/(slb1 - slb0)
×
2659
          end do
2660

2661
! boundary at xi = 1
2662
          slb(1) = safe_sqrt(1.0-al(1)*bmag(ig))
×
2663
          slb0 = 1.0
×
2664
          slb1 = slb(1)
×
2665
          slb2 = slb(2)
×
2666

2667
          slbl = (slb1 + slb0)/2.0
×
2668
          slbr = (slb1 + slb2)/2.0
×
2669

2670
! derivative of [(1-xi**2)*df/dxi] at xi_{j=1} is centered, with upper xi=1 and
2671
! lower xi = xi_{j+1/2}
2672
          fdf(ig,1) = (-1.0-slbr)/(slb2-slb1)
×
2673
          fdb(ig,1) = 0.0
×
2674

2675
! boundary at xi = 0
2676
          il = ng2
×
2677
          slb(il) = safe_sqrt(1.0 - al(il)*bmag(ig))
×
2678
          slb0 = safe_sqrt(1.0 - bmag(ig)*al(il-1))
×
2679
          slb1 = slb(il)
×
2680
          slb2 = -slb1
×
2681

2682
          slbl = (slb1 + slb0)/2.0
×
2683
          slbr = (slb1 + slb2)/2.0
×
2684

2685
          fdf(ig,il) = (1.0 - slbr*slbr)/(slbr-slbl)/(slb2-slb1)
×
2686
          fdb(ig,il) = (1.0 - slbl*slbl)/(slbr-slbl)/(slb1-slb0)
×
2687

2688
          slb(ng2+1:) = -slb(ng2:1:-1)
×
2689
       else          ! run with trapped particles
2690
          do il=2,je-1
×
2691
             slb(il) = safe_sqrt(1.0-al(il)*bmag(ig))
×
2692
             
2693
             slb2 = safe_sqrt(1.0-al(il+1)*bmag(ig))
×
2694
             slb1 = slb(il)
×
2695
             slb0 = safe_sqrt(1.0-al(il-1)*bmag(ig))
×
2696
             
2697
             slbr = (slb2+slb1)*0.5
×
2698
             slbl = (slb1+slb0)*0.5
×
2699

2700
             fdf(ig,il) = (1.0 - slbr*slbr)/(slbr - slbl)/(slb2 - slb1)
×
2701
             fdb(ig,il) = (1.0 - slbl*slbl)/(slbr - slbl)/(slb1 - slb0)
×
2702
          end do
2703

2704
! boundary at xi = 1
2705
          slb(1) = safe_sqrt(1.0-bmag(ig)*al(1))
×
2706
          slb0 = 1.0
×
2707
          slb1 = slb(1)
×
2708
          slb2 = slb(2)
×
2709

2710
          slbr = (slb1 + slb2)/2.0
×
2711

2712
          fdf(ig,1) = (-1.0 - slbr)/(slb2-slb1)
×
2713
          fdb(ig,1) = 0.0
×
2714

2715
! boundary at xi = 0
2716
          il = je
×
2717
          slb(il) = safe_sqrt(1.0-bmag(ig)*al(il))
×
2718
          slb0 = slb(je-1)
×
2719
          slb1 = 0.
×
2720
          slb2 = -slb0                                                        
×
2721

2722
          slbl = (slb1 + slb0)/2.0
×
2723

2724
          fdf(ig,il) = (1.0 - slbl*slbl)/slb0/slb0
×
2725
          fdb(ig,il) = fdf(ig,il)
×
2726

2727
          slb(je+1:2*je-1) = -slb(je-1:1:-1)
×
2728
       end if
2729

2730
! compute coefficients (dlcoef) multipyling first derivative of h
2731
       do il=3,ng2
×
2732
          do ip=il-2,il+2
×
2733
             if (il == ip) then
×
2734
                dlcoef(ig,il,ip-il+3) = 0.0
×
2735
                do ij=il-2,il+2
×
2736
                   if (ij /= ip) dlcoef(ig,il,ip-il+3) = dlcoef(ig,il,ip-il+3) + 1/(slb(il)-slb(ij))
×
2737
                end do
2738
             else
2739
                do ij=il-2,il+2
×
2740
                   if (ij /= ip .and. ij /= il) then
×
2741
                      dlcoef(ig,il,ip-il+3) = dlcoef(ig,il,ip-il+3)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2742
                   end if
2743
                end do
2744
                dlcoef(ig,il,ip-il+3) = dlcoef(ig,il,ip-il+3)/(slb(ip)-slb(il))
×
2745
             end if
2746
             dlcoef(ig,il,ip-il+3) = -2.0*slb(il)*dlcoef(ig,il,ip-il+3)
×
2747
          end do
2748
       end do
2749

2750
       il = 1
×
2751
       do ip=il,il+2
×
2752
          if (il == ip) then
×
2753
             dlcoef(ig,il,ip) = 0.0
×
2754
             do ij=il,il+2
×
2755
                if (ij /= ip) dlcoef(ig,il,ip) = dlcoef(ig,il,ip) + 1./(slb(il)-slb(ij))
×
2756
             end do
2757
          else
2758
             do ij=il,il+2
×
2759
                if (ij /= ip .and. ij /= il) then
×
2760
                   dlcoef(ig,il,ip) = dlcoef(ig,il,ip)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2761
                end if
2762
             end do
2763
             dlcoef(ig,il,ip) = dlcoef(ig,il,ip)/(slb(ip)-slb(il))
×
2764
          end if
2765
          dlcoef(ig,il,ip) = -2.0*slb(il)*dlcoef(ig,il,ip)
×
2766
       end do
2767

2768
       il = 2
×
2769
       do ip=il-1,il+1
×
2770
          if (il == ip) then
×
2771
             dlcoef(ig,il,ip-il+2) = 0.0
×
2772
             do ij=il-1,il+1
×
2773
                if (ij /= ip) dlcoef(ig,il,ip-il+2) = dlcoef(ig,il,ip-il+2) + 1/(slb(il)-slb(ij))
×
2774
             end do
2775
          else
2776
             do ij=il-1,il+1
×
2777
                if (ij /= ip .and. ij /= il) then
×
2778
                   dlcoef(ig,il,ip-il+2) = dlcoef(ig,il,ip-il+2)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2779
                end if
2780
             end do
2781
             dlcoef(ig,il,ip-il+2) = dlcoef(ig,il,ip-il+2)/(slb(ip)-slb(il))
×
2782
          end if
2783
          dlcoef(ig,il,ip-il+2) = -2.0*slb(il)*dlcoef(ig,il,ip-il+2)
×
2784
       end do
2785

2786
       dprod = 2.0
×
2787

2788
! compute coefficients (d2lcoef) multiplying second derivative of h
2789
       do il=3,ng2
×
2790
          do ip=il-2,il+2
×
2791
             if (il == ip) then
×
2792
                do ij=il-2,il+2
×
2793
                   if (ij /= ip) then
×
2794
                      do im=il-2,il+2
×
2795
                         if (im /= ip .and. im /= ij) d2lcoef(ig,il,ip-il+3) = &
×
2796
                              d2lcoef(ig,il,ip-il+3) + 1./((slb(il)-slb(im))*(slb(il)-slb(ij)))
×
2797
                      end do
2798
                   end if
2799
                end do
2800
             else
2801
                do ij=il-2,il+2
×
2802
                   if (ij /= il .and. ij /= ip) then
×
2803
                      dprod(il,ip-il+3) = dprod(il,ip-il+3)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2804
                   end if
2805
                end do
2806

2807
                do ij=il-2,il+2
×
2808
                   if (ij /= ip .and. ij /= il) then
×
2809
                      d2lcoef(ig,il,ip-il+3) = d2lcoef(ig,il,ip-il+3) + 1./(slb(il)-slb(ij))
×
2810
                   end if
2811
                end do
2812
                d2lcoef(ig,il,ip-il+3) = dprod(il,ip-il+3) &
×
2813
                     *d2lcoef(ig,il,ip-il+3)/(slb(ip)-slb(il))
×
2814
             end if
2815
             d2lcoef(ig,il,ip-il+3) = (1.0-slb(il)**2)*d2lcoef(ig,il,ip-il+3)
×
2816
          end do
2817
       end do
2818

2819
       il = 1
×
2820
       do ip=il,il+2
×
2821
          if (il == ip) then
×
2822
             do ij=il,il+2
×
2823
                if (ij /= ip) then
×
2824
                   do im=il,il+2
×
2825
                      if (im /= ip .and. im /= ij) d2lcoef(ig,il,ip) = d2lcoef(ig,il,ip) + 1./((slb(il)-slb(im))*(slb(il)-slb(ij)))
×
2826
                   end do
2827
                end if
2828
             end do
2829
          else
2830
             do ij=il,il+2
×
2831
                if (ij /= il .and. ij /= ip) then
×
2832
                   dprod(il,ip) = dprod(il,ip)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2833
                end if
2834
             end do
2835

2836
             do ij=il,il+2
×
2837
                if (ij /= ip .and. ij /= il) then
×
2838
                   d2lcoef(ig,il,ip) = d2lcoef(ig,il,ip) + 1./(slb(il)-slb(ij))
×
2839
                end if
2840
             end do
2841
             d2lcoef(ig,il,ip) = dprod(il,ip)*d2lcoef(ig,il,ip)/(slb(ip)-slb(il))
×
2842
          end if
2843
          d2lcoef(ig,il,ip) = (1.0-slb(il)**2)*d2lcoef(ig,il,ip)
×
2844
       end do
2845

2846
       il = 2
×
2847
       do ip=il-1,il+1
×
2848
          if (il == ip) then
×
2849
             do ij=il-1,il+1
×
2850
                if (ij /= ip) then
×
2851
                   do im=il-1,il+1
×
2852
                      if (im /= ip .and. im /= ij) d2lcoef(ig,il,ip-il+2) &
×
2853
                           = d2lcoef(ig,il,ip-il+2) + 1./((slb(il)-slb(im))*(slb(il)-slb(ij)))
×
2854
                   end do
2855
                end if
2856
             end do
2857
          else
2858
             do ij=il-1,il+1
×
2859
                if (ij /= il .and. ij /= ip) then
×
2860
                   dprod(il,ip-il+2) = dprod(il,ip-il+2)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2861
                end if
2862
             end do
2863

2864
             do ij=il-1,il+1
×
2865
                if (ij /= ip .and. ij /= il) then
×
2866
                   d2lcoef(ig,il,ip-il+2) = d2lcoef(ig,il,ip-il+2) + 1./(slb(il)-slb(ij))
×
2867
                end if
2868
             end do
2869
             d2lcoef(ig,il,ip-il+2) = dprod(il,ip-il+2)*d2lcoef(ig,il,ip-il+2)/(slb(ip)-slb(il))
×
2870
          end if
2871
          d2lcoef(ig,il,ip-il+2) = (1.0-slb(il)**2)*d2lcoef(ig,il,ip-il+2)
×
2872
       end do
2873
       
2874
       if (il_is_trapped(je)) then      ! have to handle trapped particles
×
2875

2876
          do il=ng2+1,je
×
2877
             do ip=il-2,il+2
×
2878
                if (il == ip) then
×
2879
                   dlcoef(ig,il,ip-il+3) = 0.0
×
2880
                   do ij=il-2,il+2
×
2881
                      if (ij /= ip) dlcoef(ig,il,ip-il+3) = dlcoef(ig,il,ip-il+3) + 1/(slb(il)-slb(ij))
×
2882
                   end do
2883
                else
2884
                   do ij=il-2,il+2
×
2885
                      if (ij /= ip .and. ij /= il) then
×
2886
                         dlcoef(ig,il,ip-il+3) = dlcoef(ig,il,ip-il+3)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2887
                      end if
2888
                   end do
2889
                   dlcoef(ig,il,ip-il+3) = dlcoef(ig,il,ip-il+3)/(slb(ip)-slb(il))
×
2890
                end if
2891
                dlcoef(ig,il,ip-il+3) = -2.0*slb(il)*dlcoef(ig,il,ip-il+3)
×
2892
             end do
2893
          end do
2894

2895
          do il=ng2+1,je
×
2896
             do ip=il-2,il+2
×
2897
                if (il == ip) then
×
2898
                   do ij=il-2,il+2
×
2899
                      if (ij /= ip) then
×
2900
                         do im=il-2,il+2
×
2901
                            if (im /= ip .and. im /= ij) d2lcoef(ig,il,ip-il+3) = &
×
2902
                                 d2lcoef(ig,il,ip-il+3) + 1./((slb(il)-slb(im))*(slb(il)-slb(ij)))
×
2903
                         end do
2904
                      end if
2905
                   end do
2906
                else
2907
                   do ij=il-2,il+2
×
2908
                      if (ij /= il .and. ij /= ip) then
×
2909
                         dprod(il,ip-il+3) = dprod(il,ip-il+3)*(slb(il)-slb(ij))/(slb(ip)-slb(ij))
×
2910
                      end if
2911
                   end do
2912
                   
2913
                   do ij=il-2,il+2
×
2914
                      if (ij /= ip .and. ij /= il) then
×
2915
                         d2lcoef(ig,il,ip-il+3) = d2lcoef(ig,il,ip-il+3) + 1./(slb(il)-slb(ij))
×
2916
                      end if
2917
                   end do
2918
                   d2lcoef(ig,il,ip-il+3) = dprod(il,ip-il+3) &
×
2919
                        *d2lcoef(ig,il,ip-il+3)/(slb(ip)-slb(il))
×
2920
                end if
2921
                d2lcoef(ig,il,ip-il+3) = (1.0-slb(il)**2)*d2lcoef(ig,il,ip-il+3)
×
2922
             end do
2923
          end do
2924
          
2925
       end if
2926
    end do
2927

2928
    dtot = dlcoef + d2lcoef
×
2929

2930
    deallocate (slb, dprod, dlcoef, d2lcoef)
×
2931
  end subroutine init_lorentz_error
×
2932

2933
  !> FIXME : Add documentation  
2934
  subroutine solfp1_standard_layout (g, g1, gc1, gc2, diagnostics, gtoc, ctog)
×
2935
    use gs2_layouts, only: g_lo, it_idx, ik_idx, ie_idx, is_idx
2936
    use theta_grid, only: ntgrid
2937
    use run_parameters, only: beta
2938
    use gs2_time, only: code_dt
2939
    use le_grids, only: energy => energy_maxw
2940
    use species, only: spec, is_electron_species
2941
    use dist_fn_arrays, only: vpa, aj0
2942
    use fields_arrays, only: aparnew
2943
    use run_parameters, only: ieqzip
2944
    use kt_grids, only: kwork_filter, kperp2
2945
    use optionals, only: get_option_with_default
2946
    implicit none
2947

2948
    complex, dimension (-ntgrid:,:,g_lo%llim_proc:), intent (in out) :: g, g1, gc1, gc2
2949
    integer, optional, intent (in) :: diagnostics
2950
    logical, optional, intent (in) :: gtoc, ctog
2951
    integer :: isgn, it, ik, ie, is, iglo
2952
!CMR, 12/9/2013: 
2953
!CMR   New logical optional input parameters gtoc, ctog used to set
2954
!CMR   flags (g_to_c and c_to_g) to control whether redistributes required
2955
!CMR   to map g_lo to collision_lo, and collision_lo to g_lo.
2956
!CMR   All redistributes are performed by default.
2957
!CMR  
2958
    logical :: g_to_c, c_to_g
2959

2960
    g_to_c = get_option_with_default(gtoc, .true.)
×
2961
    c_to_g = get_option_with_default(ctog, .true.)
×
2962

2963
    if (has_diffuse) then
×
2964
       call solfp_ediffuse_standard_layout (g)
×
2965
       if (conserve_moments) call conserve_diffuse (g, g1)
×
2966
    end if
2967

2968
    if (has_lorentz) then
×
2969
       if (drag) then
×
2970
          !$OMP PARALLEL DO DEFAULT(none) &
2971
          !$OMP PRIVATE(iglo, is, it, ik, ie, isgn) &
2972
          !$OMP SHARED(g_lo, spec, kwork_filter, g, ieqzip, vnmult, code_dt, vpa, &
2973
          !$OMP kperp2, aparnew, aj0, beta, energy) &
2974
          !$OMP SCHEDULE(static)
2975
          do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
2976
             is = is_idx(g_lo,iglo)
×
2977
             if (.not. is_electron_species(spec(is))) cycle
×
2978
             it = it_idx(g_lo,iglo)
×
2979
             ik = ik_idx(g_lo,iglo)
×
2980
             if(kwork_filter(it,ik)) cycle
×
2981
             if(ieqzip(it,ik)) cycle
×
2982
             ie = ie_idx(g_lo,iglo)
×
2983
             do isgn = 1, 2
×
2984
                g(:, isgn, iglo) = g(:, isgn, iglo) + vnmult(1)*spec(is)%vnewk*code_dt &
×
2985
                     * vpa(:,isgn,iglo)*kperp2(:,it,ik)*aparnew(:,it,ik)*aj0(:,iglo) &
×
2986
                     / ((-spec(is)%z*spec(is)%dens)*beta*spec(is)%stm*energy(ie)**1.5)
×
2987
                ! probably need 1/(spec(is_ion)%z*spec(is_ion)%dens) above
2988
                ! This has been implemented as 1/-spec(electron)%z*spec(electron)%dens
2989
                ! in an attempt handle the multi-ion species case.
2990
             end do
2991
          end do
2992
          !$OMP END PARALLEL DO
2993
       end if
2994

2995
       call solfp_lorentz (g, gc1, gc2, diagnostics)
×
2996
       if (conserve_moments) call conserve_lorentz (g, g1)
×
2997
    end if
2998
  end subroutine solfp1_standard_layout
×
2999

3000
  !> FIXME : Add documentation  
3001
  subroutine solfp1_le_layout (gle, diagnostics)
×
3002
    use gs2_layouts, only: le_lo, it_idx, ik_idx, ig_idx, is_idx
3003
    use run_parameters, only: beta, ieqzip
3004
    use gs2_time, only: code_dt
3005
    use le_grids, only: energy => energy_maxw, negrid
3006
    use species, only: spec, is_electron_species
3007
    use fields_arrays, only: aparnew
3008
    use kt_grids, only: kwork_filter, kperp2
3009
    implicit none
3010

3011
    complex, dimension (:,:,le_lo%llim_proc:), intent (in out) :: gle
3012
    integer, optional, intent (in) :: diagnostics
3013
    complex :: tmp
3014
    integer :: ig, it, ik, ie, is, ile, ixi
3015

3016
    if (has_diffuse) then
×
3017
       call solfp_ediffuse_le_layout (gle)
×
3018
       if (conserve_moments) call conserve_diffuse (gle)
×
3019
    end if
3020

3021
    if (has_lorentz) then
×
3022
       if (drag) then
×
3023
          !$OMP PARALLEL DO DEFAULT(none) &
3024
          !$OMP PRIVATE(ile, is, it, ik, ie, ig, ixi, tmp) &
3025
          !$OMP SHARED(le_lo, spec, kwork_filter, negrid, ieqzip, vnmult, code_dt, kperp2, &
3026
          !$OMP aparnew, beta, energy, nxi_lim, gle, vpa_aj0_le) &
3027
          !$OMP SCHEDULE(static)
3028
          do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3029
             is = is_idx(le_lo,ile)
×
3030
             if (.not. is_electron_species(spec(is))) cycle
×
3031
             it = it_idx(le_lo,ile)
×
3032
             ik = ik_idx(le_lo,ile)
×
3033
             if(kwork_filter(it,ik)) cycle
×
3034
             if(ieqzip(it,ik)) cycle
×
3035
             ig = ig_idx(le_lo,ile)
×
3036
             do ie = 1, negrid
×
3037
                ! Note here we may need aparnew from {it, ik} not owned by this
3038
                ! processor in g_lo.
3039
                tmp = vnmult(1)*spec(is)%vnewk*code_dt &
×
3040
                     * kperp2(ig,it,ik)*aparnew(ig,it,ik) &
×
3041
                     / ((-spec(is)%z*spec(is)%dens)*beta*spec(is)%stm*energy(ie)**1.5)
×
3042
                do ixi = 1, nxi_lim
×
3043
                   gle(ixi, ie, ile) = gle(ixi, ie, ile) + tmp * vpa_aj0_le(ixi, ie, ile)
×
3044
                ! probably need 1/(spec(is_ion)%z*spec(is_ion)%dens) above
3045
                ! This has been implemented as 1/-spec(electron)%z*spec(electron)%dens
3046
                ! in an attempt handle the multi-ion species case.
3047
                end do
3048
             end do
3049
          end do
3050
          !$OMP END PARALLEL DO
3051
       end if
3052

3053
       call solfp_lorentz (gle, diagnostics)
×
3054
       if (conserve_moments) call conserve_lorentz (gle)
×
3055
    end if
3056
  end subroutine solfp1_le_layout
×
3057

3058
  !> FIXME : Add documentation
3059
  subroutine conserve_lorentz_standard_layout (g, g1)
×
3060
    use theta_grid, only: ntgrid
3061
    use species, only: nspec
3062
    use kt_grids, only: naky, ntheta0, kwork_filter
3063
    use gs2_layouts, only: g_lo, ik_idx, it_idx, ie_idx, il_idx, is_idx
3064
    use le_grids, only: energy => energy_maxw, speed => speed_maxw, al, &
3065
         integrate_moment, negrid
3066
    use dist_fn_arrays, only: aj0, aj1, vpa
3067
    use run_parameters, only: ieqzip
3068
    use array_utils, only: copy
3069
    implicit none
3070
    complex, dimension (-ntgrid:,:,g_lo%llim_proc:), intent (in out) :: g, g1
3071
    complex, dimension (:,:,:), allocatable :: gtmp
×
3072
    real, dimension (:,:,:), allocatable :: vns
×
3073
    complex, dimension (:,:,:,:), allocatable :: v0y0, v1y1, v2y2
×
3074
    integer :: isgn, iglo, ik, ie, il, is, it
3075
    logical, parameter :: all_procs = .true.
3076

3077
    allocate (v0y0(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
3078
    allocate (v1y1(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
3079
    allocate (v2y2(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
3080

3081
    allocate (gtmp(-ntgrid:ntgrid,2,g_lo%llim_proc:g_lo%ulim_alloc))
×
3082
    allocate (vns(naky,negrid,nspec))
×
3083
    vns = vnmult(1) * vnew_D
×
3084

3085
    if (drag) then
×
3086

3087
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3088
! First get v0y0
3089
       !$OMP PARALLEL DO DEFAULT(none) &
3090
       !$OMP PRIVATE(iglo, it, ik, isgn) &
3091
       !$OMP SHARED(g_lo, kwork_filter, gtmp, vpa, aj0, g) &
3092
       !$OMP SCHEDULE(static)
3093
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3094
          it = it_idx(g_lo,iglo)
×
3095
          ik = ik_idx(g_lo,iglo)
×
3096
          if(kwork_filter(it,ik))cycle
×
3097
          do isgn = 1, 2
×
3098
             ! v0 = vpa J0 f0, y0 = g
3099
             gtmp(:, isgn, iglo) = vpa(:, isgn, iglo) * aj0(:, iglo) * g(:, isgn, iglo)
×
3100
          end do
3101
       end do
3102
       !$OMP END PARALLEL DO
3103
       call integrate_moment (gtmp, v0y0, all_procs)    ! v0y0
×
3104

3105
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3106
! Get y1 = y0 - v0y0 * z0 / (1 + v0z0)
3107
       !$OMP PARALLEL DO DEFAULT(none) &
3108
       !$OMP PRIVATE(iglo, it, ik, is, isgn) &
3109
       !$OMP SHARED(g_lo, kwork_filter, g1, g, ieqzip, v0y0, z0) &
3110
       !$OMP SCHEDULE(static)
3111
       do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3112
          it = it_idx(g_lo,iglo)
×
3113
          ik = ik_idx(g_lo,iglo)
×
3114
          if(kwork_filter(it,ik)) cycle
×
3115
          if(ieqzip(it,ik)) cycle
×
3116
          is = is_idx(g_lo,iglo)
×
3117
          do isgn = 1, 2
×
3118
             g1(:, isgn, iglo) = g(:, isgn, iglo) - v0y0(:, it, ik, is) * z0(:, isgn, iglo)
×
3119
          end do
3120
       end do
3121
       !$OMP END PARALLEL DO
3122
    else
3123
       call copy(g, g1)
×
3124
    end if
3125

3126
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3127
! Now get v1y1
3128

3129
    !$OMP PARALLEL DO DEFAULT(none) &
3130
    !$OMP PRIVATE(iglo, it, ik, il, ie, is, isgn) &
3131
    !$OMP SHARED(g_lo, kwork_filter, conservative, gtmp, vns, speed, vpdiff, aj0, g1, vpa) &
3132
    !$OMP SCHEDULE(static)
3133
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3134
       ik = ik_idx(g_lo,iglo)
×
3135
       it = it_idx(g_lo,iglo)
×
3136
       if(kwork_filter(it,ik))cycle
×
3137
       ie = ie_idx(g_lo,iglo)
×
3138
       is = is_idx(g_lo,iglo)
×
3139
       do isgn = 1, 2
×
3140
          ! v1 = nud vpa J0 f0, y1 = g1
3141
          if (conservative) then
×
3142
             il = il_idx(g_lo,iglo)
×
3143
             gtmp(:, isgn, iglo) = vns(ik, ie, is) * speed(ie) * vpdiff(:, isgn, il) &
×
3144
                  * aj0(:, iglo) * g1(:, isgn, iglo)
×
3145
          else
3146
             gtmp(:, isgn, iglo) = vns(ik, ie, is) * vpa(:, isgn, iglo) * aj0(:, iglo) &
×
3147
                  * g1(:, isgn, iglo)
×
3148
          end if
3149
       end do
3150
    end do
3151
    !$OMP END PARALLEL DO
3152

3153
    call integrate_moment (gtmp, v1y1, all_procs)    ! v1y1
×
3154

3155
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3156
! Get y2 = y1 - v1y1 * s1 / (1 + v1s1)
3157

3158
    !$OMP PARALLEL DO DEFAULT(none) &
3159
    !$OMP PRIVATE(iglo, it, ik, is, isgn) &
3160
    !$OMP SHARED(g_lo, kwork_filter, g1, ieqzip, v1y1, s0) &
3161
    !$OMP SCHEDULE(static)
3162
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3163
       it = it_idx(g_lo,iglo)
×
3164
       ik = ik_idx(g_lo,iglo)
×
3165
       if(kwork_filter(it,ik)) cycle
×
3166
       if(ieqzip(it,ik)) cycle
×
3167
       is = is_idx(g_lo,iglo)
×
3168
       do isgn = 1, 2
×
3169
          g1(:, isgn, iglo) = g1(:, isgn, iglo) - v1y1(:, it, ik, is) * s0(:, isgn, iglo)
×
3170
       end do
3171
    end do
3172
    !$OMP END PARALLEL DO
3173

3174
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3175
! Now get v2y2
3176

3177
    !$OMP PARALLEL DO DEFAULT(none) &
3178
    !$OMP PRIVATE(iglo, it, ik, ie, il, is, isgn) &
3179
    !$OMP SHARED(g_lo, kwork_filter, gtmp, vns, energy, al, aj1, g1) &
3180
    !$OMP SCHEDULE(static)
3181
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3182
       it = it_idx(g_lo,iglo)
×
3183
       ik = ik_idx(g_lo,iglo)
×
3184
       if(kwork_filter(it,ik))cycle
×
3185
       ie = ie_idx(g_lo,iglo)
×
3186
       il = il_idx(g_lo,iglo)
×
3187
       is = is_idx(g_lo,iglo)
×
3188
       do isgn = 1, 2
×
3189
          ! v2 = nud vperp J1 f0
3190
          gtmp(:, isgn, iglo) = vns(ik, ie, is) * energy(ie) * al(il) * aj1(:, iglo) &
×
3191
               * g1(:, isgn, iglo)
×
3192
       end do
3193
    end do
3194
    !$OMP END PARALLEL DO
3195

3196
    call integrate_moment (gtmp, v2y2, all_procs)    ! v2y2
×
3197

3198
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3199
! Finally get x = y2 - v2y2 * w2 / (1 + v2w2)
3200

3201
    !$OMP PARALLEL DO DEFAULT(none) &
3202
    !$OMP PRIVATE(iglo, it, ik, is, isgn) &
3203
    !$OMP SHARED(g_lo, kwork_filter, g, g1, ieqzip, v2y2, w0) &
3204
    !$OMP SCHEDULE(static)
3205
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3206
       it = it_idx(g_lo,iglo)
×
3207
       ik = ik_idx(g_lo,iglo)
×
3208
       if(kwork_filter(it,ik)) cycle
×
3209
       if(ieqzip(it,ik)) cycle
×
3210
       is = is_idx(g_lo,iglo)
×
3211
       do isgn = 1, 2
×
3212
          g(:, isgn, iglo) = g1(:, isgn, iglo) - v2y2(:, it, ik, is) * w0(:, isgn, iglo)
×
3213
       end do
3214
    end do
3215
    !$OMP END PARALLEL DO
3216

3217
    deallocate (vns, v0y0, v1y1, v2y2, gtmp)
×
3218

3219
  end subroutine conserve_lorentz_standard_layout
×
3220

3221
  !> FIXME : Add documentation
3222
  subroutine conserve_lorentz_le_layout (gle)
×
3223
    use gs2_layouts, only: ik_idx, it_idx, ie_idx, il_idx, is_idx, ig_idx, le_lo
3224
    use le_grids, only: speed => speed_maxw, w, wxi, negrid
3225
    use run_parameters, only: ieqzip
3226
    use kt_grids, only: kwork_filter
3227
    implicit none
3228
    complex, dimension (:,:,le_lo%llim_proc:), intent (in out) :: gle
3229
    complex :: v0y0, v1y1, v2y2
3230
    real :: nud
3231
    integer :: ig, ik, ie, is, it, ile, ixi
3232

3233
    if (drag) then
×
3234
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3235
       ! First get v0y0 and y1 = y0 - v0y0 * z0 / (1 + v0z0)
3236

3237
       ! v0 = vpa J0 f0, y0 = gle
3238
       !$OMP PARALLEL DO DEFAULT(none) &
3239
       !$OMP PRIVATE(ile, it, ik, ixi, ie, is, ig, v0y0) &
3240
       !$OMP SHARED(le_lo, kwork_filter, ieqzip, negrid, nxi_lim, &
3241
       !$OMP z0le, w, wxi, vpa_aj0_le, gle) &
3242
       !$OMP SCHEDULE(static)
3243
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3244
          it = it_idx(le_lo,ile)
×
3245
          ik = ik_idx(le_lo,ile)
×
3246
          if (kwork_filter(it, ik)) cycle
×
3247
          if (ieqzip(it, ik)) cycle
×
3248
          is = is_idx(le_lo, ile)
×
3249
          ig = ig_idx(le_lo, ile)
×
3250
          v0y0 = 0.0
×
3251
          do ie = 1, negrid
×
3252
             do ixi = 1, nxi_lim
×
3253
                ! Should we use vpdiff here if conservative?
3254
                v0y0 = v0y0 + vpa_aj0_le(ixi, ie, ile) * gle(ixi, ie, ile) * w(ie, is) * wxi(ixi, ig)
×
3255
             end do
3256
          end do
3257
          gle(:, :, ile) = gle(:, :, ile) - z0le(:, :, ile) * v0y0
×
3258
       end do
3259
       !$OMP END PARALLEL DO
3260
    end if
3261

3262
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3263
! Now get v1y1 and y2 = y1 - v1y1 * s1 / (1 + v1s1)
3264

3265
    ! v1 = nud vpa J0 f0, y1 = gle
3266
    if (conservative) then
×
3267
       !$OMP PARALLEL DO DEFAULT(none) &
3268
       !$OMP PRIVATE(ile, is, it, ik, ig, ixi, ie, nud, v1y1) &
3269
       !$OMP SHARED(le_lo, kwork_filter, ieqzip, negrid, nxi_lim, vpdiffle, &
3270
       !$OMP speed, vnmult, vnew_D, aj0le, gle, s0le, w, wxi) &
3271
       !$OMP SCHEDULE(static)
3272
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3273
          ik = ik_idx(le_lo,ile)
×
3274
          it = it_idx(le_lo,ile)
×
3275
          if (kwork_filter(it, ik)) cycle
×
3276
          if (ieqzip(it, ik)) cycle
×
3277
          is = is_idx(le_lo,ile)
×
3278
          ig = ig_idx(le_lo,ile)
×
3279
          v1y1 = 0.0
×
3280
          do ie = 1, negrid
×
3281
             nud = speed(ie) * vnmult(1) * vnew_D(ik, ie, is) * w(ie, is)
×
3282
             do ixi = 1, nxi_lim
×
3283
                v1y1 = v1y1 + vpdiffle(ixi, ig) * nud * aj0le(ixi, ie, ile) * &
×
3284
                     gle(ixi, ie, ile) * wxi(ixi, ig)
×
3285
             end do
3286
          end do
3287
          gle(:, :, ile) = gle(:, :, ile) - s0le(:, :, ile) * v1y1
×
3288
       end do
3289
       !$OMP END PARALLEL DO
3290
    else
3291
       !$OMP PARALLEL DO DEFAULT(none) &
3292
       !$OMP PRIVATE(ile, is, it, ik, ig, ixi, ie, nud, v1y1) &
3293
       !$OMP SHARED(le_lo, kwork_filter, ieqzip, negrid, nxi_lim, vpa_aj0_le, vnmult, &
3294
       !$OMP vnew_D, gle, w, wxi, s0le) &
3295
       !$OMP SCHEDULE(static)
3296
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3297
          ik = ik_idx(le_lo, ile)
×
3298
          it = it_idx(le_lo, ile)
×
3299
          if (kwork_filter(it, ik)) cycle
×
3300
          if (ieqzip(it, ik)) cycle
×
3301
          is = is_idx(le_lo, ile)
×
3302
          ig = ig_idx(le_lo, ile)
×
3303
          v1y1 = 0.0
×
3304
          do ie = 1, negrid
×
3305
             nud =  vnmult(1) * vnew_D(ik, ie, is) * w(ie, is)
×
3306
             do ixi = 1, nxi_lim
×
3307
                v1y1 = v1y1 + nud * vpa_aj0_le(ixi, ie, ile) * &
×
3308
                     gle(ixi, ie, ile) * wxi(ixi, ig)
×
3309
             end do
3310
          end do
3311
          gle(:, :, ile) = gle(:, :, ile) - s0le(:, :, ile) * v1y1
×
3312
       end do
3313
       !$OMP END PARALLEL DO
3314
    end if
3315

3316
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3317
    ! Now get v2y2 and x = y2 - v2y2 * w2 / (1 + v2w2)
3318

3319
    !$OMP PARALLEL DO DEFAULT(none) &
3320
    !$OMP PRIVATE(ile, it, ik, is, ie, ig, ixi, nud, v2y2) &
3321
    !$OMP SHARED(le_lo, kwork_filter, ieqzip, negrid, nxi_lim, &
3322
    !$OMP vnmult, vnew_D, vperp_aj1le, gle, w, wxi, w0le) &
3323
    !$OMP SCHEDULE(static)
3324
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3325
       it = it_idx(le_lo, ile)
×
3326
       ik = ik_idx(le_lo, ile)
×
3327
       if (kwork_filter(it, ik)) cycle
×
3328
       if (ieqzip(it, ik)) cycle
×
3329
       is = is_idx(le_lo, ile)
×
3330
       ig = ig_idx(le_lo, ile)
×
3331
       v2y2 = 0.0
×
3332
       do ie = 1, negrid
×
3333
          nud = vnmult(1) * vnew_D(ik, ie, is) * w(ie, is)
×
3334
          do ixi = 1, nxi_lim
×
3335
             ! aj1vp2 = 2 * J1(arg)/arg * vperp^2
3336
             v2y2 = v2y2 + nud * vperp_aj1le(ixi, ie, ile) * gle(ixi, ie, ile) * wxi(ixi, ig)
×
3337
          end do
3338
       end do
3339
       gle(:, :, ile) = gle(:, :, ile) - w0le(:, :, ile) * v2y2
×
3340
    end do
3341
    !$OMP END PARALLEL DO
3342
  end subroutine conserve_lorentz_le_layout
×
3343

3344
  !> FIXME : Add documentation
3345
  subroutine conserve_diffuse_standard_layout (g, g1)
×
3346
    use theta_grid, only: ntgrid
3347
    use species, only: nspec
3348
    use kt_grids, only: naky, ntheta0, kwork_filter
3349
    use gs2_layouts, only: g_lo, ik_idx, it_idx, ie_idx, il_idx, is_idx
3350
    use le_grids, only: energy => energy_maxw, al, integrate_moment, negrid
3351
    use dist_fn_arrays, only: aj0, aj1, vpa
3352
    use run_parameters, only: ieqzip
3353
    use array_utils, only: zero_array
3354
    implicit none
3355
    complex, dimension (-ntgrid:,:,g_lo%llim_proc:), intent (in out) :: g, g1
3356
    complex, dimension (:,:,:), allocatable :: gtmp
×
3357
    real, dimension (:,:,:), allocatable :: vns
×
3358
    integer :: isgn, iglo, ik, ie, il, is, it 
3359
    complex, dimension (:,:,:,:), allocatable :: v0y0, v1y1, v2y2    
×
3360
    logical, parameter :: all_procs = .true.
3361

3362
    allocate (v0y0(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
3363
    allocate (v1y1(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
3364
    allocate (v2y2(-ntgrid:ntgrid, ntheta0, naky, nspec))
×
3365

3366
    allocate (vns(naky, negrid, nspec))
×
3367
    allocate (gtmp(-ntgrid:ntgrid, 2, g_lo%llim_proc:g_lo%ulim_alloc))
×
3368

3369
    vns = vnmult(2)*delvnew
×
3370

3371
    !This is needed to to ensure the it,ik values we don't set aren't included
3372
    !in the integral (can also be enforced in integrate_moment routine)
3373
    if(any(kwork_filter)) call zero_array(gtmp)
×
3374

3375
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3376
! First get v0y0
3377

3378
    !$OMP PARALLEL DO DEFAULT(none) &
3379
    !$OMP PRIVATE(iglo, it, ik, ie, is, isgn) &
3380
    !$OMP SHARED(g_lo, kwork_filter, gtmp, vnmult, vnew_E, aj0, g) &
3381
    !$OMP SCHEDULE(static)
3382
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3383
       ik = ik_idx(g_lo,iglo)
×
3384
       it = it_idx(g_lo,iglo)
×
3385
       if(kwork_filter(it,ik))cycle
×
3386
       ie = ie_idx(g_lo,iglo)
×
3387
       is = is_idx(g_lo,iglo)
×
3388
       do isgn = 1, 2
×
3389
          ! v0 = nu_E E J0 f0
3390
          gtmp(:, isgn, iglo) = vnmult(2) * vnew_E(ik, ie, is) * aj0(:, iglo) &
×
3391
               * g(:, isgn, iglo)
×
3392
       end do
3393
    end do
3394
    !$OMP END PARALLEL DO
3395

3396
    call integrate_moment (gtmp, v0y0, all_procs)    ! v0y0
×
3397

3398
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3399
! Get y1 = y0 - v0y0 * z0 / (1 + v0z0)
3400

3401
    !$OMP PARALLEL DO DEFAULT(none) &
3402
    !$OMP PRIVATE(iglo, it, ik, is, isgn) &
3403
    !$OMP SHARED(g_lo, kwork_filter, g1, g, ieqzip, v0y0, bz0) &
3404
    !$OMP SCHEDULE(static)
3405
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3406
       it = it_idx(g_lo,iglo)
×
3407
       ik = ik_idx(g_lo,iglo)
×
3408
       if(kwork_filter(it,ik)) cycle
×
3409
       if(ieqzip(it,ik)) cycle
×
3410
       is = is_idx(g_lo,iglo)
×
3411
       do isgn = 1, 2
×
3412
          g1(:, isgn, iglo) = g(:, isgn, iglo) - v0y0(:, it, ik, is) * bz0(:, isgn, iglo)
×
3413
       end do
3414
    end do
3415
    !$OMP END PARALLEL DO
3416

3417
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3418
! Now get v1y1
3419

3420
    !$OMP PARALLEL DO DEFAULT(none) &
3421
    !$OMP PRIVATE(iglo, it, ik, ie, is, isgn) &
3422
    !$OMP SHARED(g_lo, kwork_filter, gtmp, vns, vpa, aj0, g1) &
3423
    !$OMP SCHEDULE(static)
3424
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3425
       ik = ik_idx(g_lo,iglo)
×
3426
       it = it_idx(g_lo,iglo)
×
3427
       if(kwork_filter(it,ik))cycle
×
3428
       ie = ie_idx(g_lo,iglo)
×
3429
       is = is_idx(g_lo,iglo)
×
3430
       do isgn = 1, 2
×
3431
          ! v1 = (nus-nud) vpa J0 f0
3432
          gtmp(:, isgn, iglo) = vns(ik, ie, is) * vpa(:, isgn, iglo) * aj0(:, iglo) &
×
3433
               * g1(:, isgn, iglo)
×
3434
       end do
3435
    end do
3436
    !$OMP END PARALLEL DO
3437

3438
    call integrate_moment (gtmp, v1y1, all_procs)    ! v1y1
×
3439

3440
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3441
! Get y2 = y1 - v1y1 * s1 / (1 + v1s1)
3442

3443
    !$OMP PARALLEL DO DEFAULT(none) &
3444
    !$OMP PRIVATE(iglo, it, ik, is, isgn) &
3445
    !$OMP SHARED(g_lo, kwork_filter, g1, ieqzip, v1y1, bs0) &
3446
    !$OMP SCHEDULE(static)
3447
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3448
       it = it_idx(g_lo,iglo)
×
3449
       ik = ik_idx(g_lo,iglo)
×
3450
       if(kwork_filter(it,ik)) cycle
×
3451
       if(ieqzip(it,ik)) cycle
×
3452
       is = is_idx(g_lo,iglo)
×
3453
       do isgn = 1, 2
×
3454
          g1(:, isgn, iglo) = g1(:, isgn, iglo) - v1y1(:, it, ik, is) * bs0(:, isgn, iglo)
×
3455
       end do
3456
    end do
3457
    !$OMP END PARALLEL DO
3458

3459
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3460
! Now get v2y2
3461

3462
    !$OMP PARALLEL DO DEFAULT(none) &
3463
    !$OMP PRIVATE(iglo, it, ik, ie, il, is, isgn) &
3464
    !$OMP SHARED(g_lo, kwork_filter, gtmp, vns, energy, al, aj1, g1) &
3465
    !$OMP SCHEDULE(static)
3466
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3467
       ik = ik_idx(g_lo,iglo)
×
3468
       it = it_idx(g_lo,iglo)
×
3469
       if(kwork_filter(it,ik))cycle
×
3470
       ie = ie_idx(g_lo,iglo)
×
3471
       il = il_idx(g_lo,iglo)
×
3472
       is = is_idx(g_lo,iglo)
×
3473
       do isgn = 1, 2
×
3474
          ! v2 = (nus-nud) vperp J1 f0
3475
          gtmp(:, isgn, iglo) = vns(ik, ie, is) * energy(ie) * al(il) * aj1(:, iglo) &
×
3476
               * g1(:, isgn, iglo)
×
3477
       end do
3478
    end do
3479
    !$OMP END PARALLEL DO
3480

3481
    call integrate_moment (gtmp, v2y2, all_procs)    ! v2y2
×
3482

3483
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3484
! Finally get x = y2 - v2y2 * w2 / (1 + v2w2)
3485

3486
    !$OMP PARALLEL DO DEFAULT(none) &
3487
    !$OMP PRIVATE(iglo, it, ik, is, isgn) &
3488
    !$OMP SHARED(g_lo, kwork_filter, g, g1, ieqzip, v2y2, bw0) &
3489
    !$OMP SCHEDULE(static)
3490
    do iglo = g_lo%llim_proc, g_lo%ulim_proc
×
3491
       it = it_idx(g_lo,iglo)
×
3492
       ik = ik_idx(g_lo,iglo)
×
3493
       if(kwork_filter(it,ik)) cycle
×
3494
       if(ieqzip(it,ik)) cycle
×
3495
       is = is_idx(g_lo,iglo)
×
3496
       do isgn = 1, 2
×
3497
          g(:, isgn, iglo) = g1(:, isgn, iglo) - v2y2(:, it, ik, is) * bw0(:, isgn, iglo)
×
3498
       end do
3499
    end do
3500
    !$OMP END PARALLEL DO
3501

3502
    deallocate (vns, v0y0, v1y1, v2y2, gtmp)
×
3503

3504
  end subroutine conserve_diffuse_standard_layout
×
3505

3506
  !> FIXME : Add documentation
3507
  subroutine conserve_diffuse_le_layout (gle)
×
3508
    use gs2_layouts, only: ik_idx, it_idx, ie_idx, il_idx, is_idx, ig_idx, le_lo
3509
    use le_grids, only: wxi, w, negrid
3510
    use run_parameters, only: ieqzip
3511
    use kt_grids, only: kwork_filter
3512
    implicit none
3513
    complex, dimension (:,:,le_lo%llim_proc:), intent (in out) :: gle
3514
    real :: delnu, vnE
3515
    integer :: ig, ik, ie, is, it, ile, ixi
3516
    complex :: v0y0, v1y1, v2y2
3517

3518
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3519
    ! First get v0y0 and then y1 = y0 - v0y0 * z0 / (1 + v0z0)
3520

3521
    !$OMP PARALLEL DO DEFAULT(none) &
3522
    !$OMP PRIVATE(ile, it, ik, is, ie, ig, ixi, vnE, v0y0) &
3523
    !$OMP SHARED(le_lo, kwork_filter, negrid, nxi_lim, w, wxi, ieqzip, bz0le, vnmult, vnew_E, aj0le, gle) &
3524
    !$OMP SCHEDULE(static)
3525
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3526
       ik = ik_idx(le_lo, ile)
×
3527
       it = it_idx(le_lo, ile)
×
3528
       if (kwork_filter(it, ik)) cycle
×
3529
       if (ieqzip(it, ik)) cycle
×
3530
       is = is_idx(le_lo, ile)
×
3531
       ig = ig_idx(le_lo, ile)
×
3532
       v0y0 = 0.0
×
3533
       do ie = 1, negrid
×
3534
          vnE = vnmult(2) * vnew_E(ik, ie, is) * w(ie, is)
×
3535
          do ixi = 1, nxi_lim
×
3536
             v0y0 = v0y0 + vnE * aj0le(ixi, ie, ile) * gle(ixi, ie, ile) * wxi(ixi, ig)
×
3537
          end do
3538
       end do
3539
       gle(:, :, ile) = gle(:, :, ile) - bz0le(:, :, ile) * v0y0
×
3540
    end do
3541
    !$OMP END PARALLEL DO
3542

3543
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3544
    ! Now get v1y1 and then y2 = y1 - v1y1 * s1 / (1 + v1s1)
3545

3546
    !$OMP PARALLEL DO DEFAULT(none) &
3547
    !$OMP PRIVATE(ile, it, ik, is, ig, delnu, ie, ixi, v1y1) &
3548
    !$OMP SHARED(le_lo, kwork_filter, negrid, vnmult, delvnew, nxi_lim, &
3549
    !$OMP bs0le, vpa_aj0_le, gle, w, wxi, ieqzip) &
3550
    !$OMP SCHEDULE(static)
3551
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3552
       ik = ik_idx(le_lo, ile)
×
3553
       it = it_idx(le_lo, ile)
×
3554
       if (kwork_filter(it, ik)) cycle
×
3555
       if (ieqzip(it, ik)) cycle
×
3556
       is = is_idx(le_lo, ile)
×
3557
       ig = ig_idx(le_lo, ile)
×
3558
       v1y1 = 0.0
×
3559
       do ie = 1, negrid
×
3560
          delnu = vnmult(2) * delvnew(ik, ie, is) * w(ie, is)
×
3561
          do ixi = 1, nxi_lim
×
3562
             v1y1 = v1y1 + vpa_aj0_le(ixi,  ie,  ile) * delnu * gle(ixi, ie, ile) * wxi(ixi, ig)
×
3563
          end do
3564
       end do
3565
       gle(:, :, ile) = gle(:, :, ile) - bs0le(:, :, ile) * v1y1
×
3566
    end do
3567
    !$OMP END PARALLEL DO
3568

3569
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3570
    ! Now get v2y2 and then get x = y2 - v2y2 * w2 / (1 + v2w2)
3571

3572
    !$OMP PARALLEL DO DEFAULT(none) &
3573
    !$OMP PRIVATE(ile, it, ik, is, ie, ig, ixi, delnu, v2y2) &
3574
    !$OMP SHARED(le_lo, kwork_filter, negrid, nxi_lim, ieqzip, &
3575
    !$OMP bw0le, delvnew, vperp_aj1le, gle, vnmult, w, wxi) &
3576
    !$OMP SCHEDULE(static)
3577
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3578
       ik = ik_idx(le_lo, ile)
×
3579
       it = it_idx(le_lo, ile)
×
3580
       if (kwork_filter(it, ik)) cycle
×
3581
       if (ieqzip(it, ik)) cycle
×
3582
       is = is_idx(le_lo, ile)
×
3583
       ig = ig_idx(le_lo, ile)
×
3584
       v2y2 = 0.0
×
3585
       do ie = 1, negrid
×
3586
          delnu = vnmult(2) * delvnew(ik, ie, is) * w(ie, is)
×
3587
          do ixi = 1, nxi_lim
×
3588
             v2y2 = v2y2 + delnu * vperp_aj1le(ixi, ie, ile) * gle(ixi, ie, ile) * wxi(ixi, ig)
×
3589
          end do
3590
       end do
3591
       gle(:, :, ile) = gle(:, :, ile) - bw0le(:, :, ile) * v2y2
×
3592
    end do
3593
    !$OMP END PARALLEL DO
3594
  end subroutine conserve_diffuse_le_layout
×
3595

3596
  !> FIXME : Add documentation
3597
  subroutine solfp_lorentz_standard_layout (g, gc, gh, diagnostics)
×
3598
    use theta_grid, only: ntgrid
3599
    use le_grids, only: jend, lambda_map, il_is_wfb, ng2, grid_has_trapped_particles
3600
    use gs2_layouts, only: ig_idx, ik_idx, il_idx, is_idx, it_idx, g_lo, lz_lo
3601
    use redistribute, only: gather, scatter
3602
    use run_parameters, only: ieqzip
3603
    use kt_grids, only: kwork_filter
3604
    use array_utils, only: zero_array
3605
    implicit none
3606
    complex, dimension (-ntgrid:,:,g_lo%llim_proc:), intent (in out) :: g, gc, gh
3607
    integer, optional, intent (in) :: diagnostics
3608
    complex, dimension (:,:), allocatable :: glz, glzc
×
3609
    complex, dimension (nxi_lim) :: delta
×
3610
    complex :: fac, gwfb
3611
    integer :: ig, ik, il, is, it, je, nxi_scatt, ilz, cur_jend
3612
    logical :: is_wfb
3613

3614
    allocate (glz(nxi_lim,lz_lo%llim_proc:lz_lo%ulim_alloc))
×
3615
    call zero_array(glz)
×
3616

3617
    call gather (lambda_map, g, glz)
×
3618

3619
    if (heating .and. present(diagnostics)) then
×
3620
       allocate (glzc(nxi_lim, lz_lo%llim_proc:lz_lo%ulim_alloc))
×
3621
       call zero_array(glzc)
×
3622
       !$OMP PARALLEL DO DEFAULT(none) &
3623
       !$OMP PRIVATE(ilz, ig, je, il, fac) &
3624
       !$OMP SHARED(lz_lo, jend, ng2, glz, glzc, d1) &
3625
       !$OMP SCHEDULE(static)
3626
       do ilz = lz_lo%llim_proc, lz_lo%ulim_proc
×
3627
          ig = ig_idx(lz_lo,ilz)
×
3628

3629
          je = 2*jend(ig)
×
3630
          if (je == 0) then
×
3631
             je = 2 * ng2
×
3632
          end if
3633

3634
! when il=je-1 below, and we have trapped particles, glz is evaluated at glz(2*jend(ig),ilz).
3635
! this seems like a bug, since there are only 2*jend(ig)-1 grid points and
3636
! the value glz(2*jend(ig),ilz) corresponds to the value of g at xi = 0...this
3637
! doesn't make any sense...MAB
3638

3639
          do il = 1, je-1
×
3640
             fac = glz(il+1,ilz)-glz(il,ilz)
×
3641
             glzc(il,ilz) = conjg(fac)*fac*d1(il,ilz)  ! d1 accounts for hC(h) entropy
×
3642
          end do
3643
       end do
3644
       !$OMP END PARALLEL DO
3645

3646
       call scatter (lambda_map, glzc, gc)
×
3647

3648
       if (hyper_colls) then
×
3649
          !$OMP PARALLEL DO DEFAULT(none) &
3650
          !$OMP PRIVATE(ilz, ig, je, il, fac) &
3651
          !$OMP SHARED(lz_lo, jend, ng2, glz, glzc, h1) &
3652
          !$OMP SCHEDULE(static)
3653
          do ilz = lz_lo%llim_proc, lz_lo%ulim_proc
×
3654
             ig = ig_idx(lz_lo,ilz)
×
3655
             
3656
             je = 2*jend(ig)          
×
3657
             if (je == 0) then
×
3658
                je = 2*ng2 
×
3659
             end if
3660
             
3661
             do il = 1, je-1
×
3662
                fac = glz(il+1,ilz)-glz(il,ilz)
×
3663
                glzc(il,ilz) = conjg(fac)*fac*h1(il,ilz)  ! h1 accounts for hH(h) entropy
×
3664
             end do
3665
          end do
3666
          !$OMP END PARALLEL DO
3667

3668
          call scatter (lambda_map, glzc, gh)
×
3669
       end if
3670
       if (allocated(glzc)) deallocate (glzc)
×
3671
    end if
3672

3673
    ! solve for glz row by row
3674
    !$OMP PARALLEL DO DEFAULT(none) &
3675
    !$OMP PRIVATE(ilz, ik, it, is, ig, je, nxi_scatt, &
3676
    !$OMP il, gwfb, delta, is_wfb, cur_jend) &
3677
    !$OMP SHARED(lz_lo, kwork_filter, ieqzip, vnew, force_collisions, jend, ng2, vpar_zero_mean, &
3678
    !$OMP glz, special_wfb_lorentz, ql, c1, betaa) &
3679
    !$OMP SCHEDULE(static)
3680
    do ilz = lz_lo%llim_proc, lz_lo%ulim_proc
×
3681
       is = is_idx(lz_lo,ilz)
×
3682
       ik = ik_idx(lz_lo,ilz)
×
3683
       if ( (abs(vnew(ik,1,is)) < 2.0*epsilon(0.0)) .and. .not. force_collisions) cycle
×
3684
       it = it_idx(lz_lo,ilz)
×
3685
       if(kwork_filter(it,ik))cycle
×
3686
       if (ieqzip(it,ik)) cycle
×
3687
       ig = ig_idx(lz_lo,ilz)
×
3688

3689
       !CMRDDGC, 10/2/2014:
3690
       ! Fixes for wfb treatment below, use same je definition in ALL cases
3691
       !   je  = #physical (unique) xi values + 1
3692
       !       NB +1 above WITH TRAPPED is duplicate xi=vpar=0 point with isign=2
3693
       !          +1 above WITHOUT TRAPPED is entirely unphysical extra grid point
3694
       !  je-1 = #physical xi values removing unphysical/duplicate extra point
3695
       cur_jend = jend(ig)
×
3696
       je = max(2 * cur_jend, 2 * ng2 + 1)
×
3697
       nxi_scatt = je - 1
×
3698
       is_wfb = il_is_wfb(cur_jend)
×
3699
       if (.not. grid_has_trapped_particles()) nxi_scatt = nxi_scatt - 1
×
3700

3701
       if (je == 2 * cur_jend .and. is_wfb .and. vpar_zero_mean) then
×
3702
          ! MRH if we have trapped particles and hence 2 vpar=0 points on the grid
3703
          ! use the average of both vpar = 0 points in the lorentz diffusion in pitch angle
3704
          ! this turns out to be necessary to suppress numerical instability
3705
          ! when we handle pitch angle scattering physically at theta = +/- pi
3706
          ! by setting special_wfb_lorentz =.false.
3707
          ! Note : This can give large change in g_wfb when it is not treated as a trapped
3708
          ! particle as the input g is unlikely to satisy g_wfb(sigma=1) ~ g_wfb(sigma=2).
3709
          ! Note : We don't apply this treatment to other trapped particles as we assume
3710
          ! g has a unique value at the bounce point for those particles.
3711
          glz(cur_jend, ilz) = (glz(cur_jend, ilz) + glz(2 * cur_jend, ilz)) / 2.0
×
3712
       end if
3713

3714
       ! zero unphysical/duplicate extra point. This shouldn't be needed
3715
       if (grid_has_trapped_particles()) glz(je, ilz) = 0.0
×
3716

3717
       if (is_wfb .and. special_wfb_lorentz) then
×
3718
          !CMRDDGC:  special_wfb_lorentz = t  => unphysical handling of wfb at bounce pt:
3719
          !          remove wfb from collisions, reinsert later
3720
          !
3721
          ! first save gwfb for reinsertion later
3722
          ! Note we don't save both sigma values as we force g(v||=0)_+ == g(v||=0)_-
3723
          ! at the end of the loop anyway.
3724
          gwfb = glz(ng2+1, ilz)
×
3725
          ! then remove vpa = 0 point, weight 0: (CMR confused by this comment!)
3726
          !The above is referring to the conservative scheme coefficients which involve
3727
          !1/pitch_weight but pitch_weight = 0 for the WFB at the WFB bounce point.
3728
          !Special_wfb_lorentz is a way to avoid this issue by ignoring the WFB pitch angle
3729
          glz(ng2+1:je-2, ilz) = glz(ng2+2:je-1, ilz)
×
3730
          ! Zero out the glz value not overwritten in the above. Shouldn't be needed
3731
          glz(je - 1, ilz) = 0.0
×
3732
          nxi_scatt = nxi_scatt - 1
×
3733
       end if
3734

3735
       ! right and left sweeps for tridiagonal solve:
3736
       delta(1) = glz(1, ilz)
×
3737
       do il = 1, nxi_scatt
×
3738
          delta(il+1) = glz(il+1, ilz) - ql(il+1, ilz) * delta(il)
×
3739
       end do
3740

3741
       glz(nxi_scatt+1, ilz) = delta(nxi_scatt+1) * betaa(nxi_scatt+1, ilz)
×
3742
       do il = nxi_scatt, 1, -1
×
3743
          glz(il, ilz) = (delta(il) - c1(il, ilz) * glz(il+1, ilz)) * betaa(il, ilz)
×
3744
       end do
3745

3746
       if (is_wfb .and. special_wfb_lorentz) then
×
3747
          glz(ng2+2:je-1, ilz) = glz(ng2+1:je-2, ilz)
×
3748
          glz(ng2+1, ilz) = gwfb
×
3749
       end if
3750

3751
       ! update the duplicate vpar=0 point with the post pitch angle scattering value
3752
       if (cur_jend /= 0) glz(2 * cur_jend, ilz) = glz(cur_jend, ilz)
×
3753
    end do
3754
    !$OMP END PARALLEL DO
3755

3756
    call scatter (lambda_map, glz, g)
×
3757
    deallocate (glz)
×
3758
  end subroutine solfp_lorentz_standard_layout
×
3759

3760
  !> FIXME : Add documentation
3761
  subroutine solfp_lorentz_le_layout (gle, diagnostics)
×
3762
    use le_grids, only: jend, ng2, negrid, integrate_moment, il_is_wfb, grid_has_trapped_particles
3763
    use gs2_layouts, only: ig_idx, ik_idx, is_idx, it_idx
3764
    use run_parameters, only: ieqzip
3765
    use gs2_layouts, only: le_lo
3766
    use dist_fn_arrays, only: c_rate
3767
    use kt_grids, only: kwork_filter
3768
    use array_utils, only: zero_array
3769
    implicit none
3770
    complex, dimension (:,:,le_lo%llim_proc:), intent (in out) :: gle
3771
    integer, optional, intent (in) :: diagnostics
3772
    complex, dimension (:), allocatable :: tmp
×
3773
    complex, dimension (:,:,:), allocatable :: glec
×
3774
    complex, dimension (nxi_lim) :: delta
×
3775
    complex :: fac, gwfb
3776
    integer :: ig, ik, il, is, je, it, ie, nxi_scatt, ile, cur_jend
3777
    logical :: is_wfb
3778

3779
    if (heating .and. present(diagnostics)) then
×
3780
       allocate (tmp(le_lo%llim_proc:le_lo%ulim_alloc)) ; call zero_array(tmp)
×
3781
       allocate (glec(nxi_lim, negrid+1, le_lo%llim_proc:le_lo%ulim_alloc))
×
3782
       call zero_array(glec)
×
3783
       !$OMP PARALLEL DO DEFAULT(none) &
3784
       !$OMP PRIVATE(ile, ig, je, ie, il, fac) &
3785
       !$OMP SHARED(le_lo, jend, ng2, negrid, gle, glec, d1le) &
3786
       !$OMP SCHEDULE(static)
3787
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3788
          ig = ig_idx(le_lo,ile)
×
3789

3790
          je = 2*jend(ig)
×
3791
          if (je == 0) then
×
3792
             je = 2*ng2 
×
3793
          end if
3794

3795
! when il=je-1 below, and we have trapped particles, gle is evaluated at gle(2*jend(ig),ie,ile).
3796
! this seems like a bug, since there are only 2*jend(ig)-1 grid points and
3797
! the value gle(2*jend(ig),ie,ile) corresponds to the value of g at xi = 0...this
3798
! doesn't make any sense...MAB
3799

3800
          do ie = 1, negrid
×
3801
             do il = 1, je-1
×
3802
                fac = gle(il+1,ie,ile)-gle(il,ie,ile)
×
3803
                glec(il,ie,ile) = conjg(fac)*fac*d1le(il,ie,ile)  ! d1le accounts for hC(h) entropy
×
3804
             end do
3805
          end do
3806
       end do
3807
       !$OMP END PARALLEL DO
3808

3809
       call integrate_moment (le_lo, glec, tmp)
×
3810
       !$OMP PARALLEL DO DEFAULT(none) &
3811
       !$OMP PRIVATE(ile, ig, it, ik, is) &
3812
       !$OMP SHARED(le_lo, c_rate, tmp) &
3813
       !$OMP SCHEDULE(static)
3814
       do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3815
          ig = ig_idx(le_lo,ile)
×
3816
          it = it_idx(le_lo,ile)
×
3817
          ik = ik_idx(le_lo,ile)
×
3818
          is = is_idx(le_lo,ile)
×
3819
          c_rate(ig,it,ik,is,1) = tmp(ile)
×
3820
       end do
3821
       !$OMP END PARALLEL DO
3822

3823
       if (hyper_colls) then
×
3824
          !$OMP PARALLEL DO DEFAULT(none) &
3825
          !$OMP PRIVATE(ile, ig, je, ie, il, fac) &
3826
          !$OMP SHARED(le_lo, jend, ng2, negrid, gle, glec, h1le) &
3827
          !$OMP SCHEDULE(static)
3828
          do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3829
             ig = ig_idx(le_lo,ile)
×
3830

3831
             je = 2*jend(ig)
×
3832
             if (je == 0) then
×
3833
                je = 2*ng2
×
3834
             end if
3835

3836
             do ie = 1, negrid
×
3837
                do il = 1, je-1
×
3838
                   fac = gle(il+1,ie,ile)-gle(il,ie,ile)
×
3839
                   glec(il,ie,ile) = conjg(fac)*fac*h1le(il,ie,ile)  ! h1le accounts for hH(h) entropy
×
3840
                end do
3841
             end do
3842
          end do
3843
          !$OMP END PARALLEL DO
3844

3845
          call integrate_moment (le_lo, glec, tmp)
×
3846

3847
          !$OMP PARALLEL DO DEFAULT(none) &
3848
          !$OMP PRIVATE(ile, ig, it, ik, is) &
3849
          !$OMP SHARED(le_lo, c_rate, tmp) &
3850
          !$OMP SCHEDULE(static)
3851
          do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3852
             ig = ig_idx(le_lo,ile)
×
3853
             it = it_idx(le_lo,ile)
×
3854
             ik = ik_idx(le_lo,ile)
×
3855
             is = is_idx(le_lo,ile)
×
3856
             c_rate(ig,it,ik,is,2) = tmp(ile)
×
3857
          end do
3858
          !$OMP END PARALLEL DO
3859
       end if
3860
       deallocate(tmp, glec)
×
3861
    end if
3862

3863
    ! solve for gle row by row
3864
    !$OMP PARALLEL DO DEFAULT(none) &
3865
    !$OMP PRIVATE(ile, is, it, ik, ig, il, ie, je, nxi_scatt, &
3866
    !$OMP gwfb, delta, is_wfb, cur_jend) &
3867
    !$OMP SHARED(le_lo, kwork_filter, ieqzip, vnew, force_collisions, jend, ng2, special_wfb_lorentz, &
3868
    !$OMP vpar_zero_mean, negrid, gle, qle, betaale, c1le) &
3869
    !$OMP SCHEDULE(static)
3870
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
3871
       is = is_idx(le_lo, ile)
×
3872
       ik = ik_idx(le_lo, ile)
×
3873
       if ((abs(vnew(ik, 1, is)) < 2.0 * epsilon(0.0)) .and. .not. force_collisions) cycle
×
3874
       it = it_idx(le_lo, ile)
×
3875
       if (kwork_filter(it, ik)) cycle
×
3876
       if (ieqzip(it, ik)) cycle
×
3877
       ig = ig_idx(le_lo, ile)
×
3878

3879
       !CMRDDGC, 10/2/1014:
3880
       ! Fixes for wfb treatment below, use same je definition in ALL cases
3881
       !   je  = #physical xi values at location, includes duplicate point at vpar=0
3882
       !  je-1 = #physical xi values removing duplicate vpar=0 point
3883
       cur_jend = jend(ig)
×
3884
       je = max(2 * cur_jend, 2 * ng2 + 1)
×
3885
       nxi_scatt = je - 1
×
3886
       is_wfb = il_is_wfb(cur_jend)
×
3887
       if ((is_wfb .and. special_wfb_lorentz) .or. .not. grid_has_trapped_particles()) &
×
3888
            nxi_scatt = nxi_scatt - 1
×
3889

3890
       do ie = 1, negrid
×
3891
          if (je == 2 * cur_jend .and. is_wfb .and. vpar_zero_mean) then
×
3892
             ! MRH if we have trapped particles and hence 2 vpar=0 points on the grid
3893
             ! use the average of both vpar = 0 points in the lorentz diffusion in pitch angle
3894
             ! this turns out to be necessary to suppress numerical instability
3895
             ! when we handle pitch angle scattering physically at theta = +/- pi
3896
             ! by setting special_wfb_lorentz =.false.
3897
             ! Note : This can give large change in g_wfb when it is not treated as a trapped
3898
             ! particle as the input g is unlikely to satisy g_wfb(sigma=1) ~ g_wfb(sigma=2).
3899
             ! Note : We don't apply this treatment to other trapped particles as we assume
3900
             ! g has a unique value at the bounce point for those particles.
3901
             gle(cur_jend, ie, ile) = (gle(cur_jend, ie, ile) + &
×
3902
                  gle(2 * cur_jend, ie, ile)) / 2.0
×
3903
          end if
3904

3905
          ! zero redundant duplicate xi, isign=2 for vpar=0! This shouldn't be needed
3906
          if (grid_has_trapped_particles()) gle(je, ie, ile) = 0.0d0
×
3907

3908
          if (is_wfb .and. special_wfb_lorentz) then
×
3909
             !CMRDDGC:  special_wfb_lorentz = t  => unphysical handling of wfb at bounce pt:
3910
             !          remove wfb from collisions, reinsert later
3911
             !
3912
             ! first save gwfb for reinsertion later
3913
             ! Note we don't save both sigma values as we force g(v||=0)_+ == g(v||=0)_-
3914
             ! at the end of the loop anyway.
3915
             gwfb = gle(ng2 + 1, ie, ile)
×
3916
             ! then remove vpa = 0 point, weight 0: (CMR confused by this comment!)
3917
             !The above is referring to the conservative scheme coefficients which involve
3918
             !1/pitch_weight but pitch_weight = 0 for the WFB at the WFB bounce point.
3919
             !Special_wfb_lorentz is a way to avoid this issue by ignoring the WFB pitch angle
3920
             gle(ng2+1:je-2, ie, ile) = gle(ng2+2:je-1, ie, ile)
×
3921
             ! Zero out the gle value not overwritten in the above. Shouldn't be needed
3922
             gle(je - 1, ie, ile) = 0.0
×
3923
          end if
3924

3925
          ! right and left sweeps for tridiagonal solve:
3926
          delta(1) = gle(1, ie, ile)
×
3927
          do il = 1, nxi_scatt
×
3928
             delta(il+1) = gle(il+1, ie, ile) - qle(il+1, ie, ile) * delta(il)
×
3929
          end do
3930

3931
          gle(nxi_scatt+1, ie, ile) = delta(nxi_scatt+1) * betaale(nxi_scatt+1, ie, ile)
×
3932
          do il = nxi_scatt, 1, -1
×
3933
             gle(il, ie, ile) = (delta(il) - c1le(il, ie, ile) * gle(il+1, ie, ile)) * &
×
3934
                  betaale(il, ie, ile)
×
3935
          end do
3936

3937
          if (is_wfb .and. special_wfb_lorentz) then
×
3938
             gle(ng2+2:je-1, ie, ile) = gle(ng2+1:je-2, ie, ile)
×
3939
             gle(ng2+1, ie, ile) = gwfb
×
3940
          end if
3941

3942
          ! next line ensures bounce condition is satisfied after lorentz collisions
3943
          ! this is right thing to do, but it would mask any prior bug in trapping condition!
3944
          if (cur_jend /= 0) gle(2 * cur_jend, ie, ile) = gle(cur_jend, ie, ile)
×
3945

3946
       end do
3947
    end do
3948
    !$OMP END PARALLEL DO
3949
  end subroutine solfp_lorentz_le_layout
×
3950

3951
  !> Energy diffusion subroutine used with energy layout (not le_layout)
3952
  !> this is always the case when initializing the conserving terms,
3953
  !> otherwise is the case if use_le_layout is no specified in the input file.
3954
  subroutine solfp_ediffuse_standard_layout (g)
×
3955
    use theta_grid, only: ntgrid
3956
    use le_grids, only: negrid, forbid, energy_map
3957
    use gs2_layouts, only: ig_idx, it_idx, ik_idx, il_idx, is_idx, e_lo, g_lo
3958
    use redistribute, only: gather, scatter
3959
    use run_parameters, only: ieqzip
3960
    use kt_grids, only: kwork_filter
3961
    use array_utils, only: zero_array
3962
    implicit none
3963
    complex, dimension (-ntgrid:,:,g_lo%llim_proc:), intent (in out) :: g
3964
    integer :: ie, is, ig, il, it, ik, ielo
3965
    complex, dimension (negrid) :: delta
×
3966
    complex, dimension (:,:), allocatable :: ged
×
3967

3968
    allocate (ged(negrid+1,e_lo%llim_proc:e_lo%ulim_alloc)) ; call zero_array(ged)
×
3969
    call gather (energy_map, g, ged)
×
3970

3971
    ! solve for ged row by row
3972
    !$OMP PARALLEL DO DEFAULT(none) &
3973
    !$OMP PRIVATE(ielo, it, ik, is, ig, il, delta, ie) &
3974
    !$OMP SHARED(e_lo, kwork_filter, ieqzip, vnew, force_collisions, forbid, negrid, &
3975
    !$OMP ged, eql, ec1, ebetaa) &
3976
    !$OMP SCHEDULE(static)
3977
    do ielo = e_lo%llim_proc, e_lo%ulim_proc
×
3978
       is = is_idx(e_lo, ielo)
×
3979
       ik = ik_idx(e_lo, ielo)
×
3980
       if ((abs(vnew(ik, 1, is)) < 2.0 * epsilon(0.0)) .and. .not. force_collisions) cycle
×
3981
       it = it_idx(e_lo, ielo)
×
3982
       if (kwork_filter(it, ik))cycle
×
3983
       if (ieqzip(it, ik)) cycle
×
3984
       ig = ig_idx(e_lo, ielo)
×
3985
       il = il_idx(e_lo, ielo)
×
3986
       if (forbid(ig, il)) cycle
×
3987

3988
       delta(1) = ged(1, ielo)
×
3989
       do ie = 1, negrid-1
×
3990
          delta(ie+1) = ged(ie+1, ielo) - eql(ie+1, ielo) * delta(ie)
×
3991
       end do
3992
       
3993
       ged(negrid+1, ielo) = 0.0
×
3994
       do ie = negrid, 1, -1
×
3995
          ged(ie, ielo) = (delta(ie) - ec1(ie, ielo) * ged(ie+1, ielo)) * ebetaa(ie, ielo)
×
3996
       end do
3997
    end do
3998
    !$OMP END PARALLEL DO
3999

4000
    call scatter (energy_map, ged, g)
×
4001
    deallocate (ged)
×
4002
  end subroutine solfp_ediffuse_standard_layout
×
4003

4004
  !> FIXME : Add documentation
4005
  subroutine solfp_ediffuse_le_layout (gle)
×
4006
    use le_grids, only: negrid, jend, ng2
4007
    use gs2_layouts, only: ig_idx, it_idx, ik_idx, is_idx, le_lo
4008
    use run_parameters, only: ieqzip
4009
    use kt_grids, only: kwork_filter
4010
    implicit none
4011
    complex, dimension (:,:,le_lo%llim_proc:), intent (in out) :: gle
4012
    integer :: ie, is, ig, ile, ixi, ik, it, max_xi
4013
    complex, dimension (negrid) :: delta
×
4014
    
4015
    ! solve for gle row by row
4016
    !$OMP PARALLEL DO DEFAULT(none) &
4017
    !$OMP PRIVATE(ile, is, it, ik, ig, ixi, max_xi, ie, delta) &
4018
    !$OMP SHARED(le_lo, vnew, force_collisions, kwork_filter, ieqzip, jend, ng2, &
4019
    !$OMP gle, negrid, eqle, ec1le, ebetaale) &
4020
    !$OMP SCHEDULE(static)
4021
    do ile = le_lo%llim_proc, le_lo%ulim_proc
×
4022
       is = is_idx(le_lo, ile)
×
4023
       ik = ik_idx(le_lo, ile)
×
4024
       if ((abs(vnew(ik, 1, is)) < 2.0 * epsilon(0.0)) .and. .not. force_collisions) cycle
×
4025
       it = it_idx(le_lo, ile)
×
4026
       if (kwork_filter(it, ik)) cycle
×
4027
       if (ieqzip(it, ik)) cycle
×
4028
       ig = ig_idx(le_lo, ile)
×
4029
       max_xi = max(2 * jend(ig), 2 * ng2)
×
4030
       do ixi = 1, max_xi
×
4031
          delta(1) = gle(ixi, 1, ile)
×
4032
          do ie = 1, negrid - 1
×
4033
             delta(ie+1) = gle(ixi, ie+1, ile) - eqle(ixi, ie+1, ile) * delta(ie)
×
4034
          end do
4035

4036
          gle(ixi, negrid+1, ile) = 0.0
×
4037
          do ie = negrid, 1, -1
×
4038
             gle(ixi, ie, ile) = (delta(ie) - ec1le(ixi, ie, ile) * gle(ixi, ie+1, ile)) &
×
4039
                  * ebetaale(ixi, ie, ile)
×
4040
          end do
4041
       end do
4042
    end do
4043
    !$OMP END PARALLEL DO
4044
  end subroutine solfp_ediffuse_le_layout
×
4045

4046
  !> FIXME : Add documentation
4047
  subroutine init_vpdiff
×
4048
    use le_grids, only: al, nlambda, jend, ng2, il_is_wfb, il_is_passing, ixi_to_il, ixi_to_isgn
4049
    use theta_grid, only: ntgrid, bmag
4050
    use array_utils, only: zero_array
4051
    implicit none
4052

4053
    integer :: il, isgn, ixi, ig, je, te
4054
    real :: slb0, slb1, slb2, slbl, slbr
4055

4056
    if (.not. allocated(vpdiff) .and. conservative) then
×
4057

4058
       allocate (vpdiff(-ntgrid:ntgrid, 2, nlambda)) ; call zero_array(vpdiff)
×
4059
       
4060
       do ig = -ntgrid, ntgrid
×
4061
          je = jend(ig)
×
4062
          if (il_is_passing(je) .or. (il_is_wfb(je) .and. special_wfb_lorentz)) then
×
4063
             te = ng2
×
4064
          else
4065
             te = je
×
4066
          end if
4067
          do il = 2, te-1
×
4068
             slb0 = safe_sqrt(1.0 - bmag(ig) * al(il-1))
×
4069
             slb1 = safe_sqrt(1.0 - bmag(ig) * al(il))
×
4070
             slb2 = safe_sqrt(1.0 - bmag(ig) * al(il+1))
×
4071
             
4072
             slbl = (slb1 + slb0) * 0.5  ! xi(j-1/2)
×
4073
             slbr = (slb1 + slb2) * 0.5  ! xi(j+1/2)
×
4074
             
4075
             vpdiff(ig, 1, il) = (slbl**2 - slbr**2) / pitch_weights(il, ig)
×
4076
          end do
4077

4078
          ! boundary at xi = 1
4079
          slb1 = safe_sqrt(1.0 - bmag(ig) * al(1))
×
4080
          slb2 = safe_sqrt(1.0 - bmag(ig) * al(2))
×
4081
          slbr = 0.5 * (slb1 + slb2)
×
4082
          vpdiff(ig, 1, 1) = (1.0 - slbr**2) / pitch_weights(1, ig)
×
4083
          
4084
          ! boundary at xi = 0
4085
          il = te
×
4086
          slb0 = safe_sqrt(1.0 - bmag(ig) * al(il-1))
×
4087
          if (te == ng2) then ! Passing
×
4088
             slb1 = safe_sqrt(1.0 - bmag(ig) * al(il))
×
4089
             slb2 = -slb1
×
4090
          else
4091
             ! We would expect safe_sqrt(1.0 - bmag(ig) * al(il)) = 0 here so could just
4092
             ! use slb1 = safe_sqrt(1.0 - bmag(ig) * al(il)) = 0 for both branches?
4093
             slb1 = 0.0
×
4094
             slb2 = -slb0
×
4095
          end if
4096
          
4097
          slbl = (slb1 + slb0) * 0.5
×
4098
          slbr = (slb1 + slb2) * 0.5
×
4099

4100
          if (abs(pitch_weights(il, ig)) <= epsilon(0.0)) then
×
4101
             vpdiff(ig, 1, il) = 0.0
×
4102
          else
4103
             vpdiff(ig, 1, il) = (slbl**2 - slbr**2) / pitch_weights(il, ig)
×
4104
          end if
4105
          
4106
          vpdiff(ig, 2, :) = -vpdiff(ig, 1, :)
×
4107
          
4108
       end do
4109

4110
       if (use_le_layout) then
×
4111
          allocate(vpdiffle(nxi_lim, -ntgrid:ntgrid))
×
4112

4113
          do ig = -ntgrid, ntgrid
×
4114
             do ixi = 1, nxi_lim
×
4115
                il = ixi_to_il(ixi, ig)
×
4116
                isgn = ixi_to_isgn(ixi, ig)
×
4117
                vpdiffle(ixi, ig) = vpdiff(ig, isgn, il)
×
4118
             end do
4119
          end do
4120
       end if
4121
    end if
4122
    
4123
  end subroutine init_vpdiff
×
4124

4125
  !> Forces recalculation of coefficients in collision operator
4126
  !! when timestep changes. Currently just calls [[finish_collisions]]
4127
  subroutine reset_init
×
4128
    call finish_collisions
×
4129
  end subroutine reset_init
×
4130

4131
  !> Forces recalculation of coefficients in collision operator
4132
  !! when timestep changes.
4133
  subroutine finish_collisions
×
4134
    use dist_fn_arrays, only: c_rate
4135
    implicit none
4136

4137
    ! This is a bit of a hack to make sure that we get the correct vnmult
4138
    ! value during a timestep change. Whilst we do restore vnmult from the
4139
    ! restart file, this unfortunately doesn't happen until after we've initialised
4140
    ! the collision operator so we choose to store this in vnm_init, which is
4141
    ! where we get our initial value of vnmult from anyway.
4142
    vnm_init = vnmult
×
4143
    vnmult = -1.0
×
4144
    initialized = .false.  
×
4145

4146
    if (allocated(c_rate)) deallocate (c_rate)
×
4147
    if (allocated(z0)) deallocate (z0, w0, s0)
×
4148
    if (allocated(bz0)) deallocate (bz0, bw0, bs0)
×
4149
    if (allocated(vnew)) deallocate (vnew, vnew_s, vnew_D, vnew_E, delvnew)
×
4150
    if (allocated(vnewh)) deallocate (vnewh)
×
4151
    if (allocated(pitch_weights)) deallocate(pitch_weights)
×
4152

4153
    if(use_le_layout) then
×
4154
      if (allocated(c1le)) then
×
4155
         deallocate (c1le, betaale, qle)
×
4156
         if (heating) deallocate (d1le, h1le)
×
4157
      end if
4158
      if (allocated(ec1le)) deallocate (ec1le, ebetaale, eqle)
×
4159
      if (allocated(s0le)) deallocate(s0le)
×
4160
      if (allocated(w0le)) deallocate(w0le)
×
4161
      if (allocated(z0le)) deallocate(z0le)
×
4162
      if (allocated(aj0le)) deallocate(aj0le)
×
4163
      if (allocated(vperp_aj1le)) deallocate(vperp_aj1le)
×
4164
      if (allocated(vpa_aj0_le)) deallocate(vpa_aj0_le)
×
4165
      if (allocated(bs0le)) deallocate(bs0le)
×
4166
      if (allocated(bw0le)) deallocate(bw0le)
×
4167
      if (allocated(bz0le)) deallocate(bz0le)
×
4168
    else
4169
      if (allocated(c1)) then
×
4170
         deallocate (c1, betaa, ql)
×
4171
         if (heating) deallocate (d1, h1)
×
4172
      end if
4173
      if (allocated(ec1)) deallocate (ec1, ebetaa, eql)
×
4174
    end if
4175
    if (allocated(vpdiff)) deallocate (vpdiff)
×
4176
    if (allocated(vpdiffle)) deallocate (vpdiffle)
×
4177
    if (allocated(dtot)) deallocate (dtot, fdf, fdb)
×
4178

4179
    call collisions_config%reset()
×
4180
  end subroutine finish_collisions
×
4181

4182
  !> Set the module level config type
4183
  !> Will abort if the module has already been initialised to avoid
4184
  !> inconsistencies.
4185
  subroutine set_collisions_config(collisions_config_in)
×
4186
    use mp, only: mp_abort
4187
    type(collisions_config_type), intent(in), optional :: collisions_config_in
4188
    if (initialized) then
×
4189
       call mp_abort("Trying to set collisions_config when already initialized.", to_screen = .true.)
×
4190
    end if
4191
    if (present(collisions_config_in)) then
×
4192
       collisions_config = collisions_config_in
×
4193
    end if
4194
  end subroutine set_collisions_config
×
4195

4196
#include "collisions_auto_gen.inc"  
4197
end module collisions
×
4198

STATUS · Troubleshooting · Open an Issue · Sales · Support · CAREERS · ENTERPRISE · START FREE · SCHEDULE DEMO
ANNOUNCEMENTS · TWITTER · TOS & SLA · Supported CI Services · What's a CI service? · Automated Testing

© 2026 Coveralls, Inc