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