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