SFEMaNS  version 5.3
Reference documentation for SFEMaNS
maxwell_update_time_with_B.f90
Go to the documentation of this file.
1 !$
2 !Authors Jean-Luc Guermond, Raphael Laguerre, Copyrights 2005
3 !Revised June 2008, Jean-Luc Guermond
4 !Revised Jan/Feb 2009, Caroline Nore, Jean-Luc Guermond, Franky Luddens
5 !
6 MODULE update_maxwell_with_b
7 
8  PUBLIC:: maxwell_decouple_with_b
9  PRIVATE
10  REAL(KIND=8), PARAMETER, PRIVATE :: alpha=0.6d0
11  INTEGER, DIMENSION(:), ALLOCATABLE :: neumann_bdy_h_sides
12  INTEGER, DIMENSION(:), ALLOCATABLE :: neumann_bdy_pmag_sides
13  INTEGER, DIMENSION(:), ALLOCATABLE :: neumann_bdy_phi_sides
14  INTEGER, DIMENSION(:), ALLOCATABLE :: dirichlet_bdy_h_sides
15 CONTAINS
16 
17  !------------------------------------------------------------------------------
18  !------------------------------------------------------------------------------
19 
20  SUBROUTINE maxwell_decouple_with_b(comm_one_d, H_mesh, pmag_mesh, phi_mesh, interface_H_phi, &
21  interface_h_mu, hn, bn, phin, hn1, bn1, phin1, vel, stab_in, sigma_in, &
22  r_fourier, index_fourier, mu_h_field, mu_phi, time, dt_in, rem, list_mode, &
23  h_phi_per, la_h, la_pmag, la_phi, la_mhd, one_over_sigma_ns_in, jj_v_to_h)
24  USE def_type_mesh
25  USE chaine_caractere
26  USE solve_petsc
27  USE boundary
28  USE tn_axi
29  USE prep_maill
30  USE dir_nodes_petsc
31  USE st_matrix
32  USE dir_nodes
33  USE my_util
34  USE sft_parallele
35  USE sub_plot
36  USE periodic
37  USE input_data
38  USE verbose
39 #include "petsc/finclude/petscsys.h"
40 #include "petsc/finclude/petscmat.h"
41 #include "petsc/finclude/petscksp.h"
42 #include "petsc/finclude/petscvec.h"
43  USE petsc
44  IMPLICIT NONE
45  TYPE(mesh_type), INTENT(IN) :: H_mesh, phi_mesh, pmag_mesh
46  TYPE(interface_type), INTENT(IN) :: interface_H_phi, interface_H_mu
47  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
48  REAL(KIND=8), DIMENSION(:,:,:), INTENT(INOUT) :: vel
49  REAL(KIND=8), DIMENSION(H_mesh%np,6,SIZE(list_mode)), INTENT(INOUT) :: Hn, Hn1
50  REAL(KIND=8), DIMENSION(H_mesh%np,6,SIZE(list_mode)), INTENT(INOUT) :: Bn, Bn1
51  REAL(KIND=8), DIMENSION(:,:,:), INTENT(INOUT) :: phin, phin1
52  REAL(KIND=8), DIMENSION(3), INTENT(IN) :: stab_in
53  REAL(KIND=8), INTENT(IN) :: R_fourier
54  INTEGER, INTENT(IN) :: index_fourier
55  REAL(KIND=8), INTENT(IN) :: mu_phi, time, dt_in, Rem
56  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: sigma_in, mu_H_field
57  !jan 29/JLG+FL/Forget about it/We replace it by H_p_phi_per/Feb 2 2010
58  TYPE(periodic_type), INTENT(IN) :: H_phi_per
59  !jan 29/JLG+FL/Forget about it/We replace it by H_p_phi_per/Feb 2 2010
60  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_ns_in
61  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
62  TYPE(petsc_csr_la) :: LA_H, LA_pmag, LA_phi, LA_mhd
63  !LC 2016/03/25
64  REAL(KIND=8), SAVE :: dt
65  REAL(KIND=8), DIMENSION(:), ALLOCATABLE, SAVE :: sigma_ns_bar
66  !LC 2016/03/25
67  REAL(KIND=8), DIMENSION(:), ALLOCATABLE, SAVE :: sigma_np
68  REAL(KIND=8), DIMENSION(:), ALLOCATABLE, SAVE :: sigma
69  REAL(KIND=8), SAVE :: sigma_min !FL: not sure we have to save it
70  TYPE(dyn_int_line), DIMENSION(:), POINTER, SAVE :: H_mode_global_js_D
71  TYPE(dyn_real_line),DIMENSION(:), ALLOCATABLE, SAVE :: H_global_D
72 !!$ REAL(KIND=8), DIMENSION(:), POINTER, SAVE :: pmag_bv_D
73  TYPE(dyn_int_line), DIMENSION(:), POINTER, SAVE :: pmag_mode_global_js_D
74  TYPE(dyn_real_line),DIMENSION(:), ALLOCATABLE, SAVE :: pmag_global_D
75 !!$ REAL(KIND=8), DIMENSION(:), POINTER, SAVE :: phi_bv1_D, phi_bv2_D
76  TYPE(dyn_int_line), DIMENSION(:), POINTER, SAVE :: phi_mode_global_js_D
77  TYPE(dyn_real_line),DIMENSION(:), ALLOCATABLE, SAVE :: phi_global_D
78  INTEGER, DIMENSION(:), POINTER, SAVE :: pmag_js_D, phi_js_D
79  LOGICAL, SAVE :: once=.true.
80  INTEGER, SAVE :: m_max_c
81 !!$ LOGICAL, SAVE :: per = .FALSE.
82  REAL(KIND=8), DIMENSION(3), SAVE :: stab
83  INTEGER, SAVE :: my_petscworld_rank
84  REAL(KIND=8), ALLOCATABLE , DIMENSION(:,:,:), SAVE :: sigma_curl_gauss_bdy
85  REAL(KIND=8), ALLOCATABLE , DIMENSION(:,:,:), SAVE :: J_over_sigma_gauss_bdy
86  REAL(KIND=8), ALLOCATABLE , DIMENSION(:,:,:), SAVE :: sigma_curl_gauss_inter_mu
87  REAL(KIND=8), ALLOCATABLE , DIMENSION(:,:,:), SAVE :: J_over_sigma_gauss_inter_mu
88  REAL(KIND=8), ALLOCATABLE , DIMENSION(:,:,:), SAVE :: sigma_tot_gauss_Neumann
89  REAL(KIND=8), ALLOCATABLE , DIMENSION(:,:), SAVE :: sigma_nj_m
90  REAL(KIND=8), DIMENSION(H_mesh%gauss%l_G*H_mesh%me,6,SIZE(list_mode)) :: sigma_curl_gauss
91  REAL(KIND=8), DIMENSION(H_mesh%gauss%l_G*H_mesh%me,6,SIZE(list_mode)) :: J_over_sigma_gauss
92  REAL(KIND=8), DIMENSION(SIZE(Hn,1),6,SIZE(Hn,3)) :: H_ns
93  REAL(KIND=8), DIMENSION(SIZE(Hn,1),2,SIZE(Hn,3)) :: one_over_sigma_tot
94  LOGICAL, ALLOCATABLE, DIMENSION(:) :: Dir_pmag
95  REAL(KIND=8), DIMENSION(H_mesh%np,6) :: rhs_H
96  REAL(KIND=8), DIMENSION(phi_mesh%np,2) :: rhs_phi
97  !FAKE FAKE FAKE
98  !DCQ H_pert = (- 1/mu)B*
99  REAL(KIND=8), DIMENSION(SIZE(Hn,1),6,SIZE(Hn,3)) :: H_pert
100  !FAKE FAKE FAKE
101  REAL(KIND=8), DIMENSION(SIZE(Hn,1),6,SIZE(Hn,3)) :: NL, B_ext
102  REAL(KIND=8), DIMENSION(3) :: temps_par
103  INTEGER, POINTER, DIMENSION(:) :: H_ifrom, pmag_ifrom, phi_ifrom, H_p_phi_ifrom
104  REAL(KIND=8), DIMENSION(phi_mesh%np, 2) :: phin_p1
105  REAL(KIND=8), DIMENSION(H_mesh%np, 6) :: Hn_p1
106  LOGICAL, DIMENSION(H_mesh%mes) :: virgin1
107  LOGICAL, DIMENSION(phi_mesh%mes) :: virgin2
108  INTEGER :: mode, k, i, n, m, ms, code, nj, j, count
109  INTEGER :: nb_procs, bloc_size, m_max_pad
110  REAL(KIND=8) :: tps, nr_vel, tps_tot, tps_cumul, norm
111  !April 17th, 2008, JLG
112  REAL(KIND=8) :: one_and_half
113  DATA one_and_half/1.5d0/
114  !April 17th, 2008, JLG
115  petscerrorcode :: ierr
116  mpi_comm, DIMENSION(:), POINTER :: comm_one_d
117  mat, DIMENSION(:), POINTER, SAVE :: h_p_phi_mat1, h_p_phi_mat2
118  mat :: tampon1, tampon2, precond1, precond2
119  ksp, DIMENSION(:), POINTER, SAVE :: h_p_phi_ksp1, h_p_phi_ksp2
120  vec, SAVE :: vx_1, vb_1, vx_1_ghost, vx_2, vb_2, vx_2_ghost
121  !------------------------------END OF DECLARATION--------------------------------------
122 
123  IF (once) THEN
124 
125  once = .false.
126 
127 !!$ IF (inputs%my_periodic%nb_periodic_pairs/=0) THEN
128 !!$ per = .TRUE.
129 !!$ ELSE
130 !!$ per = .FALSE.
131 !!$ END IF
132 
133  CALL mpi_comm_rank(petsc_comm_world,my_petscworld_rank,code)
134 
135  CALL create_my_ghost(h_mesh,la_h,h_ifrom)
136  CALL create_my_ghost(pmag_mesh,la_pmag,pmag_ifrom)
137  CALL create_my_ghost(phi_mesh,la_phi,phi_ifrom)
138 
139  !===Test if quasi-static approximation
140  IF (inputs%if_quasi_static_approx) THEN
141  dt = 1.d20*dt_in
142  ELSE IF (inputs%type_pb=="fhd") THEN
143  !TEST LC-CN 2016/12/15
144  dt = 1.d20*dt_in
145  !TEST LC-CN 2016/12/15
146  ELSE
147  dt = dt_in
148  END IF
149 
150  n = SIZE(h_ifrom)+SIZE(pmag_ifrom)+SIZE(phi_ifrom)
151  ALLOCATE(h_p_phi_ifrom(n))
152  IF (SIZE(h_ifrom)/=0) THEN
153  h_p_phi_ifrom(1:SIZE(h_ifrom)) = h_ifrom
154  END IF
155  IF (SIZE(pmag_ifrom)/=0) THEN
156  h_p_phi_ifrom(SIZE(h_ifrom)+1:SIZE(h_ifrom)+SIZE(pmag_ifrom)) = pmag_ifrom
157  END IF
158  IF (SIZE(phi_ifrom)/=0) THEN
159  h_p_phi_ifrom(SIZE(h_ifrom)+SIZE(pmag_ifrom)+1:)=phi_ifrom
160  END IF
161 
162  n = 3*h_mesh%dom_np + pmag_mesh%dom_np + phi_mesh%dom_np
163  CALL veccreateghost(comm_one_d(1), n, &
164  petsc_determine, SIZE(h_p_phi_ifrom), h_p_phi_ifrom, vx_1, ierr)
165  CALL vecghostgetlocalform(vx_1, vx_1_ghost, ierr)
166  CALL vecduplicate(vx_1, vb_1, ierr)
167  CALL veccreateghost(comm_one_d(1), n, &
168  petsc_determine, SIZE(h_p_phi_ifrom), h_p_phi_ifrom, vx_2, ierr)
169  CALL vecghostgetlocalform(vx_2, vx_2_ghost, ierr)
170  CALL vecduplicate(vx_2, vb_2, ierr)
171  !------------------------------------------------------------------------------
172 
173  !-------------RESCALING DE SIGMA-----------------------------------------------
174  ALLOCATE(sigma(SIZE(sigma_in)))
175  sigma = sigma_in * rem
176 
177  ! FL, 31/03/11
178  CALL mpi_allreduce(minval(sigma),sigma_min,1,mpi_double_precision, mpi_min,comm_one_d(1), ierr)
179  ! FL, 31/03/11
180  !------------------------------------------------------------------------------
181 
182  !-------------RESCALING DE STAB------------------------------------------------
183  !MARCH, 2010
184  !JLG+CN+LC Dec 14 2016, we redo the normalization
185  !stab = stab_in
186  !LC 2017/01/27
187  stab=stab_in/rem
188  !End LC 2017/01/27
189  !IF (inputs%type_pb=='mhd') THEN
190  ! ! FL, 31/03/11
191  ! stab = stab_in*(1/sigma_min+1.d0)
192  ! ! FL, 31/03/11
193  ! ! Velocity assume to be used as reference scale
194  ! !LC 2016/02/29
195  ! IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
196  ! stab = stab_in*(1/(MINVAL(inputs%sigma_fluid)*Rem)+1.d0)
197  ! END IF
198  ! !LC 2016/02/29
199  !ELSE
200  ! nr_vel = norm_SF(comm_one_d, 'L2', H_mesh, list_mode, vel)
201  !
202  ! IF (nr_vel .LE. 1.d-10) THEN
203  ! ! FL, 31/03/11
204  ! !stab = stab_in*(1/MINVAL(sigma))
205  ! stab = stab_in*(1/sigma_min)
206  ! ! FL, 31/03/11
207  ! !WRITE(*,*) 'case 1, stab = ',stab
208  ! ELSE
209  ! ! FL, 31/03/11
210  ! !stab = stab_in*(1/MINVAL(sigma)+1.d0)
211  ! stab = stab_in*(1/sigma_min+1.d0)
212  ! ! FL, 31/03/11
213  ! !WRITE(*,*) 'case 2, stab = ',stab
214  ! ENDIF
215  ! ! Velocity could be zero in case of Ohmic decay
216  ! END IF
217  !End JLG+CN+LC Dec 14 2016, we redo the normalization
218  !MARCH, 2010
219  !------------------------------------------------------------------------------
220 
221  !-------------DIMENSIONS-------------------------------------------------------
222  m_max_c = SIZE(list_mode)
223  !------------------------------------------------------------------------------
224 
225  !------------SIGMA IF LEVEL SET------------------------------------------------
226  ALLOCATE(sigma_nj_m(h_mesh%gauss%n_w,h_mesh%me))
227  IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
228  ALLOCATE(sigma_ns_bar(SIZE(hn,1)))
229  sigma_ns_bar = sigma_bar_in_fourier_space(h_mesh)*rem
230 
231  !===check if j=H_mesh%jj(nj,m) is in ns domain or not and define sigma in consequence
232  DO m = 1, h_mesh%me
233  DO nj = 1, h_mesh%gauss%n_w
234  j = h_mesh%jj(nj,m)
235  IF (jj_v_to_h(j) == -1) THEN
236  sigma_nj_m(nj,m) = sigma(m)
237  ELSE
238  sigma_nj_m(nj,m) = sigma_ns_bar(j)
239  END IF
240  END DO
241  END DO
242  ELSE
243  DO m = 1, h_mesh%me
244  sigma_nj_m(:,m) = sigma(m)
245  END DO
246  END IF
247  ALLOCATE(sigma_np(SIZE(hn,1)))
248  sigma_np = 0.d0
249  DO m = 1, h_mesh%me
250  DO nj = 1, h_mesh%gauss%n_w
251  sigma_np(h_mesh%jj(nj,m)) = sigma_nj_m(nj,m)
252  END DO
253  END DO
254 
255  !------------------------------------------------------------------------------
256 
257  !---------------BOUNDARY CONDITIONS FOR pmag-----------------------------------
258  ! Creation of Dirichlet boundary conditions for the magnetic pressure
259  ! Only on the boundary that is not periodic...
260  ALLOCATE (dir_pmag(maxval(pmag_mesh%sides)))
261  dir_pmag = .false.
262  DO ms = 1, SIZE(dir_pmag)
263  IF (minval(abs(inputs%list_dirichlet_sides_H-ms)) == 0) THEN
264  dir_pmag(ms) = .true.
265  END IF
266  IF (minval(abs(inputs%list_inter_H_phi-ms)) == 0) THEN
267  dir_pmag(ms) = .true.
268  END IF
269  END DO
270 
271  CALL dirichlet_nodes(pmag_mesh%jjs, pmag_mesh%sides, dir_pmag, pmag_js_d)
272  DEALLOCATE(dir_pmag)
273  !ALLOCATE(pmag_bv_D(SIZE(pmag_js_D)))
274  !pmag_bv_D = 0.d0
275  CALL scalar_with_bc_glob_js_d(pmag_mesh, list_mode, la_pmag, pmag_js_d, pmag_mode_global_js_d)
276  ALLOCATE(pmag_global_d(m_max_c))
277  DO i = 1, m_max_c
278  ALLOCATE(pmag_global_d(i)%DRL(SIZE(pmag_mode_global_js_d(i)%DIL)))
279  pmag_global_d(i)%DRL = 0.d0
280  END DO
281  ! End creation of Dirichlet boundary conditions for the magnetic pressure
282 
283  !===JLG+CN July 2017
284  !===Neuman BC for H
285  virgin1=.true.
286  virgin2=.true.
287  IF (interface_h_phi%mes/=0) THEN
288  virgin1(interface_h_phi%mesh1) = .false.
289  virgin2(interface_h_phi%mesh2) = .false.
290  END IF
291  IF (interface_h_mu%mes/=0) THEN
292  virgin1(interface_h_mu%mesh1) = .false.
293  virgin1(interface_h_mu%mesh2) = .false.
294  END IF
295  !===Create Neumann_bdy_H_sides
296  count = 0
297  DO ms = 1, h_mesh%mes
298  IF (maxval(abs(h_mesh%rr(1,h_mesh%jjs(:,ms)))).LT.1d-12*h_mesh%global_diameter) cycle ! No Neumann BC on the z-axis
299  IF (.NOT.virgin1(ms)) cycle ! No Neumann BC on H_mu interface
300  IF(minval(abs(h_mesh%sides(ms)-inputs%list_dirichlet_sides_H))==0) cycle ! Dirichlet boundary
301  !===JLG Jan 22 2018
302  IF (inputs%my_periodic%nb_periodic_pairs /=0) THEN
303  IF (minval(abs(inputs%my_periodic%list_periodic-h_mesh%sides(ms))) == 0) cycle !Periodic Boundary !JLG Jan 20 2018
304  END IF
305  !===JLG Jan 22 2018
306  count = count + 1
307  END DO
308  ALLOCATE(neumann_bdy_h_sides(count))
309  count = 0
310  DO ms = 1, h_mesh%mes
311  IF (maxval(abs(h_mesh%rr(1,h_mesh%jjs(:,ms)))).LT.1d-12*h_mesh%global_diameter) cycle
312  IF (.NOT.virgin1(ms)) cycle
313  IF(minval(abs(h_mesh%sides(ms)-inputs%list_dirichlet_sides_H))==0) cycle
314  !===JLG Jan 22 2018
315  IF (inputs%my_periodic%nb_periodic_pairs /=0) THEN
316  IF (minval(abs(inputs%my_periodic%list_periodic-h_mesh%sides(ms))) == 0) cycle !Periodic Boundary !JLG Jan 20 2018
317  END IF
318  !===JLG Jan 22 2018
319  count = count + 1
320  neumann_bdy_h_sides(count) = ms
321  END DO
322  !===Create Neumann_bdy_pmag_sides
323  count = 0
324  DO ms = 1, pmag_mesh%mes
325  IF (maxval(abs(pmag_mesh%rr(1,pmag_mesh%jjs(:,ms)))).LT.1d-12*pmag_mesh%global_diameter) cycle ! No Neumann BC on the z-axis
326  IF(minval(abs(pmag_mesh%sides(ms)-inputs%list_dirichlet_sides_H))==0) cycle ! Dirichlet boundary
327  IF(minval(abs(pmag_mesh%sides(ms)-inputs%list_inter_H_phi))==0) cycle ! No Neumann BC on H-phi interface
328  !===JLG Jan 22 2018
329  IF (inputs%my_periodic%nb_periodic_pairs /=0) THEN
330  IF (minval(abs(inputs%my_periodic%list_periodic-pmag_mesh%sides(ms))) == 0) cycle !Periodic Boundary !JLG Jan 20 2018
331  END IF
332  !===JLG Jan 22 2018
333  count = count + 1
334  END DO
335  ALLOCATE(neumann_bdy_pmag_sides(count))
336  count = 0
337  DO ms = 1, pmag_mesh%mes
338  IF (maxval(abs(pmag_mesh%rr(1,pmag_mesh%jjs(:,ms)))).LT.1d-12*pmag_mesh%global_diameter) cycle
339  IF(minval(abs(pmag_mesh%sides(ms)-inputs%list_dirichlet_sides_H))==0) cycle
340  IF(minval(abs(pmag_mesh%sides(ms)-inputs%list_inter_H_phi))==0) cycle
341  !===JLG Jan 22 2018
342  IF (inputs%my_periodic%nb_periodic_pairs /=0) THEN
343  IF (minval(abs(inputs%my_periodic%list_periodic-pmag_mesh%sides(ms))) == 0) cycle !Periodic Boundary !JLG Jan 20 2018
344  END IF
345  !===JLG Jan 22 2018
346  count = count + 1
347  neumann_bdy_pmag_sides(count) = ms
348  END DO
349  !===Create Neumann_bdy_phi_sides
350  count = 0
351  DO ms = 1, phi_mesh%mes
352  !IF (PRESENT(index_fourier)) THEN
353  IF (phi_mesh%sides(ms)==index_fourier) cycle ! No Neumann BC on Fourier boundary
354  !END IF
355  IF (.NOT.virgin2(ms)) cycle ! No Neumann BC on H_phi interface
356  IF (maxval(abs(phi_mesh%rr(1,phi_mesh%jjs(:,ms)))).LT.1d-12*phi_mesh%global_diameter) cycle ! No Neumann BC on the z-axis
357  IF (minval(abs(phi_mesh%sides(ms)-inputs%phi_list_dirichlet_sides))==0) cycle ! Dirichlet boundary
358  count = count + 1
359  END DO
360  ALLOCATE(neumann_bdy_phi_sides(count))
361  count = 0
362  DO ms = 1, phi_mesh%mes
363  !IF (PRESENT(index_fourier)) THEN
364  IF (phi_mesh%sides(ms)==index_fourier) cycle
365  !END IF
366  IF (.NOT.virgin2(ms)) cycle
367  IF (maxval(abs(phi_mesh%rr(1,phi_mesh%jjs(:,ms)))).LT.1d-12*phi_mesh%global_diameter) cycle
368  IF (minval(abs(phi_mesh%sides(ms)-inputs%phi_list_dirichlet_sides))==0) cycle ! Dirichlet boundary
369  count = count + 1
370  neumann_bdy_phi_sides(count) = ms
371  END DO
372  !===End Neuman BC for H
373 
374  !---------------BOUNDARY CONDITIONS FOR Hxn------------------------------------
375  !===Compute sides that are on Dirichlet boundary (H-H_D)xn=0
376  n = 0
377  DO ms = 1, h_mesh%mes
378  IF (minval(abs(h_mesh%sides(ms)-inputs%list_dirichlet_sides_H))/=0) cycle
379  IF (maxval(abs(h_mesh%rr(1,h_mesh%jjs(:,ms)))) .LT.1d-12*h_mesh%global_diameter) cycle
380  n = n + 1
381  END DO
382  ALLOCATE(dirichlet_bdy_h_sides(n))
383  n = 0
384  DO ms = 1, h_mesh%mes
385  IF (minval(abs(h_mesh%sides(ms)-inputs%list_dirichlet_sides_H))/=0) cycle
386  IF (maxval(abs(h_mesh%rr(1,h_mesh%jjs(:,ms)))) .LT.1d-12*h_mesh%global_diameter) cycle
387  n = n + 1
388  dirichlet_bdy_h_sides(n) = ms
389  END DO
390  !===BCs on axis for magnetic field
391  CALL vector_without_bc_glob_js_d(h_mesh, list_mode, la_h, h_mode_global_js_d)
392  ALLOCATE(h_global_d(m_max_c))
393  DO i = 1, m_max_c
394  ALLOCATE(h_global_d(i)%DRL(SIZE(h_mode_global_js_d(i)%DIL)))
395  END DO
396 
397  !---------PREPARE phi_js_D ARRAY FOR POTENTIAL---------------------------------
398  CALL dirichlet_nodes_parallel(phi_mesh, inputs%phi_list_dirichlet_sides, phi_js_d)
399  CALL dirichlet_cavities(comm_one_d(1), interface_h_phi, phi_mesh, phi_js_d)
400 !!$ ALLOCATE(phi_bv1_D(SIZE(phi_js_D)), phi_bv2_D(SIZE(phi_js_D)))
401  !===Account for BCs on axis
402  CALL scalar_with_bc_glob_js_d(phi_mesh, list_mode, la_phi, phi_js_d, phi_mode_global_js_d)
403  ALLOCATE(phi_global_d(m_max_c))
404  DO i = 1, m_max_c
405  ALLOCATE(phi_global_d(i)%DRL(SIZE(phi_mode_global_js_d(i)%DIL)))
406  phi_global_d(i)%DRL = 0.d0
407  END DO
408  !------------------------------------------------------------------------------
409 
410  !-------------MATRIX ALLOCATION------------------------------------------------
411  ALLOCATE(h_p_phi_mat1(m_max_c),h_p_phi_ksp1(m_max_c))
412  ALLOCATE(h_p_phi_mat2(m_max_c),h_p_phi_ksp2(m_max_c))
413 
414  IF (SIZE(dirichlet_bdy_h_sides).GE.1) THEN
415  ALLOCATE(sigma_curl_gauss_bdy(h_mesh%gauss%l_Gs*SIZE(dirichlet_bdy_h_sides),6,SIZE(list_mode)))
416  ALLOCATE(j_over_sigma_gauss_bdy(h_mesh%gauss%l_Gs*SIZE(dirichlet_bdy_h_sides),6,SIZE(list_mode)))
417  ELSE
418  ALLOCATE(sigma_curl_gauss_bdy(0,0,0))
419  ALLOCATE(j_over_sigma_gauss_bdy(0,0,0))
420  sigma_curl_gauss_bdy = 0.d0
421  j_over_sigma_gauss_bdy = 0.d0
422  END IF
423 
424  IF (interface_h_mu%mes.GE.1) THEN
425  ALLOCATE(sigma_curl_gauss_inter_mu(2*h_mesh%gauss%l_Gs*interface_h_mu%mes,6,SIZE(list_mode)))
426  ALLOCATE(j_over_sigma_gauss_inter_mu(2*h_mesh%gauss%l_Gs*interface_h_mu%mes,6,SIZE(list_mode)))
427  ELSE
428  ALLOCATE(sigma_curl_gauss_inter_mu(0,0,0))
429  ALLOCATE(j_over_sigma_gauss_inter_mu(0,0,0))
430  sigma_curl_gauss_inter_mu = 0.d0
431  j_over_sigma_gauss_inter_mu = 0.d0
432  END IF
433 
434  IF (SIZE(neumann_bdy_h_sides).GE.1) THEN
435  IF(my_petscworld_rank==0) THEN
436  WRITE(*,*) "WARNING, Neumann BC: either sigma or CURL(H)_Neumann is axisymmetric."
437  END IF
438  ALLOCATE(sigma_tot_gauss_neumann(h_mesh%gauss%l_Gs*SIZE(neumann_bdy_h_sides),2,SIZE(list_mode)))
439  ELSE
440  ALLOCATE(sigma_tot_gauss_neumann(0,0,0))
441  sigma_tot_gauss_neumann = 0.d0
442  END IF
443  !------------------------------------------------------------------------------
444 
445  DO i = 1, m_max_c !Boucle sur les modes
446  mode = list_mode(i)
447 
448  tps = user_time()
449  CALL create_local_petsc_matrix(comm_one_d(1), la_mhd, h_p_phi_mat1(i), clean=.false.)
450  CALL create_local_petsc_matrix(comm_one_d(1), la_mhd, h_p_phi_mat2(i), clean=.false.)
451  IF (i == 1) THEN
452  CALL create_local_petsc_matrix(comm_one_d(1), la_mhd, tampon1, clean=.false.)
453  CALL create_local_petsc_matrix(comm_one_d(1), la_mhd, tampon2, clean=.false.)
454  CALL create_local_petsc_matrix(comm_one_d(1), la_mhd, precond1, clean=.false.)
455  CALL create_local_petsc_matrix(comm_one_d(1), la_mhd, precond2, clean=.false.)
456  END IF
457 
458  tps = user_time() - tps
459 !!$ WRITE(*,*) ' Tps create_local_petsc_matrix', tps
460 
461  tps = user_time()
462  CALL mat_h_p_phi_maxwell(h_mesh,pmag_mesh,phi_mesh,interface_h_phi, &
463  mode,mu_h_field, mu_phi, one_and_half/dt, stab, r_fourier, index_fourier, &
464  la_h, la_pmag, la_phi, h_p_phi_mat1(i), h_p_phi_mat2(i), sigma_nj_m, sigma)
465  tps = user_time() - tps
466 
467  !Take care of discontinuous mu
468  tps = user_time()
469  CALL mat_maxwell_mu(h_mesh, jj_v_to_h, interface_h_mu, mode, stab, &
470  mu_h_field, sigma, la_h, h_p_phi_mat1(i), h_p_phi_mat2(i), sigma_np)
471  tps = user_time() - tps
472 
473 
474  tps = user_time()
475  CALL mat_dirichlet_maxwell(h_mesh, jj_v_to_h, dirichlet_bdy_h_sides, mode, &
476  stab, mu_h_field, la_h, h_p_phi_mat1(i), h_p_phi_mat2(i), sigma_np, sigma)
477 
478  IF (inputs%my_periodic%nb_periodic_pairs/=0) THEN
479  CALL periodic_matrix_petsc(h_phi_per%n_bord, h_phi_per%list, &
480  h_phi_per%perlist, h_p_phi_mat1(i), la_mhd)
481  CALL periodic_matrix_petsc(h_phi_per%n_bord, h_phi_per%list, &
482  h_phi_per%perlist, h_p_phi_mat2(i), la_mhd)
483  END IF
484  !!CALL error_Petsc('BUBU')!++++++++++++++++++++++++
485  tps = user_time()
486 !!$ CALL Dirichlet_M_parallel(H_p_phi_mat1(i),LA_pmag%loc_to_glob(1,pmag_js_D))
487 !!$ CALL Dirichlet_M_parallel(H_p_phi_mat1(i),LA_phi%loc_to_glob(1,phi_js_D))
488  CALL dirichlet_m_parallel(h_p_phi_mat1(i),pmag_mode_global_js_d(i)%DIL)
489  CALL dirichlet_m_parallel(h_p_phi_mat1(i),phi_mode_global_js_d(i)%DIL)
490  CALL dirichlet_m_parallel(h_p_phi_mat1(i),h_mode_global_js_d(i)%DIL)
491 !!$ CALL Dirichlet_M_parallel(H_p_phi_mat2(i),LA_pmag%loc_to_glob(1,pmag_js_D))
492 !!$ CALL Dirichlet_M_parallel(H_p_phi_mat2(i),LA_phi%loc_to_glob(1,phi_js_D))
493  CALL dirichlet_m_parallel(h_p_phi_mat2(i),pmag_mode_global_js_d(i)%DIL)
494  CALL dirichlet_m_parallel(h_p_phi_mat2(i),phi_mode_global_js_d(i)%DIL)
495  CALL dirichlet_m_parallel(h_p_phi_mat2(i),h_mode_global_js_d(i)%DIL)
496  tps = user_time() - tps
497 
498  tps = user_time()
499  CALL init_solver(inputs%my_par_H_p_phi,h_p_phi_ksp1(i),h_p_phi_mat1(i),comm_one_d(1),&
500  solver=inputs%my_par_H_p_phi%solver,precond=inputs%my_par_H_p_phi%precond)
501  CALL init_solver(inputs%my_par_H_p_phi,h_p_phi_ksp2(i),h_p_phi_mat2(i),comm_one_d(1),&
502  solver=inputs%my_par_H_p_phi%solver,precond=inputs%my_par_H_p_phi%precond)
503  tps = user_time() - tps
504 
505 !!$ !==================TEST===================
506  CALL matdestroy(h_p_phi_mat1(i),ierr)
507  CALL matdestroy(h_p_phi_mat2(i),ierr)
508  ENDDO
509 
510  !------------------------------------------------------------------------------
511  ENDIF ! End of once
512 
513  tps_tot = user_time()
514  tps_cumul = 0
515  CALL mpi_comm_rank(petsc_comm_world, my_petscworld_rank, code)
516 
517  !---Special treatment of Arpack
518  IF(inputs%if_arpack) THEN
519  IF (h_mesh%me/=0) THEN
520  IF (inputs%if_permeability_variable_in_theta) THEN
521  CALL mpi_comm_size(comm_one_d(2), nb_procs, code)
522  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
523  bloc_size = SIZE(b_ext,1)/nb_procs+1
524  CALL fft_par_var_eta_prod_t_dcl(comm_one_d(2), mu_in_real_space, &
525  h_mesh, hn, bn, nb_procs, bloc_size, m_max_pad, time,temps_par)
526  CALL fft_par_var_eta_prod_t_dcl(comm_one_d(2), mu_in_real_space, &
527  h_mesh, hn1, bn1, nb_procs, bloc_size, m_max_pad, time,temps_par)
528  ELSE
529  DO i = 1, m_max_c
530  DO k = 1, 6
531  bn(:,k,i) = mu_h_field*hn(:,k,i)
532  bn1(:,k,i) = mu_h_field*hn1(:,k,i)
533  END DO
534  END DO
535  END IF
536  END IF
537  END IF
538  !---End Special treatment of Arpack
539 
540  !-------------TRANSPORT TERM---------------------------------------------------
541  tps = user_time()
542  nr_vel = norm_sf(comm_one_d, 'L2', h_mesh, list_mode, vel)
543  !===Test if quasi-static approximation or not
544  IF(inputs%if_quasi_static_approx) THEN
545  DO i = 1, m_max_c
546  mode = list_mode(i)
547  b_ext(:,:,i) = h_b_quasi_static('B', h_mesh%rr, mode)
548  END DO
549  ELSE !===Real nonlinear MHD
550  b_ext = 2*bn - bn1
551  END IF
552 
553  IF (nr_vel .LE. 1.d-10) THEN
554  nl = 0.d0
555  ELSE IF (inputs%type_pb=="fhd") THEN
556  nl=0.d0
557  ELSE
558  CALL mpi_comm_size(comm_one_d(2), nb_procs, code)
559  bloc_size = SIZE(vel,1)/nb_procs+1
560  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
561 
562  CALL fft_par_cross_prod_dcl(comm_one_d(2), vel, b_ext, nl, nb_procs, bloc_size, &
563  m_max_pad,temps_par)
564  !NL = uxB
565  ENDIF
566 
567  IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
568  h_ns = 0.d0
569  one_over_sigma_tot = 0.d0
570  DO m = 1, h_mesh%me
571  DO nj = 1, h_mesh%gauss%n_w
572  j = h_mesh%jj(nj,m)
573  !Check if node is in Navier-Stokes domain(s)
574  IF (jj_v_to_h(j) /= -1) THEN
575  h_ns(j,:,:) = 2*hn(j,:,:)- hn1(j,:,:)
576  one_over_sigma_tot(j,:,:) = one_over_sigma_ns_in(jj_v_to_h(j),:,:)/rem
577  ELSE
578  DO i = 1, SIZE(list_mode)
579  mode = list_mode(i)
580  IF (mode==0) THEN
581  one_over_sigma_tot(j,1,i) = 1.d0/sigma(m)
582  END IF
583  END DO
584  END IF
585  END DO
586  END DO
587 
588  !===Compute (1/sigma_ns_bar - 1/sigma)*CURL(H_ns) in fluid domain and 0 elsewhere (gauss)
589  CALL smb_sigma_prod_curl(comm_one_d(2), h_mesh, jj_v_to_h, list_mode, h_ns, &
590  one_over_sigma_tot, sigma_nj_m, sigma, sigma_curl_gauss)
591  IF (SIZE(dirichlet_bdy_h_sides).GE.1) THEN
592  CALL smb_sigma_prod_curl_bdy(comm_one_d(2), h_mesh, jj_v_to_h, dirichlet_bdy_h_sides, list_mode, h_ns, &
593  one_over_sigma_tot, sigma_np, sigma, sigma_curl_gauss_bdy)
594  ELSE
595  sigma_curl_gauss_bdy = 0.d0
596  END IF
597  IF (interface_h_mu%mes.GE.1) THEN
598  CALL smb_sigma_prod_curl_inter_mu(comm_one_d(2), h_mesh, jj_v_to_h, interface_h_mu, list_mode, h_ns, &
599  one_over_sigma_tot, sigma_np, sigma, sigma_curl_gauss_inter_mu)
600  ELSE
601  sigma_curl_gauss_inter_mu = 0.d0
602  END IF
603 
604  !===Compute J/sigma
605  CALL smb_current_over_sigma(comm_one_d(2), h_mesh, jj_v_to_h, list_mode, b_ext,&
606  mu_h_field, mu_phi, one_over_sigma_tot, time, sigma, j_over_sigma_gauss)
607  IF (SIZE(dirichlet_bdy_h_sides).GE.1) THEN
608  CALL smb_current_over_sigma_bdy(comm_one_d(2), h_mesh, jj_v_to_h, dirichlet_bdy_h_sides,&
609  list_mode, b_ext, mu_h_field, mu_phi, one_over_sigma_tot, time, sigma,&
610  j_over_sigma_gauss_bdy)
611  ELSE
612  j_over_sigma_gauss_bdy = 0.d0
613  END IF
614  IF (interface_h_mu%mes.GE.1) THEN
615  CALL smb_current_over_sigma_inter_mu(comm_one_d(2), h_mesh, jj_v_to_h, interface_h_mu,&
616  list_mode, b_ext, mu_h_field, mu_phi, one_over_sigma_tot, time, sigma,&
617  j_over_sigma_gauss_inter_mu)
618  ELSE
619  j_over_sigma_gauss_inter_mu=0.d0
620  END IF
621 
622  !===Compute sigma at the gauss points on Neumann bdy
623  IF (SIZE(neumann_bdy_h_sides).GE.1) THEN
624  CALL smb_sigma_neumann(comm_one_d(2), h_mesh, neumann_bdy_h_sides,&
625  list_mode, one_over_sigma_tot, sigma_tot_gauss_neumann)
626  ELSE
627  sigma_tot_gauss_neumann = 0.d0
628  END IF
629  ELSE
630  sigma_curl_gauss = 0.d0
631  sigma_curl_gauss_bdy = 0.d0
632  sigma_curl_gauss_inter_mu = 0.d0
633  j_over_sigma_gauss = 0.d0
634  j_over_sigma_gauss_bdy = 0.d0
635  j_over_sigma_gauss_inter_mu= 0.d0
636  sigma_tot_gauss_neumann = 0.d0
637  END IF
638 
639  IF (inputs%if_permeability_variable_in_theta) THEN
640  h_pert=0.d0
641  CALL mpi_comm_size(comm_one_d(2), nb_procs, code)
642  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
643  bloc_size = SIZE(b_ext,1)/nb_procs+1
644  !H_pert = (- 1/mu)B* at nodes.
645  CALL fft_par_var_eta_prod_t_dcl(comm_one_d(2), minus_one_over_mu, &
646  h_mesh, b_ext, h_pert, nb_procs, bloc_size, m_max_pad, time,temps_par)
647  END IF
648 
649  tps = user_time() - tps; tps_cumul=tps_cumul+tps
650  !WRITE(*,*) ' Tps NLS_SFT Maxwell', tps
651  !------------------------------------------------------------------------------
652 
653  !-------------SOLUTION OF LINEAR SYSTEMS---------------------------------------
654  DO i = 1, m_max_c
655 
656  mode = list_mode(i)
657 
658  !-------------SOURCES TERMS----------------------------------------------------
659  tps = user_time()
660  DO k = 1, 6
661  rhs_h(:,k) = (4*bn(:,k,i)-bn1(:,k,i))/(2*dt)
662  END DO
663  DO k = 1, 2
664  rhs_phi(:,k) = mu_phi*(4*phin(:,k,i)-phin1(:,k,i))/(2*dt)
665  END DO
666  !-------------Integration by parts of the scalar potential------------------
667  CALL courant_int_by_parts(h_mesh,phi_mesh,interface_h_phi,sigma,mu_phi,mu_h_field,time,mode, &
668  rhs_h, nl(:,:,i), la_h, la_phi, vb_1, vb_2, b_ext(:,:,i), h_pert(:,:,i), &
669  sigma_curl_gauss(:,:,i), j_over_sigma_gauss(:,:,i))
670 !!$ ! Feb 2010, JLG + FL
671 !!$ CALL courant_int_by_parts(H_mesh,phi_mesh,interface_H_phi,sigma,mu_phi,mu_H_field,time,mode, &
672 !!$ rhs_H, NL(:,:,i), LA_H, LA_phi, vb_1, vb_2, B_ext(:,:,i), H_pert(:,:,i))
673 
674  !-------------Integration by parts of the scalar potential------------------
675 
676  tps = user_time() - tps; tps_cumul=tps_cumul+tps
677  !WRITE(*,*) ' Tps courant', tps
678  !Takes care of discontinuous mu
679  tps = user_time()
680  CALL courant_mu(h_mesh, interface_h_mu, sigma, mu_h_field, time, mode, nl(:,:,i), &
681  la_h, vb_1, vb_2, b_ext(:,:,i), j_over_sigma_gauss_inter_mu(:,:,i), &
682  sigma_curl_gauss_inter_mu(:,:,i))
683 
684  tps = user_time() - tps; tps_cumul=tps_cumul+tps
685 !!$ WRITE(*,*) ' Tps courant_mu', tps
686 
687  !JLG, FL, Feb 10, 2011
688  !Take care of Dirichlet conditions on H (H x n = Hd x n)
689  CALL rhs_dirichlet(h_mesh, dirichlet_bdy_h_sides, &
690  sigma, mu_h_field, time, mode, nl(:,:,i), stab, la_h, vb_1,vb_2, b_ext(:,:,i), &
691  j_over_sigma_gauss_bdy(:,:,i), sigma_curl_gauss_bdy(:,:,i))
692 
693  !------------------------------------------------------------------------------
694 
695  !-------------INTERFACE INTEGRAL-----------------------------------------------
696  tps = user_time()
697  !===JLG Jan 22 2018
698  !CALL surf_int(H_mesh,phi_mesh,interface_H_phi,interface_H_mu,inputs%list_dirichlet_sides_H, &
699  ! sigma,mu_phi,mu_H_field, time,mode,LA_H, LA_phi,vb_1,vb_2, R_fourier, index_fourier)
700  CALL surf_int(h_mesh, phi_mesh, pmag_mesh, interface_h_phi, interface_h_mu, inputs%list_dirichlet_sides_H, &
701  sigma, mu_phi, mu_h_field, time, mode, la_h, la_phi, la_pmag, vb_1, vb_2, &
702  sigma_tot_gauss_neumann(:,:,i), r_fourier, index_fourier)
703  !===JLG Jan 22 2018
704  tps = user_time() - tps; tps_cumul=tps_cumul+tps
705 !!$ WRITE(*,*) ' Tps surf_int', tps
706  !------------------------------------------------------------------------------
707 
708  !---------------------PERIODIC-------------------
709 !!$ IF (per) THEN
710  IF (inputs%my_periodic%nb_periodic_pairs/=0) THEN
711  CALL periodic_rhs_petsc(h_phi_per%n_bord, h_phi_per%list, h_phi_per%perlist, vb_1, la_mhd)
712  CALL periodic_rhs_petsc(h_phi_per%n_bord, h_phi_per%list, h_phi_per%perlist, vb_2, la_mhd)
713  END IF
714 
715  !-------------DIRICHLET BOUNDARY CONDITIONS-------------------------------------
716  tps = user_time()
717 !!$ CALL dirichlet_rhs(LA_pmag%loc_to_glob(1,pmag_js_D)-1, pmag_bv_D,vb_1)
718 !!$ CALL dirichlet_rhs(LA_pmag%loc_to_glob(1,pmag_js_D)-1, pmag_bv_D,vb_2)
719  pmag_global_d(i)%DRL = 0.d0
720  CALL dirichlet_rhs(pmag_mode_global_js_d(i)%DIL-1,pmag_global_d(i)%DRL,vb_1)
721  CALL dirichlet_rhs(pmag_mode_global_js_d(i)%DIL-1,pmag_global_d(i)%DRL,vb_2)
722 
723  IF (SIZE(phi_js_d)>0) THEN
724 !!$ phi_bv1_D = Phiexact(1,phi_mesh%rr(1:2,phi_js_D), mode, mu_phi, time)
725 !!$ phi_bv2_D = Phiexact(2,phi_mesh%rr(:,phi_js_D), mode, mu_phi, time)
726  !===Recall that axis nodes are at the end of the array
727  n = SIZE(phi_js_d)
728  phi_global_d(i)%DRL(1:n) = phiexact(1,phi_mesh%rr(1:2,phi_js_d), mode, mu_phi, time)
729  IF (SIZE(phi_global_d(i)%DRL)>n) phi_global_d(i)%DRL(n+1:)=0.d0
730  CALL dirichlet_rhs(la_phi%loc_to_glob(1,phi_js_d)-1, phi_global_d(i)%DRL, vb_1)
731  phi_global_d(i)%DRL(1:n) = phiexact(2,phi_mesh%rr(1:2,phi_js_d), mode, mu_phi, time)
732  IF (SIZE(phi_global_d(i)%DRL)>n) phi_global_d(i)%DRL(n+1:)=0.d0
733  CALL dirichlet_rhs(la_phi%loc_to_glob(1,phi_js_d)-1, phi_global_d(i)%DRL, vb_2)
734  ELSE
735 !!$ phi_bv1_D = 0.d0
736 !!$ phi_bv2_D = 0.d0
737  phi_global_d(i)%DRL=0.d0
738  CALL dirichlet_rhs(la_phi%loc_to_glob(1,phi_js_d)-1, phi_global_d(i)%DRL, vb_1)
739  CALL dirichlet_rhs(la_phi%loc_to_glob(1,phi_js_d)-1, phi_global_d(i)%DRL, vb_2)
740  END IF
741 
742  !===Axis boundary conditions on magnetic field
743  h_global_d(i)%DRL = 0.d0
744  CALL dirichlet_rhs(h_mode_global_js_d(i)%DIL-1,h_global_d(i)%DRL,vb_1)
745  CALL dirichlet_rhs(h_mode_global_js_d(i)%DIL-1,h_global_d(i)%DRL,vb_2)
746 
747  tps = user_time() - tps; tps_cumul=tps_cumul+tps
748 !!$ WRITE(*,*) ' Tps bcs', tps
749  !-------------------------------------------------------------------------------
750 
751  !-------------SOLVING THE LINEAR SYSTEMS----------------------------------------
752  IF (inputs%my_par_H_p_phi%verbose .AND. (i==1)) WRITE(*,*) 'start solving'
753  tps = user_time()
754 
755  CALL solver(h_p_phi_ksp1(i),vb_1,vx_1,reinit=.false.,verbose=inputs%my_par_H_p_phi%verbose)
756 
757  CALL vecghostupdatebegin(vx_1,insert_values,scatter_forward,ierr)
758  CALL vecghostupdateend(vx_1,insert_values,scatter_forward,ierr)
759  IF (h_mesh%me/=0) THEN
760  CALL extract(vx_1_ghost,1,1,la_mhd,hn_p1(:,1))
761  CALL extract(vx_1_ghost,2,2,la_mhd,hn_p1(:,4))
762  CALL extract(vx_1_ghost,3,3,la_mhd,hn_p1(:,5))
763  END IF
764  IF (phi_mesh%me/=0) THEN
765  CALL extract(vx_1_ghost,5,5,la_mhd,phin_p1(:,1))
766  END IF
767 
768  CALL solver(h_p_phi_ksp2(i),vb_2,vx_2,reinit=.false.,verbose=inputs%my_par_H_p_phi%verbose)
769  CALL vecghostupdatebegin(vx_2,insert_values,scatter_forward,ierr)
770  CALL vecghostupdateend(vx_2,insert_values,scatter_forward,ierr)
771  IF (h_mesh%me/=0) THEN
772  CALL extract(vx_2_ghost,1,1,la_mhd,hn_p1(:,2))
773  CALL extract(vx_2_ghost,2,2,la_mhd,hn_p1(:,3))
774  CALL extract(vx_2_ghost,3,3,la_mhd,hn_p1(:,6))
775  END IF
776  IF (phi_mesh%me/=0) THEN
777  CALL extract(vx_2_ghost,5,5,la_mhd,phin_p1(:,2))
778  END IF
779 
780  tps = user_time() - tps; tps_cumul=tps_cumul+tps
781  !WRITE(*,*) ' Tps solve Maxwell', tps
782  !-------------------------------------------------------------------------------
783 
784 
785  !-------------UPDATE------------------------------------------------------------
786  !JLG AR, Dec 18 2008
787  IF (mode==0) THEN
788  IF (h_mesh%me /=0) THEN
789  hn_p1(:,2) = 0.d0
790  hn_p1(:,4) = 0.d0
791  hn_p1(:,6) = 0.d0
792  END IF
793  IF (phi_mesh%me /=0 ) THEN
794  phin_p1(:,2) = 0.d0
795  END IF
796  END IF
797  !JLG AR, Dec 18 2008
798 
799  !FAKE FAKE FAKE
800 !!$ DO k = 1, 6
801 !!$ Hn_p1(:,k) = Hn_p1(:,k)/mu_H_field
802 !!$ END DO
803  !FAKE FAKE FAKE
804 
805  tps = user_time()
806  IF (h_mesh%me /=0) THEN
807  hn1(:,:,i) = hn(:,:,i)
808 
809 !!$ Hn(:,1,i) = Hn_p1(:,1)
810 !!$ Hn(:,4,i) = Hn_p1(:,4)
811 !!$ Hn(:,5,i) = Hn_p1(:,5)
812 !!$
813 !!$ Hn(:,2,i) = Hn_p1(:,2)
814 !!$ Hn(:,3,i) = Hn_p1(:,3)
815 !!$ Hn(:,6,i) = Hn_p1(:,6)
816 
817  bn1(:,:,i) = bn(:,:,i)
818 
819  bn(:,1,i) = hn_p1(:,1)
820  bn(:,4,i) = hn_p1(:,4)
821  bn(:,5,i) = hn_p1(:,5)
822 
823  bn(:,2,i) = hn_p1(:,2)
824  bn(:,3,i) = hn_p1(:,3)
825  bn(:,6,i) = hn_p1(:,6)
826 
827  END IF
828 
829  IF (phi_mesh%me /= 0) THEN
830  phin1(:,:,i) = phin(:,:,i)
831 
832  phin(:,1,i) = phin_p1(:,1)
833 
834  phin(:,2,i) = phin_p1(:,2)
835  END IF
836  tps = user_time() - tps; tps_cumul=tps_cumul+tps
837  !WRITE(*,*) ' Tps update', tps
838  !------------------------------------------------------------------------------
839 
840  ENDDO
841 
842  IF (h_mesh%me /=0) THEN
843  IF (inputs%if_permeability_variable_in_theta) THEN
844  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
845  bloc_size = SIZE(bn,1)/nb_procs+1
846  CALL fft_par_var_eta_prod_t_dcl(comm_one_d(2), one_over_mu, &
847  h_mesh, bn, hn, nb_procs, bloc_size, m_max_pad, time,temps_par)
848  ELSE
849  DO i = 1, m_max_c
850  DO k = 1, 6
851  hn(:,k,i) = bn(:,k,i)/mu_h_field
852  END DO
853  END DO
854  END IF
855  END IF
856 
857  !===Verbose divergence of velocity
858  IF (inputs%verbose_divergence) THEN
859  norm = norm_sf(comm_one_d, 'L2', h_mesh, list_mode, bn)
860  talk_to_me%div_B_L2 = norm_sf(comm_one_d, 'div', h_mesh, list_mode, bn)/norm
861  talk_to_me%time=time
862  END IF
863 
864  tps_tot = user_time() - tps_tot
865 !!$ WRITE(*,'(A,2(f13.3,2x),10(I3,x))') ' Tps boucle en temps Maxwell', tps_tot, tps_cumul, list_mode
866 !!$ WRITE(*,*) ' TIME = ', time, '========================================'
867 
868  END SUBROUTINE maxwell_decouple_with_b
869 
870  SUBROUTINE mat_h_p_phi_maxwell(H_mesh, pmag_mesh, phi_mesh, interface_H_phi, &
871  mode, mu_h_field, mu_phi, c_mass, stab, r_fourier, index_fourier, &
872  la_h, la_pmag, la_phi, h_p_phi_mat1, h_p_phi_mat2, sigma_nj_m, sigma)
873  USE def_type_mesh
874  USE dir_nodes
875  USE gauss_points
876  USE boundary
877  USE input_data
878 #include "petsc/finclude/petsc.h"
879  USE petsc
880  IMPLICIT NONE
881  TYPE(mesh_type), INTENT(IN) :: H_mesh
882  TYPE(mesh_type), INTENT(IN) :: pmag_mesh
883  TYPE(mesh_type), INTENT(IN) :: phi_mesh
884  TYPE(interface_type), INTENT(IN) :: interface_H_phi
885  INTEGER, INTENT(IN) :: mode
886  REAL(KIND=8), INTENT(IN) :: mu_phi, c_mass
887  REAL(KIND=8), DIMENSION(3), INTENT(IN) :: stab
888  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
889  REAL(KIND=8), DIMENSION(H_mesh%gauss%n_w,H_mesh%me), INTENT(IN) :: sigma_nj_m
890  REAL(KIND=8), DIMENSION(H_mesh%me),INTENT(IN):: sigma
891  REAL(KIND=8), OPTIONAL :: R_fourier
892  INTEGER, OPTIONAL :: index_fourier
893  REAL(KIND=8), DIMENSION(phi_mesh%gauss%n_ws,phi_mesh%gauss%l_Gs) :: w_cs
894  REAL(KIND=8), DIMENSION(2, H_mesh%gauss%n_w, phi_mesh%gauss%l_Gs, H_mesh%mes) :: dw_cs
895  INTEGER :: m, l, ms, ls, ni, nj, k, i, j, &
896  n_ws1, n_ws2, n_w2, n_w1, m1, m2, ki, kj,ib,jb, ms1, ms2
897  REAL(KIND=8) :: x, y, hm1, stab_div, stab_colle_H_phi
898  REAL(KIND=8) :: ray, error
899  LOGICAL :: mark=.false.
900  REAL(KIND=8), DIMENSION(3,H_mesh%gauss%n_w,pmag_mesh%gauss%n_w) :: THpmag
901  REAL(KIND=8), DIMENSION(pmag_mesh%gauss%n_w,pmag_mesh%gauss%n_w) :: Tpmag
902  REAL(KIND=8), DIMENSION(9,H_mesh%gauss%n_w,H_mesh%gauss%n_w) :: TH
903  REAL(KIND=8), DIMENSION(9,H_mesh%gauss%n_w,H_mesh%gauss%n_w) :: HtoB
904  REAL(KIND=8), DIMENSION(phi_mesh%gauss%n_w,phi_mesh%gauss%n_w):: TPhi
905 
906  !MATRICES POUR LES TERMES DE VOLUMES c_mass*B + Rot((1/sigma)Rot(B/mu)) - Grad(Div(H))
907  ! -c_mass*mu_phi*Lap(Phi)
908  !========================================================================
909  !Le probleme est decouple en deux sous groupes de variables :
910  !H1, H4, H5 et Phi1 d'une part et H2, H3, H6 et Phi2 d'autre part.
911  !Les matrices (symetriques sans terme de bord) s'ecrivent :
912 
913  !MATRICE 1 ::
914  ! (------------------------------)
915  ! ( TH1 | TH2 | TH3 | | ) H1
916  ! ( | TH4 | TH5 | | ) H4
917  ! ( | TH6 | | ) H5
918  ! ( | Tpmag | ) P1
919  ! ( |TPhi) Phi1
920  ! (------------------------------)
921 
922  !MATRICE 2 (TH2 => TH8 et TH5 => TH9::
923  ! (------------------------)
924  ! ( TH1 | TH8 | TH3 | | ) H2
925  ! ( | TH4 | TH9 | | ) H3
926  ! ( | TH6 | | ) H6
927  ! ( | Tpmag | ) P2
928  ! ( | |TPhi) Phi2
929  ! (------------------------------)
930  !=========================================================================
931 
932  REAL(KIND=8), DIMENSION(9,H_mesh%gauss%n_w,H_mesh%gauss%n_w) :: Hsij
933  REAL(KIND=8), DIMENSION(phi_mesh%gauss%n_w,phi_mesh%gauss%n_w) :: Phisij
934  REAL(KIND=8), DIMENSION(6,phi_mesh%gauss%n_w,phi_mesh%gauss%n_w) :: Sij
935  REAL(KIND=8), DIMENSION(6,phi_mesh%gauss%n_w,phi_mesh%gauss%n_w) :: Smuij
936  ! MATRICES POUR LES TERMES DE BORDS Hsij et Phisij
937  !=================================================
938  ! (--------------------------------------------------------------------)
939  ! ( Hsij(1) | Hsij(2) | Hsij(4) || Sij(1) )
940  ! ( Hsij(1) | Hsij(3) | Hsij(4) || Sij(2) )
941  ! (--------------------------------------------------------------------)
942  ! ( | Hsij(5) | || Sij(3) )
943  ! ( | Hsij(5) | || Sij(4) )
944  ! (--------------------------------------------------------------------)
945  ! ( Hsij(7) | Hsij(9) | Hsij(6) || Sij(5) )
946  ! ( Hsij(7) | Hsij(8) | Hsij(6) || Sij(6) )
947  ! (====================================================================)
948  ! ( Sij'(1) | Sij'(3) | Sij'(5) || Phisij )
949  ! ( Sij'(2) | Sij'(4) | Sij'(6) || Phisij )
950  ! (------------------------------------------------------------------- )
951  !
952  ! L'autre partie des termes croises est la symetrique de la premiere
953  ! juste apres le calcul du terme de bord dissymetrique
954 
955  !fonctions de forme propres a H_mesh
956  REAL(KIND=8), DIMENSION(:,:), POINTER :: ww_H
957  !derivees des fonctions de forme propres a H_mesh
958  REAL(KIND=8), DIMENSION(:,:,:,:), POINTER :: dw_H
959  !jacobien pour H
960  REAL(KIND=8), DIMENSION(:,:), POINTER :: rj_H
961  !fonctions de forme propres a phi_mesh
962  REAL(KIND=8), DIMENSION(:,:), POINTER :: ww_phi
963  !derivees des fonctions de forme propres a phi_mesh
964  REAL(KIND=8), DIMENSION(:,:,:,:), POINTER :: dw_phi
965  !REAL(KIND=8), DIMENSION(2,H_mesh%gauss%n_w,H_mesh%gauss%l_G) :: dwp !JLG Jan 22 2018
966  !REAL(KIND=8), DIMENSION(H_mesh%gauss%n_w,H_mesh%gauss%l_G) :: wwp !JLG Jan 22 2018
967  REAL(KIND=8), DIMENSION(2,pmag_mesh%gauss%n_w,H_mesh%gauss%l_G) :: dwp
968  REAL(KIND=8), DIMENSION(pmag_mesh%gauss%n_w,H_mesh%gauss%l_G) :: wwp
969  !jacobien pour phi
970  REAL(KIND=8), DIMENSION(:,:), POINTER :: rj_phi
971  REAL(KIND=8), DIMENSION(2,phi_mesh%gauss%l_Gs) :: gauss1, gauss2
972  INTEGER :: ls1, ls2
973  REAL(KIND=8) :: ref, diff, mu_H, c_mu_phi, muhl, &
974  dzmuhl, drmuhl, c_div, hloc, viscolm, xij, eps
975  !June 8 2008
976  REAL(KIND=8) :: c_sym=.0d0 ! Symmetrization of the bilinear form
977  !June 8 2008
978  !June 2009, JLG, CN, Normalization
979  REAL(KIND=8) :: c_lap
980  !June 2009, JLG, CN
981 !!$ FL + CN 22/03/2013
982 !!$ REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: mat_loc1, mat_loc2
983 !!$ INTEGER , DIMENSION(:), ALLOCATABLE :: idxn, jdxn
984  REAL(KIND=8), DIMENSION(3*H_mesh%gauss%n_w+pmag_mesh%gauss%n_w+ & phi_mesh%gauss%n_w , 3*H_mesh%gauss%n_w+pmag_mesh%gauss%n_w+ & phi_mesh%gauss%n_w) :: mat_loc1, mat_loc2
985  INTEGER , DIMENSION(3*H_mesh%gauss%n_w+pmag_mesh%gauss%n_w+ & phi_mesh%gauss%n_w) :: idxn, jdxn
986 !!$ FL + CN 22/03/2013
987  TYPE(petsc_csr_la) :: LA_H, LA_pmag, LA_phi
988  INTEGER :: n_wpmag, n_wH, n_wphi, ix, jx
989  !DCQ Exact mu
990  REAL(KIND=8), DIMENSION(2) :: Dmu_field
991  REAL(KIND=8), DIMENSION(2) :: gauss_pt
992  INTEGER, DIMENSION(1) :: gauss_pt_id
993  REAL(KIND=8), DIMENSION(1) :: dummy_mu_bar
994  INTEGER ::mesh_id
995  !LC 2016/03/25
996  REAL(KIND=8) :: sigma_np_gauss
997  !LC 2016/03/25
998  mat :: h_p_phi_mat1, h_p_phi_mat2
999  petscerrorcode :: ierr
1000  CALL matzeroentries (h_p_phi_mat1, ierr)
1001  CALL matzeroentries (h_p_phi_mat2, ierr)
1002  CALL matsetoption (h_p_phi_mat1, mat_row_oriented, petsc_false, ierr)
1003  CALL matsetoption (h_p_phi_mat2, mat_row_oriented, petsc_false, ierr)
1004 
1005  !June 2009, JLG, CN, Normalization
1006  c_lap = .1d0
1007  stab_colle_h_phi = stab(2)
1008  stab_div = stab(1)
1009  !Jan 2010, JLG, CN, Normalization,
1010 
1011  c_mu_phi = c_mass*mu_phi
1012 
1013  ww_h => h_mesh%gauss%ww
1014  dw_h => h_mesh%gauss%dw
1015  rj_h => h_mesh%gauss%rj
1016  ww_phi => phi_mesh%gauss%ww
1017  dw_phi => phi_mesh%gauss%dw
1018  rj_phi => phi_mesh%gauss%rj
1019 
1020  n_wh = h_mesh%gauss%n_w
1021  n_wpmag = pmag_mesh%gauss%n_w
1022  n_wphi = phi_mesh%gauss%n_w
1023 
1024  !==Block on H
1025 !!$ ALLOCATE(mat_loc1(3*n_wH+n_wpmag+n_wphi,3*n_wH+n_wpmag+n_wphi))
1026 !!$ ALLOCATE(mat_loc2(3*n_wH+n_wpmag+n_wphi,3*n_wH+n_wpmag+n_wphi))
1027 !!$ ALLOCATE(jdxn(3*n_wH+n_wpmag+n_wphi),idxn(3*n_wH+n_wpmag+n_wphi))
1028  DO m = 1, h_mesh%me
1029  mesh_id = h_mesh%i_d(m)
1030 
1031  th = 0.d0
1032  htob=0.d0
1033 
1034  DO l = 1, h_mesh%gauss%l_G
1035  !JLG+CN Dec 14 2016
1036  !hloc = SQRT(SUM(H_mesh%gauss%rj(:,m)))**(2*alpha)
1037  hloc = (sqrt(sum(h_mesh%gauss%rj(:,m)))/h_mesh%global_diameter)**(2*alpha)
1038  !End JLG+CN Dec 14 2016
1039  !===Compute radius of Gauss point
1040  !Feb 8 2007, muhl
1041  !DCQ Exact mu
1042  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
1043  muhl = sum(mu_h_field(h_mesh%jj(:,m))*ww_h(:,l))
1044  drmuhl = sum(mu_h_field(h_mesh%jj(:,m))*dw_h(1,:,l,m))
1045  dzmuhl = sum(mu_h_field(h_mesh%jj(:,m))*dw_h(2,:,l,m))
1046  ELSE
1047  gauss_pt(1)=sum(h_mesh%rr(1,h_mesh%jj(:,m))*ww_h(:,l))
1048  gauss_pt(2)=sum(h_mesh%rr(2,h_mesh%jj(:,m))*ww_h(:,l))
1049  gauss_pt_id=mesh_id
1050  dummy_mu_bar(:) = mu_bar_in_fourier_space(h_mesh,1,1,gauss_pt,gauss_pt_id)
1051  muhl=dummy_mu_bar(1)
1052  dmu_field = grad_mu_bar_in_fourier_space(gauss_pt,gauss_pt_id)
1053  drmuhl =dmu_field(1)
1054  dzmuhl =dmu_field(2)
1055  ENDIF
1056  sigma_np_gauss = sum(sigma_nj_m(:,m)*ww_h(:,l))
1057 
1058  !DCQ DEBUG
1059  !===JLG (Nov 14, 2016); remove this warning. We may work with dimensional variables
1060  !if ( muhl < 0.5d0) then
1061  ! write(*,*)'!! Warning: mu_bar is almost negative in the matrix construction, value = ', muhl
1062  !end if
1063 
1064  !June 7 2008, Normalization, JLG, FL, May, 28, 2009
1065  !c_div = stab_div*hloc
1066  !JG+CN+LC 2016/12/14
1067  !c_div = stab_div*hloc/(muhl**2*sigma_np_gauss)
1068  !LC 2017/01/29
1069  c_div = stab_div*hloc/(inputs%mu_min**2*inputs%sigma_min)
1070  !End LC 2017/01/27
1071  !June 7 2008, Normalization
1072 
1073  ray = 0
1074  DO ni = 1, h_mesh%gauss%n_w; i = h_mesh%jj(ni,m)
1075  ray = ray + h_mesh%rr(1,i)*ww_h(ni,l)
1076  END DO
1077 
1078  DO ni = 1, h_mesh%gauss%n_w
1079  DO nj = 1, h_mesh%gauss%n_w
1080 
1081  ! TEST
1082  th(1,ni,nj) = th(1,ni,nj) + rj_h(l,m) * ray* ( &
1083  c_mass*ww_h(ni,l)*ww_h(nj,l) &
1084  + (dw_h(2,ni,l,m)*dw_h(2,nj,l,m) + mode**2/ray**2*ww_h(ni,l)*ww_h(nj,l))/(sigma_np_gauss*muhl) &
1085  !+ c_div*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl) &
1086  !+ c_div*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0) &
1087  + c_div*(muhl*(ww_h(ni,l)/ray+dw_h(1,ni,l,m)) + ww_h(ni,l)*0) &
1088  *(ww_h(nj,l)/ray+dw_h(1,nj,l,m))) &
1089  + rj_h(l,m) * ray* ( &
1090  (dw_h(2,ni,l,m)*dzmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1091 
1092 
1093  th(2,ni,nj) = th(2,ni,nj)+ rj_h(l,m) * ray* ( &
1094  mode/ray**2 * ww_h(ni,l)*(ww_h(nj,l)+ray*dw_h(1,nj,l,m))/(sigma_np_gauss*muhl) &
1095  !+ c_div*mode/ray*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl)*ww_H(nj,l)) &
1096  !+ c_div*mode/ray*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*ww_H(nj,l)) &
1097  + c_div*mode/ray*(muhl*(ww_h(ni,l)/ray+dw_h(1,ni,l,m)) + ww_h(ni,l)*0)*ww_h(nj,l)) &
1098  + rj_h(l,m) * ray* ( &
1099  ((mode/ray)*ww_h(ni,l)*drmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1100 
1101  htob(2,ni,nj) = htob(2,ni,nj)+ rj_h(l,m) * ray* ( &
1102  - mode/ray**2 * ww_h(ni,l)*(ww_h(nj,l)+ray*dw_h(1,nj,l,m))/(sigma_np_gauss*muhl) &
1103  !- c_div*mode/ray*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl)*ww_H(nj,l)) &
1104  !- c_div*mode/ray*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*ww_H(nj,l)) &
1105  - c_div*mode/ray*(muhl*(ww_h(ni,l)/ray+dw_h(1,ni,l,m)) + ww_h(ni,l)*0)*ww_h(nj,l)) &
1106  - rj_h(l,m) * ray* ( &
1107  ((mode/ray)*ww_h(ni,l)*drmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1108 
1109  th(3,ni,nj) = th(3,ni,nj)+ rj_h(l,m) * ray* ( &
1110  - dw_h(2,ni,l,m)*dw_h(1,nj,l,m)/(sigma_np_gauss*muhl) &
1111  !+ c_div*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl)*(dw_H(2,nj,l,m))) &
1112  !+ c_div*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*(dw_H(2,nj,l,m))) &
1113  + c_div*(muhl*(ww_h(ni,l)/ray+dw_h(1,ni,l,m)) + ww_h(ni,l)*0)*(dw_h(2,nj,l,m))) &
1114  + rj_h(l,m) * ray* ( &
1115  - dw_h(2,ni,l,m)*drmuhl*ww_h(nj,l)*(-1/(sigma_np_gauss*muhl**2)))
1116 
1117  th(4,ni,nj) = th(4,ni,nj)+ rj_h(l,m) * ray* ( &
1118  mode/ray**2 * ww_h(nj,l)*(ww_h(ni,l)+ray*dw_h(1,ni,l,m))/(sigma_np_gauss*muhl) &
1119  !+ c_div*(mode/ray)*ww_H(ni,l)*muhl*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1120  !+ c_div*(mode/ray)*ww_H(ni,l)*1*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1121  + c_div*(mode/ray)*ww_h(ni,l)*muhl*(ww_h(nj,l)/ray+dw_h(1,nj,l,m)))
1122 
1123  htob(4,ni,nj) = htob(4,ni,nj)+ rj_h(l,m) * ray* ( &
1124  - mode/ray**2 * ww_h(nj,l)*(ww_h(ni,l)+ray*dw_h(1,ni,l,m))/(sigma_np_gauss*muhl) &
1125  !- c_div*(mode/ray)*ww_H(ni,l)*muhl*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1126  !- c_div*(mode/ray)*ww_H(ni,l)*1*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1127  - c_div*(mode/ray)*ww_h(ni,l)*muhl*(ww_h(nj,l)/ray+dw_h(1,nj,l,m)))
1128 
1129  th(5,ni,nj) = th(5,ni,nj) + rj_h(l,m) * ray* ( &
1130  c_mass*ww_h(ni,l)*ww_h(nj,l) &
1131  + (dw_h(2,ni,l,m)*dw_h(2,nj,l,m) &
1132  + 1/ray**2*(ww_h(ni,l)+ray*dw_h(1,ni,l,m))*(ww_h(nj,l)+ray*dw_h(1,nj,l,m)))/(sigma_np_gauss*muhl) &
1133  !+c_div*muhl*mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l)) &
1134  !+c_div*1*mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l)) &
1135  +c_div*muhl*mode**2/ray**2*ww_h(ni,l)*ww_h(nj,l)) &
1136  + rj_h(l,m)*ray*((dw_h(2,ni,l,m)*dzmuhl*ww_h(nj,l) &
1137  + (ww_h(ni,l)/ray+dw_h(1,ni,l,m))*drmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1138 
1139  th(6,ni,nj) = th(6,ni,nj) + rj_h(l,m) * ray* (&
1140  + mode/ray*dw_h(2,ni,l,m)*ww_h(nj,l)/(sigma_np_gauss*muhl) &
1141  !+c_div*mode/ray*muhl*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1142  !+c_div*mode/ray*1*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1143  +c_div*mode/ray*muhl*ww_h(ni,l)*(dw_h(2,nj,l,m)))
1144 
1145  htob(6,ni,nj) = htob(6,ni,nj) + rj_h(l,m) * ray* (&
1146  - mode/ray*dw_h(2,ni,l,m)*ww_h(nj,l)/(sigma_np_gauss*muhl) &
1147  !- c_div*mode/ray*muhl*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1148  !- c_div*mode/ray*1*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1149  - c_div*mode/ray*muhl*ww_h(ni,l)*(dw_h(2,nj,l,m)))
1150 
1151  th(7,ni,nj) = th(7,ni,nj)+ rj_h(l,m) * ray* ( &
1152  - dw_h(1,ni,l,m)*dw_h(2,nj,l,m)/(sigma_np_gauss*muhl) &
1153  !+ c_div*(muhl*dw_H(2,ni,l,m)+dzmuhl*ww_H(ni,l))*(ww_H(nj,l)/ray+dw_H(1,nj,l,m))) &
1154  !+ c_div*(1*dw_H(2,ni,l,m)+0*ww_H(ni,l))*(ww_H(nj,l)/ray+dw_H(1,nj,l,m))) &
1155  + c_div*(muhl*dw_h(2,ni,l,m)+0*ww_h(ni,l))*(ww_h(nj,l)/ray+dw_h(1,nj,l,m))) &
1156  + rj_h(l,m)*ray*((-dw_h(1,ni,l,m)*dzmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1157 
1158  th(8,ni,nj) = th(8,ni,nj) + rj_h(l,m) * ray* (&
1159  + (mode/ray)*ww_h(ni,l)*dw_h(2,nj,l,m)/(sigma_np_gauss*muhl) &
1160  !+ c_div*mode/ray*muhl*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1161  !+ c_div*mode/ray*1*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1162  + c_div*mode/ray*muhl*ww_h(nj,l)*(dw_h(2,ni,l,m))) &
1163  + rj_h(l,m)*ray*(((mode/ray)*ww_h(ni,l)*dzmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1164  !DCQ (Nov 13 2013). Sign mistake
1165  !+ rj_H(l,m)*ray*((-(mode/ray)*ww_H(ni,l)*dzmuhl*ww_H(nj,l))*(-1/(sigma_nj_m(nj,m)*muhl**2)))
1166 
1167  htob(8,ni,nj) = htob(8,ni,nj) + rj_h(l,m) * ray* (&
1168  - mode/ray*dw_h(2,nj,l,m)*ww_h(ni,l)/(sigma_np_gauss*muhl) &
1169  !- c_div*mode/ray*muhl*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1170  !- c_div*mode/ray*1*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1171  - c_div*mode/ray*muhl*ww_h(nj,l)*(dw_h(2,ni,l,m))) &
1172  - rj_h(l,m)*ray*(((mode/ray)*ww_h(ni,l)*dzmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1173  !DCQ (Nov 13 2013). Sign mistake
1174  !- rj_H(l,m)*ray*((-(mode/ray)*ww_H(ni,l)*dzmuhl*ww_H(nj,l))*(-1/(sigma_nj_m(nj,m)*muhl**2)))
1175 
1176  th(9,ni,nj) = th(9,ni,nj) + rj_h(l,m) * ray* ( &
1177  c_mass*ww_h(ni,l)*ww_h(nj,l) &
1178  + (mode**2/ray**2*ww_h(ni,l)*ww_h(nj,l) + dw_h(1,ni,l,m)*dw_h(1,nj,l,m))/(sigma_np_gauss*muhl) &
1179  !+ c_div*(muhl*dw_H(2,ni,l,m) + ww_H(ni,l)*dzmuhl)*(dw_H(2,nj,l,m))) &
1180  !+ c_div*(1*dw_H(2,ni,l,m) + ww_H(ni,l)*0)*(dw_H(2,nj,l,m))) &
1181  + c_div*(muhl*dw_h(2,ni,l,m) + ww_h(ni,l)*0)*(dw_h(2,nj,l,m))) &
1182  + rj_h(l,m)*ray*((dw_h(1,ni,l,m)*drmuhl*ww_h(nj,l))*(-1/(sigma_np_gauss*muhl**2)))
1183 
1184  ! TEST
1185 
1186 !!$ TH(1,ni,nj) = TH(1,ni,nj) + rj_H(l,m) * ray* ( &
1187 !!$ c_mass*ww_H(ni,l)*ww_H(nj,l) &
1188 !!$ + (dw_H(2,ni,l,m)*dw_H(2,nj,l,m) + mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l))/(sigma(m)*muhl) &
1189 !!$ !+ c_div*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl) &
1190 !!$ !+ c_div*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0) &
1191 !!$ + c_div*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0) &
1192 !!$ *(ww_H(nj,l)/ray+dw_H(1,nj,l,m))) &
1193 !!$ + rj_H(l,m) * ray* ( &
1194 !!$ (dw_H(2,ni,l,m)*dzmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1195 !!$
1196 !!$ TH(2,ni,nj) = TH(2,ni,nj)+ rj_H(l,m) * ray* ( &
1197 !!$ mode/ray**2 * ww_H(ni,l)*(ww_H(nj,l)+ray*dw_H(1,nj,l,m))/(sigma(m)*muhl) &
1198 !!$ !+ c_div*mode/ray*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl)*ww_H(nj,l)) &
1199 !!$ !+ c_div*mode/ray*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*ww_H(nj,l)) &
1200 !!$ + c_div*mode/ray*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*ww_H(nj,l)) &
1201 !!$ + rj_H(l,m) * ray* ( &
1202 !!$ ((mode/ray)*ww_H(ni,l)*drmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1203 !!$
1204 !!$ HtoB(2,ni,nj) = HtoB(2,ni,nj)+ rj_H(l,m) * ray* ( &
1205 !!$ - mode/ray**2 * ww_H(ni,l)*(ww_H(nj,l)+ray*dw_H(1,nj,l,m))/(sigma(m)*muhl) &
1206 !!$ !- c_div*mode/ray*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl)*ww_H(nj,l)) &
1207 !!$ !- c_div*mode/ray*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*ww_H(nj,l)) &
1208 !!$ - c_div*mode/ray*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*ww_H(nj,l)) &
1209 !!$ - rj_H(l,m) * ray* ( &
1210 !!$ ((mode/ray)*ww_H(ni,l)*drmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1211 !!$
1212 !!$ TH(3,ni,nj) = TH(3,ni,nj)+ rj_H(l,m) * ray* ( &
1213 !!$ - dw_H(2,ni,l,m)*dw_H(1,nj,l,m)/(sigma(m)*muhl) &
1214 !!$ !+ c_div*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*drmuhl)*(dw_H(2,nj,l,m))) &
1215 !!$ !+ c_div*(1*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*(dw_H(2,nj,l,m))) &
1216 !!$ + c_div*(muhl*(ww_H(ni,l)/ray+dw_H(1,ni,l,m)) + ww_H(ni,l)*0)*(dw_H(2,nj,l,m))) &
1217 !!$ + rj_H(l,m) * ray* ( &
1218 !!$ - dw_H(2,ni,l,m)*drmuhl*ww_H(nj,l)*(-1/(sigma(m)*muhl**2)))
1219 !!$
1220 !!$ TH(4,ni,nj) = TH(4,ni,nj)+ rj_H(l,m) * ray* ( &
1221 !!$ mode/ray**2 * ww_H(nj,l)*(ww_H(ni,l)+ray*dw_H(1,ni,l,m))/(sigma(m)*muhl) &
1222 !!$ !+ c_div*(mode/ray)*ww_H(ni,l)*muhl*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1223 !!$ !+ c_div*(mode/ray)*ww_H(ni,l)*1*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1224 !!$ + c_div*(mode/ray)*ww_H(ni,l)*muhl*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1225 !!$
1226 !!$ HtoB(4,ni,nj) = HtoB(4,ni,nj)+ rj_H(l,m) * ray* ( &
1227 !!$ - mode/ray**2 * ww_H(nj,l)*(ww_H(ni,l)+ray*dw_H(1,ni,l,m))/(sigma(m)*muhl) &
1228 !!$ !- c_div*(mode/ray)*ww_H(ni,l)*muhl*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1229 !!$ !- c_div*(mode/ray)*ww_H(ni,l)*1*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1230 !!$ - c_div*(mode/ray)*ww_H(ni,l)*muhl*(ww_H(nj,l)/ray+dw_H(1,nj,l,m)))
1231 !!$
1232 !!$ TH(5,ni,nj) = TH(5,ni,nj) + rj_H(l,m) * ray* ( &
1233 !!$ c_mass*ww_H(ni,l)*ww_H(nj,l) &
1234 !!$ + (dw_H(2,ni,l,m)*dw_H(2,nj,l,m) &
1235 !!$ + 1/ray**2*(ww_H(ni,l)+ray*dw_H(1,ni,l,m))*(ww_H(nj,l)+ray*dw_H(1,nj,l,m)))/(sigma(m)*muhl) &
1236 !!$ !+c_div*muhl*mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l)) &
1237 !!$ !+c_div*1*mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l)) &
1238 !!$ +c_div*muhl*mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l)) &
1239 !!$ + rj_H(l,m)*ray*((dw_H(2,ni,l,m)*dzmuhl*ww_H(nj,l) &
1240 !!$ + (ww_H(ni,l)/ray+dw_H(1,ni,l,m))*drmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1241 !!$
1242 !!$ TH(6,ni,nj) = TH(6,ni,nj) + rj_H(l,m) * ray* (&
1243 !!$ + mode/ray*dw_H(2,ni,l,m)*ww_H(nj,l)/(sigma(m)*muhl) &
1244 !!$ !+c_div*mode/ray*muhl*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1245 !!$ !+c_div*mode/ray*1*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1246 !!$ +c_div*mode/ray*muhl*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1247 !!$
1248 !!$ HtoB(6,ni,nj) = HtoB(6,ni,nj) + rj_H(l,m) * ray* (&
1249 !!$ - mode/ray*dw_H(2,ni,l,m)*ww_H(nj,l)/(sigma(m)*muhl) &
1250 !!$ !- c_div*mode/ray*muhl*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1251 !!$ !- c_div*mode/ray*1*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1252 !!$ - c_div*mode/ray*muhl*ww_H(ni,l)*(dw_H(2,nj,l,m)))
1253 !!$
1254 !!$ TH(7,ni,nj) = TH(7,ni,nj)+ rj_H(l,m) * ray* ( &
1255 !!$ - dw_H(1,ni,l,m)*dw_H(2,nj,l,m)/(sigma(m)*muhl) &
1256 !!$ !+ c_div*(muhl*dw_H(2,ni,l,m)+dzmuhl*ww_H(ni,l))*(ww_H(nj,l)/ray+dw_H(1,nj,l,m))) &
1257 !!$ !+ c_div*(1*dw_H(2,ni,l,m)+0*ww_H(ni,l))*(ww_H(nj,l)/ray+dw_H(1,nj,l,m))) &
1258 !!$ + c_div*(muhl*dw_H(2,ni,l,m)+0*ww_H(ni,l))*(ww_H(nj,l)/ray+dw_H(1,nj,l,m))) &
1259 !!$ + rj_H(l,m)*ray*((-dw_H(1,ni,l,m)*dzmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1260 !!$
1261 !!$ TH(8,ni,nj) = TH(8,ni,nj) + rj_H(l,m) * ray* (&
1262 !!$ + (mode/ray)*ww_H(ni,l)*dw_H(2,nj,l,m)/(sigma(m)*muhl) &
1263 !!$ !+ c_div*mode/ray*muhl*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1264 !!$ !+ c_div*mode/ray*1*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1265 !!$ + c_div*mode/ray*muhl*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1266 !!$ + rj_H(l,m)*ray*((-(mode/ray)*ww_H(ni,l)*dzmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1267 !!$
1268 !!$ HtoB(8,ni,nj) = HtoB(8,ni,nj) + rj_H(l,m) * ray* (&
1269 !!$ - mode/ray*dw_H(2,nj,l,m)*ww_H(ni,l)/(sigma(m)*muhl) &
1270 !!$ !- c_div*mode/ray*muhl*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1271 !!$ !- c_div*mode/ray*1*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1272 !!$ - c_div*mode/ray*muhl*ww_H(nj,l)*(dw_H(2,ni,l,m))) &
1273 !!$ - rj_H(l,m)*ray*((-(mode/ray)*ww_H(ni,l)*dzmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1274 !!$
1275 !!$ TH(9,ni,nj) = TH(9,ni,nj) + rj_H(l,m) * ray* ( &
1276 !!$ c_mass*ww_H(ni,l)*ww_H(nj,l) &
1277 !!$ + (mode**2/ray**2*ww_H(ni,l)*ww_H(nj,l) + dw_H(1,ni,l,m)*dw_H(1,nj,l,m))/(sigma(m)*muhl) &
1278 !!$ !+ c_div*(muhl*dw_H(2,ni,l,m) + ww_H(ni,l)*dzmuhl)*(dw_H(2,nj,l,m))) &
1279 !!$ !+ c_div*(1*dw_H(2,ni,l,m) + ww_H(ni,l)*0)*(dw_H(2,nj,l,m))) &
1280 !!$ + c_div*(muhl*dw_H(2,ni,l,m) + ww_H(ni,l)*0)*(dw_H(2,nj,l,m))) &
1281 !!$ + rj_H(l,m)*ray*((dw_H(1,ni,l,m)*drmuhl*ww_H(nj,l))*(-1/(sigma(m)*muhl**2)))
1282  ENDDO
1283  END DO
1284  END DO
1285 
1286  mat_loc1 = 0.d0
1287  mat_loc2 = 0.d0
1288  DO ki= 1, 3
1289  DO ni = 1, n_wh
1290  i = h_mesh%jj(ni, m)
1291  ib = la_h%loc_to_glob(ki,i)
1292  ix = (ki-1)*n_wh+ni
1293  idxn(ix) = ib - 1
1294  DO kj = 1, 3
1295  DO nj = 1, n_wh
1296  j = h_mesh%jj(nj, m)
1297  jb = la_h%loc_to_glob(kj,j)
1298  jx = (kj-1)*n_wh+nj
1299  jdxn(jx) = jb - 1
1300 
1301  IF ((ki == 1) .AND. (kj == 1)) THEN
1302  mat_loc1(ix,jx) = th(1,ni,nj)
1303  mat_loc2(ix,jx) = th(1,ni,nj)
1304  ELSEIF ((ki == 1) .AND. (kj == 2)) THEN
1305  mat_loc1(ix,jx) = th(2,ni,nj)
1306  mat_loc2(ix,jx) = htob(2,ni,nj)
1307  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
1308  mat_loc1(ix,jx) = th(3,ni,nj)
1309  mat_loc2(ix,jx) = th(3,ni,nj)
1310  ELSEIF ((ki == 2) .AND. (kj == 1)) THEN
1311  mat_loc1(ix,jx) = th(4,ni,nj)
1312  mat_loc2(ix,jx) = htob(4,ni,nj)
1313  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
1314  mat_loc1(ix,jx) = th(5,ni,nj)
1315  mat_loc2(ix,jx) = th(5,ni,nj)
1316  ELSEIF ((ki == 2) .AND. (kj == 3)) THEN
1317  mat_loc1(ix,jx) = th(6,ni,nj)
1318  mat_loc2(ix,jx) = htob(6,ni,nj)
1319  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
1320  mat_loc1(ix,jx) = th(7,ni,nj)
1321  mat_loc2(ix,jx) = th(7,ni,nj)
1322  ELSEIF ((ki == 3) .AND. (kj == 2)) THEN
1323  mat_loc1(ix,jx) = th(8,ni,nj)
1324  mat_loc2(ix,jx) = htob(8,ni,nj)
1325  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
1326  mat_loc1(ix,jx) = th(9,ni,nj)
1327  mat_loc2(ix,jx) = th(9,ni,nj)
1328  ENDIF
1329 
1330  END DO
1331  END DO
1332  END DO
1333  END DO
1334  CALL matsetvalues(h_p_phi_mat1, 3*n_wh, idxn(1:3*n_wh), 3*n_wh, jdxn(1:3*n_wh), &
1335  mat_loc1(1:3*n_wh,1:3*n_wh), add_values, ierr)
1336  CALL matsetvalues(h_p_phi_mat2, 3*n_wh, idxn(1:3*n_wh), 3*n_wh, jdxn(1:3*n_wh), &
1337  mat_loc2(1:3*n_wh,1:3*n_wh), add_values, ierr)
1338  END DO
1339 
1340  ! Block on Pmag
1341  DO m = 1, pmag_mesh%me
1342  tpmag = 0.d0
1343 
1344  !JLG+CN Dec 14 2016
1345  !hloc = stab_div*SQRT(SUM(pmag_mesh%gauss%rj(:,m)))**(2*(1-alpha))
1346  hloc = stab_div*(sqrt(sum(pmag_mesh%gauss%rj(:,m)))/pmag_mesh%global_diameter)**(2*(1-alpha))
1347  mesh_id = pmag_mesh%i_d(m)
1348  !End JLG+CN Dec 14 2016
1349 
1350  DO l = 1, pmag_mesh%gauss%l_G
1351 
1352  !JLG+CN Dec 14 2016
1353  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
1354  muhl = sum(mu_h_field(h_mesh%jj(1:3,m))*pmag_mesh%gauss%ww(:,l))
1355  ELSE
1356  gauss_pt(1)=sum(pmag_mesh%rr(1,pmag_mesh%jj(:,m))*pmag_mesh%gauss%ww(:,l))
1357  gauss_pt(2)=sum(pmag_mesh%rr(2,pmag_mesh%jj(:,m))*pmag_mesh%gauss%ww(:,l))
1358  gauss_pt_id=mesh_id
1359  dummy_mu_bar(:) = mu_bar_in_fourier_space(pmag_mesh,1,1,gauss_pt,gauss_pt_id)
1360  muhl=dummy_mu_bar(1)
1361  ENDIF
1362  sigma_np_gauss = sum(sigma_nj_m(1:3,m)*pmag_mesh%gauss%ww(:,l))!Recall that pmag is P1
1363 
1364  !Normalization
1365  !muhl = 1 ! SUM(mu_H_field(H_mesh%jj(1:3,m))*pmag_mesh%gauss%ww(1:3,l))
1366  !JLG + DCQ, July 17, 2013 (this should be the proper normalization)
1367 !!!!!!!!!!!!!!muhl = SUM(mu_H_field(H_mesh%jj(1:3,m))*pmag_mesh%gauss%ww(1:3,l))
1368  !Normalization
1369  !End JLG+CN Dec 14 2016
1370 
1371  !===Compute radius of Gauss point
1372  ray = 0
1373  DO ni = 1, pmag_mesh%gauss%n_w
1374  i = pmag_mesh%jj(ni,m)
1375  ray = ray + pmag_mesh%rr(1,i)*pmag_mesh%gauss%ww(ni,l)
1376  END DO
1377  !viscolm = muhl*hloc*pmag_mesh%gauss%rj(l,m)
1378  !JLG+CN Dec 14 2016
1379  !viscolm = (pmag_mesh%global_diameter)**2*muhl**2*sigma_np_gauss*hloc*pmag_mesh%gauss%rj(l,m)
1380  !End JLG+CN Dec 14 2016
1381  !LC 2017/01/29
1382  viscolm = (pmag_mesh%global_diameter)**2*inputs%mu_min**2*inputs%sigma_min*hloc*pmag_mesh%gauss%rj(l,m)
1383  !End LC 2017/01/29
1384  DO nj = 1, pmag_mesh%gauss%n_w
1385  j = pmag_mesh%jj(nj, m)
1386  DO ni = 1, pmag_mesh%gauss%n_w
1387  i = pmag_mesh%jj(ni, m)
1388  !grad(u).grad(v) en r et z
1389  xij = 0.d0
1390  DO k = 1, 2
1391  xij = xij + pmag_mesh%gauss%dw(k,nj,l,m) * pmag_mesh%gauss%dw(k,ni,l,m)
1392  END DO
1393  !blocs diagonaux
1394  tpmag(ni,nj) = tpmag(ni,nj) + ray * viscolm* xij &
1395  + viscolm*mode**2*pmag_mesh%gauss%ww(ni,l)*pmag_mesh%gauss%ww(nj,l)/ray
1396  ENDDO
1397  ENDDO
1398  ENDDO
1399 
1400  DO ni = 1, pmag_mesh%gauss%n_w
1401  i = pmag_mesh%jj(ni, m)
1402  ib = la_pmag%loc_to_glob(1,i)
1403  idxn(ni) = ib - 1
1404  DO nj = 1, pmag_mesh%gauss%n_w
1405  j = pmag_mesh%jj(nj, m)
1406  jb = la_pmag%loc_to_glob(1,j)
1407  jdxn(nj) = jb - 1
1408  END DO
1409  END DO
1410  CALL matsetvalues(h_p_phi_mat1, n_wpmag, idxn(1:n_wpmag), n_wpmag, jdxn(1:n_wpmag), &
1411  tpmag(1:n_wpmag,1:n_wpmag), add_values, ierr)
1412  CALL matsetvalues(h_p_phi_mat2, n_wpmag, idxn(1:n_wpmag), n_wpmag, jdxn(1:n_wpmag), &
1413  tpmag(1:n_wpmag,1:n_wpmag), add_values, ierr)
1414  ENDDO
1415  ! End Block on PmagxPmag
1416 
1417  ! Block on PmagxH and HxPmag
1418  DO m = 1, pmag_mesh%me
1419  mesh_id = h_mesh%i_d(m)
1420  IF (h_mesh%gauss%n_w==3) THEN
1421  dwp=h_mesh%gauss%dw(:,:,:,m)
1422  wwp=h_mesh%gauss%ww
1423  ELSE
1424  dwp(:,1,:) = h_mesh%gauss%dw(:,1,:,m) + 0.5d0*(h_mesh%gauss%dw(:,5,:,m)+h_mesh%gauss%dw(:,6,:,m))
1425  dwp(:,2,:) = h_mesh%gauss%dw(:,2,:,m) + 0.5d0*(h_mesh%gauss%dw(:,6,:,m)+h_mesh%gauss%dw(:,4,:,m))
1426  dwp(:,3,:) = h_mesh%gauss%dw(:,3,:,m) + 0.5d0*(h_mesh%gauss%dw(:,4,:,m)+h_mesh%gauss%dw(:,5,:,m))
1427  wwp(1,:) = h_mesh%gauss%ww(1,:) + 0.5d0*(h_mesh%gauss%ww(5,:)+h_mesh%gauss%ww(6,:))
1428  wwp(2,:) = h_mesh%gauss%ww(2,:) + 0.5d0*(h_mesh%gauss%ww(6,:)+h_mesh%gauss%ww(4,:))
1429  wwp(3,:) = h_mesh%gauss%ww(3,:) + 0.5d0*(h_mesh%gauss%ww(4,:)+h_mesh%gauss%ww(5,:))
1430  END IF
1431 
1432  thpmag = 0.d0
1433  DO l = 1, h_mesh%gauss%l_G
1434  ray = 0.d0
1435  DO ni = 1, h_mesh%gauss%n_w
1436  i = h_mesh%jj(ni,m)
1437  ray = ray + h_mesh%rr(1,i)*h_mesh%gauss%ww(ni,l)
1438  END DO
1439  !JLG + DCQ (normalization tests)
1440  !DCQ: Exact mu
1441  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
1442  muhl = stab_div*ray*h_mesh%gauss%rj(l,m)*sum(mu_h_field(h_mesh%jj(:,m))*h_mesh%gauss%ww(:,l))
1443  !muhl = stab_div*ray*H_mesh%gauss%rj(l,m)
1444  ELSE
1445  gauss_pt(1)=sum(h_mesh%rr(1,h_mesh%jj(:,m))*ww_h(:,l))
1446  gauss_pt(2)=sum(h_mesh%rr(2,h_mesh%jj(:,m))*ww_h(:,l))
1447  gauss_pt_id(1)=mesh_id
1448  dummy_mu_bar(:) = mu_bar_in_fourier_space(h_mesh,1,1,gauss_pt,gauss_pt_id)
1449  muhl=dummy_mu_bar(1)
1450  muhl = stab_div*ray*h_mesh%gauss%rj(l,m)*muhl
1451  ENDIF
1452  DO nj = 1, pmag_mesh%gauss%n_w
1453  j = pmag_mesh%jj(nj, m)
1454  DO ni = 1, h_mesh%gauss%n_w
1455  i = h_mesh%jj(ni, m)
1456  thpmag(1,ni,nj) = thpmag(1,ni,nj) + muhl*dwp(1,nj,l)*h_mesh%gauss%ww(ni,l)
1457  thpmag(2,ni,nj) = thpmag(2,ni,nj) - muhl*mode*wwp(nj,l)*h_mesh%gauss%ww(ni,l)/ray
1458  thpmag(3,ni,nj) = thpmag(3,ni,nj) + muhl*dwp(2,nj,l)*h_mesh%gauss%ww(ni,l)
1459  END DO
1460  END DO
1461  END DO
1462 
1463  mat_loc1 = 0.d0
1464  mat_loc2 = 0.d0
1465  idxn = 0
1466  jdxn = 0
1467  DO ni = 1, n_wh
1468  i = h_mesh%jj(ni, m)
1469  DO k = 1, 3
1470  IF (k==2) THEN
1471  eps=-1
1472  ELSE
1473  eps=1
1474  END IF
1475  ib = la_h%loc_to_glob(k,i)
1476  ix = (k-1)*n_wh + ni
1477  idxn(ix) = ib - 1
1478  DO nj = 1, n_wpmag
1479  j = pmag_mesh%jj(nj, m)
1480  jb = la_pmag%loc_to_glob(1,j)
1481  jx = nj
1482  jdxn(jx) = jb - 1
1483  mat_loc1(ix,jx) = thpmag(k,ni,nj)
1484  mat_loc2(ix,jx) = eps*thpmag(k,ni,nj)
1485  END DO
1486  END DO
1487  END DO
1488 
1489  CALL matsetvalues(h_p_phi_mat1, 3*n_wh, idxn(1:3*n_wh), n_wpmag, jdxn(1:n_wpmag), &
1490  mat_loc1(1:3*n_wh,1:n_wpmag), add_values, ierr)
1491  CALL matsetvalues(h_p_phi_mat2, 3*n_wh, idxn(1:3*n_wh), n_wpmag, jdxn(1:n_wpmag), &
1492  mat_loc2(1:3*n_wh,1:n_wpmag), add_values, ierr)
1493 
1494  !H to B
1495  thpmag = 0.d0
1496  DO l = 1, h_mesh%gauss%l_G
1497  ray = 0.d0
1498  DO ni = 1, h_mesh%gauss%n_w
1499  i = h_mesh%jj(ni,m)
1500  ray = ray + h_mesh%rr(1,i)*h_mesh%gauss%ww(ni,l)
1501  END DO
1502  x = stab_div*ray*h_mesh%gauss%rj(l,m)
1503  DO nj = 1, h_mesh%gauss%n_w
1504  j = h_mesh%jj(nj, m)
1505  DO ni = 1, pmag_mesh%gauss%n_w
1506  i = pmag_mesh%jj(ni, m)
1507  thpmag(1,nj,ni) = thpmag(1,nj,ni) - x*dwp(1,ni,l)*h_mesh%gauss%ww(nj,l)
1508  thpmag(2,nj,ni) = thpmag(2,nj,ni) + x*mode*wwp(ni,l)*h_mesh%gauss%ww(nj,l)/ray
1509  thpmag(3,nj,ni) = thpmag(3,nj,ni) - x*dwp(2,ni,l)*h_mesh%gauss%ww(nj,l)
1510  END DO
1511  END DO
1512  END DO
1513 
1514  mat_loc1 = 0.d0
1515  mat_loc2 = 0.d0
1516  DO ni = 1, n_wpmag
1517  i = pmag_mesh%jj(ni, m)
1518  ib = la_pmag%loc_to_glob(1,i)
1519  ix = ni
1520  idxn(ix) = ib - 1
1521  DO k = 1, 3
1522  IF (k==2) THEN
1523  eps=-1
1524  ELSE
1525  eps=1
1526  END IF
1527  DO nj = 1, n_wh
1528  j = h_mesh%jj(nj, m)
1529  jb = la_h%loc_to_glob(k,j)
1530  jx = (k-1)*n_wh + nj
1531  jdxn(jx) = jb - 1
1532  mat_loc1(ix,jx) = thpmag(k,nj,ni)
1533  mat_loc2(ix,jx) = eps*thpmag(k,nj,ni)
1534  END DO
1535  END DO
1536  END DO
1537  CALL matsetvalues(h_p_phi_mat1, n_wpmag, idxn(1:n_wpmag), 3*n_wh, jdxn(1:3*n_wh), &
1538  mat_loc1(1:n_wpmag,1:3*n_wh), add_values, ierr)
1539  CALL matsetvalues(h_p_phi_mat2, n_wpmag, idxn(1:n_wpmag), 3*n_wh, jdxn(1:3*n_wh), &
1540  mat_loc2(1:n_wpmag,1:3*n_wh), add_values, ierr)
1541  !H to B
1542 
1543  END DO
1544  ! End Block on PmagxH and HxPmag
1545 
1546  !==Block on phi
1547  DO m = 1,phi_mesh%me
1548 
1549  tphi = 0.d0
1550 
1551  DO l = 1, phi_mesh%gauss%l_G
1552 
1553  !===Compute radius of Gauss point
1554  ray = 0
1555  DO ni = 1, phi_mesh%gauss%n_w; i = phi_mesh%jj(ni,m)
1556  ray = ray + phi_mesh%rr(1,i)*ww_phi(ni,l)
1557  END DO
1558 
1559  DO ni = 1, phi_mesh%gauss%n_w
1560  DO nj = 1, phi_mesh%gauss%n_w
1561 
1562  !mu_phi * <Grad bi, Grad bj>
1563  !JLG, FL May 28, 2009
1564  !On ajoute le laplacien de phi.
1565  !TPhi(ni,nj) = TPhi(ni,nj) + rj_phi(l,m) * ray* (c_mu_phi) &
1566  ! *(dw_phi(1,ni,l,m)*dw_phi(1,nj,l,m)+dw_phi(2,ni,l,m)*dw_phi(2,nj,l,m) &
1567  ! +mode**2/ray**2*ww_phi(ni,l)*ww_phi(nj,l))
1568  tphi(ni,nj) = tphi(ni,nj) + rj_phi(l,m) * ray* (c_mass+c_lap)*mu_phi &
1569  *(dw_phi(1,ni,l,m)*dw_phi(1,nj,l,m)+dw_phi(2,ni,l,m)*dw_phi(2,nj,l,m) &
1570  +mode**2/ray**2*ww_phi(ni,l)*ww_phi(nj,l))
1571  !JLG, FL May 28, 2009
1572  ENDDO
1573  END DO
1574 
1575  END DO
1576 
1577  DO ni = 1, phi_mesh%gauss%n_w
1578  i = phi_mesh%jj(ni, m)
1579  ib = la_phi%loc_to_glob(1,i)
1580  idxn(ni) = ib - 1
1581  DO nj = 1, phi_mesh%gauss%n_w
1582  j = phi_mesh%jj(nj, m)
1583  jb = la_phi%loc_to_glob(1,j)
1584  jdxn(nj) = jb - 1
1585  END DO
1586  END DO
1587  CALL matsetvalues(h_p_phi_mat1, n_wphi, idxn(1:n_wphi), n_wphi, jdxn(1:n_wphi), &
1588  tphi(1:n_wphi,1:n_wphi), add_values, ierr)
1589  CALL matsetvalues(h_p_phi_mat2, n_wphi, idxn(1:n_wphi), n_wphi, jdxn(1:n_wphi), &
1590  tphi(1:n_wphi,1:n_wphi), add_values, ierr)
1591  END DO
1592 
1593  !*********************************************************************************
1594  !--------------------TERMS on interface_H_phi SIGMA-------------------------------
1595  !**********************************************************************************
1596 
1597  !WRITE(*,*) 'Assembling interface_H_phi '
1598  CALL gauss(phi_mesh)
1599  n_ws1 = h_mesh%gauss%n_ws
1600  n_ws2 = phi_mesh%gauss%n_ws
1601  n_w1 = h_mesh%gauss%n_w
1602  n_w2 = phi_mesh%gauss%n_w
1603 
1604  IF (h_mesh%gauss%n_ws == n_ws) THEN
1605 
1606  DO ms = 1, interface_h_phi%mes
1607 
1608  ms2 = interface_h_phi%mesh2(ms)
1609  m2 = phi_mesh%neighs(ms2)
1610  ms1 = interface_h_phi%mesh1(ms)
1611  m1 = h_mesh%neighs(ms1)
1612 
1613  ref = 1.d-8+sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - h_mesh%rr(:,h_mesh%jjs(2,ms1)))**2)
1614  diff = sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - phi_mesh%rr(:,phi_mesh%jjs(1,ms2)))**2)
1615  IF (diff/ref .LT. 1.d-10) THEN ! 1 = 1
1616  w_cs = wws
1617  ELSE ! 1 = 2
1618  DO ls = 1, l_gs
1619  w_cs(1,ls)= wws(2,ls)
1620  w_cs(2,ls)= wws(1,ls)
1621  w_cs(3,ls)= wws(3,ls)
1622  WRITE(*,*) ' Ouaps! oder of shape functions changed?'
1623  END DO
1624  END IF
1625 
1626  DO ls = 1, l_gs
1627  gauss2(1,ls) = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))*phi_mesh%gauss%wws(:,ls))
1628  gauss2(2,ls) = sum(phi_mesh%rr(2,phi_mesh%jjs(:,ms2))*phi_mesh%gauss%wws(:,ls))
1629  gauss1(1,ls) = sum( h_mesh%rr(1, h_mesh%jjs(:,ms1))* h_mesh%gauss%wws(:,ls))
1630  gauss1(2,ls) = sum( h_mesh%rr(2, h_mesh%jjs(:,ms1))* h_mesh%gauss%wws(:,ls))
1631  END DO
1632 
1633  DO ls2 = 1, l_gs
1634  ref = sqrt(1.d-8+sum(gauss2(:,ls2)**2))
1635  mark = .false.
1636  DO ls1 = 1, l_gs
1637  diff = sqrt(sum((gauss2(:,ls2)-gauss1(:,ls1))**2))
1638  IF (diff .LT. 1.d-10) THEN
1639  dw_cs(:,:,ls2,ms1) = h_mesh%gauss%dw_s(:,:,ls1,ms1)
1640  mark = .true.
1641  EXIT
1642  END IF
1643  END DO
1644  IF (.NOT.mark) WRITE(*,*) ' BUG '
1645  END DO
1646 
1647  END DO
1648 
1649  ELSE
1650  DO ms = 1, interface_h_phi%mes
1651 
1652  ms2 = interface_h_phi%mesh2(ms)
1653  m2 = phi_mesh%neighs(ms2)
1654  ms1 = interface_h_phi%mesh1(ms)
1655  m1 = h_mesh%neighs(ms1)
1656 
1657  ref = 1.d-8+sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - h_mesh%rr(:,h_mesh%jjs(2,ms1)))**2)
1658  diff = sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - phi_mesh%rr(:,phi_mesh%jjs(1,ms2)))**2)
1659  IF (diff/ref .LT. 1.d-10) THEN ! 1 = 1
1660  DO ls = 1, l_gs
1661  w_cs(1,ls)= wws(1,ls)+0.5*wws(3,ls)
1662  w_cs(2,ls)= wws(2,ls)+0.5*wws(3,ls)
1663  w_cs(3,ls)= 0
1664  END DO
1665  ELSE ! 1 = 2
1666  DO ls = 1, l_gs
1667  w_cs(1,ls)= wws(2,ls)+0.5*wws(3,ls)
1668  w_cs(2,ls)= wws(1,ls)+0.5*wws(3,ls)
1669  w_cs(3,ls)= 0
1670  WRITE(*,*) ' Ouaps! oder of shape functions changed?'
1671  END DO
1672  END IF
1673 
1674  DO ls = 1, l_gs
1675  dw_cs(1,:,ls,ms1) = h_mesh%gauss%dw(1,:,1,m1)
1676  dw_cs(2,:,ls,ms1) = h_mesh%gauss%dw(2,:,1,m1)
1677  END DO
1678 
1679  END DO
1680  END IF
1681 
1682  error = 0
1683  DO ms = 1, interface_h_phi%mes
1684 
1685  ms2 = interface_h_phi%mesh2(ms)
1686  ms1 = interface_h_phi%mesh1(ms)
1687  m2 = phi_mesh%neighs(ms2)
1688  m1 = h_mesh%neighs(ms1)
1689  mu_h = sum(mu_h_field(h_mesh%jj(:,m1)))/h_mesh%gauss%n_w
1690  !JLG, FL, May, 28, 2009
1691  !hm1 = stab_colle_H_phi/SUM(rjs(:,ms2))
1692  !JLG, FL, May, 28, 2009
1693  !LC 2017/01/29
1694  hm1 = stab_colle_h_phi/(sum(rjs(:,ms2))*inputs%sigma_min)
1695  !End LC 2017/01/29
1696 
1697  !====================================================================================
1698  !------------------------------------TERMES SUR LE BLOC H----------------------------
1699  !====================================================================================
1700 
1701  !-------------------------------hm1 (bi x ni) . (bj/mu x nj)----------------------------
1702  !====================================================================================
1703 
1704  hsij = 0.d0
1705  DO ls = 1, l_gs
1706  !===Compute radius of Gauss point
1707  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
1708  x = hm1*rjs(ls,ms2)*ray
1709  !H to B
1710  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
1711  !H to B
1712  DO ni = 1, n_ws1
1713  DO nj = 1, n_ws1
1714  !H to B
1715  !y = x * w_cs(ni,ls)*w_cs(nj,ls)
1716  y = x * w_cs(ni,ls)*w_cs(nj,ls)/muhl
1717  !H to B
1718  hsij(1,ni,nj) = hsij(1,ni,nj) + y*(rnorms(2,ls,ms2)**2)
1719  hsij(4,ni,nj) = hsij(4,ni,nj) - y*rnorms(1,ls,ms2)*rnorms(2,ls,ms2)
1720  hsij(5,ni,nj) = hsij(5,ni,nj) + y
1721  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(rnorms(1,ls,ms2)**2)
1722  ENDDO
1723  ENDDO
1724 
1725  ENDDO
1726 
1727 
1728  mat_loc1 = 0.d0
1729  mat_loc2 = 0.d0
1730  DO ki= 1, 3
1731  DO ni = 1, n_ws1
1732  i = interface_h_phi%jjs1(ni,ms)
1733  ib = la_h%loc_to_glob(ki,i)
1734  ix = (ki-1)*n_ws1+ni
1735  idxn(ix) = ib - 1
1736  DO kj = 1, 3
1737  DO nj = 1, n_ws1
1738  j = interface_h_phi%jjs1(nj,ms)
1739  jb = la_h%loc_to_glob(kj,j)
1740  jx = (kj-1)*n_ws1+nj
1741  jdxn(jx) = jb - 1
1742  IF ((ki == 1) .AND. (kj == 1)) THEN
1743  mat_loc1(ix,jx) = hsij(1,ni,nj)
1744  mat_loc2(ix,jx) = hsij(1,ni,nj)
1745  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
1746  mat_loc1(ix,jx) = hsij(4,ni,nj)
1747  mat_loc2(ix,jx) = hsij(4,ni,nj)
1748  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
1749  mat_loc1(ix,jx) = hsij(4,nj,ni)
1750  mat_loc2(ix,jx) = hsij(4,nj,ni)
1751  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
1752  mat_loc1(ix,jx) = hsij(5,ni,nj)
1753  mat_loc2(ix,jx) = hsij(5,ni,nj)
1754  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
1755  mat_loc1(ix,jx) = hsij(6,ni,nj)
1756  mat_loc2(ix,jx) = hsij(6,ni,nj)
1757  ENDIF
1758  END DO
1759  END DO
1760  END DO
1761  END DO
1762  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1, idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
1763  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
1764  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1, idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
1765  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
1766  !====================================================================================
1767  !------------------------(1/sigma) (Rot bj/mu) . (bi x ni)------------------------------
1768  !====================================================================================
1769 
1770  hsij = 0.d0
1771  DO ls = 1, phi_mesh%gauss%l_Gs
1772 
1773  !===Compute radius of Gauss point
1774  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
1775  x = rjs(ls,ms2)*ray/sigma(m1)
1776  ! TEST DEBUG
1777 
1778  ! TEST DEBUG
1779  !H to B
1780  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
1781  drmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(1,:,ls,ms1))
1782  dzmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(2,:,ls,ms1))
1783  !write(*,*) ' muhl, drmuhl, dzmuhl', muhl, drmuhl, dzmuhl
1784  !H to B
1785  !terms without derivatives
1786  DO ni = 1,n_ws1
1787  DO nj = 1, n_ws1
1788  y = x*w_cs(ni,ls)*w_cs(nj,ls)
1789  !Hsij(2,ni,nj) = Hsij(2,ni,nj) + y * (-mode/ray)*(-rnorms(1,ls,ms2))
1790  !Hsij(3,ni,nj) = Hsij(3,ni,nj) + y * mode/ray *(-rnorms(1,ls,ms2))
1791  !Hsij(5,ni,nj) = Hsij(5,ni,nj) + y * (-1/ray) *(-rnorms(1,ls,ms2))
1792  !Hsij(8,ni,nj) = Hsij(8,ni,nj) + y * (-mode/ray)*(-rnorms(2,ls,ms2))
1793  !Hsij(9,ni,nj) = Hsij(9,ni,nj) + y * mode/ray *(-rnorms(2,ls,ms2))
1794  !H to B
1795  hsij(2,ni,nj) = hsij(2,ni,nj) + y * (-mode/ray)*(-rnorms(1,ls,ms2))/muhl
1796  hsij(3,ni,nj) = hsij(3,ni,nj) + y * mode/ray *(-rnorms(1,ls,ms2))/muhl
1797  hsij(5,ni,nj) = hsij(5,ni,nj) + y * (-1/ray) *(-rnorms(1,ls,ms2))/muhl
1798  hsij(8,ni,nj) = hsij(8,ni,nj) + y * (-mode/ray)*(-rnorms(2,ls,ms2))/muhl
1799  hsij(9,ni,nj) = hsij(9,ni,nj) + y * mode/ray *(-rnorms(2,ls,ms2))/muhl
1800 
1801  hsij(1,ni,nj) = hsij(1,ni,nj) - y*(-rnorms(2,ls,ms2))*(-(dzmuhl/muhl**2))
1802  hsij(4,ni,nj) = hsij(4,ni,nj) - y*(-rnorms(2,ls,ms2))*( (drmuhl/muhl**2))
1803  hsij(5,ni,nj) = hsij(5,ni,nj) &
1804  + y*(-rnorms(1,ls,ms2)*drmuhl-rnorms(2,ls,ms2)*dzmuhl)/muhl**2
1805  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(-rnorms(1,ls,ms2))*( (drmuhl/muhl**2))
1806  hsij(7,ni,nj) = hsij(7,ni,nj) + y*(-rnorms(1,ls,ms2))*(-(dzmuhl/muhl**2))
1807  !H to B
1808  ENDDO
1809  ENDDO
1810 
1811  ENDDO
1812 
1813  !TEST
1814  !Hsij = 0.d0
1815  !TEST
1816 
1817  mat_loc1 = 0.d0
1818  mat_loc2 = 0.d0
1819  DO ki= 1, 3
1820  DO ni = 1, n_ws1
1821  i = interface_h_phi%jjs1(ni,ms)
1822  ib = la_h%loc_to_glob(ki,i)
1823  ix = (ki-1)*n_ws1 + ni
1824  idxn(ix) = ib - 1
1825  DO kj = 1, 3
1826  DO nj = 1, n_ws1
1827  j = interface_h_phi%jjs1(nj,ms)
1828  jb = la_h%loc_to_glob(kj,j)
1829  jx = (kj-1)*n_ws1 + nj
1830  jdxn(jx) = jb - 1
1831  ! H to B
1832  IF ( (ki == 1) .AND. (kj == 1)) THEN
1833  mat_loc1(ix,jx) = hsij(1,ni,nj)
1834  mat_loc2(ix,jx) = hsij(1,ni,nj)
1835  ELSE IF ( (ki == 1) .AND. (kj == 3)) THEN
1836  mat_loc1(ix,jx) = hsij(4,ni,nj)
1837  mat_loc2(ix,jx) = hsij(4,ni,nj)
1838  ! H to B
1839  ELSE IF ( (ki == 2) .AND. (kj == 1)) THEN
1840  mat_loc1(ix,jx) = hsij(2,ni,nj)
1841  mat_loc2(ix,jx) = hsij(3,ni,nj)
1842  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
1843  mat_loc1(ix,jx) = hsij(5,ni,nj)
1844  mat_loc2(ix,jx) = hsij(5,ni,nj)
1845  ELSEIF ( (ki == 2) .AND. (kj == 3)) THEN
1846  mat_loc1(ix,jx) = hsij(8,ni,nj)
1847  mat_loc2(ix,jx) = hsij(9,ni,nj)
1848  ! H to B
1849  ELSE IF ( (ki == 3) .AND. (kj == 1)) THEN
1850  mat_loc1(ix,jx) = hsij(7,ni,nj)
1851  mat_loc2(ix,jx) = hsij(7,ni,nj)
1852  ELSE IF ( (ki == 3) .AND. (kj == 3)) THEN
1853  mat_loc1(ix,jx) = hsij(6,ni,nj)
1854  mat_loc2(ix,jx) = hsij(6,ni,nj)
1855  ! H to B
1856  ENDIF
1857  END DO
1858  END DO
1859  END DO
1860  END DO
1861  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1, idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
1862  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
1863  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1, idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
1864  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
1865 
1866 
1867  !Feb 2 2007
1868  mat_loc1 = 0.d0
1869  mat_loc2 = 0.d0
1870  hsij=c_sym*hsij !SYM
1871  DO ki= 1, 3
1872  DO ni = 1, n_ws1
1873  i = interface_h_phi%jjs1(ni,ms)
1874  ib = la_h%loc_to_glob(ki,i)
1875  ix = (ki-1)*n_ws1 + ni
1876  idxn(ix) = ib - 1
1877  DO kj = 1, 3
1878  DO nj = 1, n_ws1
1879  j = interface_h_phi%jjs1(nj,ms)
1880  jb = la_h%loc_to_glob(kj,j)
1881  jx = (kj-1)*n_ws1 + nj
1882  jdxn(jx) = jb - 1
1883  IF ( (kj == 2) .AND. (ki == 1)) THEN
1884  mat_loc1(ix,jx) = hsij(2,nj,ni)
1885  mat_loc2(ix,jx) = hsij(3,nj,ni)
1886  ELSEIF ((kj == 2) .AND. (ki == 2)) THEN
1887  mat_loc1(ix,jx) = hsij(5,nj,ni)
1888  mat_loc2(ix,jx) = hsij(5,nj,ni)
1889  ELSEIF ( (kj == 2) .AND. (ki == 3)) THEN
1890  mat_loc1(ix,jx) = hsij(8,nj,ni)
1891  mat_loc2(ix,jx) = hsij(9,nj,ni)
1892  ENDIF
1893  END DO
1894  END DO
1895  END DO
1896  END DO
1897  !feb 2 2007
1898  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1, idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
1899  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
1900  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1, idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
1901  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
1902 
1903  hsij = 0.d0
1904  DO ls = 1, phi_mesh%gauss%l_Gs
1905 
1906  !===Compute radius of Gauss point
1907  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
1908  x = rjs(ls,ms2)*ray /sigma(m1)
1909  ! TEST DEBUG
1910 
1911  ! TEST DEBUG
1912  !H to B
1913  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
1914  !H to B
1915  !terms with derivatives
1916  DO ni = 1,n_ws1
1917  y = x*w_cs(ni,ls)
1918  DO nj = 1, n_w1
1919  !Hsij(1,ni,nj) = Hsij(1,ni,nj) + y*(-dw_cs(2,nj,ls,ms1))*(-rnorms(2,ls,ms2))
1920  !Hsij(4,ni,nj) = Hsij(4,ni,nj) + y* dw_cs(1,nj,ls,ms1) *(-rnorms(2,ls,ms2))
1921  !Hsij(5,ni,nj) = Hsij(5,ni,nj) + &
1922  ! y*(-dw_cs(2,nj,ls,ms1)*(-rnorms(2,ls,ms2))-dw_cs(1,nj,ls,ms1)*(-rnorms(1,ls,ms2)))
1923  !Hsij(6,ni,nj) = Hsij(6,ni,nj) + y*(-dw_cs(1,nj,ls,ms1))*(-rnorms(1,ls,ms2))
1924  !Hsij(7,ni,nj) = Hsij(7,ni,nj) + y* dw_cs(2,nj,ls,ms1) *(-rnorms(1,ls,ms2))
1925  !H to B
1926  hsij(1,ni,nj) = hsij(1,ni,nj) - y*(-rnorms(2,ls,ms2))*(dw_cs(2,nj,ls,ms1)/muhl)
1927  hsij(4,ni,nj) = hsij(4,ni,nj) - y*(-rnorms(2,ls,ms2))*(-dw_cs(1,nj,ls,ms1)/muhl)
1928  hsij(5,ni,nj) = hsij(5,ni,nj) &
1929  + y*(-rnorms(2,ls,ms2))*(-dw_cs(2,nj,ls,ms1)/muhl) &
1930  - y*(-rnorms(1,ls,ms2))*( dw_cs(1,nj,ls,ms1)/muhl)
1931  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(-rnorms(1,ls,ms2))*(-dw_cs(1,nj,ls,ms1)/muhl)
1932  hsij(7,ni,nj) = hsij(7,ni,nj) + y*(-rnorms(1,ls,ms2))*(dw_cs(2,nj,ls,ms1)/muhl)
1933  !H to B
1934  ENDDO
1935  ENDDO
1936  ENDDO
1937 
1938  !TEST
1939  !Hsij = 0.d0
1940  !TEST
1941 
1942  mat_loc1 = 0.d0
1943  mat_loc2 = 0.d0
1944  DO ki= 1, 3
1945  DO ni = 1, n_ws1
1946  i = interface_h_phi%jjs1(ni,ms)
1947  ib = la_h%loc_to_glob(ki,i)
1948  ix = (ki-1)*n_ws1 + ni
1949  idxn(ix) = ib - 1
1950  DO kj = 1, 3
1951  DO nj = 1, n_w1
1952  j = h_mesh%jj(nj,m1)
1953  jb = la_h%loc_to_glob(kj,j)
1954  jx = (kj-1)*n_w1 + nj
1955  jdxn(jx) = jb - 1
1956  IF ((ki == 1) .AND. (kj == 1)) THEN
1957  mat_loc1(ix,jx) = hsij(1,ni,nj)
1958  mat_loc2(ix,jx) = hsij(1,ni,nj)
1959  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
1960  mat_loc1(ix,jx) = hsij(4,ni,nj)
1961  mat_loc2(ix,jx) = hsij(4,ni,nj)
1962  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
1963  mat_loc1(ix,jx) = hsij(5,ni,nj)
1964  mat_loc2(ix,jx) = hsij(5,ni,nj)
1965  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
1966  mat_loc1(ix,jx) = hsij(6,ni,nj)
1967  mat_loc2(ix,jx) = hsij(6,ni,nj)
1968  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
1969  mat_loc1(ix,jx) = hsij(7,ni,nj)
1970  mat_loc2(ix,jx) = hsij(7,ni,nj)
1971  ENDIF
1972  END DO
1973  END DO
1974  END DO
1975  END DO
1976 
1977  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1, idxn(1:3*n_ws1), 3*n_w1, jdxn(1:3*n_w1), &
1978  mat_loc1(1:3*n_ws1,1:3*n_w1), add_values, ierr)
1979  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1, idxn(1:3*n_ws1), 3*n_w1, jdxn(1:3*n_w1), &
1980  mat_loc2(1:3*n_ws1,1:3*n_w1), add_values, ierr)
1981 
1982  !Feb 2 2007
1983  mat_loc1 = 0.d0
1984  mat_loc2 = 0.d0
1985  hsij=c_sym*hsij !SYM
1986  DO ki = 1, 3
1987  DO ni = 1, n_w1
1988  i = h_mesh%jj(ni,m1)
1989  ib = la_h%loc_to_glob(ki,i)
1990  ix = (ki-1)*n_w1 + ni
1991  idxn(ix) = ib - 1
1992  DO kj= 1, 3
1993  DO nj = 1, n_ws1
1994  j = interface_h_phi%jjs1(nj,ms)
1995  jb = la_h%loc_to_glob(kj,j)
1996  jx = (kj-1)*n_ws1 + nj
1997  jdxn(jx) = jb - 1
1998  IF ((kj == 1) .AND. (ki == 1)) THEN
1999  mat_loc1(ix,jx) = hsij(1,nj,ni)
2000  mat_loc2(ix,jx) = hsij(1,nj,ni)
2001  ELSEIF ((kj == 1) .AND. (ki == 3)) THEN
2002  mat_loc1(ix,jx) = hsij(4,nj,ni)
2003  mat_loc2(ix,jx) = hsij(4,nj,ni)
2004  ELSEIF ((kj == 2) .AND. (ki == 2)) THEN
2005  mat_loc1(ix,jx) = hsij(5,nj,ni)
2006  mat_loc2(ix,jx) = hsij(5,nj,ni)
2007  ELSEIF ((kj == 3) .AND. (ki == 3)) THEN
2008  mat_loc1(ix,jx) = hsij(6,nj,ni)
2009  mat_loc2(ix,jx) = hsij(6,nj,ni)
2010  ELSEIF ((kj == 3) .AND. (ki == 1)) THEN
2011  mat_loc1(ix,jx) = hsij(7,nj,ni)
2012  mat_loc2(ix,jx) = hsij(7,nj,ni)
2013  ENDIF
2014  END DO
2015  END DO
2016  END DO
2017  END DO
2018  CALL matsetvalues(h_p_phi_mat1, 3*n_w1, idxn(1:3*n_w1), 3*n_ws1, jdxn(1:3*n_ws1), &
2019  mat_loc1(1:3*n_w1,1:3*n_ws1), add_values, ierr)
2020  CALL matsetvalues(h_p_phi_mat2, 3*n_w1, idxn(1:3*n_w1), 3*n_ws1, jdxn(1:3*n_ws1), &
2021  mat_loc2(1:3*n_w1,1:3*n_ws1), add_values, ierr)
2022  !Feb 2 2007
2023 
2024 
2025  !====================================================================================
2026  !------------------------------------TERMES SUR LE BLOC PHI--------------------------
2027  !====================================================================================
2028 
2029  !------------------------hm1 (Grad(phi_i) x ni).(Grad(phi_j) x nj)-------------------
2030  !====================================================================================
2031 
2032  phisij = 0.d0
2033 
2034  DO ls = 1, phi_mesh%gauss%l_Gs
2035 
2036  !===Compute radius of Gauss point
2037  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2038  x = hm1*rjs(ls,ms2)*ray
2039 
2040  !term without derivatives
2041  DO ni=1, n_ws2
2042  DO nj=1, n_ws2
2043  phisij(ni,nj) = phisij(ni,nj) + x*mode**2/ray**2*wws(ni,ls)*wws(nj,ls)
2044  ENDDO
2045  ENDDO
2046 
2047  ENDDO
2048 
2049  !TEST
2050  !Phisij = 0.d0
2051  !Phisij = Phisij/hm1
2052  !TEST
2053  DO ni = 1, n_ws2
2054  i = interface_h_phi%jjs2(ni,ms)
2055  ib = la_phi%loc_to_glob(1,i)
2056  idxn(ni) = ib - 1
2057  DO nj = 1, n_ws2
2058  j = interface_h_phi%jjs2(nj,ms)
2059  jb = la_phi%loc_to_glob(1,j)
2060  jdxn(nj) = jb - 1
2061  END DO
2062  END DO
2063  CALL matsetvalues(h_p_phi_mat1, n_ws2, idxn(1:n_ws2), n_ws2, jdxn(1:n_ws2), &
2064  phisij(1:n_ws2,1:n_ws2), add_values, ierr)
2065  CALL matsetvalues(h_p_phi_mat2, n_ws2, idxn(1:n_ws2), n_ws2, jdxn(1:n_ws2), &
2066  phisij(1:n_ws2,1:n_ws2), add_values, ierr)
2067 
2068  phisij = 0.d0
2069  DO ls = 1, l_gs
2070 
2071  !===Compute radius of Gauss point
2072  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2073  x = hm1*rjs(ls,ms2)*ray
2074 
2075  !term with derivative
2076  DO ni = 1, n_w2
2077  DO nj = 1, n_w2
2078  phisij(ni,nj) = phisij(ni,nj) + x*( &
2079  (dw_s(2,ni,ls,ms2)*rnorms(1,ls,ms2) - dw_s(1,ni,ls,ms2)*rnorms(2,ls,ms2))* &
2080  (dw_s(2,nj,ls,ms2)*rnorms(1,ls,ms2) - dw_s(1,nj,ls,ms2)*rnorms(2,ls,ms2)))
2081  ENDDO
2082  ENDDO
2083  ENDDO
2084 
2085  !Phisij = 0.d0
2086  !Phisij = Phisij/hm1
2087  !TEST
2088 
2089  DO ni = 1, n_w2
2090  i = phi_mesh%jj(ni, m2)
2091  ib = la_phi%loc_to_glob(1,i)
2092  idxn(ni) = ib - 1
2093  DO nj = 1, n_w2
2094  j = phi_mesh%jj(nj, m2)
2095  jb = la_phi%loc_to_glob(1,j)
2096  jdxn(nj) = jb - 1
2097  END DO
2098  END DO
2099  CALL matsetvalues(h_p_phi_mat1, n_w2, idxn(1:n_w2), n_w2, jdxn(1:n_w2), &
2100  phisij(1:n_w2,1:n_w2), add_values, ierr)
2101  CALL matsetvalues(h_p_phi_mat2, n_w2, idxn(1:n_w2), n_w2, jdxn(1:n_w2), &
2102  phisij(1:n_w2,1:n_w2), add_values, ierr)
2103  !====================================================================================
2104  !------------------------------------MIXED TERMS-------------------------------------
2105  !====================================================================================
2106 
2107  !====================================================================================
2108  !------------------------hm1 (bi x ni) . (Grad(phi_j) x nj)--------------------------
2109  !------------------ + hm1(Grad(phi_i) x ni).(bj x nj)/muhl----------------------
2110  !====================================================================================
2111  sij = 0.d0
2112  smuij = 0.d0
2113  DO ls = 1, l_gs
2114 
2115  !===Compute radius of Gauss point
2116  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2117  x = hm1*rjs(ls,ms2)*ray
2118  !H to B
2119  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2120  !H to B
2121  !terms without derivatives
2122  DO ni = 1, n_ws1
2123  DO nj = 1, n_ws2
2124  sij(3,ni,nj) = sij(3,ni,nj) + x*(mode/ray)*w_cs(ni,ls)*wws(nj,ls)
2125  smuij(3,ni,nj) = smuij(3,ni,nj) + x*(mode/ray)*w_cs(ni,ls)*wws(nj,ls)/muhl
2126  ENDDO
2127  ENDDO
2128  ENDDO
2129  sij(4,:,:) = -sij(3,:,:)
2130  !H to B
2131  smuij(4,:,:) = -smuij(3,:,:)
2132  !H to B
2133 
2134  !TEST
2135  !Sij = 0.d0
2136  !Sij = Sij /hm1
2137  !TEST
2138 
2139  ki = 2
2140  DO ni = 1, n_ws1
2141  i = interface_h_phi%jjs1(ni,ms)
2142  ib = la_h%loc_to_glob(ki,i)
2143  idxn(ni) = ib - 1
2144  DO nj = 1, n_ws2
2145  j = interface_h_phi%jjs2(nj,ms)
2146  jb = la_phi%loc_to_glob(1,j)
2147  jdxn(nj) = jb - 1
2148  END DO
2149  ENDDO
2150  CALL matsetvalues(h_p_phi_mat1, n_ws1, idxn(1:n_ws1), n_ws2, jdxn(1:n_ws2), &
2151  sij(3,1:n_ws1,1:n_ws2), add_values, ierr)
2152  CALL matsetvalues(h_p_phi_mat2, n_ws1, idxn(1:n_ws1), n_ws2, jdxn(1:n_ws2), &
2153  sij(4,1:n_ws1,1:n_ws2), add_values, ierr)
2154 
2155  !TEST SYM
2156  !Feb 2 2003
2157  !Sij = 0.d0
2158  mat_loc1 = 0.d0
2159  mat_loc2 = 0.d0
2160  kj = 2
2161  DO ni = 1, n_ws2
2162  i = interface_h_phi%jjs2(ni,ms)
2163  ib = la_phi%loc_to_glob(1,i)
2164  idxn(ni) = ib - 1
2165  DO nj = 1, n_ws1
2166  j = interface_h_phi%jjs1(nj,ms)
2167  jb = la_h%loc_to_glob(kj,j)
2168  jdxn(nj) = jb - 1
2169  !H to B
2170  !mat_loc1(ni,nj) = Sij(3,nj,ni)
2171  !mat_loc2(ni,nj) = Sij(4,nj,ni)
2172  mat_loc1(ni,nj) = smuij(3,nj,ni)
2173  mat_loc2(ni,nj) = smuij(4,nj,ni)
2174  !H to B
2175 
2176  END DO
2177  ENDDO
2178  CALL matsetvalues(h_p_phi_mat1, n_ws2, idxn(1:n_ws2), n_ws1, jdxn(1:n_ws1), &
2179  mat_loc1(1:n_ws2,1:n_ws1), add_values, ierr)
2180  CALL matsetvalues(h_p_phi_mat2, n_ws2, idxn(1:n_ws2), n_ws1, jdxn(1:n_ws1), &
2181  mat_loc2(1:n_ws2,1:n_ws1), add_values, ierr)
2182 
2183  !Feb 2 2003
2184  !TEST SYM
2185  sij = 0.d0
2186  smuij = 0.d0
2187 
2188  DO ls = 1, l_gs
2189 
2190  !===Compute radius of Gauss point
2191  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2192  x = hm1*rjs(ls,ms2)*ray
2193  !H to B
2194 
2195  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2196  !H to B
2197  !terms with derivatives
2198  DO ni = 1, n_ws1
2199  y = x * w_cs(ni,ls)
2200  DO nj = 1, n_w2
2201  sij(1,ni,nj) = sij(1,ni,nj) + &
2202  y*(-dw_s(1,nj,ls,ms2)*rnorms(2,ls,ms2)**2 + dw_s(2,nj,ls,ms2)*rnorms(1,ls,ms2)*rnorms(2,ls,ms2))
2203  ! H to B
2204  smuij(1,ni,nj) = smuij(1,ni,nj) + &
2205  y*(-dw_s(1,nj,ls,ms2)*rnorms(2,ls,ms2)**2 + dw_s(2,nj,ls,ms2)*rnorms(1,ls,ms2)*rnorms(2,ls,ms2))/muhl
2206  ! H to B
2207  sij(5,ni,nj) = sij(5,ni,nj) + &
2208  y*(-dw_s(2,nj,ls,ms2)*rnorms(1,ls,ms2)**2 + dw_s(1,nj,ls,ms2)*rnorms(1,ls,ms2)*rnorms(2,ls,ms2))
2209  ! H to B
2210  smuij(5,ni,nj) = smuij(5,ni,nj) + &
2211  y*(-dw_s(2,nj,ls,ms2)*rnorms(1,ls,ms2)**2 + dw_s(1,nj,ls,ms2)*rnorms(1,ls,ms2)*rnorms(2,ls,ms2))/muhl
2212  ! H to B
2213  ENDDO
2214  ENDDO
2215  ENDDO
2216 
2217  !TEST
2218  !Sij = 0.d0
2219  !Sij = Sij /hm1
2220  !TEST
2221  mat_loc1 = 0.d0
2222  mat_loc2 = 0.d0
2223  DO ki= 1, 3
2224  DO ni = 1, n_ws1
2225  i = interface_h_phi%jjs1(ni,ms)
2226  ib = la_h%loc_to_glob(ki,i)
2227  ix = (ki-1)*n_ws1 + ni
2228  idxn(ix) = ib - 1
2229  DO nj = 1, n_w2
2230  j = phi_mesh%jj(nj,m2)
2231  jb = la_phi%loc_to_glob(1,j)
2232  jx = nj
2233  jdxn(jx) = jb - 1
2234  IF (ki == 1) THEN
2235  mat_loc1(ix,jx) = sij(1,ni,nj)
2236  mat_loc2(ix,jx) = sij(1,ni,nj)
2237  ELSEIF (ki == 3) THEN
2238  mat_loc1(ix,jx) = sij(5,ni,nj)
2239  mat_loc2(ix,jx) = sij(5,ni,nj)
2240  END IF
2241  END DO
2242  END DO
2243  END DO
2244  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1, idxn(1:3*n_ws1), n_w2, jdxn(1:n_w2), &
2245  mat_loc1(1:3*n_ws1,1:n_w2), add_values, ierr)
2246  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1, idxn(1:3*n_ws1), n_w2, jdxn(1:n_w2), &
2247  mat_loc2(1:3*n_ws1,1:n_w2), add_values, ierr)
2248 
2249  !TEST SYM
2250  !Feb 2 2003
2251  !Sij = 0.d0
2252  mat_loc1 = 0.d0
2253  mat_loc2 = 0.d0
2254  DO ni = 1, n_w2
2255  i = phi_mesh%jj(ni,m2)
2256  ib = la_phi%loc_to_glob(1,i)
2257  ix = ni
2258  idxn(ix) = ib - 1
2259  DO kj=1,3
2260  DO nj = 1, n_ws1
2261  j = interface_h_phi%jjs1(nj,ms)
2262  jb = la_h%loc_to_glob(kj,j)
2263  jx = (kj-1)*n_ws1 + nj
2264  jdxn(jx) = jb - 1
2265  IF (kj == 1) THEN
2266  !H to B
2267  !mat_loc1(ix,jx) = Sij(1,nj,ni)
2268  !mat_loc2(ix,jx) = Sij(1,nj,ni)
2269  mat_loc1(ix,jx) = smuij(1,nj,ni)
2270  mat_loc2(ix,jx) = smuij(1,nj,ni)
2271  !H to B
2272  ELSEIF (kj == 3) THEN
2273  !H to B
2274  !mat_loc1(ix,jx) = Sij(5,nj,ni)
2275  !mat_loc2(ix,jx) = Sij(5,nj,ni)
2276  mat_loc1(ix,jx) = smuij(5,nj,ni)
2277  mat_loc2(ix,jx) = smuij(5,nj,ni)
2278  !H to B
2279 
2280  ENDIF
2281  END DO
2282  END DO
2283  ENDDO
2284  CALL matsetvalues(h_p_phi_mat1, n_w2, idxn(1:n_w2), 3*n_ws1, jdxn(1:3*n_ws1), &
2285  mat_loc1(1:n_w2,1:3*n_ws1), add_values, ierr)
2286  CALL matsetvalues(h_p_phi_mat2, n_w2, idxn(1:n_w2), 3*n_ws1, jdxn(1:3*n_ws1), &
2287  mat_loc2(1:n_w2,1:3*n_ws1), add_values, ierr)
2288 
2289  !TEST SYM
2290  !Feb 2 2003
2291 
2292 
2293  !====================================================================================
2294  !----------------------(1/sigma) (Rot (bj/mu)).(Grad(phi_i) x ni)-------------------------
2295  !====================================================================================
2296  ! GOTO 200
2297 
2298  sij = 0.d0
2299  DO ls = 1, l_gs
2300 
2301  !===Compute radius of Gauss point
2302  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2303  x = rjs(ls,ms2)*ray/sigma(m1)
2304  ! TEST DEBUG
2305 
2306  ! TEST DEBUG
2307  !H to B
2308  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2309  drmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(1,:,ls,ms1))
2310  dzmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(2,:,ls,ms1))
2311  !write(*,*) ' muhl, drmuhl, dzmuhl', muhl, drmuhl, dzmuhl
2312  !H to B
2313 
2314  !terms without derivative
2315  DO ni = 1, n_ws2
2316  DO nj = 1, n_ws1
2317  y = x * wws(ni,ls)*w_cs(nj,ls)
2318  !H to B
2319  !Sij(1,ni,nj) = Sij(1,ni,nj) + y*( mode/ray)**2*rnorms(1,ls,ms2)
2320  !Sij(3,ni,nj) = Sij(3,ni,nj) + y*( mode/ray**2)*rnorms(1,ls,ms2)
2321  !Sij(4,ni,nj) = Sij(4,ni,nj) + y*(-mode/ray**2)*rnorms(1,ls,ms2)
2322  !Sij(5,ni,nj) = Sij(5,ni,nj) + y*( mode/ray)**2*rnorms(2,ls,ms2)
2323  sij(1,ni,nj) = sij(1,ni,nj) + y*( mode/ray)**2*rnorms(1,ls,ms2)/muhl
2324  sij(3,ni,nj) = sij(3,ni,nj) + y*( mode/ray**2)*rnorms(1,ls,ms2)/muhl
2325  sij(4,ni,nj) = sij(4,ni,nj) + y*(-mode/ray**2)*rnorms(1,ls,ms2)/muhl
2326  sij(5,ni,nj) = sij(5,ni,nj) + y*( mode/ray)**2*rnorms(2,ls,ms2)/muhl
2327  !H to B
2328  sij(3,ni,nj) = sij(3,ni,nj) &
2329  + y*(mode/ray)*(drmuhl*rnorms(1,ls,ms2)+dzmuhl*rnorms(2,ls,ms2))*(-1/muhl**2)
2330  sij(4,ni,nj) = sij(4,ni,nj) &
2331  - y*(mode/ray)*(drmuhl*rnorms(1,ls,ms2)+dzmuhl*rnorms(2,ls,ms2))*(-1/muhl**2)
2332  ENDDO
2333  ENDDO
2334 
2335 
2336  ENDDO
2337 
2338  !TEST
2339  !Sij = 0.d0
2340  !TEST
2341 
2342  mat_loc1 = 0.d0
2343  mat_loc2 = 0.d0
2344  DO ni = 1, n_ws2
2345  i = interface_h_phi%jjs2(ni,ms)
2346  ib = la_phi%loc_to_glob(1,i)
2347  ix = ni
2348  idxn(ix) = ib - 1
2349  DO kj =1,3
2350  DO nj = 1, n_ws1
2351  j = interface_h_phi%jjs1(nj,ms)
2352  jb = la_h%loc_to_glob(kj,j)
2353  jx = (kj-1)*n_ws1 + nj
2354  jdxn(jx) = jb - 1
2355  IF (kj == 1) THEN
2356  mat_loc1(ix,jx) = sij(1,ni,nj)
2357  mat_loc2(ix,jx) = sij(1,ni,nj)
2358  ELSEIF (kj == 2) THEN
2359  mat_loc1(ix,jx) = sij(3,ni,nj)
2360  mat_loc2(ix,jx) = sij(4,ni,nj)
2361  ELSEIF (kj == 3) THEN
2362  mat_loc1(ix,jx) = sij(5,ni,nj)
2363  mat_loc2(ix,jx) = sij(5,ni,nj)
2364  ENDIF
2365  END DO
2366  END DO
2367  END DO
2368  CALL matsetvalues(h_p_phi_mat1, n_ws2, idxn(1:n_ws2), 3*n_ws1, jdxn(1:3*n_ws1), &
2369  mat_loc1(1:n_ws2,1:3*n_ws1), add_values, ierr)
2370  CALL matsetvalues(h_p_phi_mat2, n_ws2, idxn(1:n_ws2), 3*n_ws1, jdxn(1:3*n_ws1), &
2371  mat_loc2(1:n_ws2,1:3*n_ws1), add_values, ierr)
2372 
2373  !Feb 2 2007
2374  mat_loc1 = 0.d0
2375  mat_loc2 = 0.d0
2376  sij = c_sym*sij !SYM
2377  DO ki =1,3
2378  DO ni = 1, n_ws1
2379  i = interface_h_phi%jjs1(ni,ms)
2380  ib = la_h%loc_to_glob(ki,i)
2381  ix = (ki-1)*n_ws1 + ni
2382  idxn(ix) = ib - 1
2383  DO nj = 1, n_ws2
2384  j = interface_h_phi%jjs2(nj,ms)
2385  jb = la_phi%loc_to_glob(1,j)
2386  jx = nj
2387  jdxn(jx) = jb - 1
2388  IF (ki == 1) THEN
2389  mat_loc1(ix,jx) = sij(1,nj,ni)
2390  mat_loc2(ix,jx) = sij(1,nj,ni)
2391  ELSEIF (ki == 2) THEN
2392  mat_loc1(ix,jx) = sij(3,nj,ni)
2393  mat_loc2(ix,jx) = sij(4,nj,ni)
2394  ELSEIF (ki == 3) THEN
2395  mat_loc1(ix,jx) = sij(5,nj,ni)
2396  mat_loc2(ix,jx) = sij(5,nj,ni)
2397  ENDIF
2398  END DO
2399  END DO
2400  END DO
2401  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1, idxn(1:3*n_ws1), n_ws2, jdxn(1:n_ws2), &
2402  mat_loc1(1:3*n_ws1,1:n_ws2), add_values, ierr)
2403  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1, idxn(1:3*n_ws1), n_ws2, jdxn(1:n_ws2), &
2404  mat_loc2(1:3*n_ws1,1:n_ws2), add_values, ierr)
2405  !Feb 2 2007
2406 
2407  sij = 0.d0
2408 
2409  DO ls = 1, l_gs
2410  !===Compute radius of Gauss point
2411  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2412  x = rjs(ls,ms2)*ray/sigma(m1)
2413  ! TEST DEBUG
2414 
2415  ! TEST DEBUG
2416  !H to B
2417  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2418  !H to B
2419  !terms with derivatives of bj only
2420  DO ni = 1, n_ws2
2421  y = x*wws(ni,ls)*mode/ray
2422  DO nj = 1, n_w1
2423  sij(3,ni,nj) = sij(3,ni,nj) + &
2424  !H to B
2425  !y*(dw_cs(2,nj,ls,ms1)*rnorms(2,ls,ms2) + dw_cs(1,nj,ls,ms1)*rnorms(1,ls,ms2))
2426  y*(dw_cs(2,nj,ls,ms1)*rnorms(2,ls,ms2)/muhl + dw_cs(1,nj,ls,ms1)*rnorms(1,ls,ms2)/muhl)
2427  !H to B
2428  ENDDO
2429  ENDDO
2430  ENDDO
2431  sij(4,:,:) = -sij(3,:,:)
2432  !TEST
2433  !Sij = 0.d0
2434  !TEST
2435  kj=2
2436  DO ni = 1, n_ws2
2437  i = interface_h_phi%jjs2(ni,ms)
2438  ib = la_phi%loc_to_glob(1,i)
2439  idxn(ni) = ib - 1
2440  DO nj = 1, n_w1
2441  j = h_mesh%jj(nj,m1)
2442  jb = la_h%loc_to_glob(kj,j)
2443  jdxn(nj) = jb - 1
2444  END DO
2445  END DO
2446  CALL matsetvalues(h_p_phi_mat1, n_ws2, idxn(1:n_ws2), n_w1, jdxn(1:n_w1), &
2447  sij(3,1:n_ws2,1:n_w1), add_values, ierr)
2448  CALL matsetvalues(h_p_phi_mat2, n_ws2, idxn(1:n_ws2), n_w1, jdxn(1:n_w1), &
2449  sij(4,1:n_ws2,1:n_w1), add_values, ierr)
2450 
2451  !Feb 2 2007
2452  sij = c_sym*sij !SYM
2453 
2454  mat_loc1 = 0.d0
2455  mat_loc2 = 0.d0
2456  ki=2
2457  DO ni = 1, n_w1
2458  i = h_mesh%jj(ni,m1)
2459  ib = la_h%loc_to_glob(ki,i)
2460  idxn(ni) = ib - 1
2461  DO nj = 1, n_ws2
2462  j = interface_h_phi%jjs2(nj,ms)
2463  jb = la_phi%loc_to_glob(1,j)
2464  jdxn(nj) = jb - 1
2465  mat_loc1(ix,jx) = sij(3,nj,ni)
2466  mat_loc2(ix,jx) = sij(4,nj,ni)
2467  END DO
2468  END DO
2469  CALL matsetvalues(h_p_phi_mat1, n_w1, idxn(1:n_w1), n_ws2, jdxn(1:n_ws2), &
2470  mat_loc1(1:n_w1,1:n_ws2), add_values, ierr)
2471  CALL matsetvalues(h_p_phi_mat2, n_w1, idxn(1:n_w1), n_ws2, jdxn(1:n_ws2), &
2472  mat_loc2(1:n_w1,1:n_ws2), add_values, ierr)
2473  !Feb 2 2007
2474 
2475  sij = 0.d0
2476  DO ls = 1, l_gs
2477 
2478  !===Compute radius of Gauss point
2479  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2480  x = rjs(ls,ms2)*ray/sigma(m1)
2481  ! TEST DEBUG
2482 
2483  ! TEST DEBUG
2484  !H to B
2485  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2486  !H to B
2487  !terms with derivatives in phi and bj
2488  DO ni = 1, n_w2
2489  y = x*(dw_s(2,ni,ls,ms2)*rnorms(1,ls,ms2) - dw_s(1,ni,ls,ms2)*rnorms(2,ls,ms2))
2490  DO nj = 1, n_w1
2491  !H to B
2492  !Sij(1,ni,nj) = Sij(1,ni,nj) + y *dw_cs(2,nj,ls,ms1)
2493  !Sij(5,ni,nj) = Sij(5,ni,nj) + (-y)*dw_cs(1,nj,ls,ms1)
2494  sij(1,ni,nj) = sij(1,ni,nj) + y * (dw_cs(2,nj,ls,ms1)/muhl)
2495  sij(5,ni,nj) = sij(5,ni,nj) + (-y)*(dw_cs(1,nj,ls,ms1)/muhl)
2496  !H to B
2497 
2498  ENDDO
2499  ENDDO
2500  ENDDO
2501 
2502  !TEST
2503  !Sij = 0.d0
2504  !TEST
2505 
2506  mat_loc1 = 0.d0
2507  mat_loc2 = 0.d0
2508  DO ni = 1, n_w2
2509  i = phi_mesh%jj(ni,m2)
2510  ib = la_phi%loc_to_glob(1,i)
2511  ix = ni
2512  idxn(ix) = ib - 1
2513  DO nj = 1, n_w1
2514  j = h_mesh%jj(nj,m1)
2515  DO kj=1,3
2516  jb = la_h%loc_to_glob(kj,j)
2517  jx = (kj-1)*n_w1 + nj
2518  jdxn(jx) = jb - 1
2519  IF (kj == 1) THEN
2520  mat_loc1(ix,jx) = sij(1,ni,nj)
2521  mat_loc2(ix,jx) = sij(1,ni,nj)
2522  ELSEIF (kj == 3) THEN
2523  mat_loc1(ix,jx) = sij(5,ni,nj)
2524  mat_loc2(ix,jx) = sij(5,ni,nj)
2525  ENDIF
2526  END DO
2527  END DO
2528  END DO
2529  CALL matsetvalues(h_p_phi_mat1, n_w2, idxn(1:n_w2), 3*n_w1, jdxn(1:3*n_w1), &
2530  mat_loc1(1:n_w2,1:3*n_w1), add_values, ierr)
2531  CALL matsetvalues(h_p_phi_mat2, n_w2, idxn(1:n_w2), 3*n_w1, jdxn(1:3*n_w1), &
2532  mat_loc2(1:n_w2,1:3*n_w1), add_values, ierr)
2533 
2534  ! H to B
2535  sij = 0.d0
2536  DO ls = 1, l_gs
2537  !===Compute radius of Gauss point
2538  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2539  x = rjs(ls,ms2)*ray/sigma(m1)
2540  ! TEST DEBUG
2541 
2542  ! TEST DEBUG
2543  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2544  drmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(1,:,ls,ms1))
2545  dzmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(2,:,ls,ms1))
2546  !terms with derivatives on phi and no derivative on bj
2547  DO ni = 1, n_w2
2548  y = x*(dw_s(2,ni,ls,ms2)*rnorms(1,ls,ms2) - dw_s(1,ni,ls,ms2)*rnorms(2,ls,ms2))
2549  DO nj = 1, n_ws1
2550  sij(1,ni,nj) = sij(1,ni,nj) + y *( (-1/muhl**2)*dzmuhl)*w_cs(nj,ls)
2551  sij(5,ni,nj) = sij(5,ni,nj) + y *(-(-1/muhl**2)*drmuhl)*w_cs(nj,ls)
2552  ENDDO
2553  ENDDO
2554  ENDDO
2555 
2556  !TEST
2557  !Sij = 0.d0
2558  !TEST
2559 
2560  mat_loc1 = 0.d0
2561  mat_loc2 = 0.d0
2562  DO ni = 1, n_w2
2563  i = phi_mesh%jj(ni,m2)
2564  ib = la_phi%loc_to_glob(1,i)
2565  ix = ni
2566  idxn(ix) = ib - 1
2567  DO kj =1,3
2568  DO nj = 1, n_ws1
2569  j = interface_h_phi%jjs1(nj,ms)
2570  jb = la_h%loc_to_glob(kj,j)
2571  jx = (kj-1)*n_ws1 + nj
2572  jdxn(jx) = jb - 1
2573  IF (kj == 1) THEN
2574  mat_loc1(ix,jx) = sij(1,ni,nj)
2575  mat_loc2(ix,jx) = sij(1,ni,nj)
2576  ELSEIF (kj == 3) THEN
2577  mat_loc1(ix,jx) = sij(5,ni,nj)
2578  mat_loc2(ix,jx) = sij(5,ni,nj)
2579  ENDIF
2580  END DO
2581  END DO
2582  END DO
2583  CALL matsetvalues(h_p_phi_mat1, n_w2, idxn(1:n_w2), 3*n_ws1, jdxn(1:3*n_ws1), &
2584  mat_loc1(1:n_w2,1:3*n_ws1), add_values, ierr)
2585  CALL matsetvalues(h_p_phi_mat2, n_w2, idxn(1:n_w2), 3*n_ws1, jdxn(1:3*n_ws1), &
2586  mat_loc2(1:n_w2,1:3*n_ws1), add_values, ierr)
2587  ! H to B
2588 
2589  !Feb 2 2007
2590  mat_loc1 = 0.d0
2591  mat_loc2 = 0.d0
2592  sij=c_sym*sij !SYM
2593  DO ki=1,3
2594  DO ni = 1, n_w1
2595  i = h_mesh%jj(ni,m1)
2596  ib = la_h%loc_to_glob(ki,i)
2597  ix = (ki-1)*n_w1 + ni
2598  idxn(ix) = ib - 1
2599  DO nj = 1, n_w2
2600  j = phi_mesh%jj(nj,m2)
2601  jb = la_phi%loc_to_glob(1,j)
2602  jx = nj
2603  jdxn(jx) = jb - 1
2604  IF (ki == 1) THEN
2605  mat_loc1(ix,jx) = sij(1,nj,ni)
2606  mat_loc2(ix,jx) = sij(1,nj,ni)
2607  ELSEIF (ki == 3) THEN
2608  mat_loc1(ix,jx) = sij(5,nj,ni)
2609  mat_loc2(ix,jx) = sij(5,nj,ni)
2610  ENDIF
2611  END DO
2612  END DO
2613  END DO
2614  CALL matsetvalues(h_p_phi_mat1, 3*n_w1, idxn(1:3*n_w1), n_w2, jdxn(1:n_w2), &
2615  mat_loc1(1:3*n_w1,1:n_w2), add_values, ierr)
2616  CALL matsetvalues(h_p_phi_mat2, 3*n_w1, idxn(1:3*n_w1), n_w2, jdxn(1:n_w2), &
2617  mat_loc2(1:3*n_w1,1:n_w2), add_values, ierr)
2618 
2619  !JLG, FL, May, 28, 2009
2620  !Add Laplacian of phi
2621  sij = 0.d0
2622  DO ls = 1, l_gs
2623  !===Compute radius of Gauss point
2624  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms2))* phi_mesh%gauss%wws(:,ls))
2625  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2626  ! H to Bo
2627  !x = c_lap*muhl*rjs(ls,ms2)*ray
2628  x = c_lap*rjs(ls,ms2)*ray
2629  ! H to Bo
2630  DO ni = 1, n_ws2
2631  DO nj = 1, n_ws1
2632  sij(1,ni,nj) = sij(1,ni,nj) - x*w_cs(nj,ls)*wws(ni,ls)*rnorms(1,ls,ms2)
2633  sij(5,ni,nj) = sij(5,ni,nj) - x*w_cs(nj,ls)*wws(ni,ls)*rnorms(2,ls,ms2)
2634  ENDDO
2635  END DO
2636  END DO
2637 
2638  !TEST
2639  !Sij(5,:,:) = 0.d0
2640  !TEST
2641  mat_loc1 = 0.d0
2642  mat_loc2 = 0.d0
2643  DO ni = 1, n_ws2
2644  i = interface_h_phi%jjs2(ni,ms)
2645  ib = la_phi%loc_to_glob(1,i)
2646  ix = ni
2647  idxn(ix) = ib - 1
2648  DO nj = 1, n_ws1
2649  j = interface_h_phi%jjs1(nj,ms)
2650  jb = la_h%loc_to_glob(1,j)
2651  jx = nj !(1-1)*n_ws1 + nj
2652  jdxn(jx) = jb - 1
2653  mat_loc1(ix,jx) = sij(1,ni,nj)
2654  mat_loc2(ix,jx) = sij(1,ni,nj)
2655 
2656  jb = la_h%loc_to_glob(3,j)
2657  jx = n_ws1 + nj !(3-1)*n_ws1 + nj
2658  jdxn(jx) = jb - 1
2659  mat_loc1(ix,jx) = sij(5,ni,nj)
2660  mat_loc2(ix,jx) = sij(5,ni,nj)
2661  END DO
2662  END DO
2663  CALL matsetvalues(h_p_phi_mat1, n_ws2, idxn(1:n_ws2), 2*n_ws1, jdxn(1:2*n_ws1), &
2664  mat_loc1(1:n_ws2,1:2*n_ws1), add_values, ierr)
2665  CALL matsetvalues(h_p_phi_mat2, n_ws2, idxn(1:n_ws2), 2*n_ws1, jdxn(1:2*n_ws1), &
2666  mat_loc2(1:n_ws2,1:2*n_ws1), add_values, ierr)
2667  !JLG, FL, May, 28, 2009
2668 
2669  !Feb 2 2007
2670  !==================
2671 
2672  !(use .true. for convergence tests)
2673  !June 6 2008, I put back (.true.) always.
2674  !Works much better when mu is discontinuous.
2675  !Mars 22 2007
2676 
2677  IF (stab(2) > 1.d-12) THEN
2678  !IF (.FALSE.) THEN
2679  !Mars 22 2007
2680  !Enforcing weak continuity on the normal components
2681  hsij = 0.d0
2682  sij = 0.d0
2683  phisij = 0.d0
2684  smuij = 0.d0
2685 
2686  ms2 = interface_h_phi%mesh2(ms)
2687  !hm1 = SUM(rjs(:,ms2))**(2*alpha-1)
2688  !LC 2017/01/29
2689  hm1 =(sum(rjs(:,ms2))/h_mesh%global_diameter)**(2*alpha-1)/(inputs%sigma_min*inputs%mu_min**2*h_mesh%global_diameter)
2690  !End LC 2017/01/29
2691 
2692  DO ls = 1, l_gs
2693 
2694  !Feb 8 2007, muhl
2695  muhl = sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
2696  !Feb 8 2007, muhl
2697  ray = 0.d0
2698  DO ni = 1, n_ws2; i = phi_mesh%jjs(ni,ms2)
2699  ray = ray + phi_mesh%rr(1,i)* phi_mesh%gauss%wws(ni,ls)
2700  END DO
2701 
2702  !ray = ray*hm1*rjs(ls,ms2)
2703  !June 8, 2008, Normalization, JLG, FL, May, 28, 2009
2704  ray = stab_div*ray*hm1*rjs(ls,ms2)
2705  !ray = stab_div*ray*hm1*rjs(ls,ms2)/muhl
2706  !ray = stab_div*ray*hm1*rjs(ls,ms2)/muhl**2
2707  !June 8, 2008, Normalization, JLG, FL, May, 28, 2009
2708  DO ni = 1, n_ws1
2709  DO nj = 1, n_ws1
2710  !H to B
2711  !x = muhl**2*w_cs(ni,ls)*w_cs(nj,ls)*ray
2712  x = muhl*w_cs(ni,ls)*w_cs(nj,ls)*ray
2713  !H to B
2714  hsij(1,ni,nj) = hsij(1,ni,nj) + x*rnorms(1,ls,ms2)**2
2715  hsij(4,ni,nj) = hsij(4,ni,nj) + x*rnorms(1,ls,ms2)*rnorms(2,ls,ms2)
2716  hsij(6,ni,nj) = hsij(6,ni,nj) + x*rnorms(2,ls,ms2)**2
2717  END DO
2718 
2719  DO nj = 1, n_w2
2720  x = muhl*mu_phi*w_cs(ni,ls)*(dw_s(1,nj,ls,ms2)*rnorms(1,ls,ms2) +&
2721  dw_s(2,nj,ls,ms2)*rnorms(2,ls,ms2))*ray
2722  sij(1,ni,nj) = sij(1,ni,nj) - x*rnorms(1,ls,ms2)
2723  sij(5,ni,nj) = sij(5,ni,nj) - x*rnorms(2,ls,ms2)
2724  ENDDO
2725  ENDDO
2726 
2727  ! H to B
2728  DO ni = 1, n_w2
2729  DO nj = 1, n_ws1
2730  x = mu_phi*w_cs(nj,ls)*(dw_s(1,ni,ls,ms2)*rnorms(1,ls,ms2) +&
2731  dw_s(2,ni,ls,ms2)*rnorms(2,ls,ms2))*ray
2732  smuij(1,ni,nj) = smuij(1,ni,nj) - x*rnorms(1,ls,ms2)
2733  smuij(5,ni,nj) = smuij(5,ni,nj) - x*rnorms(2,ls,ms2)
2734 
2735  END DO
2736  END DO
2737  ! H to B
2738 
2739  DO ni = 1, n_w2
2740  DO nj = 1, n_w2
2741  x = mu_phi**2*(dw_s(1,ni,ls,ms2)*rnorms(1,ls,ms2) + dw_s(2,ni,ls,ms2)*rnorms(2,ls,ms2))* &
2742  (dw_s(1,nj,ls,ms2)*rnorms(1,ls,ms2) + dw_s(2,nj,ls,ms2)*rnorms(2,ls,ms2))*ray
2743  phisij(ni,nj) = phisij(ni,nj) + x
2744  ENDDO
2745  ENDDO
2746 
2747  END DO
2748  sij(2,:,:) = sij(1,:,:)
2749  sij(6,:,:) = sij(5,:,:)
2750 
2751 
2752  mat_loc1 = 0.d0
2753  mat_loc2 = 0.d0
2754  DO ni = 1, n_ws1
2755  i = h_mesh%jjs(ni,ms1)
2756  DO ki= 1, 3, 2
2757  ib = la_h%loc_to_glob(ki,i)
2758  ix = (ki/2)*n_ws1 + ni
2759  idxn(ix) = ib - 1
2760  DO nj = 1, n_ws1
2761  j = h_mesh%jjs(nj,ms1)
2762  DO kj = 1, 3, 2
2763  jb = la_h%loc_to_glob(kj,j)
2764  jx = (kj/2)*n_ws1 + nj
2765  jdxn(jx) = jb - 1
2766  IF (ki*kj==1) THEN
2767  mat_loc1(ix,jx) = hsij(1,ni,nj)
2768  mat_loc2(ix,jx) = hsij(1,ni,nj)
2769  ELSE IF (ki*kj==9) THEN
2770  mat_loc1(ix,jx) = hsij(6,ni,nj)
2771  mat_loc2(ix,jx) = hsij(6,ni,nj)
2772  ELSE IF (ki*kj==3) THEN
2773  mat_loc1(ix,jx) = hsij(4,ni,nj)
2774  mat_loc2(ix,jx) = hsij(4,ni,nj)
2775  END IF
2776  END DO
2777  END DO
2778 
2779  DO nj = 1, n_w2
2780  j = phi_mesh%jj(nj,m2)
2781  jb = la_phi%loc_to_glob(1,j)
2782  jx = 2*n_ws1 + nj
2783  jdxn(jx) = jb - 1
2784  mat_loc1(ix,jx) = sij(2*ki-1,ni,nj)
2785  mat_loc2(ix,jx) = sij(2*ki-1,ni,nj)
2786  END DO
2787  ENDDO
2788  ENDDO
2789  CALL matsetvalues(h_p_phi_mat1, 2*n_ws1, idxn(1:2*n_ws1), 2*n_ws1+n_w2, jdxn(1:2*n_ws1+n_w2), &
2790  mat_loc1(1:2*n_ws1,1:2*n_ws1+n_w2), add_values, ierr)
2791  CALL matsetvalues(h_p_phi_mat2, 2*n_ws1, idxn(1:2*n_ws1), 2*n_ws1+n_w2, jdxn(1:2*n_ws1+n_w2), &
2792  mat_loc2(1:2*n_ws1,1:2*n_ws1+n_w2), add_values, ierr)
2793 
2794  mat_loc1 = 0.d0
2795  mat_loc2 = 0.d0
2796  DO ni = 1, n_w2
2797  i = phi_mesh%jj(ni,m2)
2798  ib = la_phi%loc_to_glob(1,i)
2799  ix = ni
2800  idxn(ix) = ib -1
2801  DO nj = 1, n_ws1
2802  j = h_mesh%jjs(nj,ms1)
2803  DO kj = 1, 3, 2
2804  jb = la_h%loc_to_glob(kj,j)
2805  jx = (kj/2)*n_ws1 + nj
2806  jdxn(jx) = jb - 1
2807  ! H to mu
2808  !mat_loc1(ix,jx) = Sij(2*kj-1,nj,ni)
2809  !mat_loc2(ix,jx) = Sij(2*kj-1,nj,ni)
2810  mat_loc1(ix,jx) = smuij(2*kj-1,ni,nj)
2811  mat_loc2(ix,jx) = smuij(2*kj-1,ni,nj)
2812  ! H to mu
2813  END DO
2814  END DO
2815 
2816  DO nj = 1, n_w2
2817  j = phi_mesh%jj(nj,m2)
2818  jb = la_phi%loc_to_glob(1,j)
2819  jx = 2*n_ws1 + nj
2820  jdxn(jx) = jb - 1
2821  mat_loc1(ix,jx) = phisij(ni,nj)
2822  mat_loc2(ix,jx) = phisij(ni,nj)
2823  END DO
2824  END DO
2825  CALL matsetvalues(h_p_phi_mat1, n_w2, idxn(1:n_w2), 2*n_ws1+n_w2, jdxn(1:2*n_ws1+n_w2), &
2826  mat_loc1(1:n_w2,1:2*n_ws1+n_w2), add_values, ierr)
2827  CALL matsetvalues(h_p_phi_mat2, n_w2, idxn(1:n_w2), 2*n_ws1+n_w2, jdxn(1:2*n_ws1+n_w2), &
2828  mat_loc2(1:n_w2,1:2*n_ws1+n_w2), add_values, ierr)
2829  END IF
2830  !FIN TEST
2831 
2832  ENDDO
2833 
2834 
2835  !=========================================================
2836  !--- Artificial boundary condition: d(phi)/dR + (1/R)*phi = 0
2837  !=========================================================
2838 
2839  IF (.NOT.PRESENT(index_fourier) .OR. .NOT.PRESENT(r_fourier)) RETURN
2840  IF (r_fourier.GT.0.d0) THEN
2841  !WRITE(*,*) ' Assembling the Fourier condition'
2842  DO ms = 1, phi_mesh%mes
2843  IF (phi_mesh%sides(ms) /= index_fourier) cycle ! Not on the artificial boundary
2844 
2845  phisij = 0.d0
2846 
2847  DO ls = 1, phi_mesh%gauss%l_Gs
2848 
2849  !===Compute radius of Gauss point
2850  ray = sum(phi_mesh%rr(1,phi_mesh%jjs(:,ms))* phi_mesh%gauss%wws(:,ls))
2851 
2852  x = c_mu_phi*rjs(ls,ms)*ray/r_fourier
2853 
2854  DO ni=1, phi_mesh%gauss%n_ws
2855  DO nj=1, phi_mesh%gauss%n_ws
2856  phisij(ni,nj) = phisij(ni,nj) + x*wws(ni,ls)*wws(nj,ls)
2857  ENDDO
2858  ENDDO
2859 
2860  ENDDO
2861 
2862 
2863  DO ni = 1, phi_mesh%gauss%n_ws
2864  i = phi_mesh%jjs(ni,ms)
2865  ib = la_phi%loc_to_glob(1,i)
2866  idxn(ni) = ib - 1
2867  DO nj = 1, phi_mesh%gauss%n_ws
2868  j = phi_mesh%jjs(nj,ms)
2869  jb = la_phi%loc_to_glob(1,j)
2870  jdxn(nj) = jb - 1
2871  END DO
2872  END DO
2873  CALL matsetvalues(h_p_phi_mat1, n_ws2, idxn(1:n_ws2), n_ws2, jdxn(1:n_ws2), &
2874  phisij(1:n_ws2,1:n_ws2), add_values, ierr)
2875  CALL matsetvalues(h_p_phi_mat2, n_ws2, idxn(1:n_ws2), n_ws2, jdxn(1:n_ws2), &
2876  phisij(1:n_ws2,1:n_ws2), add_values, ierr)
2877  END DO
2878  END IF
2879 
2880  CALL matassemblybegin(h_p_phi_mat1,mat_final_assembly,ierr)
2881  CALL matassemblyend(h_p_phi_mat1,mat_final_assembly,ierr)
2882  CALL matassemblybegin(h_p_phi_mat2,mat_final_assembly,ierr)
2883  CALL matassemblyend(h_p_phi_mat2,mat_final_assembly,ierr)
2884 
2885 !!$ DEALLOCATE(mat_loc1, mat_loc2, idxn, jdxn)
2886 
2887  END SUBROUTINE mat_h_p_phi_maxwell
2888 
2889  SUBROUTINE mat_dirichlet_maxwell(H_mesh, jj_v_to_H, Dirichlet_bdy_H_sides, &
2890  mode, stab, mu_h_field, la_h, h_p_phi_mat1, h_p_phi_mat2, sigma_np, sigma)
2891  USE def_type_mesh
2892  USE dir_nodes
2893  USE gauss_points
2894  USE boundary
2895  USE my_util
2896  USE input_data
2897 #include "petsc/finclude/petsc.h"
2898  USE petsc
2899  IMPLICIT NONE
2900  TYPE(mesh_type), INTENT(IN) :: H_mesh
2901  INTEGER, DIMENSION(:), INTENT(IN) :: jj_v_to_H
2902  INTEGER, DIMENSION(:), INTENT(IN) :: Dirichlet_bdy_H_sides
2903  INTEGER, INTENT(IN) :: mode
2904  REAL(KIND=8), DIMENSION(3), INTENT(IN) :: stab
2905  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field, sigma_np
2906  REAL(KIND=8), DIMENSION(H_mesh%me), INTENT(IN) :: sigma
2907  INTEGER :: ms, ls, ni, nj, i, j, &
2908  n_ws1, n_w1, m1, ki, kj, ib, jb
2909  REAL(KIND=8) :: x, y, hm1
2910  REAL(KIND=8) :: ray, error, stab_colle_h_mu
2911  REAL(KIND=8), DIMENSION(9,H_mesh%gauss%n_w,H_mesh%gauss%n_w) :: Hsij
2912  ! MATRICES POUR LES TERMES DE BORDS Hsij et Phisij
2913  !=================================================
2914  ! (--------------------------------------------------------------------)
2915  ! ( Hsij(1) | Hsij(2) | Hsij(4) || Sij(1) )
2916  ! ( Hsij(1) | Hsij(3) | Hsij(4) || Sij(2) )
2917  ! (--------------------------------------------------------------------)
2918  ! ( | Hsij(5) | || Sij(3) )
2919  ! ( | Hsij(5) | || Sij(4) )
2920  ! (--------------------------------------------------------------------)
2921  ! ( Hsij(7) | Hsij(9) | Hsij(6) || Sij(5) )
2922  ! ( Hsij(7) | Hsij(8) | Hsij(6) || Sij(6) )
2923  ! (====================================================================)
2924  ! ( Sij'(1) | Sij'(3) | Sij'(5) || Phisij )
2925  ! ( Sij'(2) | Sij'(4) | Sij'(6) || Phisij )
2926  ! (------------------------------------------------------------------- )
2927  !
2928  ! L'autre partie des termes croises est la symetrique de la premiere
2929  ! juste apres le calcsrhs_maul du terme de bord dissymetrique
2930 
2931  REAL(KIND=8) :: muhl, dzmuhl, drmuhl, norm
2932  !June 8 2008
2933  REAL(KIND=8) :: c_sym=.0d0 ! Symmetrization of the bilinear form
2934  !June 8 2008
2935 !!$ FL + CN 22/03 2013
2936 !!$ REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: mat_loc1, mat_loc2
2937 !!$ INTEGER , DIMENSION(:), ALLOCATABLE :: idxn, jdxn
2938  REAL(KIND=8), DIMENSION(3*H_mesh%gauss%n_w,3*H_mesh%gauss%n_w) :: mat_loc1, mat_loc2
2939  INTEGER , DIMENSION(3*H_mesh%gauss%n_w) :: idxn, jdxn
2940 !!$ FL + CN 22/03 2013
2941  TYPE(petsc_csr_la) :: LA_H
2942  INTEGER :: ix, jx
2943  INTEGER :: count
2944  !DCQ Exact mu
2945  REAL(KIND=8), DIMENSION(2) :: Dmu_field
2946  REAL(KIND=8), DIMENSION(2) :: gauss_pt
2947  INTEGER, DIMENSION(1) :: gauss_pt_id
2948  REAL(KIND=8), DIMENSION(1) :: dummy_mu_bar
2949  INTEGER::mesh_id
2950  petscerrorcode :: ierr
2951  mat :: h_p_phi_mat1, h_p_phi_mat2
2952 
2953  !June 2009, JLG, CN, Normalization
2954  stab_colle_h_mu = stab(3)
2955  !Jan 2010, JLG, CN, Normalization,
2956 
2957  !*********************************************************************************
2958  !--------------------TERMS ON DIRICHLET BOUNDARY-----------------------------
2959  !**********************************************************************************
2960  CALL gauss(h_mesh)
2961  n_ws1 = h_mesh%gauss%n_ws
2962  n_w1 = h_mesh%gauss%n_w
2963 
2964 !!$ ALLOCATE(mat_loc1(3*n_w1,3*n_w1))
2965 !!$ ALLOCATE(mat_loc2(3*n_w1,3*n_w1))
2966 !!$ ALLOCATE(idxn(3*n_w1))
2967 !!$ ALLOCATE(jdxn(3*n_w1))
2968 
2969  error = 0
2970  DO count = 1, SIZE(dirichlet_bdy_h_sides)
2971  ms = dirichlet_bdy_h_sides(count)
2972  !hm1 = stab_colle_H_mu/SUM(H_mesh%gauss%rjs(:,ms))
2973  !LC 2017/01/29
2974  hm1 = stab_colle_h_mu/(sum(h_mesh%gauss%rjs(:,ms))*inputs%sigma_min)
2975  !End LC 2017/01/29
2976  m1 = h_mesh%neighs(ms)
2977  mesh_id = h_mesh%i_d(m1)
2978  !====================================================================================
2979  !------------------------------------TERMES SUR LE BLOC H----------------------------
2980  !====================================================================================
2981 
2982  !-------------------------------hm1 (bi x ni) . (bj/mu x nj)----------------------------
2983  !====================================================================================
2984 
2985  hsij = 0.d0
2986  DO ls = 1, h_mesh%gauss%l_Gs
2987  !===Compute radius of Gauss point
2988  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
2989  !H to B
2990  !DCQ mu exact
2991  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
2992  muhl = sum(mu_h_field(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
2993  ELSE
2994  gauss_pt(1)=sum(h_mesh%rr(1,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
2995  gauss_pt(2)=sum(h_mesh%rr(2,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
2996  gauss_pt_id(1)=mesh_id
2997  dummy_mu_bar(:) = mu_bar_in_fourier_space(h_mesh,1,1,gauss_pt,gauss_pt_id)
2998  muhl=dummy_mu_bar(1)
2999  END IF
3000  !DCQ DEBUG
3001 
3002  x = hm1*h_mesh%gauss%rjs(ls,ms)*ray /muhl
3003  ! H to B
3004  DO ni = 1, h_mesh%gauss%n_ws
3005  DO nj = 1, h_mesh%gauss%n_ws
3006  y = x * h_mesh%gauss%wws(ni,ls)*h_mesh%gauss%wws(nj,ls)
3007 
3008  hsij(1,ni,nj) = hsij(1,ni,nj) + y*(h_mesh%gauss%rnorms(2,ls,ms)**2)
3009  hsij(4,ni,nj) = hsij(4,ni,nj) - y*h_mesh%gauss%rnorms(1,ls,ms)*h_mesh%gauss%rnorms(2,ls,ms)
3010  hsij(5,ni,nj) = hsij(5,ni,nj) + y
3011  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(h_mesh%gauss%rnorms(1,ls,ms)**2)
3012  ENDDO
3013  ENDDO
3014 
3015  ENDDO
3016 
3017 
3018  !TEST
3019  !Hsij = 0.d0
3020  !Hsij = Hsij / hm1
3021  !TEST
3022  mat_loc1 = 0.d0
3023  mat_loc2 = 0.d0
3024  DO ki= 1, 3
3025  DO ni = 1, n_ws1
3026  i = h_mesh%jjs(ni,ms)
3027  ib = la_h%loc_to_glob(ki,i)
3028  ix = ni + (ki-1)*n_ws1
3029  idxn(ix) = ib - 1
3030  DO kj = 1, 3
3031  DO nj = 1, n_ws1
3032  j = h_mesh%jjs(nj,ms)
3033  jb = la_h%loc_to_glob(kj,j)
3034  jx = nj + (kj-1)*n_ws1
3035  jdxn(jx) = jb - 1
3036  IF ((ki == 1) .AND. (kj == 1)) THEN
3037  mat_loc1(ix,jx) = hsij(1,ni,nj)
3038  mat_loc2(ix,jx) = hsij(1,ni,nj)
3039  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
3040  mat_loc1(ix,jx) = hsij(4,ni,nj)
3041  mat_loc2(ix,jx) = hsij(4,ni,nj)
3042  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
3043  mat_loc1(ix,jx) = hsij(4,nj,ni)
3044  mat_loc2(ix,jx) = hsij(4,nj,ni)
3045  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
3046  mat_loc1(ix,jx) = hsij(5,ni,nj)
3047  mat_loc2(ix,jx) = hsij(5,ni,nj)
3048  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
3049  mat_loc1(ix,jx) = hsij(6,ni,nj)
3050  mat_loc2(ix,jx) = hsij(6,ni,nj)
3051  ENDIF
3052  END DO
3053  END DO
3054  END DO
3055  END DO
3056 
3057  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3058  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3059  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3060  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3061 
3062  !====================================================================================
3063  !------------------------(1/sigma) (Rot bj/mu) . (bi x ni)------------------------------
3064  !====================================================================================
3065 
3066  !JLG+FL: Jan 18 2013
3067  !There was a bug on the sign of the normal
3068  !The sign before rnorms has been changed everywhere in this loop.
3069  hsij = 0.d0
3070 
3071  DO ls = 1, h_mesh%gauss%l_Gs
3072  !===Compute radius of Gauss point
3073  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3074  !H to B
3075  !DCQ mu exact
3076  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
3077  muhl = sum(mu_h_field(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3078  drmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_s(1,:,ls,ms))
3079  dzmuhl = sum(mu_h_field(h_mesh%jj(:,m1))*dw_s(2,:,ls,ms))
3080  ELSE
3081  gauss_pt(1)=sum(h_mesh%rr(1,h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3082  gauss_pt(2)=sum(h_mesh%rr(2,h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3083  gauss_pt_id(1)=mesh_id
3084  dummy_mu_bar(:) = mu_bar_in_fourier_space(h_mesh,1,1,gauss_pt,gauss_pt_id)
3085  muhl=dummy_mu_bar(1)
3086  dmu_field = grad_mu_bar_in_fourier_space(gauss_pt,gauss_pt_id)
3087  drmuhl =dmu_field(1)
3088  dzmuhl =dmu_field(2)
3089  ENDIF
3090 
3091  ! TEST DEBUG
3092  IF (jj_v_to_h(h_mesh%jj(1,m1)) == -1) THEN
3093  x = h_mesh%gauss%rjs(ls,ms)*ray/sigma(m1)
3094  ELSE
3095  x = h_mesh%gauss%rjs(ls,ms)*ray/sum(sigma_np(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3096  END IF
3097  ! TEST DEBUG
3098 
3099  !H to B
3100  !terms without derivatives
3101  DO ni = 1,n_ws1
3102  DO nj = 1, n_ws1
3103  y = x*h_mesh%gauss%wws(ni,ls)*h_mesh%gauss%wws(nj,ls)
3104 
3105  hsij(2,ni,nj) = hsij(2,ni,nj) + y * (-mode/ray)*(rnorms(1,ls,ms))/muhl
3106  hsij(3,ni,nj) = hsij(3,ni,nj) + y * mode/ray *(rnorms(1,ls,ms))/muhl
3107  hsij(5,ni,nj) = hsij(5,ni,nj) + y * (-1/ray) *(rnorms(1,ls,ms))/muhl
3108  hsij(8,ni,nj) = hsij(8,ni,nj) + y * (-mode/ray)*(rnorms(2,ls,ms))/muhl
3109  hsij(9,ni,nj) = hsij(9,ni,nj) + y * mode/ray *(rnorms(2,ls,ms))/muhl
3110 
3111  hsij(1,ni,nj) = hsij(1,ni,nj) - y*(rnorms(2,ls,ms))*(-(dzmuhl/muhl**2))
3112  hsij(4,ni,nj) = hsij(4,ni,nj) - y*(rnorms(2,ls,ms))*( (drmuhl/muhl**2))
3113  hsij(5,ni,nj) = hsij(5,ni,nj) &
3114  + y*(rnorms(1,ls,ms)*drmuhl+rnorms(2,ls,ms)*dzmuhl)/muhl**2
3115  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(rnorms(1,ls,ms))*( (drmuhl/muhl**2))
3116  hsij(7,ni,nj) = hsij(7,ni,nj) + y*(rnorms(1,ls,ms))*(-(dzmuhl/muhl**2))
3117  !H to B
3118  ENDDO
3119  ENDDO
3120 
3121 
3122 
3123  ENDDO
3124 
3125  !TEST
3126  !Hsij = 0.d0
3127  !TEST
3128 
3129  mat_loc1 = 0.d0
3130  mat_loc2 = 0.d0
3131  DO ki= 1, 3
3132  DO ni = 1, n_ws1
3133  i = h_mesh%jjs(ni,ms)
3134  ib = la_h%loc_to_glob(ki,i)
3135  ix = ni + (ki-1)*n_ws1
3136  idxn(ix) = ib - 1
3137  DO kj = 1, 3
3138  DO nj = 1, n_ws1
3139  j = h_mesh%jjs(nj,ms)
3140  jb = la_h%loc_to_glob(kj,j)
3141  jx = nj + (kj-1)*n_ws1
3142  jdxn(jx) = jb - 1
3143  IF ((ki == 1) .AND. (kj == 1)) THEN
3144  mat_loc1(ix,jx) = hsij(1,ni,nj)
3145  mat_loc2(ix,jx) = hsij(1,ni,nj)
3146  ELSE IF ( (ki == 1) .AND. (kj == 3)) THEN
3147  mat_loc1(ix,jx) = hsij(4,ni,nj)
3148  mat_loc2(ix,jx) = hsij(4,ni,nj)
3149  ELSE IF ( (ki == 2) .AND. (kj == 1)) THEN
3150  mat_loc1(ix,jx) = hsij(2,ni,nj)
3151  mat_loc2(ix,jx) = hsij(3,ni,nj)
3152  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
3153  mat_loc1(ix,jx) = hsij(5,ni,nj)
3154  mat_loc2(ix,jx) = hsij(5,ni,nj)
3155  ELSEIF ( (ki == 2) .AND. (kj == 3)) THEN
3156  mat_loc1(ix,jx) = hsij(8,ni,nj)
3157  mat_loc2(ix,jx) = hsij(9,ni,nj)
3158  ELSEIF ( (ki == 3) .AND. (kj == 1)) THEN
3159  mat_loc1(ix,jx) = hsij(7,ni,nj)
3160  mat_loc2(ix,jx) = hsij(7,ni,nj)
3161  ELSEIF ( (ki == 3) .AND. (kj == 3)) THEN
3162  mat_loc1(ix,jx) = hsij(6,ni,nj)
3163  mat_loc2(ix,jx) = hsij(6,ni,nj)
3164  ENDIF
3165  END DO
3166  END DO
3167  END DO
3168  END DO
3169 
3170  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3171  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3172  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3173  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3174 
3175  !Feb 2 2007
3176  hsij=c_sym*hsij !SYM
3177  mat_loc1 = 0.d0
3178  mat_loc2 = 0.d0
3179  DO ki= 1, 3
3180  DO ni = 1, n_ws1
3181  i = h_mesh%jjs(ni,ms)
3182  ib = la_h%loc_to_glob(ki,i)
3183  ix = ni + (ki-1)*n_ws1
3184  idxn(ix) = ib - 1
3185  DO kj = 1, 3
3186  DO nj = 1, n_ws1
3187  j = h_mesh%jjs(nj,ms)
3188  jb = la_h%loc_to_glob(kj,j)
3189  jx = nj + (kj-1)*n_ws1
3190  jdxn(jx) = jb - 1
3191  IF ( (kj == 2) .AND. (ki == 1)) THEN
3192  mat_loc1(ix,jx) = hsij(2,nj,ni)
3193  mat_loc2(ix,jx) = hsij(3,nj,ni)
3194  ELSEIF ((kj == 2) .AND. (ki == 2)) THEN
3195  mat_loc1(ix,jx) = hsij(5,nj,ni)
3196  mat_loc2(ix,jx) = hsij(5,nj,ni)
3197  ELSEIF ( (kj == 2) .AND. (ki == 3)) THEN
3198  mat_loc1(ix,jx) = hsij(8,nj,ni)
3199  mat_loc2(ix,jx) = hsij(9,nj,ni)
3200  ENDIF
3201  END DO
3202  END DO
3203  END DO
3204  END DO
3205  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3206  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3207  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3208  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3209  !feb 2 2007
3210 
3211 
3212  hsij = 0.d0
3213 
3214  DO ls = 1, h_mesh%gauss%l_Gs
3215  !===Compute radius of Gauss point
3216  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3217  !H to B
3218  !DCQ mu exact
3219  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
3220  muhl = sum(mu_h_field(h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3221  ELSE
3222  gauss_pt(1)=sum(h_mesh%rr(1,h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3223  gauss_pt(2)=sum(h_mesh%rr(2,h_mesh%jjs(:,ms))* h_mesh%gauss%wws(:,ls))
3224  gauss_pt_id(1)=mesh_id
3225  dummy_mu_bar(:) = mu_bar_in_fourier_space(h_mesh,1,1,gauss_pt,gauss_pt_id)
3226  muhl=dummy_mu_bar(1)
3227  END IF
3228 
3229  ! TEST DEBUG
3230  IF (jj_v_to_h(h_mesh%jj(1,m1)) == -1) THEN
3231  x = h_mesh%gauss%rjs(ls,ms)*ray/(sigma(m1)*muhl)
3232  ELSE
3233  x = h_mesh%gauss%rjs(ls,ms)*ray/(sum(sigma_np(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))*muhl)
3234  END IF
3235  ! TEST DEBUG
3236 
3237  !H to B
3238  !terms with derivatives
3239  DO ni = 1,n_ws1
3240  y = x*h_mesh%gauss%wws(ni,ls)
3241  DO nj = 1, n_w1
3242  hsij(1,ni,nj) = hsij(1,ni,nj) + y*(-h_mesh%gauss%dw_s(2,nj,ls,ms))*(rnorms(2,ls,ms))
3243  hsij(4,ni,nj) = hsij(4,ni,nj) + y* h_mesh%gauss%dw_s(1,nj,ls,ms) *(rnorms(2,ls,ms))
3244  hsij(5,ni,nj) = hsij(5,ni,nj) + &
3245  y*(-h_mesh%gauss%dw_s(2,nj,ls,ms)*(rnorms(2,ls,ms))-h_mesh%gauss%dw_s(1,nj,ls,ms)*(rnorms(1,ls,ms)))
3246  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(-h_mesh%gauss%dw_s(1,nj,ls,ms))*(rnorms(1,ls,ms))
3247  hsij(7,ni,nj) = hsij(7,ni,nj) + y* h_mesh%gauss%dw_s(2,nj,ls,ms) *(rnorms(1,ls,ms))
3248  ENDDO
3249  ENDDO
3250  ENDDO
3251 
3252  !TEST
3253  !Hsij = 0.d0
3254  !TEST
3255 
3256 
3257  mat_loc1 = 0.d0
3258  mat_loc2 = 0.d0
3259  DO ki= 1, 3
3260  DO ni = 1, n_ws1
3261  i = h_mesh%jjs(ni,ms)
3262  ib = la_h%loc_to_glob(ki,i)
3263  ix = ni + (ki-1)*n_ws1
3264  idxn(ix) = ib - 1
3265  DO kj = 1, 3
3266  DO nj = 1, n_w1
3267  j = h_mesh%jj(nj,m1)
3268  jb = la_h%loc_to_glob(kj,j)
3269  jx = nj + (kj-1)*n_w1
3270  jdxn(jx) = jb - 1
3271  IF ((ki == 1) .AND. (kj == 1)) THEN
3272  mat_loc1(ix,jx) = hsij(1,ni,nj)
3273  mat_loc2(ix,jx) = hsij(1,ni,nj)
3274  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
3275  mat_loc1(ix,jx) = hsij(4,ni,nj)
3276  mat_loc2(ix,jx) = hsij(4,ni,nj)
3277  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
3278  mat_loc1(ix,jx) = hsij(5,ni,nj)
3279  mat_loc2(ix,jx) = hsij(5,ni,nj)
3280  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
3281  mat_loc1(ix,jx) = hsij(6,ni,nj)
3282  mat_loc2(ix,jx) = hsij(6,ni,nj)
3283  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
3284  mat_loc1(ix,jx) = hsij(7,ni,nj)
3285  mat_loc2(ix,jx) = hsij(7,ni,nj)
3286  ENDIF
3287  END DO
3288  END DO
3289  END DO
3290  END DO
3291 
3292  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_w1, jdxn(1:3*n_w1), &
3293  mat_loc1(1:3*n_ws1,1:3*n_w1), add_values, ierr)
3294  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_w1, jdxn(1:3*n_w1), &
3295  mat_loc2(1:3*n_ws1,1:3*n_w1), add_values, ierr)
3296 
3297  !Feb 2 2007
3298  hsij=c_sym*hsij !SYM
3299  mat_loc1 = 0.d0
3300  mat_loc2 = 0.d0
3301  DO ki = 1, 3
3302  DO ni = 1, n_w1
3303  i = h_mesh%jj(ni,m1)
3304  ib = la_h%loc_to_glob(ki,i)
3305  ix = ni + (ki-1)*n_w1
3306  idxn(ix) = ib - 1
3307  DO kj= 1, 3
3308  DO nj = 1, n_ws1
3309  j = h_mesh%jjs(nj,ms)
3310  jb = la_h%loc_to_glob(kj,j)
3311  jx = nj + (kj-1)*n_ws1
3312  jdxn(jx) = jb - 1
3313  IF ((kj == 1) .AND. (ki == 1)) THEN
3314  mat_loc1(ix,jx) = hsij(1,nj,ni)
3315  mat_loc2(ix,jx) = hsij(1,nj,ni)
3316  ELSEIF ((kj == 1) .AND. (ki == 3)) THEN
3317  mat_loc1(ix,jx) = hsij(4,nj,ni)
3318  mat_loc2(ix,jx) = hsij(4,nj,ni)
3319  ELSEIF ((kj == 2) .AND. (ki == 2)) THEN
3320  mat_loc1(ix,jx) = hsij(5,nj,ni)
3321  mat_loc2(ix,jx) = hsij(5,nj,ni)
3322  ELSEIF ((kj == 3) .AND. (ki == 3)) THEN
3323  mat_loc1(ix,jx) = hsij(6,nj,ni)
3324  mat_loc2(ix,jx) = hsij(6,nj,ni)
3325  ELSEIF ((kj == 3) .AND. (ki == 1)) THEN
3326  mat_loc1(ix,jx) = hsij(7,nj,ni)
3327  mat_loc2(ix,jx) = hsij(7,nj,ni)
3328  ENDIF
3329  END DO
3330  END DO
3331  END DO
3332  END DO
3333 
3334  CALL matsetvalues(h_p_phi_mat1, 3*n_w1 , idxn(1:3*n_w1), 3*n_ws1, jdxn(1:3*n_ws1), &
3335  mat_loc1(1:3*n_w1,1:3*n_ws1), add_values, ierr)
3336  CALL matsetvalues(h_p_phi_mat2, 3*n_w1 , idxn(1:3*n_w1), 3*n_ws1, jdxn(1:3*n_ws1), &
3337  mat_loc2(1:3*n_w1,1:3*n_ws1), add_values, ierr)
3338 
3339  ENDDO
3340 
3341  !===JLG+CN July 2017 stabilizing terms for Neumann BC
3342  DO count = 1, SIZE(neumann_bdy_h_sides)
3343  ms = neumann_bdy_h_sides(count)
3344  norm = (inputs%stab(1)/inputs%Rem)*(sum(rjs(:,ms))/h_mesh%global_diameter)**(2*alpha-1)&
3345  /(h_mesh%global_diameter*inputs%sigma_min*inputs%mu_min**2)
3346  !====================================================================================
3347  !-------------------------------norm (mu bi . ni) . (bj . nj)-------------------------
3348  !====================================================================================
3349  hsij = 0.d0
3350  DO ls = 1, h_mesh%gauss%l_Gs
3351  !===Compute radius of Gauss point
3352  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3353  !===ATTENTION
3354  !===Mu supposed to be constant at the boundary where B.n is enforced
3355  muhl = sum(mu_h_field(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3356  x = norm*muhl*h_mesh%gauss%rjs(ls,ms)*ray
3357  !TEST JLG RZ, Jan 22 2018 Removed stabilization
3358  !x=0.d0
3359  !TEST JLG RZ, Jan 22 2018 Removed stabilization
3360  DO ni = 1, h_mesh%gauss%n_ws
3361  DO nj = 1, h_mesh%gauss%n_ws
3362  y = x*h_mesh%gauss%wws(ni,ls)*h_mesh%gauss%wws(nj,ls)
3363  hsij(1,ni,nj) = hsij(1,ni,nj) + y*(h_mesh%gauss%rnorms(1,ls,ms))**2
3364  hsij(4,ni,nj) = hsij(4,ni,nj) + y*h_mesh%gauss%rnorms(1,ls,ms)*h_mesh%gauss%rnorms(2,ls,ms)
3365  hsij(6,ni,nj) = hsij(6,ni,nj) + y*(h_mesh%gauss%rnorms(2,ls,ms))**2
3366  hsij(7,ni,nj) = hsij(7,ni,nj) + y*h_mesh%gauss%rnorms(1,ls,ms)*h_mesh%gauss%rnorms(2,ls,ms)
3367  ENDDO
3368  ENDDO
3369  ENDDO
3370 
3371  mat_loc1 = 0.d0
3372  mat_loc2 = 0.d0
3373  DO ki= 1, 3
3374  DO ni = 1, n_ws1
3375  i = h_mesh%jjs(ni,ms)
3376  ib = la_h%loc_to_glob(ki,i)
3377  ix = ni + (ki-1)*n_ws1
3378  idxn(ix) = ib - 1
3379  DO kj = 1, 3
3380  DO nj = 1, n_ws1
3381  j = h_mesh%jjs(nj,ms)
3382  jb = la_h%loc_to_glob(kj,j)
3383  jx = nj + (kj-1)*n_ws1
3384  jdxn(jx) = jb - 1
3385  IF ((ki == 1) .AND. (kj == 1)) THEN
3386  mat_loc1(ix,jx) = hsij(1,ni,nj)
3387  mat_loc2(ix,jx) = hsij(1,ni,nj)
3388  ELSE IF ((ki == 1) .AND. (kj == 3)) THEN
3389  mat_loc1(ix,jx) = hsij(4,ni,nj)
3390  mat_loc2(ix,jx) = hsij(4,ni,nj)
3391  ELSE IF ((ki == 3) .AND. (kj == 1)) THEN
3392  mat_loc1(ix,jx) = hsij(7,ni,nj)
3393  mat_loc2(ix,jx) = hsij(7,ni,nj)
3394  ELSE IF ((ki == 3) .AND. (kj == 3)) THEN
3395  mat_loc1(ix,jx) = hsij(6,ni,nj)
3396  mat_loc2(ix,jx) = hsij(6,ni,nj)
3397  ENDIF
3398  END DO
3399  END DO
3400  END DO
3401  END DO
3402 
3403  CALL matsetvalues(h_p_phi_mat1, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3404  mat_loc1(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3405  CALL matsetvalues(h_p_phi_mat2, 3*n_ws1 , idxn(1:3*n_ws1), 3*n_ws1, jdxn(1:3*n_ws1), &
3406  mat_loc2(1:3*n_ws1,1:3*n_ws1), add_values, ierr)
3407 
3408  END DO
3409  !===JLG+CN July 2017 stabilizing terms for Neumann BC
3410 
3411  CALL matassemblybegin(h_p_phi_mat1,mat_final_assembly,ierr)
3412  CALL matassemblyend(h_p_phi_mat1,mat_final_assembly,ierr)
3413  CALL matassemblybegin(h_p_phi_mat2,mat_final_assembly,ierr)
3414  CALL matassemblyend(h_p_phi_mat2,mat_final_assembly,ierr)
3415 
3416 !!$ IF (ALLOCATED(mat_loc1)) DEALLOCATE(mat_loc1)
3417 !!$ IF (ALLOCATED(mat_loc2)) DEALLOCATE(mat_loc2)
3418 !!$ IF (ALLOCATED(idxn)) DEALLOCATE(idxn)
3419 !!$ IF (ALLOCATED(jdxn)) DEALLOCATE(jdxn)
3420 
3421 
3422  END SUBROUTINE mat_dirichlet_maxwell
3423 
3424  SUBROUTINE courant_int_by_parts(H_mesh,phi_mesh,interface_H_phi,sigma,mu_phi,mu_H_field,time,mode,&
3425  rhs_h,nl, la_h, la_phi, vb_1, vb_2, b_ext, h_pert, sigma_curl_gauss, j_over_sigma_gauss)
3426 
3427  !forcage faisant intervenir J, volumique et interface_H_phi
3428  !pour le probleme en entier
3429 
3430  USE def_type_mesh
3431  USE gauss_points
3432  USE boundary
3433  USE my_util
3434  USE input_data
3435 #include "petsc/finclude/petsc.h"
3436  USE petsc
3437  IMPLICIT NONE
3438  TYPE(mesh_type), INTENT(IN) :: H_mesh, phi_mesh
3439  TYPE(interface_type), INTENT(IN) :: interface_H_phi
3440  REAL(KIND=8), INTENT(IN) :: mu_phi, time
3441  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: sigma
3442  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
3443  INTEGER, INTENT(IN) :: mode
3444  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: nl
3445  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: B_ext
3446  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: rhs_H
3447  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: H_pert !Used only if mu is variable
3448  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: J_over_sigma_gauss !Used only if sigma variable in fluid
3449  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: sigma_curl_gauss !Used only if sigma variable in fluid
3450  INTEGER :: index
3451  REAL(KIND=8), DIMENSION(H_mesh%np,6) :: src_H
3452  REAL(KIND=8), DIMENSION(phi_mesh%np,2) :: src_phi
3453  REAL(KIND=8), DIMENSION(6) :: c !used to store rotational of H_pert
3454  REAL(KIND=8), DIMENSION(phi_mesh%gauss%n_ws,phi_mesh%gauss%l_Gs) :: w_cs
3455  REAL(KIND=8), DIMENSION(2) :: gaussp
3456  REAL(KIND=8) :: ray
3457  INTEGER :: m, l, i, ni, k, ms, ls, n_ws1, n_ws2, ms1, ms2, H_bloc_size, n_w2, m1
3458  INTEGER :: mesh_id1
3459  REAL(KIND=8), DIMENSION(6) :: JsolH_anal, rhs_Hl
3460  REAL(KIND=8), DIMENSION(2,H_mesh%gauss%n_w) :: dwH
3461  !REAL(KIND=8), DIMENSION(2,phi_mesh%gauss%n_w) :: dwphi
3462  !REAL(KIND=8), DIMENSION(2,phi_mesh%gauss%n_w) :: src_phil
3463  REAL(KIND=8) :: ray_rjl, muhl, drmuhl, dzmuhl
3464  !REAL(KIND=8) :: moderay2
3465  !REAL(KIND=8) :: tps, dummy
3466 !!$ FL + CN, 22/03/2013
3467 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: idxn
3468  INTEGER, DIMENSION(H_mesh%np) :: idxn_H
3469  INTEGER, DIMENSION(phi_mesh%np) :: idxn_phi
3470  !DCQ Exact mu
3471  REAL(KIND=8), DIMENSION(2) :: Dmu_field
3472  REAL(KIND=8), DIMENSION(2) :: gauss_pt
3473  INTEGER, DIMENSION(1) :: gauss_pt_id
3474  REAL(KIND=8), DIMENSION(1) :: dummy_mu_bar
3475 !!$ FL + CN, 22/03/2013
3476  TYPE(petsc_csr_la) :: LA_H, LA_phi
3477  REAL(KIND=8), DIMENSION(6) :: B_ext_l
3478  petscerrorcode :: ierr
3479  vec :: vb_1, vb_2
3480 
3481  !ALLOCATE(src_H(H_mesh%np,6), src_phi(phi_mesh%np,2))
3482 
3483  CALL veczeroentries(vb_1, ierr)
3484  CALL veczeroentries(vb_2, ierr)
3485 
3486  !forcage volumique
3487  !attention on comprime le calcul sur les points de Gauss et integration !!
3488  !j/sigma *(Rot(b))
3489 
3490  !tps = user_time(dummy)
3491  src_h=0.d0
3492  src_phi=0.d0
3493  index = 0
3494 
3495  DO m = 1, h_mesh%me
3496  mesh_id1 = h_mesh%i_d(m)
3497  DO l = 1, h_mesh%gauss%l_G
3498  index = index + 1
3499  !Feb 8 2007, muhl
3500  ! This value of muhl is used in Jexact only
3501  ! DCQ comment: we should use here also mu_exact. (To be done if necessary)
3502  muhl=sum(mu_h_field(h_mesh%jj(:,m))*h_mesh%gauss%ww(:,l))
3503  !Feb 8 2007, muhl
3504  dwh = h_mesh%gauss%dw(:,:,l,m)
3505  !===Compute radius of Gauss point
3506  DO k=1, 6
3507  b_ext_l(k) = sum(b_ext(h_mesh%jj(:,m),k)*h_mesh%gauss%ww(:,l))
3508  END DO
3509 
3510  jsolh_anal = 0.d0
3511  rhs_hl = 0.d0
3512  gaussp = 0.d0
3513  DO ni = 1, h_mesh%gauss%n_w; i = h_mesh%jj(ni,m)
3514  gaussp = gaussp + h_mesh%rr(:,i)*h_mesh%gauss%ww(ni,l)
3515  jsolh_anal(:) = jsolh_anal(:) + nl(i,:)*h_mesh%gauss%ww(ni,l)
3516  rhs_hl(:) = rhs_hl(:) + rhs_h(i,:)*h_mesh%gauss%ww(ni,l)
3517  ENDDO
3518  ray = gaussp(1)
3519  ray_rjl = h_mesh%gauss%rj(l,m)*ray
3520 
3521  IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
3522  DO k = 1, 6
3523  jsolh_anal(k) = jsolh_anal(k) + j_over_sigma_gauss(index,k) + sigma_curl_gauss(index,k)
3524  END DO
3525  ELSE
3526  DO k = 1, 6
3527  !JsolH_anal(k) = muhl*JsolH_anal(k) + & ! BUG Jan 2010, JLG, CN, FL
3528  jsolh_anal(k) = jsolh_anal(k) + &
3529  jexact_gauss(k, gaussp, mode, mu_phi, sigma(m), muhl, time, mesh_id1, b_ext_l)/sigma(m)
3530  END DO
3531  END IF
3532 
3533  !DCQ Begins
3534  IF (inputs%if_permeability_variable_in_theta) THEN
3535  !DCQ Exact mu
3536  IF(inputs%if_use_fem_integration_for_mu_bar) THEN
3537  muhl = sum(mu_h_field(h_mesh%jj(:,m))*h_mesh%gauss%ww(:,l))
3538  drmuhl = sum(mu_h_field(h_mesh%jj(:,m))*h_mesh%gauss%dw(1,:,l,m))
3539  dzmuhl = sum(mu_h_field(h_mesh%jj(:,m))*h_mesh%gauss%dw(2,:,l,m))
3540  ELSE
3541  gauss_pt(1)=sum(h_mesh%rr(1,h_mesh%jj(:,m))*h_mesh%gauss%ww(:,l))
3542  gauss_pt(2)=sum(h_mesh%rr(2,h_mesh%jj(:,m))*h_mesh%gauss%ww(:,l))
3543  gauss_pt_id(1)=mesh_id1
3544  dummy_mu_bar(:) = mu_bar_in_fourier_space(h_mesh,1,1,gauss_pt,gauss_pt_id)
3545  muhl=dummy_mu_bar(1)
3546  dmu_field = grad_mu_bar_in_fourier_space(gauss_pt,gauss_pt_id)
3547  drmuhl =dmu_field(1)
3548  dzmuhl =dmu_field(2)
3549  ENDIF
3550 
3551  c = 0.d0
3552  DO ni = 1,h_mesh%gauss%n_w
3553  i = h_mesh%jj(ni,m)
3554  !DCQ
3555  ! - CURL(1/mu B*) + CURL(1/mu_bar)B*)
3556  !code obtained from FEMSUB_OBJECT/fem_tn_navier_mhd.f90
3557  !--------Composante r------
3558  c(1) = c(1) + ( mode/ray*h_pert(i,6)*h_mesh%gauss%ww(ni,l) &
3559  - h_pert(i,3)*h_mesh%gauss%dw(2,ni,l,m)) &
3560  + (1/muhl)*( mode/ray*b_ext(i,6)*h_mesh%gauss%ww(ni,l) &
3561  - b_ext(i,3)*h_mesh%gauss%dw(2,ni,l,m)) &
3562  -(1/muhl**2)*(-dzmuhl*b_ext(i,3)*h_mesh%gauss%ww(ni,l))
3563 
3564  c(2) = c(2) + (-mode/ray*h_pert(i,5)*h_mesh%gauss%ww(ni,l) &
3565  - h_pert(i,4)*h_mesh%gauss%dw(2,ni,l,m)) &
3566  + (1/muhl)*(-mode/ray*b_ext(i,5)*h_mesh%gauss%ww(ni,l) &
3567  - b_ext(i,4)*h_mesh%gauss%dw(2,ni,l,m)) &
3568  -(1/muhl**2)*(-dzmuhl*b_ext(i,4)*h_mesh%gauss%ww(ni,l))
3569 
3570  !--------Composante theta------
3571  c(3) = c(3) + (h_pert(i,1)*h_mesh%gauss%dw(2,ni,l,m) &
3572  - h_pert(i,5)*h_mesh%gauss%dw(1,ni,l,m)) &
3573  + (1/muhl)*(b_ext(i,1)*h_mesh%gauss%dw(2,ni,l,m) &
3574  - b_ext(i,5)*h_mesh%gauss%dw(1,ni,l,m)) &
3575  -(1/muhl**2)*(dzmuhl*b_ext(i,1)-drmuhl*b_ext(i,5))*h_mesh%gauss%ww(ni,l)
3576 
3577  c(4) = c(4) + (h_pert(i,2)*h_mesh%gauss%dw(2,ni,l,m) &
3578  - h_pert(i,6)*h_mesh%gauss%dw(1,ni,l,m)) &
3579  + (1/muhl)*(b_ext(i,2)*h_mesh%gauss%dw(2,ni,l,m) &
3580  - b_ext(i,6)*h_mesh%gauss%dw(1,ni,l,m)) &
3581  -(1/muhl**2)*(dzmuhl*b_ext(i,2)-drmuhl*b_ext(i,6))*h_mesh%gauss%ww(ni,l)
3582 
3583  !--------Composante z------
3584  c(5) = c(5) + (h_pert(i,3)*h_mesh%gauss%dw(1,ni,l,m) &
3585  + h_pert(i,3)*h_mesh%gauss%ww(ni,l)/ray &
3586  - mode/ray*h_pert(i,2)*h_mesh%gauss%ww(ni,l)) &
3587  + (1/muhl)*(b_ext(i,3)*h_mesh%gauss%dw(1,ni,l,m) &
3588  + b_ext(i,3)*h_mesh%gauss%ww(ni,l)/ray &
3589  - mode/ray*b_ext(i,2)*h_mesh%gauss%ww(ni,l)) &
3590  -(1/muhl**2)*(drmuhl*b_ext(i,3)*h_mesh%gauss%ww(ni,l))
3591 
3592  c(6) = c(6) + (h_pert(i,4)*h_mesh%gauss%dw(1,ni,l,m) &
3593  + h_pert(i,4)*h_mesh%gauss%ww(ni,l)/ray &
3594  + mode/ray*h_pert(i,1)*h_mesh%gauss%ww(ni,l)) &
3595  + (1/muhl)*(b_ext(i,4)*h_mesh%gauss%dw(1,ni,l,m) &
3596  + b_ext(i,4)*h_mesh%gauss%ww(ni,l)/ray &
3597  + mode/ray*b_ext(i,1)*h_mesh%gauss%ww(ni,l)) &
3598  -(1/muhl**2)*(drmuhl*b_ext(i,4)*h_mesh%gauss%ww(ni,l))
3599 
3600  ENDDO
3601  c=c/sigma(m)
3602  jsolh_anal= jsolh_anal + c
3603  !DCQ Ends
3604  END IF
3605 
3606  DO ni = 1,h_mesh%gauss%n_w
3607 
3608  i = h_mesh%jj(ni,m)
3609 
3610  !--------Composante r------
3611  src_h(i,1) = src_h(i,1)+ ray_rjl &
3612  *(jsolh_anal(3)*dwh(2,ni) &
3613  + mode/ray*jsolh_anal(6)*h_mesh%gauss%ww(ni,l) &
3614  + rhs_hl(1)*h_mesh%gauss%ww(ni,l))
3615 
3616  src_h(i,2) = src_h(i,2)+ ray_rjl &
3617  *(jsolh_anal(4)*dwh(2,ni) &
3618  - mode/ray*jsolh_anal(5)*h_mesh%gauss%ww(ni,l) &
3619  + rhs_hl(2)*h_mesh%gauss%ww(ni,l))
3620 
3621  !--------Composante theta------
3622  src_h(i,3) = src_h(i,3)+ ray_rjl &
3623  * (-jsolh_anal(1)*dwh(2,ni) &
3624  + 1/ray*jsolh_anal(5)*(ray*dwh(1,ni) + h_mesh%gauss%ww(ni,l)) &
3625  + rhs_hl(3)*h_mesh%gauss%ww(ni,l))
3626 
3627  src_h(i,4) = src_h(i,4)+ ray_rjl &
3628  * (-jsolh_anal(2)*dwh(2,ni) &
3629  + 1/ray*jsolh_anal(6)*(ray*dwh(1,ni) + h_mesh%gauss%ww(ni,l)) &
3630  + rhs_hl(4)*h_mesh%gauss%ww(ni,l))
3631 
3632  !--------Composante z------
3633  src_h(i,5) = src_h(i,5)+ ray_rjl* &
3634  (-mode/ray*jsolh_anal(2)*h_mesh%gauss%ww(ni,l) &
3635  - jsolh_anal(3)*dwh(1,ni) &
3636  + rhs_hl(5)*h_mesh%gauss%ww(ni,l))
3637 
3638  src_h(i,6) = src_h(i,6)+ ray_rjl* &
3639  (mode/ray*jsolh_anal(1)*h_mesh%gauss%ww(ni,l) &
3640  - jsolh_anal(4)*dwh(1,ni) &
3641  + rhs_hl(6)*h_mesh%gauss%ww(ni,l))
3642  ENDDO
3643 
3644  END DO
3645  END DO
3646  !tps = user_time(dummy)- tps
3647  !WRITE(*,*) ' Temps in courant boucle me H', tps
3648  !tps = user_time(dummy)
3649 
3650  ! We integrate by parts this term
3651  ! JLG + FL, FEB 10, 2010
3652  !DO m = 1, phi_mesh%me
3653  ! src_phil=0
3654  ! DO l = 1, phi_mesh%gauss%l_G
3655  ! dwphi = phi_mesh%gauss%dw(:,:,l,m)
3656  ! !===Compute radius of Gauss point
3657  ! rhs_dphil=0
3658  ! rhs_phil=0
3659  ! ray = 0
3660  ! DO ni = 1, phi_mesh%gauss%n_w; i = phi_mesh%jj(ni,m)
3661  ! ray = ray + phi_mesh%rr(1,i)*phi_mesh%gauss%ww(ni,l)
3662  ! rhs_phil(:) = rhs_phil(:) + rhs_phi(i,:)*phi_mesh%gauss%ww(ni,l)
3663  ! DO k =1 ,2
3664  ! rhs_dphil(:,k) = rhs_dphil(:,k) + rhs_phi(i,:)*dwphi(k,ni)
3665  ! END DO
3666  ! END DO
3667  ! ray_rjl = phi_mesh%gauss%rj(l,m)*ray
3668  ! moderay2 = (mode/ray)**2
3669 
3670  ! DO ni = 1, phi_mesh%gauss%n_w
3671 
3672  ! src_phil(1,ni) = src_phil(1,ni) + ray_rjl* &
3673  ! (rhs_dphil(1,1)*dwphi(1,ni) + &
3674  ! moderay2*rhs_phil(1)*phi_mesh%gauss%ww(ni,l) + &
3675  ! rhs_dphil(1,2)*dwphi(2,ni))
3676 
3677  ! src_phil(2,ni) = src_phil(2,ni) + ray_rjl* &
3678  ! (rhs_dphil(2,1)*dwphi(1,ni) + &
3679  ! moderay2*rhs_phil(2)*phi_mesh%gauss%ww(ni,l) + &
3680  ! rhs_dphil(2,2)*dwphi(2,ni))
3681  ! END DO
3682 
3683  ! END DO
3684  ! DO ni = 1, phi_mesh%gauss%n_w
3685  ! i = phi_mesh%jj(ni,m)
3686  ! src_phi(i,:) = src_phi(i,:) + src_phil(:,ni)
3687  ! END DO
3688  !END DO
3689  ! End integration by parts
3690  ! JLG + FL, FEB 10, 2010
3691 
3692 
3693  !==interface_H_phi
3694  !forcage sur l'interface_H_phi
3695  !attention on comprime le calcul sur les points de Gauss et integration !!
3696  !j/sigma*(b x nc + grad(phi) x nv)
3697 
3698  CALL gauss(phi_mesh)
3699 
3700  n_ws1 = h_mesh%gauss%n_ws
3701  n_ws2 = phi_mesh%gauss%n_ws
3702  n_w2 = phi_mesh%gauss%n_w
3703 
3704  h_bloc_size = h_mesh%np
3705 
3706  IF (interface_h_phi%mes /=0) THEN ! Ajout du test pour les grands nb de domaines
3707  IF (h_mesh%gauss%n_ws == n_ws) THEN
3708  w_cs = wws
3709  ELSE
3710  DO ls = 1, l_gs
3711  w_cs(1,ls)= wws(1,ls)+0.5*wws(3,ls)
3712  w_cs(2,ls)= wws(2,ls)+0.5*wws(3,ls)
3713  w_cs(3,ls)=0
3714  ENDDO
3715  END IF
3716  END IF
3717 
3718 
3719  !WRITE(*,*) ' Courant: init gauss'
3720  DO ms = 1, interface_h_phi%mes
3721 
3722  ms2 = interface_h_phi%mesh2(ms)
3723  ms1 = interface_h_phi%mesh1(ms)
3724  m = phi_mesh%neighs(ms2)
3725  m1 = h_mesh%neighs(ms1)
3726  mesh_id1 = h_mesh%i_d(m1)
3727  DO ls = 1,l_gs
3728  !Feb 9 2007, muhl
3729  ! This value of muhl is used in Jexact only
3730  muhl=sum(mu_h_field(interface_h_phi%jjs1(1:n_ws1,ms))*w_cs(1:n_ws1,ls))
3731  !Feb 9 2007, muhl
3732  DO k=1, 6
3733  b_ext_l(k) = sum(b_ext(interface_h_phi%jjs1(1:n_ws1,ms),k)*w_cs(1:n_ws1,ls))
3734  END DO
3735 
3736  !===Compute radius of Gauss point
3737  ray = 0
3738  DO ni = 1, n_ws2; i = phi_mesh%jjs(ni,interface_h_phi%mesh2(ms))
3739  ray = ray + phi_mesh%rr(1,i)* wws(ni,ls)
3740  END DO
3741 
3742  gaussp = 0.d0
3743  DO ni=1, n_ws2
3744  i=phi_mesh%jjs(ni,ms2)
3745  gaussp = gaussp + phi_mesh%rr(:,i)*phi_mesh%gauss%wws(ni,ls)
3746  END DO
3747 
3748  DO k=1, 6
3749  jsolh_anal(k) = jexact_gauss(k, gaussp, mode, mu_phi ,sigma(m1), &
3750  muhl, time, mesh_id1, b_ext_l)/sigma(m1) &
3751  + sum(nl(h_mesh%jjs(1:n_ws1,ms1),k)*w_cs(1:n_ws1,ls))
3752  END DO
3753 !!$! TEST DEBUG : to do before using H with phi
3754 !!$ IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
3755 !!$ DO k = 1, 6
3756 !!$ JsolH_anal(k) = J_over_sigma_gauss(index,k) + sigma_curl(index,k) &
3757 !!$ + SUM(NL(H_mesh%jjs(1:n_ws1,ms1),k)*w_cs(1:n_ws1,ls))
3758 !!$ END DO
3759 !!$ ELSE
3760 !!$ DO k = 1, 6
3761 !!$ JsolH_anal(k) = Jexact_gauss(k, gaussp, mode, mu_phi ,sigma(m1), &
3762 !!$ muhl, time, mesh_id1, B_ext_l)/sigma(m1) &
3763 !!$ + SUM(NL(H_mesh%jjs(1:n_ws1,ms1),k)*w_cs(1:n_ws1,ls))
3764 !!$ END DO
3765 !!$ END IF
3766 !!$! TEST DEBUG
3767 
3768  !---------forcage pour H
3769 
3770  DO ni=1, n_ws1
3771  i = interface_h_phi%jjs1(ni,ms)
3772  src_h(i,1) = src_h(i,1)+rjs(ls,ms2)*ray*( &
3773  -jsolh_anal(3)*w_cs(ni,ls)*(-rnorms(2,ls,ms2)))
3774 
3775  src_h(i,2) = src_h(i,2)+rjs(ls,ms2)*ray*( &
3776  -jsolh_anal(4)*w_cs(ni,ls)*(-rnorms(2,ls,ms2)))
3777 
3778  src_h(i,3) = src_h(i,3)+rjs(ls,ms2)*ray*( &
3779  jsolh_anal(1)*w_cs(ni,ls)*(-rnorms(2,ls,ms2)) &
3780  -jsolh_anal(5)*w_cs(ni,ls)*(-rnorms(1,ls,ms2)))
3781 
3782  src_h(i,4) = src_h(i,4)+rjs(ls,ms2)*ray*( &
3783  jsolh_anal(2)*w_cs(ni,ls)*(-rnorms(2,ls,ms2)) &
3784  -jsolh_anal(6)*w_cs(ni,ls)*(-rnorms(1,ls,ms2)))
3785 
3786  src_h(i,5) = src_h(i,5)+rjs(ls,ms2)*ray*( &
3787  jsolh_anal(3)*w_cs(ni,ls)*(-rnorms(1,ls,ms2)))
3788 
3789  src_h(i,6) = src_h(i,6)+rjs(ls,ms2)*ray*( &
3790  jsolh_anal(4)*w_cs(ni,ls)*(-rnorms(1,ls,ms2)))
3791  ENDDO
3792 
3793  !---------forcage pour phi
3794  !terme sans derivee de phi
3795  DO ni=1,n_ws2
3796  i = interface_h_phi%jjs2(ni,ms)
3797  !attention si on force sur l'axe, il faut retirer les 1/ray
3798  !There was a BUG here. There was w_cs instead of wws
3799  src_phi(i,1) = src_phi(i,1)+rjs(ls,ms2)*( &
3800  - mode*jsolh_anal(2)*wws(ni,ls) * rnorms(2,ls,ms2) &
3801  + mode*jsolh_anal(6)*wws(ni,ls) * rnorms(1,ls,ms2))
3802 
3803  src_phi(i,2) = src_phi(i,2)+rjs(ls,ms2)*( &
3804  + mode*jsolh_anal(1)*wws(ni,ls) * rnorms(2,ls,ms2) &
3805  - mode*jsolh_anal(5)*wws(ni,ls) * rnorms(1,ls,ms2))
3806 
3807  ENDDO
3808 
3809  !terme avec derivee de phi
3810  DO ni=1,n_w2
3811  i = phi_mesh%jj(ni,m)
3812  src_phi(i,1) = src_phi(i,1)+rjs(ls,ms2)*ray*( &
3813  + jsolh_anal(3) *(dw_s(2,ni,ls,ms2) * rnorms(1,ls,ms2)&
3814  -dw_s(1,ni,ls,ms2) * rnorms(2,ls,ms2)))
3815 
3816  src_phi(i,2) = src_phi(i,2)+rjs(ls,ms2)*ray*( &
3817  + jsolh_anal(4)*(dw_s(2,ni,ls,ms2) * rnorms(1,ls,ms2)&
3818  -dw_s(1,ni,ls,ms2) * rnorms(2,ls,ms2)))
3819 
3820  ENDDO
3821 
3822  ! Integration by parts of int(GRAD rhs_phi Grad psi)
3823  rhs_hl = 0.d0
3824  DO ni=1, n_ws1
3825  i = interface_h_phi%jjs1(ni,ms)
3826  rhs_hl(:) = rhs_hl(:) + rhs_h(i,:)*w_cs(ni,ls)
3827  ENDDO
3828 
3829  DO ni=1, n_ws2
3830  i = interface_h_phi%jjs2(ni,ms)
3831  src_phi(i,1) = src_phi(i,1)+rjs(ls,ms2)*ray*wws(ni,ls)*( &
3832  rhs_hl(1)*rnorms(1,ls,ms2) + rhs_hl(5)*rnorms(2,ls,ms2))
3833  src_phi(i,2) = src_phi(i,2)+rjs(ls,ms2)*ray*wws(ni,ls)*( &
3834  rhs_hl(2)*rnorms(1,ls,ms2) + rhs_hl(6)*rnorms(2,ls,ms2))
3835  END DO
3836  ! End integration by parts of int(GRAD rhs_phi Grad psi)
3837  END DO
3838  END DO
3839  !tps = user_time(dummy)- tps
3840  !WRITE(*,*) ' Courant: init interface_H_phi'
3841 
3842  IF (h_mesh%np /= 0) THEN
3843 !!$ ALLOCATE(idxn(H_mesh%np))
3844  idxn_h = la_h%loc_to_glob(1,:)-1
3845  CALL vecsetvalues(vb_1, h_mesh%np, idxn_h, src_h(:,1), add_values, ierr)
3846  CALL vecsetvalues(vb_2, h_mesh%np, idxn_h, src_h(:,2), add_values, ierr)
3847  idxn_h = la_h%loc_to_glob(2,:)-1
3848  CALL vecsetvalues(vb_1, h_mesh%np, idxn_h, src_h(:,4), add_values, ierr)
3849  CALL vecsetvalues(vb_2, h_mesh%np, idxn_h, src_h(:,3), add_values, ierr)
3850  idxn_h = la_h%loc_to_glob(3,:)-1
3851  CALL vecsetvalues(vb_1, h_mesh%np, idxn_h, src_h(:,5), add_values, ierr)
3852  CALL vecsetvalues(vb_2, h_mesh%np, idxn_h, src_h(:,6), add_values, ierr)
3853 !!$ DEALLOCATE(idxn)
3854  END IF
3855  IF (phi_mesh%np /=0) THEN
3856 !!$ ALLOCATE(idxn(phi_mesh%np))
3857  idxn_phi = la_phi%loc_to_glob(1,:)-1
3858  CALL vecsetvalues(vb_1, phi_mesh%np, idxn_phi, src_phi(:,1), add_values, ierr)
3859  CALL vecsetvalues(vb_2, phi_mesh%np, idxn_phi, src_phi(:,2), add_values, ierr)
3860 !!$ DEALLOCATE(idxn)
3861  END IF
3862 
3863  CALL vecassemblybegin(vb_1,ierr)
3864  CALL vecassemblyend(vb_1,ierr)
3865  CALL vecassemblybegin(vb_2,ierr)
3866  CALL vecassemblyend(vb_2,ierr)
3867 
3868 !!$ IF (H_mesh%me /=0) THEN
3869 !!$ DEALLOCATE(nl)
3870 !!$ END IF
3871  !DEALLOCATE(src_H, src_phi)
3872 
3873  END SUBROUTINE courant_int_by_parts
3874 
3875  !===JLG Jan 22 2018
3876  !SUBROUTINE surf_int(H_mesh,phi_mesh, interface_H_phi, interface_H_mu, &
3877  SUBROUTINE surf_int(H_mesh, phi_mesh, pmag_mesh, interface_H_phi, interface_H_mu, &
3878  list_dirichlet_sides_h, sigma,mu_phi, mu_h_field, time, mode, &
3879  la_h, la_phi, la_pmag, vb_1, vb_2, sigma_tot_gauss, r_fourier, index_fourier)
3880  !calcul du forcage a la frontiere exterieure
3881  USE my_util
3882  USE def_type_mesh
3883  USE boundary
3884  USE input_data
3885 #include "petsc/finclude/petsc.h"
3886  USE petsc
3887  IMPLICIT NONE
3888  TYPE(mesh_type), INTENT(IN) :: H_mesh, phi_mesh, pmag_mesh
3889  TYPE(interface_type), INTENT(IN) :: interface_H_phi, interface_H_mu
3890  INTEGER, DIMENSION(:), INTENT(IN) :: list_dirichlet_sides_H
3891  REAL(KIND=8), INTENT(IN) :: mu_phi, time
3892  REAL(KIND=8),DIMENSION(H_mesh%me),INTENT(IN):: sigma
3893  REAL(KIND=8),DIMENSION(:), INTENT(IN) :: mu_H_field
3894  INTEGER, INTENT(IN) :: mode
3895  REAL(KIND=8), DIMENSION(:,:) :: sigma_tot_gauss
3896  REAL(KIND=8), OPTIONAL :: R_fourier
3897  INTEGER, OPTIONAL :: index_fourier
3898  REAL(KIND=8), DIMENSION(H_mesh%np, 6) :: src_H
3899  REAL(KIND=8), DIMENSION(phi_mesh%np, 2) :: src_phi
3900  REAL(KIND=8), DIMENSION(pmag_mesh%np, 2) :: src_pmag !===JLG Jan 22 2018
3901  REAL(KIND=8), DIMENSION(4,H_mesh%gauss%l_Gs):: Banal
3902  REAL(KIND=8), DIMENSION(2,H_mesh%gauss%l_Gs):: rloc
3903  REAL(KIND=8), DIMENSION(H_mesh%gauss%l_Gs) :: B_dot_n_cos, B_dot_n_sin, muloc
3904  REAL(KIND=8), DIMENSION(4,pmag_mesh%gauss%l_Gs):: Banal_pmesh
3905  REAL(KIND=8), DIMENSION(2,pmag_mesh%gauss%l_Gs):: rloc_pmesh
3906  REAL(KIND=8), DIMENSION(pmag_mesh%gauss%l_Gs) :: B_dot_n_cos_pmesh, B_dot_n_sin_pmesh, muloc_pmesh
3907  REAL(KIND=8) :: ray, muhl, norm, y
3908  INTEGER :: ms, ls, ns, i, k, m, n, ni, count, index
3909  REAL(KIND=8), DIMENSION(2) :: gaussp
3910  REAL(KIND=8), DIMENSION(6) :: EsolH_anal, Esolphi_anal
3911  INTEGER, DIMENSION(H_mesh%np) :: idxn_H
3912  INTEGER, DIMENSION(phi_mesh%np) :: idxn_phi
3913  INTEGER, DIMENSION(pmag_mesh%np) :: idxn_pmag !===JLG Jan 22 2018
3914  TYPE(petsc_csr_la) :: LA_H, LA_phi, LA_pmag !===JLG Jan 22 2018
3915  petscerrorcode :: ierr
3916  vec :: vb_1, vb_2
3917 
3918  src_h = 0.d0
3919  src_phi = 0.d0
3920  src_pmag = 0.d0
3921 
3922 !!$ !LC 2019/04/29: error dimension pmag_mesh%jjs and H_mesh%jjs
3923 !!$ !===JLG Jan 22 2018
3924 !!$ !===Non-homogeneous Neumann BC. -\int_{\Gamma_N} (B_anal.n) q ds
3925 !!$ IF (H_mesh%gauss%n_ws==2) THEN
3926 !!$ wwps=H_mesh%gauss%wws
3927 !!$ ELSE
3928 !!$ wwps(1,:) = H_mesh%gauss%wws(1,:) + 0.5d0*H_mesh%gauss%wws(3,:)
3929 !!$ wwps(2,:) = H_mesh%gauss%wws(2,:) + 0.5d0*H_mesh%gauss%wws(3,:)
3930 !!$ END IF
3931 !!$ !===Non-homogeneous Neumann BC. -\int_{\Gamma_N} (B_anal.n) q ds
3932 !!$ !===JLG Jan 22 2018
3933 !!$ !LC 2019/04/29: error dimension pmag_mesh%jjs and H_mesh%jjs
3934 
3935  index = 0
3936  DO count = 1, SIZE(neumann_bdy_h_sides)
3937  ms = neumann_bdy_h_sides(count)
3938  m = h_mesh%neighs(ms)
3939  !===JLG+CN July 20 2017. Non-homogeneous B.n (due to divergence stabilization)
3940  DO ls = 1, h_mesh%gauss%l_Gs
3941  muhl = sum(mu_h_field(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3942  muloc(ls) = muhl
3943  rloc(1,ls) = sum(h_mesh%rr(1,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3944  rloc(2,ls) = sum(h_mesh%rr(2,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3945  END DO
3946  banal(1,:) = muhl*hexact(h_mesh, 1, rloc, mode, muloc, time)
3947  banal(2,:) = muhl*hexact(h_mesh, 2, rloc, mode, muloc, time)
3948  banal(3,:) = muhl*hexact(h_mesh, 5, rloc, mode, muloc, time)
3949  banal(4,:) = muhl*hexact(h_mesh, 6, rloc, mode, muloc, time)
3950  b_dot_n_cos = banal(1,:)*h_mesh%gauss%rnorms(1,:,ms) + banal(3,:)*h_mesh%gauss%rnorms(2,:,ms)
3951  b_dot_n_sin = banal(2,:)*h_mesh%gauss%rnorms(1,:,ms) + banal(4,:)*h_mesh%gauss%rnorms(2,:,ms)
3952  !===JLG+CN July 20 2017. Non-homogeneous B.n (due to divergence stabilization)
3953 
3954  DO ls = 1, h_mesh%gauss%l_Gs
3955  index = index+1
3956  !Feb 8 2007, mmuhl
3957  muhl = sum(mu_h_field(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
3958  !Feb 8 2007, mmuhl
3959 
3960  !===Compute radius of Gauss point
3961  ray = 0
3962  DO ni = 1, h_mesh%gauss%n_ws; i = h_mesh%jjs(ni,ms)
3963  ray = ray + h_mesh%rr(1,i)* h_mesh%gauss%wws(ni,ls)
3964  END DO
3965 
3966  IF (ray.LT.1.d-12*h_mesh%global_diameter) cycle !ATTENTION Axe
3967 
3968  gaussp = 0.d0
3969  DO ns=1, h_mesh%gauss%n_ws
3970  i=h_mesh%jjs(ns,ms)
3971  gaussp = gaussp + h_mesh%rr(:,i)*h_mesh%gauss%wws(ns,ls)
3972  ENDDO
3973 
3974 !!$ DO k=1, 6
3975 !!$ EsolH_anal(k) = Eexact_gauss(k,gaussp,mode,mu_phi,sigma(m),muhl, time)
3976 !!$ ENDDO
3977  !LC-JLG-CN 2018/04
3978  DO k=1, 6
3979  esolh_anal(k) = eexact_gauss(k,gaussp,mode,mu_phi,sigma_tot_gauss(index,mod(k+1,2)+1),muhl, time)
3980  ENDDO
3981  !LC-JLG-CN 2018/04
3982 
3983 !!$ !LC 2019/04/29: error dimension pmag_mesh%jjs and H_mesh%jjs
3984 !!$ !===JLG Jan 22 2018
3985 !!$ !===Non-homogeneous Neumann BC. -\int_{\Gamma_N} (B_anal.n) q ds
3986 !!$ DO ns=1, pmag_mesh%gauss%n_ws
3987 !!$ i = pmag_mesh%jjs(ns,ms)
3988 !!$ src_pmag(i,1) = src_pmag(i,1) - inputs%stab(1)*B_dot_n_cos(ls)*wwps(ns,ls)*H_mesh%gauss%rjs(ls,ms)*ray
3989 !!$ src_pmag(i,2) = src_pmag(i,2) - inputs%stab(1)*B_dot_n_sin(ls)*wwps(ns,ls)*H_mesh%gauss%rjs(ls,ms)*ray
3990 !!$ END DO
3991 !!$ !===Non-homogeneous Neumann BC. -\int_{\Gamma_N} (B_anal.n) q ds
3992 !!$ !===JLG Jan 22 2018
3993 !!$ !LC 2019/04/29: error dimension pmag_mesh%jjs and H_mesh%jjs
3994 
3995  !===Forcing at the boundary
3996  !=== - E.(b x nc)
3997  DO ns=1, h_mesh%gauss%n_ws
3998  i = h_mesh%jjs(ns,ms)
3999  src_h(i,1) = src_h(i,1)-h_mesh%gauss%rjs(ls,ms)*ray*( &
4000  -esolh_anal(3)*h_mesh%gauss%wws(ns,ls)* &
4001  (h_mesh%gauss%rnorms(2,ls,ms)))
4002 
4003  src_h(i,2) = src_h(i,2)-h_mesh%gauss%rjs(ls,ms)*ray*( &
4004  -esolh_anal(4)*h_mesh%gauss%wws(ns,ls)* &
4005  (h_mesh%gauss%rnorms(2,ls,ms)))
4006 
4007  src_h(i,3) = src_h(i,3)-h_mesh%gauss%rjs(ls,ms)*ray*( &
4008  esolh_anal(1)*h_mesh%gauss%wws(ns,ls)* &
4009  (h_mesh%gauss%rnorms(2,ls,ms)) - &
4010  esolh_anal(5)*h_mesh%gauss%wws(ns,ls) * &
4011  (h_mesh%gauss%rnorms(1,ls,ms)))
4012 
4013  src_h(i,4) = src_h(i,4)-h_mesh%gauss%rjs(ls,ms)*ray*( &
4014  esolh_anal(2)*h_mesh%gauss%wws(ns,ls) * &
4015  (h_mesh%gauss%rnorms(2,ls,ms)) - &
4016  esolh_anal(6)*h_mesh%gauss%wws(ns,ls) * &
4017  (h_mesh%gauss%rnorms(1,ls,ms)))
4018 
4019  src_h(i,5) = src_h(i,5)-h_mesh%gauss%rjs(ls,ms)*ray*( &
4020  esolh_anal(3)*h_mesh%gauss%wws(ns,ls)* &
4021  (h_mesh%gauss%rnorms(1,ls,ms)))
4022 
4023  src_h(i,6) = src_h(i,6)-h_mesh%gauss%rjs(ls,ms)*ray*( &
4024  esolh_anal(4)*h_mesh%gauss%wws(ns,ls) * &
4025  (h_mesh%gauss%rnorms(1,ls,ms)))
4026 
4027  ENDDO
4028 
4029  !=== JLG+CN July 20 2017. Non-homogeneous B.n (due to divergence stabilization)
4030  norm = (inputs%stab(1)/inputs%Rem)*(sum(h_mesh%gauss%rjs(:,ms))/h_mesh%global_diameter)**(2*alpha-1)&
4031  /(h_mesh%global_diameter*inputs%sigma_min*inputs%mu_min**2)
4032  !TEST JLG RZ, Jan 22 2018 Removed stabilization
4033  !norm =0.d0
4034  !TEST JLG RZ, Jan 22 2018 Removed stabilization
4035  DO ns = 1, h_mesh%gauss%n_ws
4036  i = h_mesh%jjs(ns,ms)
4037  y = norm*muhl*h_mesh%gauss%rjs(ls,ms)*ray
4038  src_h(i,1) = src_h(i,1) + y*b_dot_n_cos(ls)*h_mesh%gauss%wws(ns,ls)*h_mesh%gauss%rnorms(1,ls,ms)
4039  src_h(i,2) = src_h(i,2) + y*b_dot_n_sin(ls)*h_mesh%gauss%wws(ns,ls)*h_mesh%gauss%rnorms(1,ls,ms)
4040  src_h(i,5) = src_h(i,5) + y*b_dot_n_cos(ls)*h_mesh%gauss%wws(ns,ls)*h_mesh%gauss%rnorms(2,ls,ms)
4041  src_h(i,6) = src_h(i,6) + y*b_dot_n_sin(ls)*h_mesh%gauss%wws(ns,ls)*h_mesh%gauss%rnorms(2,ls,ms)
4042  END DO
4043  !=== JLG+CN July 20 2017. Non-homogeneous B.n (due to divergence stabilization)
4044 
4045  ENDDO
4046  ENDDO
4047 
4048  !===Neumann boundary pmag_mesh
4049  DO count = 1, SIZE(neumann_bdy_pmag_sides)
4050  ms = neumann_bdy_pmag_sides(count)
4051  m = pmag_mesh%neighs(ms)
4052  !===JLG+CN July 20 2017. Non-homogeneous B.n (due to divergence stabilization)
4053  DO ls = 1, pmag_mesh%gauss%l_Gs
4054  muhl = sum(mu_h_field(pmag_mesh%jjs(:,ms))*pmag_mesh%gauss%wws(:,ls))
4055  muloc_pmesh(ls) = muhl
4056  rloc_pmesh(1,ls) = sum(pmag_mesh%rr(1,pmag_mesh%jjs(:,ms))*pmag_mesh%gauss%wws(:,ls))
4057  rloc_pmesh(2,ls) = sum(pmag_mesh%rr(2,pmag_mesh%jjs(:,ms))*pmag_mesh%gauss%wws(:,ls))
4058  END DO
4059  banal_pmesh(1,:) = muhl*hexact(pmag_mesh, 1, rloc_pmesh, mode, muloc_pmesh, time)
4060  banal_pmesh(2,:) = muhl*hexact(pmag_mesh, 2, rloc_pmesh, mode, muloc_pmesh, time)
4061  banal_pmesh(3,:) = muhl*hexact(pmag_mesh, 5, rloc_pmesh, mode, muloc_pmesh, time)
4062  banal_pmesh(4,:) = muhl*hexact(pmag_mesh, 6, rloc_pmesh, mode, muloc_pmesh, time)
4063  b_dot_n_cos_pmesh = banal_pmesh(1,:)*pmag_mesh%gauss%rnorms(1,:,ms) &
4064  + banal_pmesh(3,:)*pmag_mesh%gauss%rnorms(2,:,ms)
4065  b_dot_n_sin_pmesh = banal_pmesh(2,:)*pmag_mesh%gauss%rnorms(1,:,ms) &
4066  + banal_pmesh(4,:)*pmag_mesh%gauss%rnorms(2,:,ms)
4067  !===JLG+CN July 20 2017. Non-homogeneous B.n (due to divergence stabilization)
4068 
4069  DO ls = 1, pmag_mesh%gauss%l_Gs
4070  !Feb 8 2007, mmuhl
4071  muhl = sum(mu_h_field(pmag_mesh%jjs(:,ms))*pmag_mesh%gauss%wws(:,ls))
4072  !Feb 8 2007, mmuhl
4073 
4074  !===Compute radius of Gauss point
4075  ray = 0
4076  DO ni = 1, pmag_mesh%gauss%n_ws; i = pmag_mesh%jjs(ni,ms)
4077  ray = ray + pmag_mesh%rr(1,i)* pmag_mesh%gauss%wws(ni,ls)
4078  END DO
4079 
4080  IF (ray.LT.1.d-12*h_mesh%global_diameter) cycle !ATTENTION Axe
4081 
4082  !===JLG Jan 22 2018
4083  !===Non-homogeneous Neumann BC. -\int_{\Gamma_N} (B_anal.n) q ds
4084  DO ns=1, pmag_mesh%gauss%n_ws
4085  i = pmag_mesh%jjs(ns,ms)
4086  src_pmag(i,1) = src_pmag(i,1) - inputs%stab(1)*b_dot_n_cos_pmesh(ls)* &
4087  pmag_mesh%gauss%wws(ns,ls)*pmag_mesh%gauss%rjs(ls,ms)*ray
4088  src_pmag(i,2) = src_pmag(i,2) - inputs%stab(1)*b_dot_n_sin_pmesh(ls)* &
4089  pmag_mesh%gauss%wws(ns,ls)*pmag_mesh%gauss%rjs(ls,ms)*ray
4090  END DO
4091  !===Non-homogeneous Neumann BC. -\int_{\Gamma_N} (B_anal.n) q ds
4092  !===JLG Jan 22 2018
4093  ENDDO
4094  ENDDO
4095 
4096  !===Neumann boundary phi_mesh
4097  DO count = 1, SIZE(neumann_bdy_phi_sides)
4098  ms = neumann_bdy_phi_sides(count)
4099  m = phi_mesh%neighs(ms)
4100  DO ls = 1, phi_mesh%gauss%l_Gs
4101  !===Compute radius of Gauss point
4102  ray = 0
4103  DO ni = 1, phi_mesh%gauss%n_ws; i = phi_mesh%jjs(ni,ms)
4104  ray = ray + phi_mesh%rr(1,i)* phi_mesh%gauss%wws(ni,ls)
4105  END DO
4106 
4107  gaussp = 0.d0
4108  DO ns=1, phi_mesh%gauss%n_ws
4109  i=phi_mesh%jjs(ns,ms)
4110  gaussp = gaussp + phi_mesh%rr(:,i)*phi_mesh%gauss%wws(ns,ls)
4111  ENDDO
4112 
4113  DO k=1, 6
4114  !===Here sigma and mu_H_field should not intervene
4115  !===I put boggus values for sigma and mu_H_field, Feb 8 2007, Jean-Luc Guermond
4116  esolphi_anal(k) = eexact_gauss(k,gaussp,mode,mu_phi,sigma(1),mu_h_field(1),time)
4117  ENDDO
4118  !TO DEBUG
4119 
4120  !TO DEBUG
4121 
4122  !===Nemnann forcing for phi in rhs: - E.(grad(phi) x nv)
4123  DO ns=1, phi_mesh%gauss%n_ws
4124  i = phi_mesh%jjs(ns,ms)
4125  DO n = 1, phi_mesh%gauss%n_w
4126  IF (phi_mesh%jj(n,m) == i) EXIT
4127  END DO
4128  !===There should not be any Neumann forcing on z-axis (1/ray would be infinite)
4129  src_phi(i,1) = src_phi(i,1)-phi_mesh%gauss%rjs(ls,ms)*ray*( &
4130  +esolphi_anal(3)*(phi_mesh%gauss%dw_s(2,n,ls,ms)*phi_mesh%gauss%rnorms(1,ls,ms) &
4131  -phi_mesh%gauss%dw_s(1,n,ls,ms)*phi_mesh%gauss%rnorms(2,ls,ms))) &
4132  -phi_mesh%gauss%rjs(ls,ms)*(&
4133  -mode*esolphi_anal(2)*phi_mesh%gauss%wws(ns,ls)*phi_mesh%gauss%rnorms(2,ls,ms) &
4134  +mode*esolphi_anal(6)*phi_mesh%gauss%wws(ns,ls)*phi_mesh%gauss%rnorms(1,ls,ms))
4135 
4136  src_phi(i,2) = src_phi(i,2)-phi_mesh%gauss%rjs(ls,ms)*ray*( &
4137  +esolphi_anal(4)*(phi_mesh%gauss%dw_s(2,n,ls,ms)*phi_mesh%gauss%rnorms(1,ls,ms) &
4138  -phi_mesh%gauss%dw_s(1,n,ls,ms)*phi_mesh%gauss%rnorms(2,ls,ms))) &
4139  -phi_mesh%gauss%rjs(ls,ms)*(&
4140  mode*esolphi_anal(1)*phi_mesh%gauss%wws(ns,ls)*phi_mesh%gauss%rnorms(2,ls,ms) &
4141  -mode*esolphi_anal(5)*phi_mesh%gauss%wws(ns,ls)*phi_mesh%gauss%rnorms(1,ls,ms))
4142  ENDDO
4143  ENDDO
4144  ENDDO
4145  !===ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION
4146  !JLG, FL, FEB, 10, 2010
4147  !We assume that integral int_Gammav n.GRAD (4phi_n-phi_(n-1))/(2dt) psi dsigma = 0
4148  !JLG, FL, FEB, 10, 2010
4149  !JLG, FL, May, 28, 2009
4150  !We assume that integral int_Gammav (Hinfty . n) psi ds = 0!
4151  !JLG, FL, May, 28, 2009
4152  !===ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION ATTENTION
4153 
4154  !=========================================================
4155  !--- Artificial boundary condition: d(phi_t)/dR + (1/R)*phi_t = 0
4156  !=========================================================
4157 
4158  IF (PRESENT(r_fourier)) THEN
4159  IF (r_fourier.GE.0.d0) CALL error_petsc('maxwell_update_time_with_B: R_fourier should be -1')
4160  END IF
4161  !IF (.NOT.present(index_fourier) .OR. .NOT.present(R_fourier)) RETURN
4162  !IF (R_fourier.le.0.d0) RETURN
4163  !DO ms = 1, phi_mesh%mes
4164  ! IF (phi_mesh%sides(ms) /= index_fourier) CYCLE ! Not on the artificial boundary
4165 
4166  ! DO ls = 1, phi_mesh%gauss%l_Gs
4167 
4168  !===Compute radius of Gauss point
4169  ! ray = SUM(phi_mesh%rr(1,phi_mesh%jjs(:,ms))* phi_mesh%gauss%wws(:,ls))
4170  ! x = phi_mesh%gauss%rjs(ls,ms)*ray/R_fourier
4171  ! y1 = x* SUM(rhs(phi_mesh%jjs(:,ms),1)* phi_mesh%gauss%wws(:,ls))
4172  ! y2 = x* SUM(rhs(phi_mesh%jjs(:,ms),2)* phi_mesh%gauss%wws(:,ls))
4173  ! DO ns =1, phi_mesh%gauss%n_ws
4174  ! src_phi(1,phi_mesh%jjs(ns,ms)) = src_phi(1,phi_mesh%jjs(ns,ms)) + &
4175  ! y1*phi_mesh%gauss%wws(ns,ls)
4176  ! src_phi(2,phi_mesh%jjs(ns,ms)) = src_phi(2,phi_mesh%jjs(ns,ms)) + &
4177  ! y2*phi_mesh%gauss%wws(ns,ls)
4178  ! ENDDO
4179  !
4180  ! ENDDO
4181  !END DO
4182  IF (h_mesh%mes/=0) THEN
4183 !!$ ALLOCATE(idxn(H_mesh%np))
4184  idxn_h = la_h%loc_to_glob(1,:)-1
4185  CALL vecsetvalues(vb_1, h_mesh%np, idxn_h, src_h(:,1), add_values, ierr)
4186  CALL vecsetvalues(vb_2, h_mesh%np, idxn_h, src_h(:,2), add_values, ierr)
4187  idxn_h = la_h%loc_to_glob(2,:)-1
4188  CALL vecsetvalues(vb_1, h_mesh%np, idxn_h, src_h(:,4), add_values, ierr)
4189  CALL vecsetvalues(vb_2, h_mesh%np, idxn_h, src_h(:,3), add_values, ierr)
4190  idxn_h = la_h%loc_to_glob(3,:)-1
4191  CALL vecsetvalues(vb_1, h_mesh%np, idxn_h, src_h(:,5), add_values, ierr)
4192  CALL vecsetvalues(vb_2, h_mesh%np, idxn_h, src_h(:,6), add_values, ierr)
4193 
4194  !===JLG Jan 22 2018
4195  idxn_pmag = la_pmag%loc_to_glob(1,:)-1
4196  CALL vecsetvalues(vb_1, pmag_mesh%np, idxn_pmag, src_pmag(:,1), add_values, ierr)
4197  CALL vecsetvalues(vb_2, pmag_mesh%np, idxn_pmag, src_pmag(:,2), add_values, ierr)
4198  !===JLG Jan 22 2018
4199 
4200 !!$ DEALLOCATE(idxn)
4201  END IF
4202  IF (phi_mesh%mes/=0) THEN
4203 !!$ ALLOCATE(idxn(phi_mesh%np))
4204  idxn_phi = la_phi%loc_to_glob(1,:)-1
4205  CALL vecsetvalues(vb_1, phi_mesh%np, idxn_phi, src_phi(:,1), add_values, ierr)
4206  CALL vecsetvalues(vb_2, phi_mesh%np, idxn_phi, src_phi(:,2), add_values, ierr)
4207 !!$ DEALLOCATE(idxn)
4208  END IF
4209 
4210  CALL vecassemblybegin(vb_1,ierr)
4211  CALL vecassemblyend(vb_1,ierr)
4212  CALL vecassemblybegin(vb_2,ierr)
4213  CALL vecassemblyend(vb_2,ierr)
4214 
4215  !DEALLOCATE(src_H,src_phi)
4216 
4217  !===Dummies variables to avoid warning
4218  count=index_fourier; count=interface_h_mu%mes; count=interface_h_phi%mes
4219  count=SIZE(list_dirichlet_sides_h)
4220  !===Dummies variables to avoid warning
4221  END SUBROUTINE surf_int
4222 
4223  SUBROUTINE mat_maxwell_mu(H_mesh, jj_v_to_H, interface_H_mu, mode, stab, &
4224  mu_h_field, sigma, la_h, h_p_phi_mat1, h_p_phi_mat2, sigma_np)
4225  USE def_type_mesh
4226  USE gauss_points
4227  USE my_util
4228  USE input_data
4229 #include "petsc/finclude/petsc.h"
4230  USE petsc
4231  IMPLICIT NONE
4232  TYPE(mesh_type), INTENT(IN) :: H_mesh
4233  INTEGER, DIMENSION(:), INTENT(IN) :: jj_v_to_H
4234  TYPE(interface_type), INTENT(IN) :: interface_H_mu
4235  INTEGER, INTENT(IN) :: mode
4236  REAL(KIND=8), DIMENSION(3), INTENT(IN) :: stab
4237  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: sigma, mu_H_field
4238  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: sigma_np
4239  INTEGER :: ms, ls, ni, nj, i, j, &
4240  n_ws1, n_ws2, n_w2, n_w1, m1, m2, ki, kj,ib,jb, ms1, ms2
4241  REAL(KIND=8) :: x, y, z, norm, hm1
4242  REAL(KIND=8) :: ray, stab_colle_H_mu
4243  LOGICAL :: mark=.false.
4244  REAL(KIND=8), DIMENSION(9,SIZE(H_mesh%jj,1),SIZE(H_mesh%jj,1),2,2) :: Hsij, Gsij
4245 
4246  ! MATRICES POUR LES TERMES DE BORDS Hsij et Gsij
4247  !=================================================
4248  ! (--------------------------------------------------)
4249  ! ( Hsij(1) +G | GSij(2) | Hsij(4) +G )
4250  ! ( Hsij(1) +G | GSij(3) | Hsij(4) +G )
4251  ! (--------------------------------------------------)
4252  ! ( Hsij(2) | Hsij(5) +G | Hsij(8) )
4253  ! ( Hsij(3) | Hsij(5) +G | Hsij(9) )
4254  ! (--------------------------------------------------)
4255  ! ( Hsij(7) +G | GSij(8) | Hsij(6) +G )
4256  ! ( Hsij(7) +G | GSij(9) | Hsij(6) +G )
4257  ! (==================================================)
4258 !!$ FL+CN 22/03/2013
4259  REAL(KIND=8), DIMENSION(H_mesh%gauss%n_ws,H_mesh%gauss%l_Gs) :: w_cs
4260  REAL(KIND=8), DIMENSION(2, H_mesh%gauss%n_w, H_mesh%gauss%l_Gs, H_mesh%mes) :: dw_cs
4261  REAL(KIND=8), DIMENSION(2, H_mesh%gauss%n_w) :: dwsi,dwsj
4262  REAL(KIND=8), DIMENSION(2,H_mesh%gauss%l_Gs) :: gauss1, gauss2
4263 !!$ REAL(KIND=8), DIMENSION(:,:) , ALLOCATABLE :: w_cs
4264 !!$ REAL(KIND=8), DIMENSION(:,:,:,:), ALLOCATABLE :: dw_cs
4265 !!$ REAL(KIND=8), DIMENSION(:,:) , ALLOCATABLE :: dwsi,dwsj
4266 !!$ REAL(KIND=8), DIMENSION(:,:) , ALLOCATABLE :: gauss1, gauss2
4267 !!$ FL+CN 22/03/2013
4268  REAL(KIND=8), DIMENSION(2) :: normi, normj
4269  REAL(KIND=8), DIMENSION(SIZE(H_mesh%jjs,1)) :: wwsi, wwsj
4270  INTEGER :: n_wsi, n_wsj, ci, cj, n_wi, n_wj
4271 
4272  INTEGER :: ls1, ls2
4273  REAL(KIND=8) :: ref, diff, mu_H, muhl1, muhl2, muhi, muhj, sigmai, sigmaj
4274  ! June 14 2008
4275  REAL(KIND=8) :: c_sym =.0d0 ! (c_sym=1.d0 symmetrizes the bilinear form)
4276  REAL(KIND=8) :: wwiwwj, normt, stab_div
4277  ! H to B
4278  REAL(KIND=8) :: drmuhl1, drmuhl2, drmuhj, dzmuhl1, dzmuhl2, dzmuhj
4279  REAL(KIND=8) :: sigmal1, sigmal2
4280  ! H to B
4281  ! June 14 2008
4282 !!$ FL +CN 22/03/2013
4283 !!$ REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: mat_loc1, mat_loc2
4284 !!$ INTEGER , DIMENSION(:), ALLOCATABLE :: idxn, jdxn
4285  REAL(KIND=8), DIMENSION(6*H_mesh%gauss%n_w,6*H_mesh%gauss%n_w) :: mat_loc1, mat_loc2
4286  INTEGER , DIMENSION(6*H_mesh%gauss%n_w) :: idxn, jdxn
4287 !!$ FL +CN 22/03/2013
4288  TYPE(petsc_csr_la) :: LA_H
4289  INTEGER :: ix, jx
4290  mat :: h_p_phi_mat1, h_p_phi_mat2
4291  petscerrorcode :: ierr
4292 
4293  ! June 2009, JLG, CN, normalization
4294  stab_colle_h_mu = stab(3)
4295  stab_div = stab(1)
4296  ! June 2009, JLG, CN
4297 
4298  !**********************************************************************************
4299  !--------------------TERMS ON SIGMA_MU-------------------------------
4300  !**********************************************************************************
4301 
4302  !WRITE(*,*) 'Assembling interface_H_mu'
4303  CALL gauss(h_mesh)
4304  n_ws1 = h_mesh%gauss%n_ws
4305  n_ws2 = h_mesh%gauss%n_ws
4306  n_w1 = h_mesh%gauss%n_w
4307  n_w2 = h_mesh%gauss%n_w
4308 
4309 !!$ ALLOCATE(w_cs(n_ws1,l_Gs))
4310 !!$ ALLOCATE(dw_cs(2, n_w1, l_Gs, H_mesh%mes))
4311 !!$ ALLOCATE(dwsi(2, n_w1),dwsj(2, n_w2))
4312 !!$ ALLOCATE(gauss1(2,l_Gs),gauss2(2,l_Gs))
4313 
4314 !!$ ALLOCATE(mat_loc1(6*n_w1,6*n_w2))
4315 !!$ ALLOCATE(mat_loc2(6*n_w1,6*n_w2))
4316 !!$ ALLOCATE(idxn(6*n_w1))
4317 !!$ ALLOCATE(jdxn(6*n_w2))
4318 
4319  DO ms = 1, interface_h_mu%mes
4320 
4321  ms2 = interface_h_mu%mesh2(ms)
4322  m2 = h_mesh%neighs(ms2)
4323  ms1 = interface_h_mu%mesh1(ms)
4324  m1 = h_mesh%neighs(ms1)
4325 
4326  ref = 1.d-8+sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - h_mesh%rr(:,h_mesh%jjs(2,ms1)))**2)
4327  diff = sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - h_mesh%rr(:,h_mesh%jjs(1,ms2)))**2)
4328  IF (diff/ref .LT. 1.d-10) THEN ! 1 = 1
4329  w_cs = wws
4330  ELSE ! 1 = 2
4331  DO ls = 1, l_gs
4332  w_cs(1,ls)= wws(2,ls)
4333  w_cs(2,ls)= wws(1,ls)
4334  IF (n_ws1==3) w_cs(n_ws1,ls) = wws(n_ws1,ls)
4335  WRITE(*,*) ' Ouaps! oder of shape functions changed?'
4336  END DO
4337  END IF
4338 
4339  DO ls = 1, l_gs
4340  gauss2(1,ls) = sum(h_mesh%rr(1,h_mesh%jjs(:,ms2))*h_mesh%gauss%wws(:,ls))
4341  gauss2(2,ls) = sum(h_mesh%rr(2,h_mesh%jjs(:,ms2))*h_mesh%gauss%wws(:,ls))
4342  gauss1(1,ls) = sum(h_mesh%rr(1,h_mesh%jjs(:,ms1))*h_mesh%gauss%wws(:,ls))
4343  gauss1(2,ls) = sum(h_mesh%rr(2,h_mesh%jjs(:,ms1))*h_mesh%gauss%wws(:,ls))
4344  END DO
4345 
4346  DO ls2 = 1, l_gs
4347  ref = sqrt(1.d-8+sum(gauss2(:,ls2)**2))
4348  mark = .false.
4349  DO ls1 = 1, l_gs
4350  diff = sqrt(sum((gauss2(:,ls2)-gauss1(:,ls1))**2))
4351  IF (diff .LT. 1.d-10) THEN
4352  dw_cs(:,:,ls2,ms1) = h_mesh%gauss%dw_s(:,:,ls1,ms1)
4353  mark = .true.
4354  EXIT
4355  END IF
4356  END DO
4357  IF (.NOT.mark) WRITE(*,*) ' BUG '
4358  END DO
4359 
4360  END DO
4361 
4362  DO ms = 1, interface_h_mu%mes
4363 
4364  ms2 = interface_h_mu%mesh2(ms)
4365  ms1 = interface_h_mu%mesh1(ms)
4366  m2 = h_mesh%neighs(ms2)
4367  m1 = h_mesh%neighs(ms1)
4368  mu_h = sum(mu_h_field(h_mesh%jj(:,m1)))/h_mesh%gauss%n_w
4369  !JLG, FL, May, 28, 2009
4370  !hm1 = stab_colle_H_mu*(((mu_H+mu_H)/mu_H)/SUM(rjs(:,ms2)))
4371  hm1 = 1/sum(rjs(:,ms2))
4372  !JLG, FL, May, 28, 2009
4373  !====================================================================================
4374  !------------------------------------TERMES SUR LE BLOC H----------------------------
4375  !====================================================================================
4376 
4377  !-------------------------------hm1 (bi x ni) . (bj/muhl x nj)----------------------------
4378  !---------------------------------+ (mui bi.ni) (bj.nj)--------------------------
4379  !====================================================================================
4380  hsij = 0.d0
4381  DO ls = 1, l_gs
4382  !===Compute radius of Gauss point
4383  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms2))* h_mesh%gauss%wws(:,ls))
4384  x = hm1*rjs(ls,ms2)*ray
4385 
4386  !June 14 2008, muhl
4387  muhl1 = sum(mu_h_field(h_mesh%jjs(:,ms1))*w_cs(:,ls))
4388  muhl2 = sum(mu_h_field(h_mesh%jjs(:,ms2))* wws(:,ls))
4389  !JLG, FL, May, 28, 2009, Normalization
4390  !normt =stab_colle_H_mu
4391  !LC 2017/01/29
4392  normt =stab_colle_h_mu/inputs%sigma_min
4393  !LC 2017/01/29
4394  !JLG+CN+LC Dec 14 2016, normalization (h/Diam)**(2*alpha)/(mu**2*sigma)
4395  !norm = stab_div*SUM(rjs(:,ms2))**(2*alpha)
4396  !norm = stab_div*(SUM(rjs(:,ms2))/H_mesh%global_diameter)**(2*alpha)/(min(sigma(m1),sigma(m2))*min(muhl1,muhl2)**2)
4397  !End JLG+CN+LC Dec 14 2016, normalization (h/Diam)**(2*alpha)/(mu**2*sigma)
4398  !LC 2017/01/29
4399  norm = stab_div*(sum(rjs(:,ms2))/h_mesh%global_diameter)**(2*alpha)/(inputs%sigma_min*inputs%mu_min**2)
4400  !End 2017/01/29
4401  !norm = stab_div*SUM(rjs(:,ms2))**(2*alpha)/MAX(muhl1,muhl2)
4402  !norm = stab_div*SUM(rjs(:,ms2))**(2*alpha)/MAX(muhl1,muhl2)**2
4403  !norm = 1.d0/MAX(muhl1,muhl2)
4404  !norm = 1.d0/MAX(muhl1,muhl2)**2
4405  !JLG, FL, May, 28, 2009, Normalization
4406  !June 14 2008, muhl
4407 
4408  DO ci = 1, 2
4409  IF (ci==1) THEN
4410  normi = rnorms(:,ls,ms1)
4411  wwsi = w_cs(:,ls)
4412  n_wsi = n_ws1
4413  muhi = muhl1
4414  ELSE
4415  normi = rnorms(:,ls,ms2)
4416  wwsi = wws(:,ls)
4417  n_wsi = n_ws2
4418  muhi = muhl2
4419  END IF
4420  DO cj = 1, 2
4421  IF (cj==1) THEN
4422  normj = rnorms(:,ls,ms1)
4423  wwsj = w_cs(:,ls)
4424  n_wsj = n_ws1
4425  muhj = muhl1
4426  ELSE
4427  normj = rnorms(:,ls,ms2)
4428  wwsj = wws(:,ls)
4429  n_wsj = n_ws2
4430  muhj = muhl2
4431  END IF
4432 
4433  DO ni = 1, n_wsi
4434  DO nj = 1, n_wsj
4435  wwiwwj = x * wwsi(ni)*wwsj(nj)
4436  ! H to B
4437  !y = normt * wwiwwj
4438  ! June 14 2008, added z
4439  !z = norm * muhi * muhj * wwiwwj
4440  ! June 14 2008, added z
4441  y = normt * wwiwwj/muhj
4442  z = norm * muhi * wwiwwj
4443  !H to B
4444  hsij(1,ni,nj,ci,cj) = hsij(1,ni,nj,ci,cj) + y*normi(2)*normj(2) &
4445  + z*normi(1)*normj(1)
4446  hsij(4,ni,nj,ci,cj) = hsij(4,ni,nj,ci,cj) - y*normj(1)*normi(2) &
4447  + z*normi(1)*normj(2)
4448  ! H to B
4449  hsij(7,ni,nj,ci,cj) = hsij(7,ni,nj,ci,cj) - y*normj(2)*normi(1) &
4450  + z*normi(2)*normj(1)
4451  ! H to B
4452  hsij(5,ni,nj,ci,cj) = hsij(5,ni,nj,ci,cj) + y*(normi(1)*normj(1) + normi(2)*normj(2))
4453  hsij(6,ni,nj,ci,cj) = hsij(6,ni,nj,ci,cj) + y*normi(1)*normj(1) &
4454  + z*normi(2)*normj(2)
4455  END DO
4456  END DO
4457  END DO
4458  END DO
4459  END DO
4460 
4461  mat_loc1 = 0.d0
4462  mat_loc2 = 0.d0
4463  DO ci = 1, 2
4464  DO ki = 1, 3
4465  DO ni = 1, n_ws1
4466  IF (ci==1) THEN
4467  i = interface_h_mu%jjs1(ni,ms)
4468  ELSE
4469  i = interface_h_mu%jjs2(ni,ms)
4470  END IF
4471  ib = la_h%loc_to_glob(ki,i)
4472  ix = ni + n_ws1*((ki-1) + 3*(ci-1))
4473  idxn(ix) = ib-1
4474 
4475  DO cj = 1, 2
4476  DO kj = 1, 3
4477  DO nj = 1, n_ws2
4478  IF (cj==1) THEN
4479  j = interface_h_mu%jjs1(nj,ms)
4480  ELSE
4481  j = interface_h_mu%jjs2(nj,ms)
4482  END IF
4483  jb = la_h%loc_to_glob(kj,j)
4484  jx = nj + n_ws2*((kj-1) + 3*(cj-1))
4485  jdxn(jx) = jb-1
4486  IF ((ki == 1) .AND. (kj == 1)) THEN
4487  mat_loc1(ix,jx) = hsij(1,ni,nj,ci,cj)
4488  mat_loc2(ix,jx) = hsij(1,ni,nj,ci,cj)
4489  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
4490  mat_loc1(ix,jx) = hsij(4,ni,nj,ci,cj)
4491  mat_loc2(ix,jx) = hsij(4,ni,nj,ci,cj)
4492  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
4493  ! H to B
4494  !mat_loc1(ix,jx) = Hsij(4,nj,ni,cj,ci)
4495  !mat_loc2(ix,jx) = Hsij(4,nj,ni,cj,ci)
4496  ! H to B
4497  mat_loc1(ix,jx) = hsij(7,ni,nj,ci,cj)
4498  mat_loc2(ix,jx) = hsij(7,ni,nj,ci,cj)
4499  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
4500  mat_loc1(ix,jx) = hsij(5,ni,nj,ci,cj)
4501  mat_loc2(ix,jx) = hsij(5,ni,nj,ci,cj)
4502  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
4503  mat_loc1(ix,jx) = hsij(6,ni,nj,ci,cj)
4504  mat_loc2(ix,jx) = hsij(6,ni,nj,ci,cj)
4505  ENDIF
4506  END DO
4507  END DO
4508  END DO
4509  END DO
4510  END DO
4511  END DO
4512 
4513  CALL matsetvalues(h_p_phi_mat1, 6*n_ws1, idxn(1:6*n_ws1), 6*n_ws2, jdxn(1:6*n_ws2), &
4514  mat_loc1(1:6*n_ws1,1:6*n_ws2), add_values, ierr)
4515  CALL matsetvalues(h_p_phi_mat2, 6*n_ws1, idxn(1:6*n_ws1), 6*n_ws2, jdxn(1:6*n_ws2), &
4516  mat_loc2(1:6*n_ws1,1:6*n_ws2), add_values, ierr)
4517 
4518  !====================================================================================
4519  !------------------------(1/sigma) (Rot bj/muj) . (bi x ni)------------------------------
4520  !====================================================================================
4521 
4522  !terms without derivatives
4523  hsij = 0.d0
4524  gsij = 0.d0
4525  DO ls = 1, h_mesh%gauss%l_Gs
4526 
4527  !===Compute radius of Gauss point
4528  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms2))* h_mesh%gauss%wws(:,ls))
4529  x = rjs(ls,ms2)*ray
4530  ! H to B
4531  muhl1 = sum(mu_h_field(h_mesh%jjs(:,ms1))*w_cs(:,ls))
4532  muhl2 = sum(mu_h_field(h_mesh%jjs(:,ms2))* wws(:,ls))
4533  drmuhl1 = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(1,:,ls,ms1))
4534  drmuhl2 = sum(mu_h_field(h_mesh%jj(:,m2))* dw_s(1,:,ls,ms2))
4535  dzmuhl1 = sum(mu_h_field(h_mesh%jj(:,m1))*dw_cs(2,:,ls,ms1))
4536  dzmuhl2 = sum(mu_h_field(h_mesh%jj(:,m2))* dw_s(2,:,ls,ms2))
4537  ! TEST DEBUG
4538  IF (jj_v_to_h(h_mesh%jj(1,m1)) == -1) THEN
4539  sigmal1 = sigma(m1)
4540  ELSE
4541  sigmal1 = sum(sigma_np(h_mesh%jjs(:,ms1))*w_cs(:,ls))
4542  END IF
4543  IF (jj_v_to_h(h_mesh%jj(1,m2)) == -1) THEN
4544  sigmal2 = sigma(m2)
4545  ELSE
4546  sigmal2 = sum(sigma_np(h_mesh%jjs(:,ms2))* wws(:,ls))
4547  END IF
4548  ! TEST DEBUG
4549  ! H to B
4550  DO ci = 1, 2
4551  IF (ci==1) THEN
4552  normi = rnorms(:,ls,ms1)
4553  wwsi = w_cs(:,ls)
4554  n_wsi = n_ws1
4555  ! sigmai = sigma(m1)
4556  ! TEST DEBUG
4557  sigmai = sigmal1
4558  ! TEST DEBUG
4559  ELSE
4560  normi = rnorms(:,ls,ms2)
4561  wwsi = wws(:,ls)
4562  n_wsi = n_ws2
4563  ! sigmai = sigma(m2)
4564  ! TEST DEBUG
4565  sigmai = sigmal2
4566  ! TEST DEBUG
4567  END IF
4568  DO cj = 1, 2
4569  IF (cj==1) THEN
4570  normj = rnorms(:,ls,ms1)
4571  wwsj = w_cs(:,ls)
4572  n_wsj = n_ws1
4573  ! sigmaj = sigma(m1)
4574  ! TEST DEBUG
4575  sigmaj = sigmal1
4576  ! TEST DEBUG
4577  ! H to B
4578  muhj = muhl1
4579  drmuhj = drmuhl1
4580  dzmuhj = dzmuhl1
4581  ! H to B
4582  ELSE
4583  normj = rnorms(:,ls,ms2)
4584  wwsj = wws(:,ls)
4585  n_wsj = n_ws2
4586  ! sigmaj = sigma(m2)
4587  ! TEST DEBUG
4588  sigmaj = sigmal2
4589  ! TEST DEBUG
4590  ! H to B
4591  muhj = muhl2
4592  drmuhj = drmuhl2
4593  dzmuhj = dzmuhl2
4594  ! H to B
4595  END IF
4596 
4597  DO ni = 1,n_wsi !
4598  DO nj = 1, n_wsj
4599  ! H to B
4600  !y = x*wwsi(ni)*wwsj(nj)/(2*sigmaj)
4601  y = x*wwsi(ni)*wwsj(nj)/(2*sigmaj*muhj)
4602  ! H to B
4603  hsij(2,ni,nj,ci,cj) = hsij(2,ni,nj,ci,cj) + y * (-mode/ray)*normi(1)
4604  hsij(3,ni,nj,ci,cj) = hsij(3,ni,nj,ci,cj) + y * mode/ray *normi(1)
4605  ! H to B
4606  !Hsij(5,ni,nj,ci,cj) = Hsij(5,ni,nj,ci,cj) + y * (-1/ray) *normi(1)
4607  hsij(5,ni,nj,ci,cj) = hsij(5,ni,nj,ci,cj) - y * normi(1) *((+1/ray)+(-1/muhj)*drmuhj) &
4608  + y * normi(2)*(1/muhj)*dzmuhj
4609  ! H to B
4610  hsij(8,ni,nj,ci,cj) = hsij(8,ni,nj,ci,cj) + y * (-mode/ray)*normi(2)
4611  hsij(9,ni,nj,ci,cj) = hsij(9,ni,nj,ci,cj) + y * mode/ray *normi(2)
4612  ! H to B
4613  hsij(1,ni,nj,ci,cj) = hsij(1,ni,nj,ci,cj) - y * normi(2)*(-1/muhj)*dzmuhj
4614  hsij(4,ni,nj,ci,cj) = hsij(4,ni,nj,ci,cj) - y * normi(2)* (1/muhj)*drmuhj
4615  hsij(7,ni,nj,ci,cj) = hsij(7,ni,nj,ci,cj) + y * normi(1)*(-1/muhj)*dzmuhj
4616  hsij(6,ni,nj,ci,cj) = hsij(6,ni,nj,ci,cj) + y * normi(1)* (1/muhj)*drmuhj
4617  ! H to B
4618 
4619  y = x*wwsi(ni)*wwsj(nj)/(2*sigmai)
4620  gsij(2,ni,nj,ci,cj) = gsij(2,ni,nj,ci,cj) + y * (-mode/ray)*normj(1)
4621  gsij(3,ni,nj,ci,cj) = gsij(3,ni,nj,ci,cj) + y * ( mode/ray)*normj(1)
4622  gsij(5,ni,nj,ci,cj) = gsij(5,ni,nj,ci,cj) + y * (-1/ray) *normj(1)
4623  gsij(8,ni,nj,ci,cj) = gsij(8,ni,nj,ci,cj) + y * (-mode/ray)*normj(2)
4624  gsij(9,ni,nj,ci,cj) = gsij(9,ni,nj,ci,cj) + y * mode/ray *normj(2)
4625  ENDDO
4626  ENDDO
4627  ENDDO
4628  END DO
4629  END DO
4630 
4631  !June 14 2008
4632  gsij = c_sym*gsij !c_sym must be 0
4633  !June 14 2008
4634 
4635  mat_loc1 = 0.d0
4636  mat_loc2 = 0.d0
4637 
4638  DO ci = 1, 2
4639  DO ki = 1, 3
4640  DO ni = 1, n_wsi
4641  IF (ci==1) THEN
4642  i = interface_h_mu%jjs1(ni,ms)
4643  ELSE
4644  i = interface_h_mu%jjs2(ni,ms)
4645  END IF
4646  ib = la_h%loc_to_glob(ki,i)
4647  ix = ni + n_wsi*((ki-1) + 3*(ci-1))
4648  idxn(ix) = ib - 1
4649  DO cj = 1, 2
4650  DO kj = 1, 3
4651  DO nj = 1, n_wsj
4652  IF (cj==1) THEN
4653  j = interface_h_mu%jjs1(nj,ms)
4654  ELSE
4655  j = interface_h_mu%jjs2(nj,ms)
4656  END IF
4657  jb = la_h%loc_to_glob(kj,j)
4658  jx = nj + n_wsj*((kj-1) + 3*(cj-1))
4659  jdxn(jx) = jb - 1
4660  IF ((ki == 1) .AND. (kj == 1)) THEN !H to B
4661  mat_loc1(ix,jx) = hsij(1,ni,nj,ci,cj)
4662  mat_loc2(ix,jx) = hsij(1,ni,nj,ci,cj)
4663  ELSE IF((ki == 1) .AND. (kj == 2)) THEN
4664  mat_loc1(ix,jx) = gsij(2,ni,nj,ci,cj)
4665  mat_loc2(ix,jx) = gsij(3,ni,nj,ci,cj)
4666  ELSE IF ((ki == 1) .AND. (kj == 3)) THEN !H to B
4667  mat_loc1(ix,jx) = hsij(4,ni,nj,ci,cj)
4668  mat_loc2(ix,jx) = hsij(4,ni,nj,ci,cj)
4669  ELSE IF ((ki == 2) .AND. (kj == 1)) THEN
4670  mat_loc1(ix,jx) = hsij(2,ni,nj,ci,cj)
4671  mat_loc2(ix,jx) = hsij(3,ni,nj,ci,cj)
4672  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
4673  mat_loc1(ix,jx) = hsij(5,ni,nj,ci,cj)+gsij(5,ni,nj,ci,cj)
4674  mat_loc2(ix,jx) = hsij(5,ni,nj,ci,cj)+gsij(5,ni,nj,ci,cj)
4675  ELSEIF ((ki == 2) .AND. (kj == 3)) THEN
4676  mat_loc1(ix,jx) = hsij(8,ni,nj,ci,cj)
4677  mat_loc2(ix,jx) = hsij(9,ni,nj,ci,cj)
4678  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN !H to B
4679  mat_loc1(ix,jx) = hsij(7,ni,nj,ci,cj)
4680  mat_loc2(ix,jx) = hsij(7,ni,nj,ci,cj)
4681  ELSEIF ((ki == 3) .AND. (kj == 2)) THEN
4682  mat_loc1(ix,jx) = gsij(8,ni,nj,ci,cj)
4683  mat_loc2(ix,jx) = gsij(9,ni,nj,ci,cj)
4684  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN !H to B
4685  mat_loc1(ix,jx) = hsij(6,ni,nj,ci,cj)
4686  mat_loc2(ix,jx) = hsij(6,ni,nj,ci,cj)
4687  ENDIF
4688  END DO
4689  END DO
4690  END DO
4691  END DO
4692  END DO
4693  END DO
4694 
4695  CALL matsetvalues(h_p_phi_mat1, 6*n_ws1, idxn(1:6*n_ws1), 6*n_ws2, jdxn(1:6*n_ws2), &
4696  mat_loc1(1:6*n_ws1,1:6*n_ws2), add_values, ierr)
4697  CALL matsetvalues(h_p_phi_mat2, 6*n_ws1, idxn(1:6*n_ws1), 6*n_ws2, jdxn(1:6*n_ws2), &
4698  mat_loc2(1:6*n_ws1,1:6*n_ws2), add_values, ierr)
4699 
4700  !terms with derivatives
4701  hsij = 0.d0
4702  gsij = 0.d0
4703  DO ls = 1, h_mesh%gauss%l_Gs
4704 
4705  !===Compute radius of Gauss point
4706  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms2))* h_mesh%gauss%wws(:,ls))
4707  x = rjs(ls,ms2)*ray
4708  ! H to B
4709  muhl1 = sum(mu_h_field(h_mesh%jjs(:,ms1))*w_cs(:,ls))
4710  muhl2 = sum(mu_h_field(h_mesh%jjs(:,ms2))* wws(:,ls))
4711  ! H to B
4712  ! TEST DEBUG
4713  IF (jj_v_to_h(h_mesh%jj(1,m1)) == -1) THEN
4714  sigmal1 = sigma(m1)
4715  ELSE
4716  sigmal1 = sum(sigma_np(h_mesh%jjs(:,ms1))*w_cs(:,ls))
4717  END IF
4718  IF (jj_v_to_h(h_mesh%jj(1,m2)) == -1) THEN
4719  sigmal2 = sigma(m2)
4720  ELSE
4721  sigmal2 = sum(sigma_np(h_mesh%jjs(:,ms2))* wws(:,ls))
4722  END IF
4723  ! TEST DEBUG
4724  DO ci = 1, 2
4725  IF (ci==1) THEN
4726  normi = rnorms(:,ls,ms1)
4727  wwsi = w_cs(:,ls)
4728  dwsi = dw_cs(:,:,ls,ms1)
4729  n_wsi = n_ws1
4730  n_wi = n_w1
4731  ! sigmai = sigma(m1)
4732  ! TEST DEBUG
4733  sigmai = sigmal1
4734  ! TEST DEBUG
4735  ELSE
4736  normi = rnorms(:,ls,ms2)
4737  wwsi = wws(:,ls)
4738  dwsi = dw_s(:,:,ls,ms2)
4739  n_wsi = n_ws2
4740  n_wi = n_w2
4741  ! sigmai = sigma(m2)
4742  ! TEST DEBUG
4743  sigmai = sigmal2
4744  ! TEST DEBUG
4745  END IF
4746  DO cj = 1, 2
4747  IF (cj==1) THEN
4748  normj = rnorms(:,ls,ms1)
4749  wwsj = w_cs(:,ls)
4750  dwsj = dw_cs(:,:,ls,ms1)
4751  n_wsj = n_ws1
4752  n_wj = n_w1
4753  ! sigmaj = sigma(m1)
4754  ! TEST DEBUG
4755  sigmaj = sigmal1
4756  ! TEST DEBUG
4757  muhj = muhl1 ! H to B
4758  ELSE
4759  normj = rnorms(:,ls,ms2)
4760  wwsj = wws(:,ls)
4761  dwsj = dw_s(:,:,ls,ms2)
4762  n_wsj = n_ws2
4763  n_wj = n_w2
4764  ! sigmaj = sigma(m2)
4765  ! TEST DEBUG
4766  sigmaj = sigmal2
4767  ! TEST DEBUG
4768  muhj = muhl2 ! H to B
4769  END IF
4770 
4771  !terms with derivatives
4772  DO ni = 1,n_wsi
4773  DO nj = 1, n_wj
4774  ! H to B
4775  !y = x*wwsi(ni)/(2*sigmaj)
4776  y = x*wwsi(ni)/(2*sigmaj*muhj)
4777  ! H to B
4778  hsij(1,ni,nj,ci,cj) = hsij(1,ni,nj,ci,cj) + y*(-dwsj(2,nj))*normi(2)
4779  hsij(4,ni,nj,ci,cj) = hsij(4,ni,nj,ci,cj) + y* dwsj(1,nj) *normi(2)
4780  hsij(5,ni,nj,ci,cj) = hsij(5,ni,nj,ci,cj) + y*(-dwsj(2,nj) *normi(2)-dwsj(1,nj)*normi(1))
4781  hsij(6,ni,nj,ci,cj) = hsij(6,ni,nj,ci,cj) + y*(-dwsj(1,nj))*normi(1)
4782  hsij(7,ni,nj,ci,cj) = hsij(7,ni,nj,ci,cj) + y* dwsj(2,nj) *normi(1)
4783  ENDDO
4784  END DO
4785  DO ni = 1,n_wi
4786  DO nj = 1, n_wsj
4787  y = x*wwsj(nj)/(2*sigmai)
4788  gsij(1,ni,nj,ci,cj) = gsij(1,ni,nj,ci,cj) + y*(-dwsi(2,ni))*normj(2)
4789  gsij(4,ni,nj,ci,cj) = gsij(4,ni,nj,ci,cj) + y* dwsi(2,ni) *normj(1)
4790  gsij(5,ni,nj,ci,cj) = gsij(5,ni,nj,ci,cj) + y*(-dwsi(2,ni) *normj(2)-dwsi(1,ni)*normj(1))
4791  gsij(6,ni,nj,ci,cj) = gsij(6,ni,nj,ci,cj) + y*(-dwsi(1,ni))*normj(1)
4792  gsij(7,ni,nj,ci,cj) = gsij(7,ni,nj,ci,cj) + y* dwsi(1,ni) *normj(2)
4793  ENDDO
4794  END DO
4795 
4796  ENDDO
4797  ENDDO
4798  ENDDO
4799 
4800  !June 14 2008
4801  gsij = c_sym*gsij
4802  !June 14 2008
4803 
4804  mat_loc1 = 0.d0
4805  mat_loc2 = 0.d0
4806  DO ci = 1, 2
4807  DO ki = 1, 3
4808  DO ni = 1, n_wsi
4809  IF (ci==1) THEN
4810  i = interface_h_mu%jjs1(ni,ms)
4811  ELSE
4812  i = interface_h_mu%jjs2(ni,ms)
4813  END IF
4814  ib = la_h%loc_to_glob(ki,i)
4815  ix = ni + n_wsi*((ki-1) + 3*(ci-1))
4816  idxn(ix) = ib - 1
4817  DO cj = 1, 2
4818  DO kj = 1, 3
4819  DO nj = 1, n_wj
4820  IF (cj==1) THEN
4821  j = h_mesh%jj(nj,m1)
4822  ELSE
4823  j = h_mesh%jj(nj,m2)
4824  END IF
4825  jb = la_h%loc_to_glob(kj,j)
4826  jx = nj + n_wj*((kj-1) + 3*(cj-1))
4827  jdxn(jx) = jb - 1
4828  IF ((ki == 1) .AND. (kj == 1)) THEN
4829  mat_loc1(ix,jx) = hsij(1,ni,nj,ci,cj)
4830  mat_loc2(ix,jx) = hsij(1,ni,nj,ci,cj)
4831  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
4832  mat_loc1(ix,jx) = hsij(4,ni,nj,ci,cj)
4833  mat_loc2(ix,jx) = hsij(4,ni,nj,ci,cj)
4834  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
4835  mat_loc1(ix,jx) = hsij(7,ni,nj,ci,cj)
4836  mat_loc2(ix,jx) = hsij(7,ni,nj,ci,cj)
4837  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
4838  mat_loc1(ix,jx) = hsij(5,ni,nj,ci,cj)
4839  mat_loc2(ix,jx) = hsij(5,ni,nj,ci,cj)
4840  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
4841  mat_loc1(ix,jx) = hsij(6,ni,nj,ci,cj)
4842  mat_loc2(ix,jx) = hsij(6,ni,nj,ci,cj)
4843  ENDIF
4844 
4845  END DO
4846  END DO
4847  END DO
4848  END DO
4849  END DO
4850  END DO
4851 
4852  CALL matsetvalues(h_p_phi_mat1, 6*n_ws1, idxn(1:6*n_ws1), 6*n_w2, jdxn(1:6*n_w2), &
4853  mat_loc1(1:6*n_ws1,1:6*n_w2), add_values, ierr)
4854  CALL matsetvalues(h_p_phi_mat2, 6*n_ws1, idxn(1:6*n_ws1), 6*n_w2, jdxn(1:6*n_w2), &
4855  mat_loc2(1:6*n_ws1,1:6*n_w2), add_values, ierr)
4856 
4857  mat_loc1 = 0.d0
4858  mat_loc2 = 0.d0
4859  DO ci = 1, 2
4860  DO ki = 1, 3
4861  DO ni = 1, n_wi
4862  IF (ci==1) THEN
4863  i = h_mesh%jj(ni,m1)
4864  ELSE
4865  i = h_mesh%jj(ni,m2)
4866  END IF
4867  ib = la_h%loc_to_glob(ki,i)
4868  ix = ni + n_wi*((ki-1) + 3*(ci-1))
4869  idxn(ix) = ib - 1
4870  DO cj = 1, 2
4871  DO kj = 1, 3
4872  DO nj = 1, n_wsj
4873  IF (cj==1) THEN
4874  j = interface_h_mu%jjs1(nj,ms)
4875  ELSE
4876  j = interface_h_mu%jjs2(nj,ms)
4877  END IF
4878  jb = la_h%loc_to_glob(kj,j)
4879  jx = nj + n_wsj*((kj-1) + 3*(cj-1))
4880  jdxn(jx) = jb-1
4881  IF ((ki == 1) .AND. (kj == 1)) THEN
4882  mat_loc1(ix,jx) = gsij(1,ni,nj,ci,cj)
4883  mat_loc2(ix,jx) = gsij(1,ni,nj,ci,cj)
4884  ELSEIF ((ki == 1) .AND. (kj == 3)) THEN
4885  mat_loc1(ix,jx) = gsij(4,ni,nj,ci,cj)
4886  mat_loc2(ix,jx) = gsij(4,ni,nj,ci,cj)
4887  ELSEIF ((ki == 3) .AND. (kj == 1)) THEN
4888  mat_loc1(ix,jx) = gsij(7,ni,nj,ci,cj)
4889  mat_loc2(ix,jx) = gsij(7,ni,nj,ci,cj)
4890  ELSEIF ((ki == 2) .AND. (kj == 2)) THEN
4891  mat_loc1(ix,jx) = gsij(5,ni,nj,ci,cj)
4892  mat_loc2(ix,jx) = gsij(5,ni,nj,ci,cj)
4893  ELSEIF ((ki == 3) .AND. (kj == 3)) THEN
4894  mat_loc1(ix,jx) = gsij(6,ni,nj,ci,cj)
4895  mat_loc2(ix,jx) = gsij(6,ni,nj,ci,cj)
4896  ENDIF
4897  END DO
4898  END DO
4899  END DO
4900  END DO
4901  END DO
4902  END DO
4903 
4904  CALL matsetvalues(h_p_phi_mat1, 6*n_w1, idxn(1:6*n_w1), 6*n_ws2, jdxn(1:6*n_ws2), &
4905  mat_loc1(1:6*n_w1,1:6*n_ws2), add_values, ierr)
4906  CALL matsetvalues(h_p_phi_mat2, 6*n_w1, idxn(1:6*n_w1), 6*n_ws2, jdxn(1:6*n_ws2), &
4907  mat_loc2(1:6*n_w1,1:6*n_ws2), add_values, ierr)
4908 
4909  END DO
4910 
4911  CALL matassemblybegin(h_p_phi_mat1,mat_final_assembly,ierr)
4912  CALL matassemblyend(h_p_phi_mat1,mat_final_assembly,ierr)
4913  CALL matassemblybegin(h_p_phi_mat2,mat_final_assembly,ierr)
4914  CALL matassemblyend(h_p_phi_mat2,mat_final_assembly,ierr)
4915 
4916 !!$ DEALLOCATE(mat_loc1, mat_loc2, idxn, jdxn)
4917 !!$ DEALLOCATE(w_cs, dw_cs, gauss1, gauss2, dwsi, dwsj)
4918 
4919  END SUBROUTINE mat_maxwell_mu
4920 
4921  SUBROUTINE courant_mu(H_mesh,interface_H_mu,sigma,mu_H_field,time,mode,nl, &
4922  la_h, vb_1, vb_2, b_ext, j_over_sigma_gauss, sigma_curl_gauss)
4923  !forcage faisant intervenir J, volumique et interface pour H et phi
4924  !pour le probleme en entier
4925  USE def_type_mesh
4926  USE gauss_points
4927  USE boundary
4928  USE input_data
4929 #include "petsc/finclude/petsc.h"
4930  USE petsc
4931  IMPLICIT NONE
4932  TYPE(mesh_type), INTENT(IN) :: H_mesh
4933  TYPE(interface_type), INTENT(IN) :: interface_H_mu
4934  REAL(KIND=8), INTENT(IN) :: time
4935  REAL(KIND=8), DIMENSION(H_mesh%me), INTENT(IN) :: sigma
4936  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
4937  INTEGER, INTENT(IN) :: mode
4938  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: nl
4939  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: B_ext
4940  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: J_over_sigma_gauss
4941  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: sigma_curl_gauss
4942  REAL(KIND=8), DIMENSION(H_mesh%np,6) :: src_H
4943  REAL(KIND=8), DIMENSION(H_mesh%gauss%n_ws,H_mesh%gauss%l_Gs) :: w_cs
4944  REAL(KIND=8), DIMENSION(2) :: normi, gaussp1, gaussp2
4945  REAL(KIND=8), DIMENSION(H_mesh%gauss%n_ws) :: wwsi
4946  REAL(KIND=8) :: x, ray
4947  INTEGER :: i, ni, ms, k, ls, n_ws1, n_ws2, ms1, ms2, n_w1, n_w2, m1, m2, ci, n_wsi
4948  INTEGER :: mesh_id1, mesh_id2, index
4949  REAL(KIND=8), DIMENSION(6) :: JsolH_anal, test, B_ext_l, J_over_sigma_l
4950  REAL(KIND=8) :: muhl1, muhl2, ref, diff
4951  !April 17th, 2008, JLG
4952  REAL(KIND=8) :: one
4953  DATA one/1.d0/
4954  !April 17th, 2008, JLG
4955  !$$ FL+CN 22/03/2013
4956 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: idxn
4957  INTEGER, DIMENSION(H_mesh%np) :: idxn
4958  !$$ FL+CN 22/03/2013
4959  TYPE(petsc_csr_la) :: LA_H
4960  petscerrorcode :: ierr
4961  vec :: vb_1, vb_2
4962 
4963 
4964  !**********************************************************************************
4965  !--------------------TERMS ON SIGMA_MU-------------------------------
4966  !**********************************************************************************
4967  src_h = 0.d0
4968  !WRITE(*,*) 'Assembling rhs interface_H_mu'
4969  CALL gauss(h_mesh)
4970  n_ws1 = h_mesh%gauss%n_ws
4971  n_ws2 = h_mesh%gauss%n_ws
4972  n_w1 = h_mesh%gauss%n_w
4973  n_w2 = h_mesh%gauss%n_w
4974 
4975  DO ms = 1, interface_h_mu%mes
4976  ms1 = interface_h_mu%mesh1(ms)
4977  ms2 = interface_h_mu%mesh2(ms)
4978  m1 = h_mesh%neighs(ms1)
4979  m2 = h_mesh%neighs(ms2)
4980 
4981  ref = 1.d-8+sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - h_mesh%rr(:,h_mesh%jjs(2,ms1)))**2)
4982  diff = sum((h_mesh%rr(:,h_mesh%jjs(1,ms1)) - h_mesh%rr(:,h_mesh%jjs(1,ms2)))**2)
4983  IF (diff/ref .LT. 1.d-10) THEN ! 1 = 1
4984  w_cs = wws
4985  ELSE ! 1 = 2
4986  DO ls = 1, l_gs
4987  w_cs(1,ls)= wws(2,ls)
4988  w_cs(2,ls)= wws(1,ls)
4989  IF (n_ws1==3) w_cs(n_ws1,ls) = wws(n_ws1,ls)
4990  WRITE(*,*) ' Ouaps! oder of shape functions changed?'
4991  END DO
4992  END IF
4993  END DO
4994 
4995  index=0
4996  DO ms = 1, interface_h_mu%mes
4997  ms2 = interface_h_mu%mesh2(ms)
4998  ms1 = interface_h_mu%mesh1(ms)
4999  m2 = h_mesh%neighs(ms2)
5000  m1 = h_mesh%neighs(ms1)
5001  mesh_id1 = h_mesh%i_d(m1)
5002  mesh_id2 = h_mesh%i_d(m2)
5003  DO ls = 1, l_gs
5004  !===Compute radius of Gauss point
5005  ray = sum(h_mesh%rr(1,h_mesh%jjs(:,ms2))* h_mesh%gauss%wws(:,ls))
5006 
5007  ! Side 1
5008  index=index+1
5009  DO k=1, 6
5010  b_ext_l(k) = sum(b_ext(h_mesh%jjs(:,ms1),k)*h_mesh%gauss%wws(:,ls))
5011  j_over_sigma_l(k) = j_over_sigma_gauss(index,k) + sigma_curl_gauss(index,k)
5012  END DO
5013  muhl1=sum(mu_h_field(h_mesh%jjs(:,ms1))*w_cs(:,ls))
5014  gaussp1(1) = sum(h_mesh%rr(1,h_mesh%jjs(:,ms1))*w_cs(:,ls))
5015  gaussp1(2) = sum(h_mesh%rr(2,h_mesh%jjs(:,ms1))*w_cs(:,ls))
5016 
5017  IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
5018  DO k=1, 6
5019  jsolh_anal(k) = j_over_sigma_l(k) &
5020  + sum(nl(h_mesh%jjs(1:n_ws1,ms1),k)*w_cs(1:n_ws1,ls))
5021  ENDDO
5022  ELSE
5023  DO k=1, 6
5024  jsolh_anal(k) = jexact_gauss(k, gaussp1, mode, one ,sigma(m1), &
5025  muhl1, time, mesh_id1, b_ext_l)/sigma(m1) &
5026  + sum(nl(h_mesh%jjs(1:n_ws1,ms1),k)*w_cs(1:n_ws1,ls))
5027  ENDDO
5028  END IF
5029 
5030  ! Side 2
5031  index=index+1
5032  DO k=1, 6
5033  b_ext_l(k) = sum(b_ext(h_mesh%jjs(:,ms2),k)*h_mesh%gauss%wws(:,ls))
5034  j_over_sigma_l(k) = j_over_sigma_gauss(index,k) + sigma_curl_gauss(index,k)
5035  END DO
5036  muhl2=sum(mu_h_field(h_mesh%jjs(:,ms2))*wws(:,ls))
5037  gaussp2(1) = sum(h_mesh%rr(1,h_mesh%jjs(:,ms2))*wws(:,ls))
5038  gaussp2(2) = sum(h_mesh%rr(2,h_mesh%jjs(:,ms2))*wws(:,ls))
5039  IF (maxval(abs(gaussp1-gaussp2)) > 1.d-11) THEN
5040  WRITE(*,*) ' BUG courant_mu '
5041  stop
5042  END IF
5043 
5044  IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
5045  DO k=1, 6
5046  test(k) = j_over_sigma_l(k) &
5047  + sum(nl(h_mesh%jjs(1:n_ws2,ms2),k)*wws(1:n_ws2,ls))
5048  jsolh_anal(k) = jsolh_anal(k) + test(k)
5049  ENDDO
5050  ELSE
5051  DO k=1, 6
5052  test(k) = jexact_gauss(k, gaussp2, mode, one ,sigma(m2), &
5053  muhl2, time, mesh_id2, b_ext_l)/sigma(m2) &
5054  + sum(nl(h_mesh%jjs(1:n_ws2,ms2),k)*wws(1:n_ws2,ls))
5055  jsolh_anal(k) = jsolh_anal(k) + test(k)
5056  ENDDO
5057  END IF
5058  ! Division by 2 to get the mean is in definition of x below.
5059 
5060  !---------forcage pour H
5061  DO ci = 1, 2
5062  IF (ci==1) THEN
5063  normi = rnorms(:,ls,ms1)
5064  wwsi = w_cs(:,ls)
5065  n_wsi = n_ws1
5066  ELSE
5067  normi = rnorms(:,ls,ms2)
5068  wwsi = wws(:,ls)
5069  n_wsi = n_ws2
5070  END IF
5071  DO ni = 1, n_wsi
5072  IF (ci==1) THEN
5073  i = interface_h_mu%jjs1(ni,ms)
5074  ELSE
5075  i = interface_h_mu%jjs2(ni,ms)
5076  END IF
5077  x = rjs(ls,ms2)*ray*wwsi(ni)/2
5078  src_h(i,1) = src_h(i,1)+x*(-jsolh_anal(3)*normi(2))
5079  src_h(i,2) = src_h(i,2)+x*(-jsolh_anal(4)*normi(2))
5080  src_h(i,3) = src_h(i,3)+x*(jsolh_anal(1)*normi(2)-jsolh_anal(5)*normi(1))
5081  src_h(i,4) = src_h(i,4)+x*(jsolh_anal(2)*normi(2)-jsolh_anal(6)*normi(1))
5082  src_h(i,5) = src_h(i,5)+x*(jsolh_anal(3)*normi(1))
5083  src_h(i,6) = src_h(i,6)+x*(jsolh_anal(4)*normi(1))
5084  END DO
5085  ENDDO
5086  END DO
5087  END DO
5088 
5089  IF (h_mesh%np /= 0) THEN
5090 !!$ ALLOCATE(idxn(H_mesh%np))
5091  idxn = la_h%loc_to_glob(1,:)-1
5092  CALL vecsetvalues(vb_1, h_mesh%np, idxn, src_h(:,1), add_values, ierr)
5093  CALL vecsetvalues(vb_2, h_mesh%np, idxn, src_h(:,2), add_values, ierr)
5094  idxn = la_h%loc_to_glob(2,:)-1
5095  CALL vecsetvalues(vb_1, h_mesh%np, idxn, src_h(:,4), add_values, ierr)
5096  CALL vecsetvalues(vb_2, h_mesh%np, idxn, src_h(:,3), add_values, ierr)
5097  idxn = la_h%loc_to_glob(3,:)-1
5098  CALL vecsetvalues(vb_1, h_mesh%np, idxn, src_h(:,5), add_values, ierr)
5099  CALL vecsetvalues(vb_2, h_mesh%np, idxn, src_h(:,6), add_values, ierr)
5100 !!$ DEALLOCATE(idxn)
5101  END IF
5102  CALL vecassemblybegin(vb_1,ierr)
5103  CALL vecassemblyend(vb_1,ierr)
5104  CALL vecassemblybegin(vb_2,ierr)
5105  CALL vecassemblyend(vb_2,ierr)
5106 
5107  END SUBROUTINE courant_mu
5108 
5109  SUBROUTINE rhs_dirichlet(H_mesh,Dirichlet_bdy_H_sides,sigma,&
5110  mu_h_field,time,mode,nl,stab, la_h, vb_1, vb_2, b_ext, j_over_sigma_bdy, &
5111  sigma_curl_bdy_in)
5112  !forcage faisant intervenir J, volumique et surfacique
5113  !pour le probleme en entier
5114  USE def_type_mesh
5115  USE boundary
5116  USE input_data
5117 #include "petsc/finclude/petsc.h"
5118  USE petsc
5119  IMPLICIT NONE
5120  TYPE(mesh_type), INTENT(IN) :: H_mesh
5121  INTEGER, DIMENSION(:), INTENT(IN) :: Dirichlet_bdy_H_sides
5122  REAL(KIND=8), INTENT(IN) :: time
5123  REAL(KIND=8), DIMENSION(H_mesh%me), INTENT(IN) :: sigma
5124  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
5125  INTEGER, INTENT(IN) :: mode
5126  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: nl
5127  REAL(KIND=8), DIMENSION(3), INTENT(IN) :: stab
5128  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: B_ext
5129  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: J_over_sigma_bdy !Used only if sigma variable in fluid
5130  REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: sigma_curl_bdy_in !Used only if sigma variable in fluid
5131  REAL(KIND=8), DIMENSION(H_mesh%np,6) :: src_H
5132  REAL(KIND=8), DIMENSION(2) :: gaussp1
5133  REAL(KIND=8) :: x, ray, stab_colle_H_mu
5134  INTEGER :: i, ni, ms, k, ls, m1, count
5135  INTEGER :: mesh_id1
5136  REAL(KIND=8), DIMENSION(6) :: JsolH_anal, B_ext_l
5137  REAL(KIND=8) :: muhl1, hm1
5138  REAL(KIND=8), DIMENSION(6,H_mesh%gauss%l_Gs) :: Hloc, Hlocxn
5139  REAL(KIND=8), DIMENSION(2,H_mesh%gauss%l_Gs) :: rloc
5140  REAL(KIND=8), DIMENSION(1) :: muloc
5141  INTEGER :: index
5142  !April 17th, 2008, JLG
5143  REAL(KIND=8) :: one
5144  DATA one/1.d0/
5145  !April 17th, 2008, JLG
5146 !!$ FL+CN 22/03/2013
5147 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: idxn
5148  INTEGER, DIMENSION(H_mesh%np) :: idxn
5149 !!$ FL+CN 22/03/2013
5150  TYPE(petsc_csr_la) :: LA_H
5151  petscerrorcode :: ierr
5152  vec :: vb_1, vb_2
5153 
5154  !IF (SIZE(Dirichlet_bdy_H_sides)==0) THEN
5155  ! RETURN
5156  !END IF
5157 
5158  src_h = 0.d0
5159 
5160  !IF (SIZE(Dirichlet_bdy_H_sides)==0) THEN
5161  ! IF (ASSOCIATED(nl)) DEALLOCATE(nl)
5162  ! RETURN
5163  !END IF
5164 
5165  stab_colle_h_mu = stab(3)
5166  index = 0
5167 
5168  DO count = 1, SIZE(dirichlet_bdy_h_sides)
5169  ms = dirichlet_bdy_h_sides(count)
5170  !hm1 = stab_colle_H_mu/SUM(H_mesh%gauss%rjs(:,ms))
5171  !LC 2017/01/29
5172  hm1 = stab_colle_h_mu/(sum(h_mesh%gauss%rjs(:,ms))*inputs%sigma_min)
5173  !End LC 2017/01/29
5174  m1 = h_mesh%neighs(ms)
5175  mesh_id1 = h_mesh%i_d(m1)
5176  muloc(1) = mu_h_field(h_mesh%jj(1,m1))
5177  DO ls = 1, h_mesh%gauss%l_Gs
5178  rloc(1,ls) = sum(h_mesh%rr(1,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
5179  rloc(2,ls) = sum(h_mesh%rr(2,h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
5180  END DO
5181 
5182  DO k = 1, 6
5183  hloc(k,:) = hexact(h_mesh, k, rloc, mode, muloc, time)
5184  END DO
5185 
5186  hlocxn(1,:) = hloc(3,:)*h_mesh%gauss%rnorms(2,:,ms)
5187  hlocxn(2,:) = hloc(4,:)*h_mesh%gauss%rnorms(2,:,ms)
5188  hlocxn(3,:) = hloc(5,:)*h_mesh%gauss%rnorms(1,:,ms)-hloc(1,:)*h_mesh%gauss%rnorms(2,:,ms)
5189  hlocxn(4,:) = hloc(6,:)*h_mesh%gauss%rnorms(1,:,ms)-hloc(2,:)*h_mesh%gauss%rnorms(2,:,ms)
5190  hlocxn(5,:) = -hloc(3,:)*h_mesh%gauss%rnorms(1,:,ms)
5191  hlocxn(6,:) = -hloc(4,:)*h_mesh%gauss%rnorms(1,:,ms)
5192 
5193  DO ls = 1, h_mesh%gauss%l_Gs
5194  index = index + 1
5195  !===Compute radius of Gauss point
5196  ray = rloc(1,ls) !SUM(H_mesh%rr(1,H_mesh%jjs(:,ms))* H_mesh%gauss%wws(:,ls))
5197  DO k = 1, 6
5198  b_ext_l(k) = sum(b_ext(h_mesh%jjs(:,ms),k)*h_mesh%gauss%wws(:,ls))
5199  END DO
5200 
5201  ! Cote 1
5202  muhl1=sum(mu_h_field(h_mesh%jjs(:,ms))*h_mesh%gauss%wws(:,ls))
5203  gaussp1(1) = rloc(1,ls) !SUM(H_mesh%rr(1,H_mesh%jjs(:,ms))*H_mesh%gauss%wws(:,ls))
5204  gaussp1(2) = rloc(2,ls) !SUM(H_mesh%rr(2,H_mesh%jjs(:,ms))*H_mesh%gauss%wws(:,ls))
5205 !!$ DO k=1, 6
5206 !!$ JsolH_anal(k) = Jexact_gauss(k, gaussp1, mode, one ,sigma(m1), muhl1, &
5207 !!$ time, mesh_id1, B_ext_l)/sigma(m1) &
5208 !!$ + SUM(NL(H_mesh%jjs(:,ms),k)*H_mesh%gauss%wws(:,ls)) &
5209 !!$ + hm1*Hlocxn(k,ls)
5210 !!$ END DO
5211  ! TEST DEBUG
5212  IF (inputs%if_level_set.AND.inputs%variation_sigma_fluid) THEN
5213  DO k = 1, 6
5214  jsolh_anal(k) = j_over_sigma_bdy(index,k) &
5215  + sigma_curl_bdy_in(index,k) &
5216  + sum(nl(h_mesh%jjs(:,ms),k)*h_mesh%gauss%wws(:,ls)) &
5217  + hm1*hlocxn(k,ls)
5218  END DO
5219  ELSE
5220  DO k = 1, 6
5221  jsolh_anal(k) = jexact_gauss(k, gaussp1, mode, one ,sigma(m1), muhl1, &
5222  time, mesh_id1, b_ext_l)/sigma(m1) &
5223  + sum(nl(h_mesh%jjs(:,ms),k)*h_mesh%gauss%wws(:,ls)) &
5224  + hm1*hlocxn(k,ls)
5225  END DO
5226  END IF
5227  ! TEST DEBUG
5228  DO ni = 1, h_mesh%gauss%n_ws
5229  i = h_mesh%jjs(ni,ms)
5230  x = h_mesh%gauss%rjs(ls,ms)*ray*h_mesh%gauss%wws(ni,ls)
5231 
5232  src_h(i,1) = src_h(i,1)+x*(-jsolh_anal(3)*h_mesh%gauss%rnorms(2,ls,ms))
5233  src_h(i,2) = src_h(i,2)+x*(-jsolh_anal(4)*h_mesh%gauss%rnorms(2,ls,ms))
5234  src_h(i,3) = src_h(i,3)+x*(jsolh_anal(1)*h_mesh%gauss%rnorms(2,ls,ms)&
5235  -jsolh_anal(5)*h_mesh%gauss%rnorms(1,ls,ms))
5236  src_h(i,4) = src_h(i,4)+x*(jsolh_anal(2)*h_mesh%gauss%rnorms(2,ls,ms)&
5237  -jsolh_anal(6)*h_mesh%gauss%rnorms(1,ls,ms))
5238  src_h(i,5) = src_h(i,5)+x*(jsolh_anal(3)*h_mesh%gauss%rnorms(1,ls,ms))
5239  src_h(i,6) = src_h(i,6)+x*(jsolh_anal(4)*h_mesh%gauss%rnorms(1,ls,ms))
5240 
5241  END DO
5242  ENDDO
5243 
5244  END DO
5245 
5246  IF (h_mesh%np /= 0) THEN
5247 !!$ ALLOCATE(idxn(H_mesh%np))
5248  idxn = la_h%loc_to_glob(1,:)-1
5249  CALL vecsetvalues(vb_1, h_mesh%np, idxn, src_h(:,1), add_values, ierr)
5250  CALL vecsetvalues(vb_2, h_mesh%np, idxn, src_h(:,2), add_values, ierr)
5251  idxn = la_h%loc_to_glob(2,:)-1
5252  CALL vecsetvalues(vb_1, h_mesh%np, idxn, src_h(:,4), add_values, ierr)
5253  CALL vecsetvalues(vb_2, h_mesh%np, idxn, src_h(:,3), add_values, ierr)
5254  idxn = la_h%loc_to_glob(3,:)-1
5255  CALL vecsetvalues(vb_1, h_mesh%np, idxn, src_h(:,5), add_values, ierr)
5256  CALL vecsetvalues(vb_2, h_mesh%np, idxn, src_h(:,6), add_values, ierr)
5257 !!$ DEALLOCATE(idxn)
5258  END IF
5259  CALL vecassemblybegin(vb_1,ierr)
5260  CALL vecassemblyend(vb_1,ierr)
5261  CALL vecassemblybegin(vb_2,ierr)
5262  CALL vecassemblyend(vb_2,ierr)
5263 
5264  END SUBROUTINE rhs_dirichlet
5265 
5266  SUBROUTINE dirichlet_cavities(communicator, interface_H_phi, mesh, js_D)
5267  USE def_type_mesh
5268  USE chaine_caractere
5269  USE input_data
5270  USE my_util
5271 #include "petsc/finclude/petsc.h"
5272  USE petsc
5273  IMPLICIT NONE
5274  TYPE(interface_type), INTENT(IN) :: interface_H_phi
5275  TYPE(mesh_type), INTENT(IN) :: mesh
5276  INTEGER, POINTER, DIMENSION(:) :: js_D
5277  INTEGER, ALLOCATABLE, DIMENSION(:) :: on_proc_loc, on_proc, not_cav_loc, not_cav
5278  INTEGER, ALLOCATABLE, DIMENSION(:) :: is_ok, j_tmp
5279  INTEGER, DIMENSION(1) :: loc
5280  INTEGER :: m, ms, i, nb_dom, idx, nb_cav, ni
5281  LOGICAL :: okay
5282 #include "petsc/finclude/petsc.h"
5283  mpi_comm, INTENT(IN) :: communicator
5284  petscint :: rank
5285  petscerrorcode :: ierr
5286 
5287  IF (inputs%nb_dom_phi==0) RETURN
5288 
5289  CALL mpi_comm_rank(communicator, rank, ierr)
5290 
5291  nb_dom = inputs%nb_dom_phi
5292  ALLOCATE(on_proc_loc(nb_dom), on_proc(nb_dom))
5293  ALLOCATE(not_cav_loc(nb_dom), not_cav(nb_dom))
5294  on_proc_loc = -1
5295  on_proc = -1
5296  not_cav_loc = -1
5297  not_cav = -1
5298 
5299  DO m = 1, mesh%me
5300  i = mesh%i_d(m)
5301  IF (minval(abs(inputs%list_dom_phi-i)) /= 0) THEN
5302  WRITE(*,*) 'error in dirichlet cavities'
5303  END IF
5304  loc = minloc(abs(inputs%list_dom_phi-i))
5305  on_proc_loc(loc(1)) = rank
5306  END DO
5307  IF (mesh%mes /= 0) THEN
5308  ALLOCATE(is_ok(mesh%mes))
5309  is_ok = mesh%i_d(mesh%neighs)
5310  IF (interface_h_phi%mes /=0) THEN
5311  is_ok(interface_h_phi%mesh2) = 0
5312  END IF
5313  DO ms = 1, mesh%mes
5314  IF (sum(abs(mesh%rr(1,mesh%jjs(:,ms)))) .LT. 1.d-12*mesh%global_diameter) THEN
5315  is_ok(ms) = 0
5316  END IF
5317  IF (inputs%my_periodic%nb_periodic_pairs /=0) THEN
5318  IF (minval(abs(inputs%my_periodic%list_periodic-mesh%sides(ms))) == 0) THEN
5319  is_ok(ms) = 0
5320  END IF
5321  END IF
5322  END DO
5323 
5324  DO ms = 1, mesh%mes
5325  IF (is_ok(ms) == 0) cycle
5326  i = is_ok(ms)
5327  IF (minval(abs(inputs%list_dom_phi-i)) /= 0) THEN
5328  WRITE(*,*) 'error in dirichlet cavities'
5329  END IF
5330  loc = minloc(abs(inputs%list_dom_phi-i))
5331  not_cav_loc(loc(1)) = rank
5332  END DO
5333  END IF
5334  CALL mpi_allreduce(on_proc_loc, on_proc, nb_dom, mpi_integer, mpi_max, communicator, ierr)
5335  CALL mpi_allreduce(not_cav_loc, not_cav, nb_dom, mpi_integer, mpi_max, communicator, ierr)
5336 
5337  ALLOCATE(j_tmp(SIZE(js_d)+nb_dom))
5338  j_tmp(1:SIZE(js_d)) = js_d
5339  idx = SIZE(js_d)
5340  DO i = 1, nb_dom
5341  IF ( (not_cav(i)==-1) .AND. (on_proc(i)==rank) ) THEN
5342  idx = idx + 1
5343  okay = .false.
5344  DO m = 1, mesh%me
5345  IF (mesh%i_d(m) == inputs%list_dom_phi(i)) THEN
5346  DO ni = 1, mesh%gauss%n_w
5347  IF (minval(abs(mesh%jjs-mesh%jj(ni,m))) /=0) THEN
5348  j_tmp(idx) = mesh%jj(ni,m)
5349  okay = .true.
5350  EXIT
5351  END IF
5352  END DO
5353  IF (okay) THEN
5354  WRITE(*,*) 'add ', j_tmp(idx), 'in dom ', inputs%list_dom_phi(i), ' : proc ', rank
5355  WRITE(*,*) 'add ', mesh%rr(:,j_tmp(idx)), mesh%i_d(m)
5356  EXIT
5357  END IF
5358  END IF
5359  END DO
5360  END IF
5361  END DO
5362 
5363  nb_cav = idx - SIZE(js_d)
5364  IF (nb_cav /= 0) THEN
5365  DEALLOCATE(js_d)
5366  ALLOCATE(js_d(idx))
5367  js_d = j_tmp(1:idx)
5368  END IF
5369 
5370  DEALLOCATE(on_proc_loc, on_proc, j_tmp)
5371  DEALLOCATE(not_cav_loc, not_cav)
5372  IF (ALLOCATED(is_ok)) DEALLOCATE(is_ok)
5373 
5374  WRITE(*,'(a,x,i2,x,a,x,i2)') 'I have detected', nb_cav, ' cavity(ies) on proc', rank
5375 
5376  END SUBROUTINE dirichlet_cavities
5377 
5378  !===Analytical permeability, -1/mu in real space (if needed)
5379  FUNCTION minus_one_over_mu(H_mesh,angles,nb_angles,nb,ne,time) RESULT(vv)
5380  USE def_type_mesh
5381  USE boundary
5382  IMPLICIT NONE
5383  TYPE(mesh_type), INTENT(IN) :: H_mesh
5384  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: angles
5385  INTEGER, INTENT(IN) :: nb_angles
5386  INTEGER, INTENT(IN) :: nb, ne
5387  REAL(KIND=8), INTENT(IN) :: time
5388  REAL(KIND=8), DIMENSION(nb_angles,ne-nb+1) :: vv
5389 
5390  vv = -1/mu_in_real_space(h_mesh,angles,nb_angles,nb,ne,time)
5391  RETURN
5392  END FUNCTION minus_one_over_mu
5393 
5394  !===Analytical permeability, 1/mu in real space (if needed)
5395  FUNCTION one_over_mu(H_mesh,angles,nb_angles,nb,ne,time) RESULT(vv)
5396  USE def_type_mesh
5397  USE boundary
5398  IMPLICIT NONE
5399  TYPE(mesh_type), INTENT(IN) :: H_mesh
5400  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: angles
5401  INTEGER, INTENT(IN) :: nb_angles
5402  INTEGER, INTENT(IN) :: nb, ne
5403  REAL(KIND=8), INTENT(IN) :: time
5404  REAL(KIND=8), DIMENSION(nb_angles,ne-nb+1) :: vv
5405 
5406  vv = 1/mu_in_real_space(h_mesh,angles,nb_angles,nb,ne,time)
5407  RETURN
5408  END FUNCTION one_over_mu
5409 
5410  SUBROUTINE smb_sigma_prod_curl(communicator, mesh, jj_v_to_H, list_mode, H_in, one_over_sigma_in, sigma_nj_m,&
5411  sigma, v_out)
5412  !=================================
5413  USE sft_parallele
5414  USE chaine_caractere
5415  USE input_data
5416  USE def_type_mesh
5417  USE user_data
5418 #include "petsc/finclude/petsc.h"
5419  USE petsc
5420  IMPLICIT NONE
5421  TYPE(mesh_type), INTENT(IN) :: mesh
5422  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
5423  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
5424  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: H_in
5425  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_in
5426  REAL(KIND=8), DIMENSION(mesh%gauss%n_w,mesh%me), INTENT(IN) :: sigma_nj_m
5427  REAL(KIND=8), DIMENSION(mesh%me),INTENT(IN) :: sigma
5428  REAL(KIND=8), DIMENSION(:,:,:) :: V_out
5429  REAL(KIND=8), DIMENSION(mesh%gauss%l_G*mesh%me,6,SIZE(list_mode)) :: H_gauss, RotH
5430  REAL(KIND=8), DIMENSION(mesh%gauss%l_G*mesh%me,2,SIZE(list_mode)) :: one_over_sigma_gauss
5431  REAL(KIND=8), DIMENSION(mesh%gauss%l_G*mesh%me,6,SIZE(list_mode)) :: RotH_bar
5432  INTEGER, DIMENSION(mesh%gauss%n_w) :: j_loc
5433  REAL(KIND=8), DIMENSION(mesh%gauss%k_d,mesh%gauss%n_w) :: dw_loc
5434  INTEGER :: m, l , i, mode, index, k
5435  REAL(KIND=8), DIMENSION(mesh%gauss%n_w,6) :: H_in_loc
5436  REAL(KIND=8), DIMENSION(mesh%gauss%n_w,2) :: one_over_sigma_in_loc
5437  REAL(KIND=8) :: ray, sigma_np_gauss
5438  INTEGER :: nb_procs, bloc_size, m_max_pad, code
5439  mpi_comm :: communicator
5440 
5441  DO i = 1, SIZE(list_mode)
5442  mode = list_mode(i)
5443  index = 0
5444  DO m = 1, mesh%me
5445  j_loc = mesh%jj(:,m)
5446  DO k = 1, 6
5447  h_in_loc(:,k) = h_in(j_loc,k,i)
5448  END DO
5449  DO k = 1, 2
5450  one_over_sigma_in_loc(:,k) = one_over_sigma_in(j_loc,k,i)
5451  END DO
5452 
5453  DO l = 1, mesh%gauss%l_G
5454  index = index + 1
5455  dw_loc = mesh%gauss%dw(:,:,l,m)
5456 
5457  !===Compute radius of Gauss point
5458  ray = sum(mesh%rr(1,j_loc)*mesh%gauss%ww(:,l))
5459 
5460  !-----------------magnetic field on gauss points---------------------------
5461  h_gauss(index,1,i) = sum(h_in_loc(:,1)*mesh%gauss%ww(:,l))
5462  h_gauss(index,3,i) = sum(h_in_loc(:,3)*mesh%gauss%ww(:,l))
5463  h_gauss(index,5,i) = sum(h_in_loc(:,5)*mesh%gauss%ww(:,l))
5464 
5465  h_gauss(index,2,i) = sum(h_in_loc(:,2)*mesh%gauss%ww(:,l))
5466  h_gauss(index,4,i) = sum(h_in_loc(:,4)*mesh%gauss%ww(:,l))
5467  h_gauss(index,6,i) = sum(h_in_loc(:,6)*mesh%gauss%ww(:,l))
5468  !-----------------Curl of H on gauss points--------------------------------
5469  !coeff sur les cosinus
5470  roth(index,1,i) = mode/ray*h_gauss(index,6,i) &
5471  -sum(h_in_loc(:,3)*dw_loc(2,:))
5472  roth(index,4,i) = sum(h_in_loc(:,2)*dw_loc(2,:)) &
5473  -sum(h_in_loc(:,6)*dw_loc(1,:))
5474  roth(index,5,i) = 1/ray*h_gauss(index,3,i) &
5475  +sum(h_in_loc(:,3)*dw_loc(1,:)) &
5476  -mode/ray*h_gauss(index,2,i)
5477  !coeff sur les sinus
5478  roth(index,2,i) =-mode/ray*h_gauss(index,5,i) &
5479  -sum(h_in_loc(:,4)*dw_loc(2,:))
5480  roth(index,3,i) = sum(h_in_loc(:,1)*dw_loc(2,:)) &
5481  -sum(h_in_loc(:,5)*dw_loc(1,:))
5482  roth(index,6,i) = 1/ray*h_gauss(index,4,i) &
5483  +sum(h_in_loc(:,4)*dw_loc(1,:))&
5484  +mode/ray*h_gauss(index,1,i)
5485  !-----------------one over sigma on gauss points---------------------------
5486  IF (jj_v_to_h(mesh%jj(1,m)) == -1) THEN
5487  one_over_sigma_gauss(index,1,i) = 0.d0
5488  one_over_sigma_gauss(index,2,i) = 0.d0
5489  IF (mode==0) THEN
5490  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m)
5491  END IF
5492  ELSE
5493  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc(:,1)*mesh%gauss%ww(:,l))
5494  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc(:,2)*mesh%gauss%ww(:,l))
5495  END IF
5496  !-----------------RotHbar on gauss points----------------------------------
5497  sigma_np_gauss = sum(sigma_nj_m(:,m)*mesh%gauss%ww(:,l))
5498  DO k = 1, 6
5499  roth_bar(index,k,i) = roth(index,k,i)/sigma_np_gauss
5500  END DO
5501  ENDDO
5502  ENDDO
5503  END DO
5504 
5505  CALL mpi_comm_size(communicator, nb_procs, code)
5506  bloc_size = SIZE(one_over_sigma_gauss,1)/nb_procs+1
5507  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
5508  CALL fft_scalar_vect_no_overshoot(communicator, 1.d0/(inputs%sigma_fluid*inputs%Rem), &
5509  roth, one_over_sigma_gauss, v_out, 1, nb_procs, bloc_size, m_max_pad)
5510  v_out = roth_bar - v_out
5511 
5512  END SUBROUTINE smb_sigma_prod_curl
5513 
5514  SUBROUTINE smb_sigma_prod_curl_bdy(communicator, mesh, jj_v_to_H, Dirichlet_bdy_H_sides, list_mode, &
5515  h_in, one_over_sigma_in, sigma_np, sigma, v_out)
5516  !=================================
5517  USE sft_parallele
5518  USE chaine_caractere
5519  USE input_data
5520  USE def_type_mesh
5521  USE user_data
5522 #include "petsc/finclude/petsc.h"
5523  USE petsc
5524  IMPLICIT NONE
5525  TYPE(mesh_type), INTENT(IN) :: mesh
5526  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
5527  INTEGER, DIMENSION(:), INTENT(IN) :: Dirichlet_bdy_H_sides
5528  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
5529  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: H_in
5530  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_in
5531  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: sigma_np
5532  REAL(KIND=8), DIMENSION(mesh%me),INTENT(IN) :: sigma
5533  REAL(KIND=8), DIMENSION(:,:,:) :: V_out
5534  REAL(KIND=8), DIMENSION(mesh%gauss%l_Gs*SIZE(Dirichlet_bdy_H_sides),6,SIZE(list_mode)) :: H_gauss, RotH
5535  REAL(KIND=8), DIMENSION(mesh%gauss%l_Gs*SIZE(Dirichlet_bdy_H_sides),6,SIZE(list_mode)) :: RotH_bar
5536  REAL(KIND=8), DIMENSION(mesh%gauss%l_Gs*SIZE(Dirichlet_bdy_H_sides),2,SIZE(list_mode)) :: one_over_sigma_gauss
5537  REAL(KIND=8), DIMENSION(mesh%gauss%k_d,mesh%gauss%n_w) :: dw_loc
5538  INTEGER :: ms, ls , i, mode, index, k
5539  INTEGER, DIMENSION(mesh%gauss%n_ws) :: j_loc
5540  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,6) :: H_in_loc
5541  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,2) :: one_over_sigma_in_loc
5542  REAL(KIND=8) :: ray
5543  INTEGER :: nb_procs, bloc_size, m_max_pad, code, count, m1
5544  mpi_comm :: communicator
5545 
5546  DO i = 1, SIZE(list_mode)
5547  mode = list_mode(i)
5548  index = 0
5549  DO count = 1, SIZE(dirichlet_bdy_h_sides)
5550  ms = dirichlet_bdy_h_sides(count)
5551  m1 = mesh%neighs(ms)
5552 
5553  j_loc = mesh%jjs(:,ms)
5554  DO k = 1, 6
5555  h_in_loc(:,k) = h_in(j_loc,k,i)
5556  END DO
5557  DO k = 1, 2
5558  one_over_sigma_in_loc(:,k) = one_over_sigma_in(j_loc,k,i)
5559  END DO
5560 
5561  DO ls = 1, mesh%gauss%l_Gs
5562  index = index + 1
5563  dw_loc = mesh%gauss%dw_s(:,:,ls,ms)
5564 
5565  !===Compute radius of Gauss point
5566  ray = sum(mesh%rr(1,mesh%jjs(:,ms))*mesh%gauss%wws(:,ls))
5567 
5568  !-----------------magnetic field on bdy gauss points---------------------------
5569  h_gauss(index,1,i) = sum(h_in_loc(:,1)*mesh%gauss%wws(:,ls))
5570  h_gauss(index,3,i) = sum(h_in_loc(:,3)*mesh%gauss%wws(:,ls))
5571  h_gauss(index,5,i) = sum(h_in_loc(:,5)*mesh%gauss%wws(:,ls))
5572 
5573  h_gauss(index,2,i) = sum(h_in_loc(:,2)*mesh%gauss%wws(:,ls))
5574  h_gauss(index,4,i) = sum(h_in_loc(:,4)*mesh%gauss%wws(:,ls))
5575  h_gauss(index,6,i) = sum(h_in_loc(:,6)*mesh%gauss%wws(:,ls))
5576  !-----------------Curl of H on bdy gauss points--------------------------------
5577  !coeff sur les cosinus
5578  roth(index,1,i) = mode/ray*h_gauss(index,6,i) &
5579  -sum(h_in(mesh%jj(:,m1),3,i)*dw_loc(2,:))
5580 
5581  roth(index,4,i) = sum(h_in(mesh%jj(:,m1),2,i)*dw_loc(2,:)) &
5582  -sum(h_in(mesh%jj(:,m1),6,i)*dw_loc(1,:))
5583 
5584  roth(index,5,i) = 1/ray*h_gauss(index,3,i) &
5585  +sum(h_in(mesh%jj(:,m1),3,i)*dw_loc(1,:)) &
5586  -mode/ray*h_gauss(index,2,i)
5587 
5588  !coeff sur les sinus
5589  roth(index,2,i) =-mode/ray*h_gauss(index,5,i) &
5590  -sum(h_in(mesh%jj(:,m1),4,i)*dw_loc(2,:))
5591 
5592  roth(index,3,i) = sum(h_in(mesh%jj(:,m1),1,i)*dw_loc(2,:)) &
5593  -sum(h_in(mesh%jj(:,m1),5,i)*dw_loc(1,:))
5594 
5595  roth(index,6,i) = 1/ray*h_gauss(index,4,i) &
5596  +sum(h_in(mesh%jj(:,m1),4,i)*dw_loc(1,:))&
5597  +mode/ray*h_gauss(index,1,i)
5598  !-----------------one over sigma and RotH_bar on bdy gauss points--------------
5599  IF (jj_v_to_h(mesh%jj(1,m1)) == -1) THEN
5600  one_over_sigma_gauss(index,1,i) = 0.d0
5601  one_over_sigma_gauss(index,2,i) = 0.d0
5602  IF (mode==0) THEN
5603  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m1)
5604  END IF
5605  DO k = 1, 6
5606  roth_bar(index,k,i) = roth(index,k,i)/sigma(m1)
5607  END DO
5608  ELSE
5609  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc(:,1)*mesh%gauss%wws(:,ls))
5610  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc(:,2)*mesh%gauss%wws(:,ls))
5611  DO k = 1, 6
5612  roth_bar(index,k,i) = roth(index,k,i)/sum(sigma_np(mesh%jjs(:,ms))*mesh%gauss%wws(:,ls))
5613  END DO
5614  END IF
5615  END DO
5616  END DO
5617  END DO
5618 
5619  IF ( SIZE(dirichlet_bdy_h_sides).GE.1) THEN
5620  CALL mpi_comm_size(communicator, nb_procs, code)
5621  bloc_size = SIZE(one_over_sigma_gauss,1)/nb_procs+1
5622  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
5623  CALL fft_scalar_vect_no_overshoot(communicator, 1.d0/(inputs%sigma_fluid*inputs%Rem), &
5624  roth, one_over_sigma_gauss, v_out, 1, nb_procs, bloc_size, m_max_pad)
5625 
5626  v_out = roth_bar - v_out
5627  END IF
5628 
5629  END SUBROUTINE smb_sigma_prod_curl_bdy
5630 
5631  SUBROUTINE smb_sigma_prod_curl_inter_mu(communicator, mesh, jj_v_to_H, interface_H_mu, list_mode, &
5632  h_in, one_over_sigma_in, sigma_np, sigma, v_out)
5633  !=================================
5634  USE sft_parallele
5635  USE chaine_caractere
5636  USE input_data
5637  USE def_type_mesh
5638  USE user_data
5639 #include "petsc/finclude/petsc.h"
5640  USE petsc
5641  IMPLICIT NONE
5642  TYPE(mesh_type), INTENT(IN) :: mesh
5643  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
5644  TYPE(interface_type), INTENT(IN) :: interface_H_mu
5645  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
5646  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: H_in
5647  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_in
5648  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: sigma_np
5649  REAL(KIND=8), DIMENSION(mesh%me),INTENT(IN) :: sigma
5650  REAL(KIND=8), DIMENSION(:,:,:) :: V_out
5651  REAL(KIND=8), DIMENSION(2*mesh%gauss%l_Gs*interface_H_mu%mes,6,SIZE(list_mode)) :: H_gauss, RotH
5652  REAL(KIND=8), DIMENSION(2*mesh%gauss%l_Gs*interface_H_mu%mes,6,SIZE(list_mode)) :: RotH_bar
5653  REAL(KIND=8), DIMENSION(2*mesh%gauss%l_Gs*interface_H_mu%mes,2,SIZE(list_mode)) :: one_over_sigma_gauss
5654  REAL(KIND=8), DIMENSION(mesh%gauss%k_d,mesh%gauss%n_w) :: dw_loc
5655  INTEGER :: ms, ls , i, mode, index, k
5656  INTEGER, DIMENSION(mesh%gauss%n_ws) :: j_loc1, j_loc2
5657  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,6) :: H_in_loc1, H_in_loc2
5658  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,2) :: one_over_sigma_in_loc1, one_over_sigma_in_loc2
5659  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,mesh%gauss%l_Gs) :: w_cs
5660  REAL(KIND=8) :: ray, diff, ref
5661  INTEGER :: nb_procs, bloc_size, m_max_pad, code
5662  INTEGER :: ms1, ms2, m1, m2, mesh_id1, mesh_id2
5663  mpi_comm :: communicator
5664 
5665  DO ms = 1, interface_h_mu%mes
5666  ms1 = interface_h_mu%mesh1(ms)
5667  ms2 = interface_h_mu%mesh2(ms)
5668  m1 = mesh%neighs(ms1)
5669  m2 = mesh%neighs(ms2)
5670  ref = 1.d-8+sum((mesh%rr(:,mesh%jjs(1,ms1)) - mesh%rr(:,mesh%jjs(2,ms1)))**2)
5671  diff = sum((mesh%rr(:,mesh%jjs(1,ms1)) - mesh%rr(:,mesh%jjs(1,ms2)))**2)
5672  IF (diff/ref .LT. 1.d-10) THEN ! 1 = 1
5673  w_cs = mesh%gauss%wws
5674  ELSE ! 1 = 2
5675  DO ls = 1, mesh%gauss%l_Gs
5676  w_cs(1,ls)= mesh%gauss%wws(2,ls)
5677  w_cs(2,ls)= mesh%gauss%wws(1,ls)
5678  IF (mesh%gauss%n_ws==3) w_cs(mesh%gauss%n_ws,ls) = mesh%gauss%wws(mesh%gauss%n_ws,ls)
5679  WRITE(*,*) ' Ouaps! oder of shape functions changed?'
5680  END DO
5681  END IF
5682  END DO
5683 
5684  DO i = 1, SIZE(list_mode)
5685  mode = list_mode(i)
5686  index = 0
5687  DO ms = 1, interface_h_mu%mes
5688  ms2 = interface_h_mu%mesh2(ms)
5689  ms1 = interface_h_mu%mesh1(ms)
5690  m2 = mesh%neighs(ms2)
5691  m1 = mesh%neighs(ms1)
5692  mesh_id1 = mesh%i_d(m1)
5693  mesh_id2 = mesh%i_d(m2)
5694  j_loc1 = mesh%jjs(:,ms1)
5695  j_loc2 = mesh%jjs(:,ms2)
5696  DO k = 1, 6
5697  h_in_loc1(:,k) = h_in(j_loc1,k,i)
5698  h_in_loc2(:,k) = h_in(j_loc2,k,i)
5699  END DO
5700  DO k = 1, 2
5701  one_over_sigma_in_loc1(:,k) = one_over_sigma_in(j_loc1,k,i)
5702  one_over_sigma_in_loc2(:,k) = one_over_sigma_in(j_loc2,k,i)
5703  END DO
5704 
5705  DO ls = 1, mesh%gauss%l_Gs
5706  !===Side 1
5707  index = index + 1
5708  dw_loc = mesh%gauss%dw_s(:,:,ls,ms1)
5709  !Compute radius of Gauss point
5710  ray = sum(mesh%rr(1,mesh%jjs(:,ms1))*w_cs(:,ls))
5711  !-----------------magnetic field on bdy gauss points---------------------------
5712  h_gauss(index,1,i) = sum(h_in_loc1(:,1)*w_cs(:,ls))
5713  h_gauss(index,3,i) = sum(h_in_loc1(:,3)*w_cs(:,ls))
5714  h_gauss(index,5,i) = sum(h_in_loc1(:,5)*w_cs(:,ls))
5715  h_gauss(index,2,i) = sum(h_in_loc1(:,2)*w_cs(:,ls))
5716  h_gauss(index,4,i) = sum(h_in_loc1(:,4)*w_cs(:,ls))
5717  h_gauss(index,6,i) = sum(h_in_loc1(:,6)*w_cs(:,ls))
5718  !-----------------Curl of H on bdy gauss points--------------------------------
5719  !coeff sur les cosinus
5720  roth(index,1,i) = mode/ray*h_gauss(index,6,i) &
5721  -sum(h_in(mesh%jj(:,m1),3,i)*dw_loc(2,:))
5722  roth(index,4,i) = sum(h_in(mesh%jj(:,m1),2,i)*dw_loc(2,:)) &
5723  -sum(h_in(mesh%jj(:,m1),6,i)*dw_loc(1,:))
5724  roth(index,5,i) = 1/ray*h_gauss(index,3,i) &
5725  +sum(h_in(mesh%jj(:,m1),3,i)*dw_loc(1,:)) &
5726  -mode/ray*h_gauss(index,2,i)
5727  !coeff sur les sinus
5728  roth(index,2,i) =-mode/ray*h_gauss(index,5,i) &
5729  -sum(h_in(mesh%jj(:,m1),4,i)*dw_loc(2,:))
5730  roth(index,3,i) = sum(h_in(mesh%jj(:,m1),1,i)*dw_loc(2,:)) &
5731  -sum(h_in(mesh%jj(:,m1),5,i)*dw_loc(1,:))
5732  roth(index,6,i) = 1/ray*h_gauss(index,4,i) &
5733  +sum(h_in(mesh%jj(:,m1),4,i)*dw_loc(1,:))&
5734  +mode/ray*h_gauss(index,1,i)
5735  !-----------------one over sigma and RotH_bar on bdy gauss points--------------
5736  IF (jj_v_to_h(mesh%jj(1,m1)) == -1) THEN
5737  one_over_sigma_gauss(index,1,i) = 0.d0
5738  one_over_sigma_gauss(index,2,i) = 0.d0
5739  IF (mode==0) THEN
5740  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m1)
5741  END IF
5742  DO k = 1, 6
5743  roth_bar(index,k,i) = roth(index,k,i)/sigma(m1)
5744  END DO
5745  ELSE
5746  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc1(:,1)*w_cs(:,ls))
5747  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc1(:,2)*w_cs(:,ls))
5748  DO k = 1, 6
5749  roth_bar(index,k,i) = roth(index,k,i)/sum(sigma_np(mesh%jjs(:,ms1))*w_cs(:,ls))
5750  END DO
5751  END IF
5752 
5753  !===Side 2
5754  index = index + 1
5755  dw_loc = mesh%gauss%dw_s(:,:,ls,ms2)
5756  !Compute radius of Gauss point
5757  ray = sum(mesh%rr(1,mesh%jjs(:,ms2))*mesh%gauss%wws(:,ls))
5758  !-----------------magnetic field on bdy gauss points---------------------------
5759  h_gauss(index,1,i) = sum(h_in_loc2(:,1)*mesh%gauss%wws(:,ls))
5760  h_gauss(index,3,i) = sum(h_in_loc2(:,3)*mesh%gauss%wws(:,ls))
5761  h_gauss(index,5,i) = sum(h_in_loc2(:,5)*mesh%gauss%wws(:,ls))
5762  h_gauss(index,2,i) = sum(h_in_loc2(:,2)*mesh%gauss%wws(:,ls))
5763  h_gauss(index,4,i) = sum(h_in_loc2(:,4)*mesh%gauss%wws(:,ls))
5764  h_gauss(index,6,i) = sum(h_in_loc2(:,6)*mesh%gauss%wws(:,ls))
5765  !-----------------Curl of H on bdy gauss points--------------------------------
5766  !coeff sur les cosinus
5767  roth(index,1,i) = mode/ray*h_gauss(index,6,i) &
5768  -sum(h_in(mesh%jj(:,m2),3,i)*dw_loc(2,:))
5769  roth(index,4,i) = sum(h_in(mesh%jj(:,m2),2,i)*dw_loc(2,:)) &
5770  -sum(h_in(mesh%jj(:,m2),6,i)*dw_loc(1,:))
5771  roth(index,5,i) = 1/ray*h_gauss(index,3,i) &
5772  +sum(h_in(mesh%jj(:,m2),3,i)*dw_loc(1,:)) &
5773  -mode/ray*h_gauss(index,2,i)
5774  !coeff sur les sinus
5775  roth(index,2,i) =-mode/ray*h_gauss(index,5,i) &
5776  -sum(h_in(mesh%jj(:,m2),4,i)*dw_loc(2,:))
5777  roth(index,3,i) = sum(h_in(mesh%jj(:,m2),1,i)*dw_loc(2,:)) &
5778  -sum(h_in(mesh%jj(:,m2),5,i)*dw_loc(1,:))
5779  roth(index,6,i) = 1/ray*h_gauss(index,4,i) &
5780  +sum(h_in(mesh%jj(:,m2),4,i)*dw_loc(1,:))&
5781  +mode/ray*h_gauss(index,1,i)
5782  !-----------------one over sigma and RotH_bar on bdy gauss points--------------
5783  IF (jj_v_to_h(mesh%jj(1,m2)) == -1) THEN
5784  one_over_sigma_gauss(index,1,i) = 0.d0
5785  one_over_sigma_gauss(index,2,i) = 0.d0
5786  IF (mode==0) THEN
5787  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m2)
5788  END IF
5789  DO k = 1, 6
5790  roth_bar(index,k,i) = roth(index,k,i)/sigma(m2)
5791  END DO
5792  ELSE
5793  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc2(:,1)*mesh%gauss%wws(:,ls))
5794  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc2(:,2)*mesh%gauss%wws(:,ls))
5795  DO k = 1, 6
5796  roth_bar(index,k,i) = roth(index,k,i)/sum(sigma_np(mesh%jjs(:,ms2))*mesh%gauss%wws(:,ls))
5797  END DO
5798  END IF
5799  END DO
5800  END DO
5801  END DO
5802 
5803  IF (interface_h_mu%mes.GE.1) THEN
5804  CALL mpi_comm_size(communicator, nb_procs, code)
5805  bloc_size = SIZE(one_over_sigma_gauss,1)/nb_procs+1
5806  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
5807  CALL fft_scalar_vect_no_overshoot(communicator, 1.d0/(inputs%sigma_fluid*inputs%Rem), &
5808  roth, one_over_sigma_gauss, v_out, 1, nb_procs, bloc_size, m_max_pad)
5809 
5810  v_out = roth_bar - v_out
5811  END IF
5812 
5813  END SUBROUTINE smb_sigma_prod_curl_inter_mu
5814 
5815  SUBROUTINE smb_current_over_sigma(communicator, mesh, jj_v_to_H, list_mode, B_in, &
5816  mu_h_field, mu_phi, one_over_sigma_tot, time, sigma, j_over_sigma_gauss)
5817  USE sft_parallele
5818  USE chaine_caractere
5819  USE input_data
5820  USE def_type_mesh
5821  USE boundary
5822 #include "petsc/finclude/petsc.h"
5823  USE petsc
5824  IMPLICIT NONE
5825  TYPE(mesh_type), INTENT(IN) :: mesh
5826  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
5827  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
5828  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: B_in
5829  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_tot
5830  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
5831  REAL(KIND=8), INTENT(IN) :: mu_phi, time
5832  REAL(KIND=8), DIMENSION(mesh%me),INTENT(IN) :: sigma
5833  REAL(KIND=8), DIMENSION(:,:,:), INTENT(OUT) :: J_over_sigma_gauss
5834  REAL(KIND=8), DIMENSION(mesh%me*mesh%gauss%l_G,6,SIZE(list_mode)) :: J_exact_gauss
5835  REAL(KIND=8), DIMENSION(mesh%me*mesh%gauss%l_G,2,SIZE(list_mode)) :: one_over_sigma_gauss
5836  INTEGER, DIMENSION(mesh%gauss%n_w) :: j_loc
5837  REAL(KIND=8), DIMENSION(mesh%gauss%n_w,6) :: B_in_loc
5838  REAL(KIND=8), DIMENSION(mesh%gauss%n_w,2) :: one_over_sigma_in_loc
5839  REAL(KIND=8), DIMENSION(6) :: B_ext_l
5840  REAL(KIND=8) :: muhl, ray
5841  REAL(KIND=8), DIMENSION(2) :: gaussp
5842  INTEGER :: mode, mesh_id1, k, i, index, l, m, ni
5843  INTEGER :: nb_procs, bloc_size, m_max_pad, code
5844  mpi_comm :: communicator
5845 
5846  DO i = 1, SIZE(list_mode)
5847  mode = list_mode(i)
5848  index = 0
5849  DO m = 1, mesh%me
5850  mesh_id1 = mesh%i_d(m)
5851  j_loc = mesh%jj(:,m)
5852  DO k = 1, 6
5853  b_in_loc(:,k) = b_in(j_loc,k,i)
5854  END DO
5855  DO k = 1, 2
5856  one_over_sigma_in_loc(:,k) = one_over_sigma_tot(j_loc,k,i)
5857  END DO
5858  DO l = 1, mesh%gauss%l_G
5859  index = index + 1
5860 
5861  !===Compute radius of Gauss point
5862  ray = sum(mesh%rr(1,j_loc)*mesh%gauss%ww(:,l))
5863 
5864  !-----------------Variable for Jexact on gauss points----------------------
5865  b_ext_l(1) = sum(b_in_loc(:,1)*mesh%gauss%ww(:,l))
5866  b_ext_l(3) = sum(b_in_loc(:,3)*mesh%gauss%ww(:,l))
5867  b_ext_l(5) = sum(b_in_loc(:,5)*mesh%gauss%ww(:,l))
5868  b_ext_l(2) = sum(b_in_loc(:,2)*mesh%gauss%ww(:,l))
5869  b_ext_l(4) = sum(b_in_loc(:,4)*mesh%gauss%ww(:,l))
5870  b_ext_l(6) = sum(b_in_loc(:,6)*mesh%gauss%ww(:,l))
5871  gaussp = 0.d0
5872  DO ni = 1, mesh%gauss%n_w
5873  gaussp = gaussp + mesh%rr(:,mesh%jj(ni,m))*mesh%gauss%ww(ni,l)
5874  ENDDO
5875  muhl=sum(mu_h_field(mesh%jj(:,m))*mesh%gauss%ww(:,l))
5876  !-----------------J_exact on gauss points----------------------------------
5877  DO k = 1, 6
5878  j_exact_gauss(index,k,i)=jexact_gauss(k, gaussp, mode, mu_phi, sigma(m), &
5879  muhl, time, mesh_id1, b_ext_l)
5880  END DO
5881  !-----------------one over sigma on gauss points---------------------------
5882  IF (jj_v_to_h(mesh%jj(1,m)) == -1) THEN
5883  one_over_sigma_gauss(index,1,i) = 0.d0
5884  one_over_sigma_gauss(index,2,i) = 0.d0
5885  IF (mode==0) THEN
5886  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m)
5887  END IF
5888  ELSE
5889  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc(:,1)*mesh%gauss%ww(:,l))
5890  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc(:,2)*mesh%gauss%ww(:,l))
5891  END IF
5892 
5893  ENDDO
5894  ENDDO
5895  END DO
5896 
5897  CALL mpi_comm_size(communicator, nb_procs, code)
5898  bloc_size = SIZE(j_exact_gauss,1)/nb_procs+1
5899  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
5900  CALL fft_scalar_vect_no_overshoot(communicator, 1.d0/(inputs%sigma_fluid*inputs%Rem), &
5901  j_exact_gauss, one_over_sigma_gauss, j_over_sigma_gauss,&
5902  1, nb_procs, bloc_size, m_max_pad)
5903 
5904  END SUBROUTINE smb_current_over_sigma
5905 
5906  SUBROUTINE smb_current_over_sigma_bdy(communicator, mesh, jj_v_to_H, Dirichlet_bdy_H_sides, list_mode, B_in, &
5907  mu_h_field, mu_phi, one_over_sigma_tot, time, sigma, j_over_sigma_gauss)
5908  USE sft_parallele
5909  USE chaine_caractere
5910  USE input_data
5911  USE def_type_mesh
5912  USE boundary
5913 #include "petsc/finclude/petsc.h"
5914  USE petsc
5915  IMPLICIT NONE
5916  TYPE(mesh_type), INTENT(IN) :: mesh
5917  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
5918  INTEGER, DIMENSION(:), INTENT(IN) :: Dirichlet_bdy_H_sides
5919  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
5920  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: B_in
5921  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_tot
5922  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
5923  REAL(KIND=8), INTENT(IN) :: mu_phi, time
5924  REAL(KIND=8), DIMENSION(mesh%me),INTENT(IN) :: sigma
5925  REAL(KIND=8), DIMENSION(:,:,:), INTENT(OUT) :: J_over_sigma_gauss
5926  REAL(KIND=8), DIMENSION(SIZE(Dirichlet_bdy_H_sides)*mesh%gauss%l_Gs,6,SIZE(list_mode)) :: J_exact_gauss
5927  REAL(KIND=8), DIMENSION(SIZE(Dirichlet_bdy_H_sides)*mesh%gauss%l_Gs,2,SIZE(list_mode)) :: one_over_sigma_gauss
5928  INTEGER, DIMENSION(mesh%gauss%n_ws) :: j_loc
5929  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,6) :: B_in_loc
5930  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,2) :: one_over_sigma_in_loc
5931  REAL(KIND=8), DIMENSION(6) :: B_ext_l
5932  REAL(KIND=8) :: muhl, ray
5933  REAL(KIND=8), DIMENSION(2) :: gaussp
5934  INTEGER :: mode, mesh_id1, k, i, count, index, ls, ms, ni
5935  INTEGER :: nb_procs, bloc_size, m_max_pad, code, m1
5936  mpi_comm :: communicator
5937 
5938  DO i = 1, SIZE(list_mode)
5939  mode = list_mode(i)
5940  index = 0
5941  DO count = 1, SIZE(dirichlet_bdy_h_sides)
5942  ms = dirichlet_bdy_h_sides(count)
5943  m1 = mesh%neighs(ms)
5944  mesh_id1 = mesh%i_d(m1)
5945  j_loc = mesh%jjs(:,ms)
5946  DO k = 1, 6
5947  b_in_loc(:,k) = b_in(j_loc,k,i)
5948  END DO
5949  DO k = 1, 2
5950  one_over_sigma_in_loc(:,k) = one_over_sigma_tot(j_loc,k,i)
5951  END DO
5952 
5953  DO ls = 1, mesh%gauss%l_Gs
5954  index = index + 1
5955 
5956  !===Compute radius of Gauss point
5957  ray = sum(mesh%rr(1,mesh%jjs(:,ms))*mesh%gauss%wws(:,ls))
5958 
5959  !-----------------Variable for Jexact on gauss points----------------------
5960  b_ext_l(1) = sum(b_in_loc(:,1)*mesh%gauss%wws(:,ls))
5961  b_ext_l(3) = sum(b_in_loc(:,3)*mesh%gauss%wws(:,ls))
5962  b_ext_l(5) = sum(b_in_loc(:,5)*mesh%gauss%wws(:,ls))
5963  b_ext_l(2) = sum(b_in_loc(:,2)*mesh%gauss%wws(:,ls))
5964  b_ext_l(4) = sum(b_in_loc(:,4)*mesh%gauss%wws(:,ls))
5965  b_ext_l(6) = sum(b_in_loc(:,6)*mesh%gauss%wws(:,ls))
5966  gaussp = 0.d0
5967  DO ni = 1, mesh%gauss%n_ws
5968  gaussp = gaussp + mesh%rr(:,mesh%jjs(ni,ms))*mesh%gauss%wws(ni,ls)
5969  ENDDO
5970  muhl=sum(mu_h_field(mesh%jjs(:,ms))*mesh%gauss%wws(:,ls))
5971  !-----------------J_exact on gauss points----------------------------------
5972  DO k = 1, 6
5973  j_exact_gauss(index,k,i)=jexact_gauss(k, gaussp, mode, mu_phi, sigma(m1),&
5974  muhl, time, mesh_id1, b_ext_l)
5975  END DO
5976  !-----------------one over sigma on gauss points---------------------------
5977  IF (jj_v_to_h(mesh%jj(1,m1)) == -1) THEN
5978  one_over_sigma_gauss(index,1,i) = 0.d0
5979  one_over_sigma_gauss(index,2,i) = 0.d0
5980  IF (mode==0) THEN
5981  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m1)
5982  END IF
5983  ELSE
5984  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc(:,1)*mesh%gauss%wws(:,ls))
5985  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc(:,2)*mesh%gauss%wws(:,ls))
5986  END IF
5987  END DO
5988  END DO
5989  END DO
5990 
5991  IF ( SIZE(dirichlet_bdy_h_sides).GE.1) THEN
5992  CALL mpi_comm_size(communicator, nb_procs, code)
5993  bloc_size = SIZE(j_exact_gauss,1)/nb_procs+1
5994  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
5995  CALL fft_scalar_vect_no_overshoot(communicator, 1.d0/(inputs%sigma_fluid*inputs%Rem), &
5996  j_exact_gauss, one_over_sigma_gauss, j_over_sigma_gauss,&
5997  1, nb_procs, bloc_size, m_max_pad)
5998  END IF
5999 
6000  END SUBROUTINE smb_current_over_sigma_bdy
6001 
6002  SUBROUTINE smb_current_over_sigma_inter_mu(communicator, mesh, jj_v_to_H, interface_H_mu, list_mode, B_in, &
6003  mu_h_field, mu_phi, one_over_sigma_tot, time, sigma, j_over_sigma_gauss)
6004  USE sft_parallele
6005  USE chaine_caractere
6006  USE input_data
6007  USE def_type_mesh
6008  USE boundary
6009 #include "petsc/finclude/petsc.h"
6010  USE petsc
6011  IMPLICIT NONE
6012  TYPE(mesh_type), INTENT(IN) :: mesh
6013  INTEGER, DIMENSION(:) , INTENT(IN) :: jj_v_to_H
6014  TYPE(interface_type), INTENT(IN) :: interface_H_mu
6015  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
6016  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: B_in
6017  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_tot
6018  REAL(KIND=8), DIMENSION(:), INTENT(IN) :: mu_H_field
6019  REAL(KIND=8), INTENT(IN) :: mu_phi, time
6020  REAL(KIND=8), DIMENSION(mesh%me),INTENT(IN) :: sigma
6021  REAL(KIND=8), DIMENSION(:,:,:), INTENT(OUT) :: J_over_sigma_gauss
6022  REAL(KIND=8), DIMENSION(2*interface_H_mu%mes*mesh%gauss%l_Gs,6,SIZE(list_mode)) :: J_exact_gauss
6023  REAL(KIND=8), DIMENSION(2*interface_H_mu%mes*mesh%gauss%l_Gs,2,SIZE(list_mode)) :: one_over_sigma_gauss
6024  REAL(KIND=8), DIMENSION(6) :: B_ext_l
6025  REAL(KIND=8) :: muhl, diff, ref, ray
6026  REAL(KIND=8), DIMENSION(2) :: gaussp
6027  INTEGER :: mode, k, i, mesh_id1, mesh_id2, ni
6028  INTEGER :: nb_procs, bloc_size, m_max_pad, code
6029  INTEGER :: ms, ms1, ms2, m1, m2, ls, index
6030  INTEGER, DIMENSION(mesh%gauss%n_ws) :: j_loc1, j_loc2
6031  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,6) :: B_in_loc1, B_in_loc2
6032  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,2) :: one_over_sigma_in_loc1,one_over_sigma_in_loc2
6033  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,mesh%gauss%l_Gs) :: w_cs
6034  mpi_comm :: communicator
6035 
6036 
6037  DO ms = 1, interface_h_mu%mes
6038  ms1 = interface_h_mu%mesh1(ms)
6039  ms2 = interface_h_mu%mesh2(ms)
6040  m1 = mesh%neighs(ms1)
6041  m2 = mesh%neighs(ms2)
6042  ref = 1.d-8+sum((mesh%rr(:,mesh%jjs(1,ms1)) - mesh%rr(:,mesh%jjs(2,ms1)))**2)
6043  diff = sum((mesh%rr(:,mesh%jjs(1,ms1)) - mesh%rr(:,mesh%jjs(1,ms2)))**2)
6044  IF (diff/ref .LT. 1.d-10) THEN ! 1 = 1
6045  w_cs = mesh%gauss%wws
6046  ELSE ! 1 = 2
6047  DO ls = 1, mesh%gauss%l_Gs
6048  w_cs(1,ls)= mesh%gauss%wws(2,ls)
6049  w_cs(2,ls)= mesh%gauss%wws(1,ls)
6050  IF (mesh%gauss%n_ws==3) w_cs(mesh%gauss%n_ws,ls) = mesh%gauss%wws(mesh%gauss%n_ws,ls)
6051  WRITE(*,*) ' Ouaps! oder of shape functions changed?'
6052  END DO
6053  END IF
6054  END DO
6055 
6056  DO i = 1, SIZE(list_mode)
6057  mode = list_mode(i)
6058  index = 0
6059  DO ms = 1, interface_h_mu%mes
6060  ms2 = interface_h_mu%mesh2(ms)
6061  ms1 = interface_h_mu%mesh1(ms)
6062  m2 = mesh%neighs(ms2)
6063  m1 = mesh%neighs(ms1)
6064  mesh_id1 = mesh%i_d(m1)
6065  mesh_id2 = mesh%i_d(m2)
6066  j_loc1 = mesh%jjs(:,ms1)
6067  j_loc2 = mesh%jjs(:,ms2)
6068  DO k = 1, 6
6069  b_in_loc1(:,k) = b_in(j_loc1,k,i)
6070  b_in_loc2(:,k) = b_in(j_loc2,k,i)
6071  END DO
6072  DO k = 1, 2
6073  one_over_sigma_in_loc1(:,k) = one_over_sigma_tot(j_loc1,k,i)
6074  one_over_sigma_in_loc2(:,k) = one_over_sigma_tot(j_loc2,k,i)
6075  END DO
6076 
6077  DO ls = 1, mesh%gauss%l_Gs
6078  !===Side 1
6079  index = index + 1
6080  !Compute radius of Gauss point
6081  ray = sum(mesh%rr(1,mesh%jjs(:,ms1))*w_cs(:,ls))
6082  !-----------------Variable for Jexact on gauss points----------------------
6083  b_ext_l(1) = sum(b_in_loc1(:,1)*w_cs(:,ls))
6084  b_ext_l(3) = sum(b_in_loc1(:,3)*w_cs(:,ls))
6085  b_ext_l(5) = sum(b_in_loc1(:,5)*w_cs(:,ls))
6086  b_ext_l(2) = sum(b_in_loc1(:,2)*w_cs(:,ls))
6087  b_ext_l(4) = sum(b_in_loc1(:,4)*w_cs(:,ls))
6088  b_ext_l(6) = sum(b_in_loc1(:,6)*w_cs(:,ls))
6089  gaussp = 0.d0
6090  DO ni = 1, mesh%gauss%n_ws
6091  gaussp = gaussp + mesh%rr(:,mesh%jjs(ni,ms1))*w_cs(ni,ls)
6092  ENDDO
6093  muhl=sum(mu_h_field(mesh%jjs(:,ms1))*w_cs(:,ls))
6094  !-----------------J_exact on gauss points----------------------------------
6095  DO k = 1, 6
6096  j_exact_gauss(index,k,i)=jexact_gauss(k, gaussp, mode, mu_phi, sigma(m1),&
6097  muhl, time, mesh_id1, b_ext_l)
6098  END DO
6099  !-----------------one over sigma on gauss points---------------------------
6100  IF (jj_v_to_h(mesh%jj(1,m1)) == -1) THEN
6101  one_over_sigma_gauss(index,1,i) = 0.d0
6102  one_over_sigma_gauss(index,2,i) = 0.d0
6103  IF (mode==0) THEN
6104  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m1)
6105  END IF
6106  ELSE
6107  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc1(:,1)*w_cs(:,ls))
6108  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc1(:,2)*w_cs(:,ls))
6109  END IF
6110 
6111  !===Side 2
6112  index = index + 1
6113  !Compute radius of Gauss point
6114  ray = sum(mesh%rr(1,mesh%jjs(:,ms2))*mesh%gauss%wws(:,ls))
6115  !-----------------Variable for Jexact on gauss points----------------------
6116  b_ext_l(1) = sum(b_in_loc2(:,1)*mesh%gauss%wws(:,ls))
6117  b_ext_l(3) = sum(b_in_loc2(:,3)*mesh%gauss%wws(:,ls))
6118  b_ext_l(5) = sum(b_in_loc2(:,5)*mesh%gauss%wws(:,ls))
6119  b_ext_l(2) = sum(b_in_loc2(:,2)*mesh%gauss%wws(:,ls))
6120  b_ext_l(4) = sum(b_in_loc2(:,4)*mesh%gauss%wws(:,ls))
6121  b_ext_l(6) = sum(b_in_loc2(:,6)*mesh%gauss%wws(:,ls))
6122  gaussp = 0.d0
6123  DO ni = 1, mesh%gauss%n_ws
6124  gaussp = gaussp + mesh%rr(:,mesh%jjs(ni,ms2))*mesh%gauss%wws(ni,ls)
6125  ENDDO
6126  muhl=sum(mu_h_field(mesh%jjs(:,ms2))*mesh%gauss%wws(:,ls))
6127  !-----------------J_exact on gauss points----------------------------------
6128  DO k = 1, 6
6129  j_exact_gauss(index,k,i)=jexact_gauss(k, gaussp, mode, mu_phi, sigma(m2),&
6130  muhl, time, mesh_id2, b_ext_l)
6131  END DO
6132  !-----------------one over sigma on gauss points---------------------------
6133  IF (jj_v_to_h(mesh%jj(1,m2)) == -1) THEN
6134  one_over_sigma_gauss(index,1,i) = 0.d0
6135  one_over_sigma_gauss(index,2,i) = 0.d0
6136  IF (mode==0) THEN
6137  one_over_sigma_gauss(index,1,i) = 1.d0/sigma(m2)
6138  END IF
6139  ELSE
6140  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc2(:,1)*mesh%gauss%wws(:,ls))
6141  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc2(:,2)*mesh%gauss%wws(:,ls))
6142  END IF
6143  END DO
6144  END DO
6145  END DO
6146 
6147  IF (interface_h_mu%mes.GE.1) THEN
6148  CALL mpi_comm_size(communicator, nb_procs, code)
6149  bloc_size = SIZE(j_exact_gauss,1)/nb_procs+1
6150  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
6151  CALL fft_scalar_vect_no_overshoot(communicator, 1.d0/(inputs%sigma_fluid*inputs%Rem), &
6152  j_exact_gauss, one_over_sigma_gauss, j_over_sigma_gauss,&
6153  1, nb_procs, bloc_size, m_max_pad)
6154  END IF
6155 
6156  END SUBROUTINE smb_current_over_sigma_inter_mu
6157 
6158  SUBROUTINE smb_sigma_neumann(communicator, mesh, Neumann_bdy_H_sides, list_mode, &
6159  one_over_sigma_tot, sigma_tot_gauss_neumann)
6160  USE sft_parallele
6161  USE chaine_caractere
6162  USE input_data
6163  USE def_type_mesh
6164  USE boundary
6165 #include "petsc/finclude/petsc.h"
6166  USE petsc
6167  IMPLICIT NONE
6168  TYPE(mesh_type), INTENT(IN) :: mesh
6169  INTEGER, DIMENSION(:), INTENT(IN) :: Neumann_bdy_H_sides
6170  INTEGER, DIMENSION(:), INTENT(IN) :: list_mode
6171  REAL(KIND=8), DIMENSION(:,:,:), INTENT(IN) :: one_over_sigma_tot
6172  REAL(KIND=8), DIMENSION(:,:,:), INTENT(OUT) :: sigma_tot_gauss_Neumann
6173  REAL(KIND=8), DIMENSION(SIZE(Neumann_bdy_H_sides)*mesh%gauss%l_Gs,2,SIZE(list_mode)):: one_over_sigma_gauss
6174  INTEGER, DIMENSION(mesh%gauss%n_ws) :: j_loc
6175  REAL(KIND=8), DIMENSION(mesh%gauss%n_ws,2) :: one_over_sigma_in_loc
6176  INTEGER :: mode, k, i, count, index, ls, ms
6177  INTEGER :: nb_procs, bloc_size, m_max_pad, code
6178  mpi_comm :: communicator
6179 
6180  DO i = 1, SIZE(list_mode)
6181  mode = list_mode(i)
6182  index = 0
6183  DO count = 1, SIZE(neumann_bdy_h_sides)
6184  ms = neumann_bdy_h_sides(count)
6185  j_loc = mesh%jjs(:,ms)
6186  DO k = 1, 2
6187  one_over_sigma_in_loc(:,k) = one_over_sigma_tot(j_loc,k,i)
6188  END DO
6189 
6190  DO ls = 1, mesh%gauss%l_Gs
6191  index = index + 1
6192  one_over_sigma_gauss(index,1,i) = sum(one_over_sigma_in_loc(:,1)*mesh%gauss%wws(:,ls))
6193  one_over_sigma_gauss(index,2,i) = sum(one_over_sigma_in_loc(:,2)*mesh%gauss%wws(:,ls))
6194  END DO
6195  END DO
6196  END DO
6197 
6198  sigma_tot_gauss_neumann=one_over_sigma_gauss
6199 
6200  IF ( SIZE(neumann_bdy_h_sides).GE.1) THEN
6201  CALL mpi_comm_size(communicator, nb_procs, code)
6202  bloc_size = SIZE(one_over_sigma_gauss,1)/nb_procs+1
6203  m_max_pad = 3*SIZE(list_mode)*nb_procs/2
6204  CALL fft_par_scal_funct(communicator, sigma_tot_gauss_neumann, one_over_x, nb_procs, bloc_size, m_max_pad)
6205  END IF
6206 
6207  END SUBROUTINE smb_sigma_neumann
6208 
6209 
6210  FUNCTION one_over_x(x) RESULT(vv)
6211  IMPLICIT NONE
6212  REAL(KIND=8) :: x
6213  REAL(KIND=8) :: vv
6214  vv = x/ max(x*x, 1.d-20)
6215  END FUNCTION one_over_x
6216 
6217 END MODULE update_maxwell_with_b
6218 
def_type_mesh::interface_type
Definition: def_type_mesh.f90:116
update_maxwell_with_b::smb_current_over_sigma_inter_mu
subroutine smb_current_over_sigma_inter_mu(communicator, mesh, jj_v_to_H, interface_H_mu, list_mode, B_in, mu_H_field, mu_phi, one_over_sigma_tot, time, sigma, J_over_sigma_gauss)
Definition: maxwell_update_time_with_B.f90:6007
solve_petsc::solver
subroutine solver(my_ksp, b, x, reinit, verbose)
Definition: solver.f90:99
sub_plot
Definition: sub_plot.f90:4
update_maxwell_with_b::dirichlet_cavities
subroutine dirichlet_cavities(communicator, interface_H_phi, mesh, js_D)
Definition: maxwell_update_time_with_B.f90:5270
gauss_points
Definition: associate_gauss.f90:4
update_maxwell_with_b::neumann_bdy_pmag_sides
integer, dimension(:), allocatable neumann_bdy_pmag_sides
Definition: maxwell_update_time_with_B.f90:12
st_matrix::extract
subroutine, public extract(xghost, ks, ke, LA, phi)
Definition: st_csr.f90:34
update_maxwell_with_b
Definition: maxwell_update_time_with_B.f90:6
st_matrix::create_my_ghost
subroutine, public create_my_ghost(mesh, LA, ifrom)
Definition: st_csr.f90:15
sft_parallele::fft_par_var_eta_prod_t_dcl
subroutine, public fft_par_var_eta_prod_t_dcl(communicator, eta, H_mesh, c_in, c_out, nb_procs, bloc_size, m_max_pad, time, temps)
Definition: fft_parallel.f90:1634
gauss_points::l_gs
integer, public l_gs
Definition: associate_gauss.f90:9
gauss_points::n_ws
integer, public n_ws
Definition: associate_gauss.f90:9
def_type_mesh::petsc_csr_la
Definition: def_type_mesh.f90:18
update_maxwell_with_b::minus_one_over_mu
real(kind=8) function, dimension(nb_angles, ne-nb+1) minus_one_over_mu(H_mesh, angles, nb_angles, nb, ne, time)
Definition: maxwell_update_time_with_B.f90:5383
dir_nodes::dirichlet_nodes
subroutine dirichlet_nodes(jjs_in, sides_in, dir_in, js_d)
Definition: dir_nodes.f90:496
dir_nodes_petsc::vector_without_bc_glob_js_d
subroutine vector_without_bc_glob_js_d(vv_mesh, list_mode, vv_3_LA, vv_mode_global_js_D)
Definition: dir_nodes_petsc.f90:243
update_maxwell_with_b::one_over_x
real(kind=8) function one_over_x(x)
Definition: maxwell_update_time_with_B.f90:6214
sft_parallele::fft_scalar_vect_no_overshoot
subroutine, public fft_scalar_vect_no_overshoot(communicator, scalar_bounds, V1_in, V2_in, V_out, pb, nb_procs, bloc_size, m_max_pad, temps)
Definition: fft_parallel.f90:1058
update_maxwell_with_b::neumann_bdy_h_sides
integer, dimension(:), allocatable neumann_bdy_h_sides
Definition: maxwell_update_time_with_B.f90:11
update_maxwell_with_b::smb_sigma_prod_curl_inter_mu
subroutine smb_sigma_prod_curl_inter_mu(communicator, mesh, jj_v_to_H, interface_H_mu, list_mode, H_in, one_over_sigma_in, sigma_np, sigma, V_out)
Definition: maxwell_update_time_with_B.f90:5636
def_type_mesh::mesh_type
Definition: def_type_mesh.f90:74
sft_parallele::fft_par_scal_funct
subroutine, public fft_par_scal_funct(communicator, c1_inout, funct, nb_procs, bloc_size, m_max_pad, temps)
Definition: fft_parallel.f90:4136
my_util
Definition: my_util.f90:1
st_matrix
Definition: st_csr.f90:4
gauss_points::rnorms
real(kind=8), dimension(:,:,:), pointer rnorms
Definition: associate_gauss.f90:13
update_maxwell_with_b::courant_mu
subroutine courant_mu(H_mesh, interface_H_mu, sigma, mu_H_field, time, mode, nl, LA_H, vb_1, vb_2, B_ext, J_over_sigma_gauss, sigma_curl_gauss)
Definition: maxwell_update_time_with_B.f90:4926
solve_petsc::create_local_petsc_matrix
subroutine create_local_petsc_matrix(communicator, LA, matrix, clean)
Definition: solver.f90:147
my_util::error_petsc
subroutine error_petsc(string)
Definition: my_util.f90:16
input_data::inputs
type(my_data), public inputs
Definition: read_my_data.f90:237
my_util::user_time
real(kind=8) function user_time()
Definition: my_util.f90:8
sft_parallele::fft_par_cross_prod_dcl
subroutine, public fft_par_cross_prod_dcl(communicator, V1_in, V2_in, V_out, nb_procs, bloc_size, m_max_pad, temps)
Definition: fft_parallel.f90:147
update_maxwell_with_b::mat_dirichlet_maxwell
subroutine mat_dirichlet_maxwell(H_mesh, jj_v_to_H, Dirichlet_bdy_H_sides, mode, stab, mu_H_field, LA_H, H_p_phi_mat1, H_p_phi_mat2, sigma_np, sigma)
Definition: maxwell_update_time_with_B.f90:2894
dir_nodes_petsc::scalar_with_bc_glob_js_d
subroutine scalar_with_bc_glob_js_d(pp_mesh, list_mode, pp_1_LA, pp_js_D, pp_mode_global_js_D)
Definition: dir_nodes_petsc.f90:282
dir_nodes_petsc
Definition: dir_nodes_petsc.f90:4
update_maxwell_with_b::smb_current_over_sigma
subroutine smb_current_over_sigma(communicator, mesh, jj_v_to_H, list_mode, B_in, mu_H_field, mu_phi, one_over_sigma_tot, time, sigma, J_over_sigma_gauss)
Definition: maxwell_update_time_with_B.f90:5820
update_maxwell_with_b::maxwell_decouple_with_b
subroutine, public maxwell_decouple_with_b(comm_one_d, H_mesh, pmag_mesh, phi_mesh, interface_H_phi, interface_H_mu, Hn, Bn, phin, Hn1, Bn1, phin1, vel, stab_in, sigma_in, R_fourier, index_fourier, mu_H_field, mu_phi, time, dt_in, Rem, list_mode, H_phi_per, LA_H, LA_pmag, LA_phi, LA_mhd, one_over_sigma_ns_in, jj_v_to_H)
Definition: maxwell_update_time_with_B.f90:24
update_maxwell_with_b::smb_sigma_prod_curl
subroutine smb_sigma_prod_curl(communicator, mesh, jj_v_to_H, list_mode, H_in, one_over_sigma_in, sigma_nj_m, sigma, V_out)
Definition: maxwell_update_time_with_B.f90:5415
dyn_line::dyn_int_line
Definition: dyn_line.f90:5
sft_parallele
Definition: fft_parallel.f90:4
def_type_mesh::periodic_type
Definition: def_type_mesh.f90:55
prep_maill
Definition: prep_mesh.f90:5
solve_petsc::init_solver
subroutine init_solver(my_par, my_ksp, matrix, communicator, solver, precond, opt_re_init)
Definition: solver.f90:12
dir_nodes_petsc::dirichlet_rhs
subroutine dirichlet_rhs(js_D, bs_D, b)
Definition: dir_nodes_petsc.f90:173
update_maxwell_with_b::rhs_dirichlet
subroutine rhs_dirichlet(H_mesh, Dirichlet_bdy_H_sides, sigma, mu_H_field, time, mode, nl, stab, LA_H, vb_1, vb_2, B_ext, J_over_sigma_bdy, sigma_curl_bdy_in)
Definition: maxwell_update_time_with_B.f90:5115
dir_nodes_petsc::dirichlet_nodes_parallel
subroutine dirichlet_nodes_parallel(mesh, list_dirichlet_sides, js_d)
Definition: dir_nodes_petsc.f90:53
periodic::periodic_matrix_petsc
subroutine, public periodic_matrix_petsc(n_bord, list, perlist, matrix, LA)
Definition: prep_mesh_periodic.f90:378
update_maxwell_with_b::one_over_mu
real(kind=8) function, dimension(nb_angles, ne-nb+1) one_over_mu(H_mesh, angles, nb_angles, nb, ne, time)
Definition: maxwell_update_time_with_B.f90:5399
tn_axi
Definition: tn_axi.f90:5
solve_petsc
Definition: solver.f90:1
update_maxwell_with_b::courant_int_by_parts
subroutine courant_int_by_parts(H_mesh, phi_mesh, interface_H_phi, sigma, mu_phi, mu_H_field, time, mode, rhs_H, nl, LA_H, LA_phi, vb_1, vb_2, B_ext, H_pert, sigma_curl_gauss, J_over_sigma_gauss)
Definition: maxwell_update_time_with_B.f90:3429
update_maxwell_with_b::smb_current_over_sigma_bdy
subroutine smb_current_over_sigma_bdy(communicator, mesh, jj_v_to_H, Dirichlet_bdy_H_sides, list_mode, B_in, mu_H_field, mu_phi, one_over_sigma_tot, time, sigma, J_over_sigma_gauss)
Definition: maxwell_update_time_with_B.f90:5911
user_data
Definition: read_user_data.f90:10
dir_nodes_petsc::dirichlet_m_parallel
subroutine dirichlet_m_parallel(matrix, glob_js_D)
Definition: dir_nodes_petsc.f90:150
update_maxwell_with_b::neumann_bdy_phi_sides
integer, dimension(:), allocatable neumann_bdy_phi_sides
Definition: maxwell_update_time_with_B.f90:13
verbose::talk_to_me
type(my_verbose), public talk_to_me
Definition: verbose.f90:27
tn_axi::norm_sf
real(kind=8) function norm_sf(communicator, norm_type, mesh, list_mode, v)
Definition: tn_axi.f90:40
update_maxwell_with_b::surf_int
subroutine surf_int(H_mesh, phi_mesh, pmag_mesh, interface_H_phi, interface_H_mu, list_dirichlet_sides_H, sigma, mu_phi, mu_H_field, time, mode, LA_H, LA_phi, LA_pmag, vb_1, vb_2, sigma_tot_gauss, R_fourier, index_fourier)
Definition: maxwell_update_time_with_B.f90:3883
update_maxwell_with_b::mat_maxwell_mu
subroutine mat_maxwell_mu(H_mesh, jj_v_to_H, interface_H_mu, mode, stab, mu_H_field, sigma, LA_H, H_p_phi_mat1, H_p_phi_mat2, sigma_np)
Definition: maxwell_update_time_with_B.f90:4228
update_maxwell_with_b::dirichlet_bdy_h_sides
integer, dimension(:), allocatable dirichlet_bdy_h_sides
Definition: maxwell_update_time_with_B.f90:14
gauss_points::rjs
real(kind=8), dimension(:,:), pointer rjs
Definition: associate_gauss.f90:15
gauss_points::wws
real(kind=8), dimension(:,:), pointer wws
Definition: associate_gauss.f90:11
input_data
Definition: read_my_data.f90:233
gauss_points::gauss
subroutine gauss(mesh)
Definition: associate_gauss.f90:24
chaine_caractere
Definition: chaine_caractere.f90:4
dir_nodes
Definition: dir_nodes.f90:4
dyn_line::dyn_real_line
Definition: dyn_line.f90:9
def_type_mesh
Definition: def_type_mesh.f90:4
update_maxwell_with_b::alpha
real(kind=8), parameter, private alpha
Definition: maxwell_update_time_with_B.f90:10
update_maxwell_with_b::mat_h_p_phi_maxwell
subroutine mat_h_p_phi_maxwell(H_mesh, pmag_mesh, phi_mesh, interface_H_phi, mode, mu_H_field, mu_phi, c_mass, stab, R_fourier, index_fourier, LA_H, LA_pmag, LA_phi, H_p_phi_mat1, H_p_phi_mat2, sigma_nj_m, sigma)
Definition: maxwell_update_time_with_B.f90:873
periodic::periodic_rhs_petsc
subroutine, public periodic_rhs_petsc(n_bord, list, perlist, v_rhs, LA)
Definition: prep_mesh_periodic.f90:459
update_maxwell_with_b::smb_sigma_neumann
subroutine smb_sigma_neumann(communicator, mesh, Neumann_bdy_H_sides, list_mode, one_over_sigma_tot, sigma_tot_gauss_Neumann)
Definition: maxwell_update_time_with_B.f90:6163
gauss_points::dw_s
real(kind=8), dimension(:,:,:,:), pointer dw_s
Definition: associate_gauss.f90:16
update_maxwell_with_b::smb_sigma_prod_curl_bdy
subroutine smb_sigma_prod_curl_bdy(communicator, mesh, jj_v_to_H, Dirichlet_bdy_H_sides, list_mode, H_in, one_over_sigma_in, sigma_np, sigma, V_out)
Definition: maxwell_update_time_with_B.f90:5519