[cig-commits] r22299 - in seismo/3D/SPECFEM3D_GLOBE/branches/undo_att: . setup src/compute_optimized_dumping_undo_att src/shared src/specfem3D
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Fri Jun 14 17:48:58 PDT 2013
Author: dkomati1
Date: 2013-06-14 17:48:57 -0700 (Fri, 14 Jun 2013)
New Revision: 22299
Added:
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.f90
Removed:
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/original_code_now_unused_is_there_only_as_a_reference.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.F90
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.F90
Modified:
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/setup/constants.h.in
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/rules.mk
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/rules.mk
seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/specfem3D/specfem3D.F90
Log:
converted UNDO_ATT back from a compilation flag to a parameter in setup/constants.h
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/original_code_now_unused_is_there_only_as_a_reference.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/original_code_now_unused_is_there_only_as_a_reference.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/original_code_now_unused_is_there_only_as_a_reference.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,1879 +0,0 @@
-
-! *********************************************************
-! ************* MAIN LOOP OVER THE TIME STEPS *************
-! *********************************************************
-
- do it = it_begin,it_end
-
- ! update position in seismograms
- seismo_current = seismo_current + 1
-
- ! Newark time scheme update
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
-
- ! backward field
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif ! SIMULATION_TYPE == 3
-
- ! integral of strain for adjoint movie volume
- if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
-! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
-! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
- do ispec = 1,NSPEC_CRUST_MANTLE
- Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
- + deltat*epsilondev_crust_mantle(:,:,:,:,ispec)
- Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
- + deltat*eps_trace_over_3_crust_mantle(:,:,:,ispec)
- enddo
- endif
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) &
- call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
-
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
-
- iphase = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- if (SIMULATION_TYPE == 3) then
- ! note on backward/reconstructed wavefields:
- ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
- ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
- ! to a time (NSTEP - (it-1) - 1)*DT - t0
- ! for reconstructing the rotational contributions
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
- else
- time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
- endif
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
- endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
- NSTEP,it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core,b_accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-
-
- ! assemble all the contributions between slices using MPI
-
- ! outer core
- iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
- enddo
-
- ! multiply by the inverse of the mass matrix and update velocity
- do i=1,NGLOB_OUTER_CORE
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- enddo
-
- if (SIMULATION_TYPE == 3) then
-
-! ------------------- new non blocking implementation -------------------
-
- ! outer core
- b_iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
- enddo
-
-! ------------------- new non blocking implementation -------------------
-
- ! Newmark time scheme - corrector for fluid parts
- do i=1,NGLOB_OUTER_CORE
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
- enddo
-
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- iphase = 0 ! do not start any non blocking communications at this stage
- iphase_CC = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- if (SIMULATION_TYPE == 3 ) then
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_iphase_CC = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-
- endif
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
- if (SIMULATION_TYPE == 3) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
- endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
- NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
- endif ! Stacey conditions
-
- ! add the sources
- if (SIMULATION_TYPE == 1) &
- call compute_add_sources(myrank,NSOURCES, &
- accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! add adjoint sources
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- if( nadj_rec_local > 0 ) &
- call compute_add_sources_adjoint(myrank,nrec, &
- nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
- accel_crust_mantle,adj_sourcearrays, &
- nu,xi_receiver,eta_receiver,gamma_receiver, &
- xigll,yigll,zigll,ibool_crust_mantle, &
- islice_selected_rec,ispec_selected_rec, &
- NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
- it,it_begin,station_name,network_name,DT)
- endif
-
- ! add sources for backward/reconstructed wavefield
- if (SIMULATION_TYPE == 3) &
- call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! NOISE_TOMOGRAPHY
- if ( NOISE_TOMOGRAPHY == 1 ) then
- ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
- ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
- ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
- ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
- call add_source_master_rec_noise(myrank,nrec, &
- NSTEP,accel_crust_mantle,noise_sourcearray, &
- ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
- it,irec_master_noise)
- else if ( NOISE_TOMOGRAPHY == 2 ) then
- ! second step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to drive the ensemble forward wavefield
- call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
- ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
- ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
- ! note the ensemble forward sources are generally distributed on the surface of the earth
- ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
- ! therefore, we must add it here, before applying the inverse of mass matrix
- else if ( NOISE_TOMOGRAPHY == 3 ) then
- ! third step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to reconstruct the ensemble forward wavefield
- ! the ensemble adjoint wavefield is done as usual
- ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
- call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
- accel_inner_core,b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_INNER_CORE))
-
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- iphase = 1 ! initialize the non blocking communication counter
- iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
- enddo
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
- if (SIMULATION_TYPE == 3) then
-
-! ------------------- new non blocking implementation -------------------
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- b_iphase = 1 ! initialize the non blocking communication counter
- b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
- enddo
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
-! ------------------- new non blocking implementation -------------------
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
- endif ! SIMULATION_TYPE == 3
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) &
- call compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
- ! Newmark time scheme - corrector for elastic parts
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
-
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + b_two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - b_two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
- enddo
-
- endif ! SIMULATION_TYPE == 3
-
- ! restores last time snapshot saved for backward/reconstruction of wavefields
- ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
- ! and adjoint sources will become more complicated
- ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
- if( SIMULATION_TYPE == 3 .and. it == 1 ) then
- call read_forward_arrays(myrank, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
- endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
- if (SIMULATION_TYPE == 1) then
- call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- else if (SIMULATION_TYPE == 2) then
- call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- hxir_store,hetar_store,hgammar_store, &
- hpxir_store,hpetar_store,hpgammar_store, &
- tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
- hprime_xx,hprime_yy,hprime_zz, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- moment_der,sloc_der,stshift_der,shdur_der, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
- ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
- NSTEP,it,nit_written)
-
- else if (SIMULATION_TYPE == 3) then
- call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- else
- if( nrec_local > 0 ) &
- call write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT, &
- NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
- nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-! kernel calculations
- if (SIMULATION_TYPE == 3) then
- ! crust mantle
- call compute_kernels_crust_mantle(ibool_crust_mantle, &
- rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
- accel_crust_mantle,b_displ_crust_mantle, &
- epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
- deltat)
-
- ! outer core
- call compute_kernels_outer_core(ibool_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- hprime_xx,hprime_yy,hprime_zz, &
- displ_outer_core,accel_outer_core, &
- b_displ_outer_core,b_accel_outer_core, &
- vector_accel_outer_core,vector_displ_outer_core, &
- b_vector_displ_outer_core, &
- div_displ_outer_core,b_div_displ_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- deltat)
-
- ! inner core
- call compute_kernels_inner_core(ibool_inner_core, &
- rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
- accel_inner_core,b_displ_inner_core, &
- epsilondev_inner_core,b_epsilondev_inner_core, &
- eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
- deltat)
-
- ! NOISE TOMOGRAPHY --- source strength kernel
- if (NOISE_TOMOGRAPHY == 3) &
- call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
- Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
- normal_x_noise,normal_y_noise,normal_z_noise, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- ibelm_top_crust_mantle)
-
- ! --- boundary kernels ------
- if (SAVE_BOUNDARY_MESH) then
- fluid_solid_boundary = .false.
- iregion_code = IREGION_CRUST_MANTLE
-
- ! Moho
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
-
- moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
- endif
-
- ! 400
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
-
- d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
-
- ! 670
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
-
- d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
-
- ! CMB
- fluid_solid_boundary = .true.
- iregion_code = IREGION_CRUST_MANTLE
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
- cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
-
- iregion_code = IREGION_OUTER_CORE
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_outer_core,normal_top_outer_core, &
- cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
-
- cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
-
- ! ICB
- fluid_solid_boundary = .true.
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
- icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
-
- iregion_code = IREGION_INNER_CORE
- call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
- b_displ_inner_core,nspec_inner_core,iregion_code, &
- ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core,&
- gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- c33store_inner_core,dummy_array,dummy_array, &
- dummy_array,c44store_inner_core,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
- icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
-
- icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- call compute_kernels_hessian(ibool_crust_mantle, &
- hess_kl_crust_mantle,&
- accel_crust_mantle,b_accel_crust_mantle, &
- deltat)
- endif
-
- endif ! end computing kernels
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
- ! first step of noise tomography, i.e., save a surface movie at every time step
- ! modified from the subroutine 'write_movie_surface'
- if ( NOISE_TOMOGRAPHY == 1 ) then
- call noise_save_surface_movie(displ_crust_mantle, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
- endif
-
- ! save movie on surface
- if( MOVIE_SURFACE ) then
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- ! save velocity here to avoid static offset on displacement for movies
- call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
- scale_displ,displ_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
- endif
- endif
-
-
- ! save movie in full 3D mesh
- if(MOVIE_VOLUME ) then
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- if (MOVIE_VOLUME_TYPE == 1) then ! output strains
-
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
- ! output the Time Integral of Strain, or \mu*TIS
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
-
- call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- div_displ_outer_core, &
- accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
- eps_trace_over_3_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- LOCAL_PATH, &
- displ_crust_mantle,displ_inner_core,displ_outer_core, &
- veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
- accel_crust_mantle,accel_inner_core, &
- ibool_crust_mantle,ibool_inner_core)
-
- else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
- scalingval = scale_displ
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
- scalingval = scale_veloc
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else
-
- call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
-
- endif ! MOVIE_VOLUME_TYPE
- endif
- endif ! MOVIE_VOLUME
-
-!
-!---- end of time iteration loop
-!
- enddo ! end of main time loop
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,2007 +0,0 @@
-
-!! DK DK
-!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
-!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
-!! DK DK
-
- ! Newmark time scheme update
-
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
-
-! ! backward field
-! if (SIMULATION_TYPE == 3) then
-! ! mantle
-! do i=1,NGLOB_CRUST_MANTLE
-! b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
-! + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
-! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
-! + b_deltatover2*b_accel_crust_mantle(:,i)
-! b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
-! enddo
-! ! outer core
-! do i=1,NGLOB_OUTER_CORE
-! b_displ_outer_core(i) = b_displ_outer_core(i) &
-! + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
-! b_veloc_outer_core(i) = b_veloc_outer_core(i) &
-! + b_deltatover2*b_accel_outer_core(i)
-! b_accel_outer_core(i) = 0._CUSTOM_REAL
-! enddo
-! ! inner core
-! do i=1,NGLOB_INNER_CORE
-! b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
-! + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
-! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
-! + b_deltatover2*b_accel_inner_core(:,i)
-! b_accel_inner_core(:,i) = 0._CUSTOM_REAL
-! enddo
-! endif ! SIMULATION_TYPE == 3
-
- ! integral of strain for adjoint movie volume
- if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
-! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
-! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
- do ispec = 1,NSPEC_CRUST_MANTLE
- Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
- + deltat*epsilondev_crust_mantle(:,:,:,:,ispec)
- Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
- + deltat*eps_trace_over_3_crust_mantle(:,:,:,ispec)
- enddo
- endif
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
- call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
-!!!!! DK DK UNDO_ATT SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- 1,OUTPUT_FILES,time_start,DT,t0,NSTEP, & !!!!! DK DK UNDO_ATT
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
-! if (SIMULATION_TYPE == 3) then
-! call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
-! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
-! SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
-! it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
-! endif
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
-
- iphase = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
-! if (SIMULATION_TYPE == 3) then
-! ! note on backward/reconstructed wavefields:
-! ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
-! ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
-! ! to a time (NSTEP - (it-1) - 1)*DT - t0
-! ! for reconstructing the rotational contributions
-! if(CUSTOM_REAL == SIZE_REAL) then
-! time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
-! else
-! time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
-! endif
-
-! b_iphase = 0 ! do not start any non blocking communications at this stage
-! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! ! uses Deville et al. (2002) routine
-! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! else
-! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! endif
-! endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
- it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
-! if (SIMULATION_TYPE == 3) then
-! call compute_stacey_outer_core_backward(ichunk, &
-! NSTEP,it,ibool_outer_core, &
-! b_accel_outer_core, &
-! ibelm_bottom_outer_core, &
-! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
-! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
-! nimin_outer_core,nimax_outer_core, &
-! njmin_outer_core,njmax_outer_core, &
-! nkmin_xi_outer_core,nkmin_eta_outer_core, &
-! NSPEC2D_BOTTOM, &
-! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
-! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
-! reclen_zmin, &
-! reclen_xmin_outer_core,reclen_xmax_outer_core, &
-! reclen_ymin_outer_core,reclen_ymax_outer_core, &
-! nabs_zmin_oc, &
-! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
-! absorb_zmin_outer_core, &
-! absorb_xmin_outer_core,absorb_xmax_outer_core, &
-! absorb_ymin_outer_core,absorb_ymax_outer_core)
-!! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
-!! NSTEP,it,ibool_outer_core, &
-!! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
-!! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
-!! jacobian2D_bottom_outer_core, &
-!! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
-!! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
-!! ibelm_bottom_outer_core, &
-!! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
-!! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
-!! nimin_outer_core,nimax_outer_core, &
-!! njmin_outer_core,njmax_outer_core, &
-!! nkmin_xi_outer_core,nkmin_eta_outer_core, &
-!! NSPEC2D_BOTTOM, &
-!! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
-!! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
-!! reclen_zmin, &
-!! reclen_xmin_outer_core,reclen_xmax_outer_core, &
-!! reclen_ymin_outer_core,reclen_ymax_outer_core, &
-!! nabs_zmin_oc, &
-!! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
-!! absorb_zmin_outer_core, &
-!! absorb_xmin_outer_core,absorb_xmax_outer_core, &
-!! absorb_ymin_outer_core,absorb_ymax_outer_core)
-! endif
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- call compute_coupling_fluid_CMB(displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- NSPEC2D_TOP(IREGION_OUTER_CORE))
-! if (SIMULATION_TYPE == 3) then
-! call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
-! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
-! b_accel_outer_core, &
-! normal_top_outer_core,jacobian2D_top_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
-! NSPEC2D_TOP(IREGION_OUTER_CORE))
-! endif
- endif
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- call compute_coupling_fluid_ICB(displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-! if (SIMULATION_TYPE == 3) then
-! call compute_coupling_fluid_ICB(b_displ_inner_core, &
-! ibool_inner_core,ibelm_top_inner_core, &
-! b_accel_outer_core, &
-! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
-! NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-! endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
- ! outer core
- iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
- enddo
-
- ! multiply by the inverse of the mass matrix and update velocity
- do i=1,NGLOB_OUTER_CORE
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- enddo
-
-! ------------------- new non blocking implementation -------------------
-
-! if (SIMULATION_TYPE == 3) then
-
-! ! outer core
-! b_iphase = 1 ! start the non blocking communications
-! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-
-! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! ! uses Deville et al. (2002) routine
-! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! else
-! ! div_displ_outer_core is initialized to zero in the following subroutine.
-! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! endif
-
-! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
-! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-! enddo
-
-! ------------------- new non blocking implementation -------------------
-
-! ! Newmark time scheme - corrector for fluid parts
-! do i=1,NGLOB_OUTER_CORE
-! b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
-! b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
-! enddo
-
-! endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- iphase = 0 ! do not start any non blocking communications at this stage
- iphase_CC = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
-! if (SIMULATION_TYPE == 3 ) then
-
-! b_iphase = 0 ! do not start any non blocking communications at this stage
-! b_iphase_CC = 0 ! do not start any non blocking communications at this stage
-! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
-! ! for anisotropy and gravity, x y and z contain r theta and phi
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT, &
-! hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! else
-! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! endif
-! endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! if (SIMULATION_TYPE == 3) then
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! else
-! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! endif
-! endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- call compute_stacey_crust_mantle_forward(ichunk, &
- it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-
-! if(SIMULATION_TYPE == 3) then
-! call compute_stacey_crust_mantle_backward(ichunk, &
-! NSTEP,it,ibool_crust_mantle, &
-! b_accel_crust_mantle, &
-! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
-! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
-! nimin_crust_mantle,nimax_crust_mantle, &
-! njmin_crust_mantle,njmax_crust_mantle, &
-! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
-! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
-! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
-! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
-! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
-! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
-! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
-! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-!! call compute_stacey_crust_mantle(ichunk, &
-!! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
-!! veloc_crust_mantle,b_accel_crust_mantle, &
-!! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
-!! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
-!! wgllwgll_xz,wgllwgll_yz, &
-!! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
-!! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
-!! rho_vp_crust_mantle,rho_vs_crust_mantle, &
-!! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
-!! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
-!! nimin_crust_mantle,nimax_crust_mantle, &
-!! njmin_crust_mantle,njmax_crust_mantle, &
-!! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
-!! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
-!! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
-!! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
-!! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
-!! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
-!! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
-!! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-! endif
-
- endif ! Stacey conditions
-
- ! add the sources
- if (SIMULATION_TYPE == 1) &
- call compute_add_sources(myrank,NSOURCES, &
- accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! add adjoint sources only if adjoint simulation is performed for source inversion only
-!! DK DK UNDO_ATT this must remain here even when SIMULATION_TYPE == 3 because it applies to array
-!! DK DK UNDO_ATT accel_crust_mantle rather than b_accel_crust_mantle
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- if( nadj_rec_local > 0 ) &
- call compute_add_sources_adjoint(myrank,nrec, &
- nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
- accel_crust_mantle,adj_sourcearrays, &
- nu,xi_receiver,eta_receiver,gamma_receiver, &
- xigll,yigll,zigll,ibool_crust_mantle, &
- islice_selected_rec,ispec_selected_rec, &
- NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
- it,it_begin,station_name,network_name,DT)
- endif
-
-! ! add adjoint sources and add sources for backward/reconstructed wavefield
-! if (SIMULATION_TYPE == 3) &
-! call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
-! b_accel_crust_mantle,sourcearrays, &
-! DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
-! islice_selected_source,ispec_selected_source,it, &
-! hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! NOISE_TOMOGRAPHY
- if ( NOISE_TOMOGRAPHY == 1 ) then
- ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
- ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
- ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
- ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
- call add_source_master_rec_noise(myrank,nrec, &
- NSTEP,accel_crust_mantle,noise_sourcearray, &
- ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
- it,irec_master_noise)
- else if ( NOISE_TOMOGRAPHY == 2 ) then
- ! second step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to drive the ensemble forward wavefield
- call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
- ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
- ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
- ! note the ensemble forward sources are generally distributed on the surface of the earth
- ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
- ! therefore, we must add it here, before applying the inverse of mass matrix
-! else if ( NOISE_TOMOGRAPHY == 3 ) then
-! ! third step of noise tomography, i.e., read the surface movie saved at every timestep
-! ! use the movie to reconstruct the ensemble forward wavefield
-! ! the ensemble adjoint wavefield is done as usual
-! ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
-! call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
-! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
-! ibelm_top_crust_mantle,ibool_crust_mantle, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
-! it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- call compute_coupling_CMB_fluid(displ_crust_mantle, &
- accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-! if(SIMULATION_TYPE == 3) then
-! call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
-! b_accel_crust_mantle, &
-! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
-! b_accel_outer_core, &
-! normal_top_outer_core,jacobian2D_top_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
-! RHO_TOP_OC,minus_g_cmb, &
-! NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-! endif
- endif
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- call compute_coupling_ICB_fluid(displ_inner_core, &
- accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- NSPEC2D_TOP(IREGION_INNER_CORE))
-! if(SIMULATION_TYPE == 3) then
-! call compute_coupling_ICB_fluid(b_displ_inner_core, &
-! b_accel_inner_core, &
-! ibool_inner_core,ibelm_top_inner_core, &
-! b_accel_outer_core, &
-! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
-! RHO_BOTTOM_OC,minus_g_icb, &
-! NSPEC2D_TOP(IREGION_INNER_CORE))
-! endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- iphase = 1 ! initialize the non blocking communication counter
- iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
- enddo
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
-! ------------------- new non blocking implementation -------------------
-
-! if (SIMULATION_TYPE == 3) then
-
-! ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
-! b_iphase = 1 ! initialize the non blocking communication counter
-! b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
-! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
-! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
-! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
-! ! compute internal forces in the solid regions
-
-! ! for anisotropy and gravity, x y and z contain r theta and phi
-
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT, &
-! hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! else
-! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! endif
-
-! ! Deville routine
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! else
-! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
-! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
-! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-! enddo
-
-! !---
-! !--- use buffers to assemble forces with the central cube
-! !---
-
-! if(INCLUDE_CENTRAL_CUBE) then
-! do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
-! call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
-! ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
-! enddo
-! endif ! end of assembling forces with the central cube
-
-! ------------------- new non blocking implementation -------------------
-
-! if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
-! do i=1,NGLOB_CRUST_MANTLE
-! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
-! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
-! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
-! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
-! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-! enddo
-
-! else
-
-! do i=1,NGLOB_CRUST_MANTLE
-! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
-! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
-! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
-! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
-! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-! enddo
-
-! endif
-
-! endif ! SIMULATION_TYPE == 3
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) then
- call compute_coupling_ocean(accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
-! if(SIMULATION_TYPE == 3) then
-! call compute_coupling_ocean(b_accel_crust_mantle, &
-! rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
-! rmass_ocean_load,normal_top_crust_mantle, &
-! ibool_crust_mantle,ibelm_top_crust_mantle, &
-! updated_dof_ocean_load,NGLOB_XY, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
-! ABSORBING_CONDITIONS)
-! endif
- endif
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! Newmark time scheme - corrector for elastic parts
-
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
-
-! if (SIMULATION_TYPE == 3) then
-! ! mantle
-! do i=1,NGLOB_CRUST_MANTLE
-! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
-! enddo
-! ! inner core
-! do i=1,NGLOB_INNER_CORE
-! b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
-! + b_two_omega_earth*b_veloc_inner_core(2,i)
-! b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
-! - b_two_omega_earth*b_veloc_inner_core(1,i)
-! b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
-! enddo
-! endif ! SIMULATION_TYPE == 3
-
-! ! restores last time snapshot saved for backward/reconstruction of wavefields
-! ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
-! ! and adjoint sources will become more complicated
-! ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
-! if(SIMULATION_TYPE == 3 .and. it == 1) then
-! call read_forward_arrays(myrank, &
-! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
-! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
-! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
-! b_R_memory_crust_mantle,b_R_memory_inner_core, &
-! b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
-! b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
-! endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
- if (SIMULATION_TYPE == 1) then
- call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- else if (SIMULATION_TYPE == 2) then
- call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- hxir_store,hetar_store,hgammar_store, &
- hpxir_store,hpetar_store,hpgammar_store, &
- tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
- hprime_xx,hprime_yy,hprime_zz, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- moment_der,sloc_der,stshift_der,shdur_der, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
- ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
- NSTEP,it,nit_written)
-
-! else if (SIMULATION_TYPE == 3) then
-! call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
-! nu,hxir_store,hetar_store,hgammar_store, &
-! scale_displ,ibool_crust_mantle, &
-! ispec_selected_rec,number_receiver_global, &
-! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
-! seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- else ! case of SIMULATION_TYPE == 2
- if( nrec_local > 0 ) &
- call write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT, &
- NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
- nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-! kernel calculations
-! if (SIMULATION_TYPE == 3) then
-! ! crust mantle
-! call compute_kernels_crust_mantle(ibool_crust_mantle, &
-! rho_kl_crust_mantle,beta_kl_crust_mantle, &
-! alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
-! accel_crust_mantle,b_displ_crust_mantle, &
-! epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
-! eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
-! deltat)
-
-! ! outer core
-! call compute_kernels_outer_core(ibool_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! displ_outer_core,accel_outer_core, &
-! b_displ_outer_core,b_accel_outer_core, &
-! vector_accel_outer_core,vector_displ_outer_core, &
-! b_vector_displ_outer_core, &
-! div_displ_outer_core,b_div_displ_outer_core, &
-! rhostore_outer_core,kappavstore_outer_core, &
-! rho_kl_outer_core,alpha_kl_outer_core, &
-! deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
-! deltat)
-
-! ! inner core
-! call compute_kernels_inner_core(ibool_inner_core, &
-! rho_kl_inner_core,beta_kl_inner_core, &
-! alpha_kl_inner_core, &
-! accel_inner_core,b_displ_inner_core, &
-! epsilondev_inner_core,b_epsilondev_inner_core, &
-! eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
-! deltat)
-
-! ! NOISE TOMOGRAPHY --- source strength kernel
-! if (NOISE_TOMOGRAPHY == 3) &
-! call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
-! Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
-! normal_x_noise,normal_y_noise,normal_z_noise, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
-! ibelm_top_crust_mantle)
-
-! ! --- boundary kernels ------
-! if (SAVE_BOUNDARY_MESH) then
-! fluid_solid_boundary = .false.
-! iregion_code = IREGION_CRUST_MANTLE
-
-! ! Moho
-! if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
-
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
-
-! moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
-! endif
-
-! ! d400
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
-
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
-
-! d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
-
-! ! d670
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
-
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
-
-! d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
-
-! ! CMB
-! fluid_solid_boundary = .true.
-! iregion_code = IREGION_CRUST_MANTLE
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
-! cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
-
-! iregion_code = IREGION_OUTER_CORE
-! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
-! b_vector_displ_outer_core,nspec_outer_core, &
-! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core,&
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! k_bot,ibelm_top_outer_core,normal_top_outer_core, &
-! cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
-
-! cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
-
-! ! ICB
-! fluid_solid_boundary = .true.
-! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
-! b_vector_displ_outer_core,nspec_outer_core, &
-! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core,&
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
-! icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
-
-! iregion_code = IREGION_INNER_CORE
-! call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
-! b_displ_inner_core,nspec_inner_core,iregion_code, &
-! ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core,&
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
-! dummy_array,dummy_array,dummy_array, &
-! c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! c33store_inner_core,dummy_array,dummy_array, &
-! dummy_array,c44store_inner_core,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
-! icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
-
-! icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
-! endif
-
-! ! approximate hessian
-! if( APPROXIMATE_HESS_KL ) then
-! call compute_kernels_hessian(ibool_crust_mantle, &
-! hess_kl_crust_mantle,&
-! accel_crust_mantle,b_accel_crust_mantle, &
-! deltat)
-! endif
-
-! endif ! end of if computing kernels
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! first step of noise tomography, i.e., save a surface movie at every time step
- ! modified from the subroutine 'write_movie_surface'
- if ( NOISE_TOMOGRAPHY == 1 ) then
- call noise_save_surface_movie(displ_crust_mantle, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
- endif
-
- ! save movie on surface
- if( MOVIE_SURFACE ) then
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- ! save velocity here to avoid static offset on displacement for movies
- call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
- scale_displ,displ_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
- endif
- endif
-
-
- ! save movie in full 3D mesh
- if(MOVIE_VOLUME ) then
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- if (MOVIE_VOLUME_TYPE == 1) then ! output strains
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
- ! output the Time Integral of Strain, or \mu*TIS
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
- call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- div_displ_outer_core, &
- accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
- eps_trace_over_3_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- LOCAL_PATH, &
- displ_crust_mantle,displ_inner_core,displ_outer_core, &
- veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
- accel_crust_mantle,accel_inner_core, &
- ibool_crust_mantle,ibool_inner_core)
-
- else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
- scalingval = scale_displ
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
- scalingval = scale_veloc
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else
-
- call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
-
- endif ! MOVIE_VOLUME_TYPE
- endif
- endif ! MOVIE_VOLUME
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_classical.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,2007 @@
+
+!! DK DK
+!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
+!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ + deltatover2*accel_crust_mantle(:,i)
+ accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ displ_outer_core(i) = displ_outer_core(i) &
+ + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) &
+ + deltatover2*accel_outer_core(i)
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ displ_inner_core(:,i) = displ_inner_core(:,i) &
+ + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ + deltatover2*accel_inner_core(:,i)
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+
+! ! backward field
+! if (SIMULATION_TYPE == 3) then
+! ! mantle
+! do i=1,NGLOB_CRUST_MANTLE
+! b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+! + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+! + b_deltatover2*b_accel_crust_mantle(:,i)
+! b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+! enddo
+! ! outer core
+! do i=1,NGLOB_OUTER_CORE
+! b_displ_outer_core(i) = b_displ_outer_core(i) &
+! + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+! b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+! + b_deltatover2*b_accel_outer_core(i)
+! b_accel_outer_core(i) = 0._CUSTOM_REAL
+! enddo
+! ! inner core
+! do i=1,NGLOB_INNER_CORE
+! b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+! + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+! + b_deltatover2*b_accel_inner_core(:,i)
+! b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+! enddo
+! endif ! SIMULATION_TYPE == 3
+
+ ! integral of strain for adjoint movie volume
+ if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
+! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
+! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
+ + deltat*epsilondev_crust_mantle(:,:,:,:,ispec)
+ Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
+ + deltat*eps_trace_over_3_crust_mantle(:,:,:,ispec)
+ enddo
+ endif
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+!!!!! DK DK UNDO_ATT SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ 1,OUTPUT_FILES,time_start,DT,t0,NSTEP, & !!!!! DK DK UNDO_ATT
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+! if (SIMULATION_TYPE == 3) then
+! call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+! SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+! it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+! endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT-t0)*scale_t_inv
+ endif
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+! if (SIMULATION_TYPE == 3) then
+! ! note on backward/reconstructed wavefields:
+! ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+! ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+! ! to a time (NSTEP - (it-1) - 1)*DT - t0
+! ! for reconstructing the rotational contributions
+! if(CUSTOM_REAL == SIZE_REAL) then
+! time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+! else
+! time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+! endif
+
+! b_iphase = 0 ! do not start any non blocking communications at this stage
+! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! ! uses Deville et al. (2002) routine
+! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! else
+! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! endif
+! endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+! if (SIMULATION_TYPE == 3) then
+! call compute_stacey_outer_core_backward(ichunk, &
+! NSTEP,it,ibool_outer_core, &
+! b_accel_outer_core, &
+! ibelm_bottom_outer_core, &
+! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+! nimin_outer_core,nimax_outer_core, &
+! njmin_outer_core,njmax_outer_core, &
+! nkmin_xi_outer_core,nkmin_eta_outer_core, &
+! NSPEC2D_BOTTOM, &
+! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+! reclen_zmin, &
+! reclen_xmin_outer_core,reclen_xmax_outer_core, &
+! reclen_ymin_outer_core,reclen_ymax_outer_core, &
+! nabs_zmin_oc, &
+! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+! absorb_zmin_outer_core, &
+! absorb_xmin_outer_core,absorb_xmax_outer_core, &
+! absorb_ymin_outer_core,absorb_ymax_outer_core)
+!! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+!! NSTEP,it,ibool_outer_core, &
+!! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+!! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+!! jacobian2D_bottom_outer_core, &
+!! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+!! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+!! ibelm_bottom_outer_core, &
+!! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+!! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+!! nimin_outer_core,nimax_outer_core, &
+!! njmin_outer_core,njmax_outer_core, &
+!! nkmin_xi_outer_core,nkmin_eta_outer_core, &
+!! NSPEC2D_BOTTOM, &
+!! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+!! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+!! reclen_zmin, &
+!! reclen_xmin_outer_core,reclen_xmax_outer_core, &
+!! reclen_ymin_outer_core,reclen_ymax_outer_core, &
+!! nabs_zmin_oc, &
+!! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+!! absorb_zmin_outer_core, &
+!! absorb_xmin_outer_core,absorb_xmax_outer_core, &
+!! absorb_ymin_outer_core,absorb_ymax_outer_core)
+! endif
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_fluid_CMB(displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+! if (SIMULATION_TYPE == 3) then
+! call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
+! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+! b_accel_outer_core, &
+! normal_top_outer_core,jacobian2D_top_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+! NSPEC2D_TOP(IREGION_OUTER_CORE))
+! endif
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_fluid_ICB(displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+! if (SIMULATION_TYPE == 3) then
+! call compute_coupling_fluid_ICB(b_displ_inner_core, &
+! ibool_inner_core,ibelm_top_inner_core, &
+! b_accel_outer_core, &
+! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+! NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+! endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+ ! outer core
+ iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+ enddo
+
+ ! multiply by the inverse of the mass matrix and update velocity
+ do i=1,NGLOB_OUTER_CORE
+ accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+! if (SIMULATION_TYPE == 3) then
+
+! ! outer core
+! b_iphase = 1 ! start the non blocking communications
+! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+
+! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! ! uses Deville et al. (2002) routine
+! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! else
+! ! div_displ_outer_core is initialized to zero in the following subroutine.
+! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! endif
+
+! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+! enddo
+
+! ------------------- new non blocking implementation -------------------
+
+! ! Newmark time scheme - corrector for fluid parts
+! do i=1,NGLOB_OUTER_CORE
+! b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+! b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+! enddo
+
+! endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ iphase_CC = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+! if (SIMULATION_TYPE == 3 ) then
+
+! b_iphase = 0 ! do not start any non blocking communications at this stage
+! b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+! ! for anisotropy and gravity, x y and z contain r theta and phi
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT, &
+! hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! else
+! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! endif
+! endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! if (SIMULATION_TYPE == 3) then
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! else
+! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! endif
+! endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+
+! if(SIMULATION_TYPE == 3) then
+! call compute_stacey_crust_mantle_backward(ichunk, &
+! NSTEP,it,ibool_crust_mantle, &
+! b_accel_crust_mantle, &
+! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+! nimin_crust_mantle,nimax_crust_mantle, &
+! njmin_crust_mantle,njmax_crust_mantle, &
+! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+!! call compute_stacey_crust_mantle(ichunk, &
+!! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
+!! veloc_crust_mantle,b_accel_crust_mantle, &
+!! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+!! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+!! wgllwgll_xz,wgllwgll_yz, &
+!! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+!! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+!! rho_vp_crust_mantle,rho_vs_crust_mantle, &
+!! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+!! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+!! nimin_crust_mantle,nimax_crust_mantle, &
+!! njmin_crust_mantle,njmax_crust_mantle, &
+!! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+!! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+!! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+!! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+!! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+!! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+!! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+!! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+! endif
+
+ endif ! Stacey conditions
+
+ ! add the sources
+ if (SIMULATION_TYPE == 1) &
+ call compute_add_sources(myrank,NSOURCES, &
+ accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! add adjoint sources only if adjoint simulation is performed for source inversion only
+!! DK DK UNDO_ATT this must remain here even when SIMULATION_TYPE == 3 because it applies to array
+!! DK DK UNDO_ATT accel_crust_mantle rather than b_accel_crust_mantle
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ if( nadj_rec_local > 0 ) &
+ call compute_add_sources_adjoint(myrank,nrec, &
+ nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
+ accel_crust_mantle,adj_sourcearrays, &
+ nu,xi_receiver,eta_receiver,gamma_receiver, &
+ xigll,yigll,zigll,ibool_crust_mantle, &
+ islice_selected_rec,ispec_selected_rec, &
+ NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
+ it,it_begin,station_name,network_name,DT)
+ endif
+
+! ! add adjoint sources and add sources for backward/reconstructed wavefield
+! if (SIMULATION_TYPE == 3) &
+! call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+! b_accel_crust_mantle,sourcearrays, &
+! DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+! islice_selected_source,ispec_selected_source,it, &
+! hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! NOISE_TOMOGRAPHY
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+ ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+ ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+ ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+ call add_source_master_rec_noise(myrank,nrec, &
+ NSTEP,accel_crust_mantle,noise_sourcearray, &
+ ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+ it,irec_master_noise)
+ else if ( NOISE_TOMOGRAPHY == 2 ) then
+ ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to drive the ensemble forward wavefield
+ call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
+ ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
+ ! note the ensemble forward sources are generally distributed on the surface of the earth
+ ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
+ ! therefore, we must add it here, before applying the inverse of mass matrix
+! else if ( NOISE_TOMOGRAPHY == 3 ) then
+! ! third step of noise tomography, i.e., read the surface movie saved at every timestep
+! ! use the movie to reconstruct the ensemble forward wavefield
+! ! the ensemble adjoint wavefield is done as usual
+! ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
+! call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
+! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+! ibelm_top_crust_mantle,ibool_crust_mantle, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+! it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_CMB_fluid(displ_crust_mantle, &
+ accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+! if(SIMULATION_TYPE == 3) then
+! call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
+! b_accel_crust_mantle, &
+! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+! b_accel_outer_core, &
+! normal_top_outer_core,jacobian2D_top_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+! RHO_TOP_OC,minus_g_cmb, &
+! NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+! endif
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_ICB_fluid(displ_inner_core, &
+ accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ NSPEC2D_TOP(IREGION_INNER_CORE))
+! if(SIMULATION_TYPE == 3) then
+! call compute_coupling_ICB_fluid(b_displ_inner_core, &
+! b_accel_inner_core, &
+! ibool_inner_core,ibelm_top_inner_core, &
+! b_accel_outer_core, &
+! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+! RHO_BOTTOM_OC,minus_g_icb, &
+! NSPEC2D_TOP(IREGION_INNER_CORE))
+! endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ iphase = 1 ! initialize the non blocking communication counter
+ iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+ enddo
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + two_omega_earth*veloc_crust_mantle(2,i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - two_omega_earth*veloc_crust_mantle(1,i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + two_omega_earth*veloc_crust_mantle(2,i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - two_omega_earth*veloc_crust_mantle(1,i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+! ------------------- new non blocking implementation -------------------
+
+! if (SIMULATION_TYPE == 3) then
+
+! ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+! b_iphase = 1 ! initialize the non blocking communication counter
+! b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+! ! compute internal forces in the solid regions
+
+! ! for anisotropy and gravity, x y and z contain r theta and phi
+
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT, &
+! hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! else
+! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! endif
+
+! ! Deville routine
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! else
+! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+! enddo
+
+! !---
+! !--- use buffers to assemble forces with the central cube
+! !---
+
+! if(INCLUDE_CENTRAL_CUBE) then
+! do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+! call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+! ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+! enddo
+! endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+! if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+! do i=1,NGLOB_CRUST_MANTLE
+! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+! enddo
+
+! else
+
+! do i=1,NGLOB_CRUST_MANTLE
+! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+! enddo
+
+! endif
+
+! endif ! SIMULATION_TYPE == 3
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ call compute_coupling_ocean(accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+! if(SIMULATION_TYPE == 3) then
+! call compute_coupling_ocean(b_accel_crust_mantle, &
+! rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+! rmass_ocean_load,normal_top_crust_mantle, &
+! ibool_crust_mantle,ibelm_top_crust_mantle, &
+! updated_dof_ocean_load,NGLOB_XY, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+! ABSORBING_CONDITIONS)
+! endif
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*veloc_inner_core(2,i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*veloc_inner_core(1,i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+
+! if (SIMULATION_TYPE == 3) then
+! ! mantle
+! do i=1,NGLOB_CRUST_MANTLE
+! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+! enddo
+! ! inner core
+! do i=1,NGLOB_INNER_CORE
+! b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+! + b_two_omega_earth*b_veloc_inner_core(2,i)
+! b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+! - b_two_omega_earth*b_veloc_inner_core(1,i)
+! b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+! enddo
+! endif ! SIMULATION_TYPE == 3
+
+! ! restores last time snapshot saved for backward/reconstruction of wavefields
+! ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+! ! and adjoint sources will become more complicated
+! ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+! if(SIMULATION_TYPE == 3 .and. it == 1) then
+! call read_forward_arrays(myrank, &
+! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+! b_R_memory_crust_mantle,b_R_memory_inner_core, &
+! b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+! b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+! endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 1) then
+ call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ else if (SIMULATION_TYPE == 2) then
+ call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ hxir_store,hetar_store,hgammar_store, &
+ hpxir_store,hpetar_store,hpgammar_store, &
+ tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ moment_der,sloc_der,stshift_der,shdur_der, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+ ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+ NSTEP,it,nit_written)
+
+! else if (SIMULATION_TYPE == 3) then
+! call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+! nu,hxir_store,hetar_store,hgammar_store, &
+! scale_displ,ibool_crust_mantle, &
+! ispec_selected_rec,number_receiver_global, &
+! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+! seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ else ! case of SIMULATION_TYPE == 2
+ if( nrec_local > 0 ) &
+ call write_adj_seismograms(seismograms,number_receiver_global, &
+ nrec_local,it,nit_written,DT, &
+ NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
+ nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+! kernel calculations
+! if (SIMULATION_TYPE == 3) then
+! ! crust mantle
+! call compute_kernels_crust_mantle(ibool_crust_mantle, &
+! rho_kl_crust_mantle,beta_kl_crust_mantle, &
+! alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+! accel_crust_mantle,b_displ_crust_mantle, &
+! epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
+! eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
+! deltat)
+
+! ! outer core
+! call compute_kernels_outer_core(ibool_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! displ_outer_core,accel_outer_core, &
+! b_displ_outer_core,b_accel_outer_core, &
+! vector_accel_outer_core,vector_displ_outer_core, &
+! b_vector_displ_outer_core, &
+! div_displ_outer_core,b_div_displ_outer_core, &
+! rhostore_outer_core,kappavstore_outer_core, &
+! rho_kl_outer_core,alpha_kl_outer_core, &
+! deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+! deltat)
+
+! ! inner core
+! call compute_kernels_inner_core(ibool_inner_core, &
+! rho_kl_inner_core,beta_kl_inner_core, &
+! alpha_kl_inner_core, &
+! accel_inner_core,b_displ_inner_core, &
+! epsilondev_inner_core,b_epsilondev_inner_core, &
+! eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
+! deltat)
+
+! ! NOISE TOMOGRAPHY --- source strength kernel
+! if (NOISE_TOMOGRAPHY == 3) &
+! call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
+! Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
+! normal_x_noise,normal_y_noise,normal_z_noise, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+! ibelm_top_crust_mantle)
+
+! ! --- boundary kernels ------
+! if (SAVE_BOUNDARY_MESH) then
+! fluid_solid_boundary = .false.
+! iregion_code = IREGION_CRUST_MANTLE
+
+! ! Moho
+! if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
+
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
+
+! moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
+! endif
+
+! ! d400
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
+
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
+
+! d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
+
+! ! d670
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
+
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
+
+! d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
+
+! ! CMB
+! fluid_solid_boundary = .true.
+! iregion_code = IREGION_CRUST_MANTLE
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
+! cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
+
+! iregion_code = IREGION_OUTER_CORE
+! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+! b_vector_displ_outer_core,nspec_outer_core, &
+! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core,&
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! k_bot,ibelm_top_outer_core,normal_top_outer_core, &
+! cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
+
+! cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
+
+! ! ICB
+! fluid_solid_boundary = .true.
+! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+! b_vector_displ_outer_core,nspec_outer_core, &
+! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core,&
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
+! icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
+
+! iregion_code = IREGION_INNER_CORE
+! call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
+! b_displ_inner_core,nspec_inner_core,iregion_code, &
+! ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core,&
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+! dummy_array,dummy_array,dummy_array, &
+! c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! c33store_inner_core,dummy_array,dummy_array, &
+! dummy_array,c44store_inner_core,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
+! icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
+
+! icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
+! endif
+
+! ! approximate hessian
+! if( APPROXIMATE_HESS_KL ) then
+! call compute_kernels_hessian(ibool_crust_mantle, &
+! hess_kl_crust_mantle,&
+! accel_crust_mantle,b_accel_crust_mantle, &
+! deltat)
+! endif
+
+! endif ! end of if computing kernels
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! first step of noise tomography, i.e., save a surface movie at every time step
+ ! modified from the subroutine 'write_movie_surface'
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ call noise_save_surface_movie(displ_crust_mantle, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
+ endif
+
+ ! save movie on surface
+ if( MOVIE_SURFACE ) then
+ if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ ! save velocity here to avoid static offset on displacement for movies
+ call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
+ scale_displ,displ_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
+ endif
+ endif
+
+
+ ! save movie in full 3D mesh
+ if(MOVIE_VOLUME ) then
+ if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
+ .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
+
+ if (MOVIE_VOLUME_TYPE == 1) then ! output strains
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
+ ! output the Time Integral of Strain, or \mu*TIS
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
+ call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
+ div_displ_outer_core, &
+ accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
+ eps_trace_over_3_inner_core, &
+ epsilondev_crust_mantle,epsilondev_inner_core, &
+ LOCAL_PATH, &
+ displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
+ accel_crust_mantle,accel_inner_core, &
+ ibool_crust_mantle,ibool_inner_core)
+
+ else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
+ scalingval = scale_displ
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
+ scalingval = scale_veloc
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else
+
+ call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
+
+ endif ! MOVIE_VOLUME_TYPE
+ endif
+ endif ! MOVIE_VOLUME
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,2043 +0,0 @@
-
-!! DK DK
-!! DK DK this should be written in the future, starting from a copy of part1_classical.f90 once part1_classical.f90 is debugged
-!! DK DK
-
-
-!! DK DK
-!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
-!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
-!! DK DK
-
- ! Newmark time scheme update
-
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
-
-! ! backward field
-! if (SIMULATION_TYPE == 3) then
-! ! mantle
-! do i=1,NGLOB_CRUST_MANTLE
-! b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
-! + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
-! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
-! + b_deltatover2*b_accel_crust_mantle(:,i)
-! b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
-! enddo
-! ! outer core
-! do i=1,NGLOB_OUTER_CORE
-! b_displ_outer_core(i) = b_displ_outer_core(i) &
-! + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
-! b_veloc_outer_core(i) = b_veloc_outer_core(i) &
-! + b_deltatover2*b_accel_outer_core(i)
-! b_accel_outer_core(i) = 0._CUSTOM_REAL
-! enddo
-! ! inner core
-! do i=1,NGLOB_INNER_CORE
-! b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
-! + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
-! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
-! + b_deltatover2*b_accel_inner_core(:,i)
-! b_accel_inner_core(:,i) = 0._CUSTOM_REAL
-! enddo
-! endif ! SIMULATION_TYPE == 3
-
- ! integral of strain for adjoint movie volume
- if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
-! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
-! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
- do ispec = 1,NSPEC_CRUST_MANTLE
- Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
- + deltat*epsilondev_crust_mantle(:,:,:,:,ispec)
- Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
- + deltat*eps_trace_over_3_crust_mantle(:,:,:,ispec)
- enddo
- endif
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
- call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
-!!!!! DK DK UNDO_ATT SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- 1,OUTPUT_FILES,time_start,DT,t0,NSTEP, & !!!!! DK DK UNDO_ATT
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
-! if (SIMULATION_TYPE == 3) then
-! call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
-! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
-! SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
-! it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
-! endif
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
-
- iphase = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
-! if (SIMULATION_TYPE == 3) then
-! ! note on backward/reconstructed wavefields:
-! ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
-! ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
-! ! to a time (NSTEP - (it-1) - 1)*DT - t0
-! ! for reconstructing the rotational contributions
-! if(CUSTOM_REAL == SIZE_REAL) then
-! time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
-! else
-! time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
-! endif
-
-! b_iphase = 0 ! do not start any non blocking communications at this stage
-! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! ! uses Deville et al. (2002) routine
-! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! else
-! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! endif
-! endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
- it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
-! if (SIMULATION_TYPE == 3) then
-! call compute_stacey_outer_core_backward(ichunk, &
-! NSTEP,it,ibool_outer_core, &
-! b_accel_outer_core, &
-! ibelm_bottom_outer_core, &
-! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
-! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
-! nimin_outer_core,nimax_outer_core, &
-! njmin_outer_core,njmax_outer_core, &
-! nkmin_xi_outer_core,nkmin_eta_outer_core, &
-! NSPEC2D_BOTTOM, &
-! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
-! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
-! reclen_zmin, &
-! reclen_xmin_outer_core,reclen_xmax_outer_core, &
-! reclen_ymin_outer_core,reclen_ymax_outer_core, &
-! nabs_zmin_oc, &
-! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
-! absorb_zmin_outer_core, &
-! absorb_xmin_outer_core,absorb_xmax_outer_core, &
-! absorb_ymin_outer_core,absorb_ymax_outer_core)
-!! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
-!! NSTEP,it,ibool_outer_core, &
-!! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
-!! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
-!! jacobian2D_bottom_outer_core, &
-!! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
-!! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
-!! ibelm_bottom_outer_core, &
-!! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
-!! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
-!! nimin_outer_core,nimax_outer_core, &
-!! njmin_outer_core,njmax_outer_core, &
-!! nkmin_xi_outer_core,nkmin_eta_outer_core, &
-!! NSPEC2D_BOTTOM, &
-!! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
-!! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
-!! reclen_zmin, &
-!! reclen_xmin_outer_core,reclen_xmax_outer_core, &
-!! reclen_ymin_outer_core,reclen_ymax_outer_core, &
-!! nabs_zmin_oc, &
-!! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
-!! absorb_zmin_outer_core, &
-!! absorb_xmin_outer_core,absorb_xmax_outer_core, &
-!! absorb_ymin_outer_core,absorb_ymax_outer_core)
-! endif
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- call compute_coupling_fluid_CMB(displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- NSPEC2D_TOP(IREGION_OUTER_CORE))
-! if (SIMULATION_TYPE == 3) then
-! call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
-! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
-! b_accel_outer_core, &
-! normal_top_outer_core,jacobian2D_top_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
-! NSPEC2D_TOP(IREGION_OUTER_CORE))
-! endif
- endif
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- call compute_coupling_fluid_ICB(displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-! if (SIMULATION_TYPE == 3) then
-! call compute_coupling_fluid_ICB(b_displ_inner_core, &
-! ibool_inner_core,ibelm_top_inner_core, &
-! b_accel_outer_core, &
-! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
-! NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-! endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
- ! outer core
- iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
- enddo
-
- ! multiply by the inverse of the mass matrix and update velocity
- do i=1,NGLOB_OUTER_CORE
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- enddo
-
-! ------------------- new non blocking implementation -------------------
-
-! if (SIMULATION_TYPE == 3) then
-
-! ! outer core
-! b_iphase = 1 ! start the non blocking communications
-! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-
-! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! ! uses Deville et al. (2002) routine
-! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! else
-! ! div_displ_outer_core is initialized to zero in the following subroutine.
-! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
-! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
-! minus_rho_g_over_kappa_fluid, &
-! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
-! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! is_on_a_slice_edge_outer_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! ibool_outer_core,MOVIE_VOLUME)
-! endif
-
-! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
-! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
-! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
-! iboolfaces_outer_core,iboolcorner_outer_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
-! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-! enddo
-
-! ------------------- new non blocking implementation -------------------
-
-! ! Newmark time scheme - corrector for fluid parts
-! do i=1,NGLOB_OUTER_CORE
-! b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
-! b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
-! enddo
-
-! endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- iphase = 0 ! do not start any non blocking communications at this stage
- iphase_CC = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
-! if (SIMULATION_TYPE == 3 ) then
-
-! b_iphase = 0 ! do not start any non blocking communications at this stage
-! b_iphase_CC = 0 ! do not start any non blocking communications at this stage
-! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
-! ! for anisotropy and gravity, x y and z contain r theta and phi
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT, &
-! hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! else
-! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! endif
-! endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! if (SIMULATION_TYPE == 3) then
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! else
-! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! endif
-! endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- call compute_stacey_crust_mantle_forward(ichunk, &
- it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-
-! if(SIMULATION_TYPE == 3) then
-! call compute_stacey_crust_mantle_backward(ichunk, &
-! NSTEP,it,ibool_crust_mantle, &
-! b_accel_crust_mantle, &
-! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
-! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
-! nimin_crust_mantle,nimax_crust_mantle, &
-! njmin_crust_mantle,njmax_crust_mantle, &
-! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
-! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
-! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
-! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
-! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
-! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
-! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
-! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-!! call compute_stacey_crust_mantle(ichunk, &
-!! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
-!! veloc_crust_mantle,b_accel_crust_mantle, &
-!! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
-!! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
-!! wgllwgll_xz,wgllwgll_yz, &
-!! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
-!! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
-!! rho_vp_crust_mantle,rho_vs_crust_mantle, &
-!! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
-!! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
-!! nimin_crust_mantle,nimax_crust_mantle, &
-!! njmin_crust_mantle,njmax_crust_mantle, &
-!! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
-!! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
-!! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
-!! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
-!! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
-!! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
-!! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
-!! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-! endif
-
- endif ! Stacey conditions
-
- ! add the sources
- if (SIMULATION_TYPE == 1) &
- call compute_add_sources(myrank,NSOURCES, &
- accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! add adjoint sources only if adjoint simulation is performed for source inversion only
-!! DK DK UNDO_ATT this must remain here even when SIMULATION_TYPE == 3 because it applies to array
-!! DK DK UNDO_ATT accel_crust_mantle rather than b_accel_crust_mantle
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- if( nadj_rec_local > 0 ) &
- call compute_add_sources_adjoint(myrank,nrec, &
- nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
- accel_crust_mantle,adj_sourcearrays, &
- nu,xi_receiver,eta_receiver,gamma_receiver, &
- xigll,yigll,zigll,ibool_crust_mantle, &
- islice_selected_rec,ispec_selected_rec, &
- NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
- it,it_begin,station_name,network_name,DT)
- endif
-
-! ! add adjoint sources and add sources for backward/reconstructed wavefield
-! if (SIMULATION_TYPE == 3) &
-! call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
-! b_accel_crust_mantle,sourcearrays, &
-! DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
-! islice_selected_source,ispec_selected_source,it, &
-! hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! NOISE_TOMOGRAPHY
- if ( NOISE_TOMOGRAPHY == 1 ) then
- ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
- ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
- ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
- ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
- call add_source_master_rec_noise(myrank,nrec, &
- NSTEP,accel_crust_mantle,noise_sourcearray, &
- ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
- it,irec_master_noise)
- else if ( NOISE_TOMOGRAPHY == 2 ) then
- ! second step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to drive the ensemble forward wavefield
- call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
- ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
- ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
- ! note the ensemble forward sources are generally distributed on the surface of the earth
- ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
- ! therefore, we must add it here, before applying the inverse of mass matrix
-! else if ( NOISE_TOMOGRAPHY == 3 ) then
-! ! third step of noise tomography, i.e., read the surface movie saved at every timestep
-! ! use the movie to reconstruct the ensemble forward wavefield
-! ! the ensemble adjoint wavefield is done as usual
-! ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
-! call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
-! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
-! ibelm_top_crust_mantle,ibool_crust_mantle, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
-! it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- call compute_coupling_CMB_fluid(displ_crust_mantle, &
- accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-! if(SIMULATION_TYPE == 3) then
-! call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
-! b_accel_crust_mantle, &
-! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
-! b_accel_outer_core, &
-! normal_top_outer_core,jacobian2D_top_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
-! RHO_TOP_OC,minus_g_cmb, &
-! NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-! endif
- endif
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- call compute_coupling_ICB_fluid(displ_inner_core, &
- accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- NSPEC2D_TOP(IREGION_INNER_CORE))
-! if(SIMULATION_TYPE == 3) then
-! call compute_coupling_ICB_fluid(b_displ_inner_core, &
-! b_accel_inner_core, &
-! ibool_inner_core,ibelm_top_inner_core, &
-! b_accel_outer_core, &
-! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
-! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
-! RHO_BOTTOM_OC,minus_g_icb, &
-! NSPEC2D_TOP(IREGION_INNER_CORE))
-! endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- iphase = 1 ! initialize the non blocking communication counter
- iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
- enddo
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
-! ------------------- new non blocking implementation -------------------
-
-! if (SIMULATION_TYPE == 3) then
-
-! ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
-! b_iphase = 1 ! initialize the non blocking communication counter
-! b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
-! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
-! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
-! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
-! ! compute internal forces in the solid regions
-
-! ! for anisotropy and gravity, x y and z contain r theta and phi
-
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT, &
-! hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! else
-! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_crust_mantle,b_accel_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! is_on_a_slice_edge_crust_mantle,b_icall, &
-! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
-! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
-! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
-! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
-! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
-! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-! endif
-
-! ! Deville routine
-! if( USE_DEVILLE_PRODUCTS_VAL ) then
-! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! else
-! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
-! b_displ_inner_core,b_accel_inner_core, &
-! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core, &
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-! is_on_a_slice_edge_inner_core,b_icall, &
-! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
-! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
-! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
-! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
-! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
-! c13store_inner_core,c44store_inner_core, &
-! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
-! one_minus_sum_beta_inner_core, &
-! b_alphaval,b_betaval,b_gammaval, &
-! factor_common_inner_core, &
-! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
-! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-! endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
-! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
-! iproc_xi,iproc_eta,ichunk,addressing, &
-! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
-! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
-! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
-! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
-! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-! iboolfaces_inner_core,iboolcorner_inner_core, &
-! iprocfrom_faces,iprocto_faces, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
-! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
-! NUMMSGS_FACES,NCORNERSCHUNKS, &
-! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
-! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-! enddo
-
-! !---
-! !--- use buffers to assemble forces with the central cube
-! !---
-
-! if(INCLUDE_CENTRAL_CUBE) then
-! do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
-! call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
-! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
-! receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
-! ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
-! enddo
-! endif ! end of assembling forces with the central cube
-
-! ------------------- new non blocking implementation -------------------
-
-! if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
-! do i=1,NGLOB_CRUST_MANTLE
-! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
-! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
-! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
-! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
-! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-! enddo
-
-! else
-
-! do i=1,NGLOB_CRUST_MANTLE
-! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
-! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
-! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
-! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
-! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-! enddo
-
-! endif
-
-! endif ! SIMULATION_TYPE == 3
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) then
- call compute_coupling_ocean(accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
-! if(SIMULATION_TYPE == 3) then
-! call compute_coupling_ocean(b_accel_crust_mantle, &
-! rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
-! rmass_ocean_load,normal_top_crust_mantle, &
-! ibool_crust_mantle,ibelm_top_crust_mantle, &
-! updated_dof_ocean_load,NGLOB_XY, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
-! ABSORBING_CONDITIONS)
-! endif
- endif
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! Newmark time scheme - corrector for elastic parts
-
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
-
-! if (SIMULATION_TYPE == 3) then
-! ! mantle
-! do i=1,NGLOB_CRUST_MANTLE
-! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
-! enddo
-! ! inner core
-! do i=1,NGLOB_INNER_CORE
-! b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
-! + b_two_omega_earth*b_veloc_inner_core(2,i)
-! b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
-! - b_two_omega_earth*b_veloc_inner_core(1,i)
-! b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
-! enddo
-! endif ! SIMULATION_TYPE == 3
-
-! ! restores last time snapshot saved for backward/reconstruction of wavefields
-! ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
-! ! and adjoint sources will become more complicated
-! ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
-! if(SIMULATION_TYPE == 3 .and. it == 1) then
-! call read_forward_arrays(myrank, &
-! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
-! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
-! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
-! b_R_memory_crust_mantle,b_R_memory_inner_core, &
-! b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
-! b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
-! endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
- if (SIMULATION_TYPE == 1) then
- call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- else if (SIMULATION_TYPE == 2) then
- call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- hxir_store,hetar_store,hgammar_store, &
- hpxir_store,hpetar_store,hpgammar_store, &
- tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
- hprime_xx,hprime_yy,hprime_zz, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- moment_der,sloc_der,stshift_der,shdur_der, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
- ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
- NSTEP,it,nit_written)
-
-! else if (SIMULATION_TYPE == 3) then
-! call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
-! nu,hxir_store,hetar_store,hgammar_store, &
-! scale_displ,ibool_crust_mantle, &
-! ispec_selected_rec,number_receiver_global, &
-! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
-! seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
-if(UNDO_ATT_WITH_STORE)then
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- elseif(SIMULATION_TYPE == 2)then ! case of SIMULATION_TYPE == 2
- if( nrec_local > 0 ) &
- call write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT, &
- NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
- nit_written = it
- endif
-!ZN seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-else
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- else ! case of SIMULATION_TYPE == 2
- if( nrec_local > 0 ) &
- call write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT, &
- NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
- nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-! kernel calculations
-! if (SIMULATION_TYPE == 3) then
-! ! crust mantle
-! call compute_kernels_crust_mantle(ibool_crust_mantle, &
-! rho_kl_crust_mantle,beta_kl_crust_mantle, &
-! alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
-! accel_crust_mantle,b_displ_crust_mantle, &
-! epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
-! eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
-! deltat)
-
-! ! outer core
-! call compute_kernels_outer_core(ibool_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core, &
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! displ_outer_core,accel_outer_core, &
-! b_displ_outer_core,b_accel_outer_core, &
-! vector_accel_outer_core,vector_displ_outer_core, &
-! b_vector_displ_outer_core, &
-! div_displ_outer_core,b_div_displ_outer_core, &
-! rhostore_outer_core,kappavstore_outer_core, &
-! rho_kl_outer_core,alpha_kl_outer_core, &
-! deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
-! deltat)
-
-! ! inner core
-! call compute_kernels_inner_core(ibool_inner_core, &
-! rho_kl_inner_core,beta_kl_inner_core, &
-! alpha_kl_inner_core, &
-! accel_inner_core,b_displ_inner_core, &
-! epsilondev_inner_core,b_epsilondev_inner_core, &
-! eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
-! deltat)
-
-! ! NOISE TOMOGRAPHY --- source strength kernel
-! if (NOISE_TOMOGRAPHY == 3) &
-! call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
-! Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
-! normal_x_noise,normal_y_noise,normal_z_noise, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
-! ibelm_top_crust_mantle)
-
-! ! --- boundary kernels ------
-! if (SAVE_BOUNDARY_MESH) then
-! fluid_solid_boundary = .false.
-! iregion_code = IREGION_CRUST_MANTLE
-
-! ! Moho
-! if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
-
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
-
-! moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
-! endif
-
-! ! d400
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
-
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
-
-! d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
-
-! ! d670
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
-
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
-
-! d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
-
-! ! CMB
-! fluid_solid_boundary = .true.
-! iregion_code = IREGION_CRUST_MANTLE
-! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
-! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
-! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
-! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
-! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
-! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
-! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
-! k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
-! cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
-
-! iregion_code = IREGION_OUTER_CORE
-! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
-! b_vector_displ_outer_core,nspec_outer_core, &
-! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core,&
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! k_bot,ibelm_top_outer_core,normal_top_outer_core, &
-! cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
-
-! cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
-
-! ! ICB
-! fluid_solid_boundary = .true.
-! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
-! b_vector_displ_outer_core,nspec_outer_core, &
-! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
-! xix_outer_core,xiy_outer_core,xiz_outer_core, &
-! etax_outer_core,etay_outer_core,etaz_outer_core,&
-! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
-! icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
-
-! iregion_code = IREGION_INNER_CORE
-! call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
-! b_displ_inner_core,nspec_inner_core,iregion_code, &
-! ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
-! xix_inner_core,xiy_inner_core,xiz_inner_core, &
-! etax_inner_core,etay_inner_core,etaz_inner_core,&
-! gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
-! rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
-! dummy_array,dummy_array,dummy_array, &
-! c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array,dummy_array, &
-! c33store_inner_core,dummy_array,dummy_array, &
-! dummy_array,c44store_inner_core,dummy_array,dummy_array, &
-! dummy_array,dummy_array,dummy_array, &
-! k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
-! icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
-
-! icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
-! endif
-
-! ! approximate hessian
-! if( APPROXIMATE_HESS_KL ) then
-! call compute_kernels_hessian(ibool_crust_mantle, &
-! hess_kl_crust_mantle,&
-! accel_crust_mantle,b_accel_crust_mantle, &
-! deltat)
-! endif
-
-! endif ! end of if computing kernels
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! first step of noise tomography, i.e., save a surface movie at every time step
- ! modified from the subroutine 'write_movie_surface'
- if ( NOISE_TOMOGRAPHY == 1 ) then
- call noise_save_surface_movie(displ_crust_mantle, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
- endif
-
- ! save movie on surface
- if( MOVIE_SURFACE ) then
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- ! save velocity here to avoid static offset on displacement for movies
- call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
- scale_displ,displ_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
- endif
- endif
-
-
- ! save movie in full 3D mesh
- if(MOVIE_VOLUME ) then
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- if (MOVIE_VOLUME_TYPE == 1) then ! output strains
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
- ! output the Time Integral of Strain, or \mu*TIS
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
- call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- div_displ_outer_core, &
- accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
- eps_trace_over_3_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- LOCAL_PATH, &
- displ_crust_mantle,displ_inner_core,displ_outer_core, &
- veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
- accel_crust_mantle,accel_inner_core, &
- ibool_crust_mantle,ibool_inner_core)
-
- else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
- scalingval = scale_displ
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
- scalingval = scale_veloc
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else
-
- call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
-
- endif ! MOVIE_VOLUME_TYPE
- endif
- endif ! MOVIE_VOLUME
-
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part1_undo_att.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,2043 @@
+
+!! DK DK
+!! DK DK this should be written in the future, starting from a copy of part1_classical.f90 once part1_classical.f90 is debugged
+!! DK DK
+
+
+!! DK DK
+!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
+!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ + deltatover2*accel_crust_mantle(:,i)
+ accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ displ_outer_core(i) = displ_outer_core(i) &
+ + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) &
+ + deltatover2*accel_outer_core(i)
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ displ_inner_core(:,i) = displ_inner_core(:,i) &
+ + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ + deltatover2*accel_inner_core(:,i)
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+
+! ! backward field
+! if (SIMULATION_TYPE == 3) then
+! ! mantle
+! do i=1,NGLOB_CRUST_MANTLE
+! b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+! + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+! + b_deltatover2*b_accel_crust_mantle(:,i)
+! b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+! enddo
+! ! outer core
+! do i=1,NGLOB_OUTER_CORE
+! b_displ_outer_core(i) = b_displ_outer_core(i) &
+! + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+! b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+! + b_deltatover2*b_accel_outer_core(i)
+! b_accel_outer_core(i) = 0._CUSTOM_REAL
+! enddo
+! ! inner core
+! do i=1,NGLOB_INNER_CORE
+! b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+! + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+! + b_deltatover2*b_accel_inner_core(:,i)
+! b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+! enddo
+! endif ! SIMULATION_TYPE == 3
+
+ ! integral of strain for adjoint movie volume
+ if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
+! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
+! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
+ + deltat*epsilondev_crust_mantle(:,:,:,:,ispec)
+ Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
+ + deltat*eps_trace_over_3_crust_mantle(:,:,:,ispec)
+ enddo
+ endif
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+!!!!! DK DK UNDO_ATT SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ 1,OUTPUT_FILES,time_start,DT,t0,NSTEP, & !!!!! DK DK UNDO_ATT
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+! if (SIMULATION_TYPE == 3) then
+! call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+! SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+! it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+! endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT-t0)*scale_t_inv
+ endif
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+! if (SIMULATION_TYPE == 3) then
+! ! note on backward/reconstructed wavefields:
+! ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+! ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+! ! to a time (NSTEP - (it-1) - 1)*DT - t0
+! ! for reconstructing the rotational contributions
+! if(CUSTOM_REAL == SIZE_REAL) then
+! time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+! else
+! time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+! endif
+
+! b_iphase = 0 ! do not start any non blocking communications at this stage
+! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! ! uses Deville et al. (2002) routine
+! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! else
+! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! endif
+! endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+! if (SIMULATION_TYPE == 3) then
+! call compute_stacey_outer_core_backward(ichunk, &
+! NSTEP,it,ibool_outer_core, &
+! b_accel_outer_core, &
+! ibelm_bottom_outer_core, &
+! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+! nimin_outer_core,nimax_outer_core, &
+! njmin_outer_core,njmax_outer_core, &
+! nkmin_xi_outer_core,nkmin_eta_outer_core, &
+! NSPEC2D_BOTTOM, &
+! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+! reclen_zmin, &
+! reclen_xmin_outer_core,reclen_xmax_outer_core, &
+! reclen_ymin_outer_core,reclen_ymax_outer_core, &
+! nabs_zmin_oc, &
+! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+! absorb_zmin_outer_core, &
+! absorb_xmin_outer_core,absorb_xmax_outer_core, &
+! absorb_ymin_outer_core,absorb_ymax_outer_core)
+!! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+!! NSTEP,it,ibool_outer_core, &
+!! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+!! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+!! jacobian2D_bottom_outer_core, &
+!! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+!! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+!! ibelm_bottom_outer_core, &
+!! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+!! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+!! nimin_outer_core,nimax_outer_core, &
+!! njmin_outer_core,njmax_outer_core, &
+!! nkmin_xi_outer_core,nkmin_eta_outer_core, &
+!! NSPEC2D_BOTTOM, &
+!! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+!! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+!! reclen_zmin, &
+!! reclen_xmin_outer_core,reclen_xmax_outer_core, &
+!! reclen_ymin_outer_core,reclen_ymax_outer_core, &
+!! nabs_zmin_oc, &
+!! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+!! absorb_zmin_outer_core, &
+!! absorb_xmin_outer_core,absorb_xmax_outer_core, &
+!! absorb_ymin_outer_core,absorb_ymax_outer_core)
+! endif
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_fluid_CMB(displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+! if (SIMULATION_TYPE == 3) then
+! call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
+! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+! b_accel_outer_core, &
+! normal_top_outer_core,jacobian2D_top_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+! NSPEC2D_TOP(IREGION_OUTER_CORE))
+! endif
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_fluid_ICB(displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+! if (SIMULATION_TYPE == 3) then
+! call compute_coupling_fluid_ICB(b_displ_inner_core, &
+! ibool_inner_core,ibelm_top_inner_core, &
+! b_accel_outer_core, &
+! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+! NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+! endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+ ! outer core
+ iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+ enddo
+
+ ! multiply by the inverse of the mass matrix and update velocity
+ do i=1,NGLOB_OUTER_CORE
+ accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+! if (SIMULATION_TYPE == 3) then
+
+! ! outer core
+! b_iphase = 1 ! start the non blocking communications
+! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+
+! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! ! uses Deville et al. (2002) routine
+! call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! else
+! ! div_displ_outer_core is initialized to zero in the following subroutine.
+! call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+! b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+! minus_rho_g_over_kappa_fluid, &
+! b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+! xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! is_on_a_slice_edge_outer_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! ibool_outer_core,MOVIE_VOLUME)
+! endif
+
+! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+! call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+! npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+! iboolfaces_outer_core,iboolcorner_outer_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+! NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+! enddo
+
+! ------------------- new non blocking implementation -------------------
+
+! ! Newmark time scheme - corrector for fluid parts
+! do i=1,NGLOB_OUTER_CORE
+! b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+! b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+! enddo
+
+! endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ iphase_CC = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+! if (SIMULATION_TYPE == 3 ) then
+
+! b_iphase = 0 ! do not start any non blocking communications at this stage
+! b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+! b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+! ! for anisotropy and gravity, x y and z contain r theta and phi
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT, &
+! hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! else
+! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! endif
+! endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! if (SIMULATION_TYPE == 3) then
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! else
+! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! endif
+! endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+
+! if(SIMULATION_TYPE == 3) then
+! call compute_stacey_crust_mantle_backward(ichunk, &
+! NSTEP,it,ibool_crust_mantle, &
+! b_accel_crust_mantle, &
+! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+! nimin_crust_mantle,nimax_crust_mantle, &
+! njmin_crust_mantle,njmax_crust_mantle, &
+! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+!! call compute_stacey_crust_mantle(ichunk, &
+!! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
+!! veloc_crust_mantle,b_accel_crust_mantle, &
+!! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+!! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+!! wgllwgll_xz,wgllwgll_yz, &
+!! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+!! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+!! rho_vp_crust_mantle,rho_vs_crust_mantle, &
+!! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+!! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+!! nimin_crust_mantle,nimax_crust_mantle, &
+!! njmin_crust_mantle,njmax_crust_mantle, &
+!! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+!! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+!! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+!! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+!! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+!! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+!! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+!! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+! endif
+
+ endif ! Stacey conditions
+
+ ! add the sources
+ if (SIMULATION_TYPE == 1) &
+ call compute_add_sources(myrank,NSOURCES, &
+ accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! add adjoint sources only if adjoint simulation is performed for source inversion only
+!! DK DK UNDO_ATT this must remain here even when SIMULATION_TYPE == 3 because it applies to array
+!! DK DK UNDO_ATT accel_crust_mantle rather than b_accel_crust_mantle
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ if( nadj_rec_local > 0 ) &
+ call compute_add_sources_adjoint(myrank,nrec, &
+ nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
+ accel_crust_mantle,adj_sourcearrays, &
+ nu,xi_receiver,eta_receiver,gamma_receiver, &
+ xigll,yigll,zigll,ibool_crust_mantle, &
+ islice_selected_rec,ispec_selected_rec, &
+ NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
+ it,it_begin,station_name,network_name,DT)
+ endif
+
+! ! add adjoint sources and add sources for backward/reconstructed wavefield
+! if (SIMULATION_TYPE == 3) &
+! call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+! b_accel_crust_mantle,sourcearrays, &
+! DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+! islice_selected_source,ispec_selected_source,it, &
+! hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! NOISE_TOMOGRAPHY
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+ ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+ ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+ ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+ call add_source_master_rec_noise(myrank,nrec, &
+ NSTEP,accel_crust_mantle,noise_sourcearray, &
+ ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+ it,irec_master_noise)
+ else if ( NOISE_TOMOGRAPHY == 2 ) then
+ ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to drive the ensemble forward wavefield
+ call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
+ ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
+ ! note the ensemble forward sources are generally distributed on the surface of the earth
+ ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
+ ! therefore, we must add it here, before applying the inverse of mass matrix
+! else if ( NOISE_TOMOGRAPHY == 3 ) then
+! ! third step of noise tomography, i.e., read the surface movie saved at every timestep
+! ! use the movie to reconstruct the ensemble forward wavefield
+! ! the ensemble adjoint wavefield is done as usual
+! ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
+! call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
+! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+! ibelm_top_crust_mantle,ibool_crust_mantle, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+! it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_CMB_fluid(displ_crust_mantle, &
+ accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+! if(SIMULATION_TYPE == 3) then
+! call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
+! b_accel_crust_mantle, &
+! ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+! b_accel_outer_core, &
+! normal_top_outer_core,jacobian2D_top_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+! RHO_TOP_OC,minus_g_cmb, &
+! NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+! endif
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_ICB_fluid(displ_inner_core, &
+ accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ NSPEC2D_TOP(IREGION_INNER_CORE))
+! if(SIMULATION_TYPE == 3) then
+! call compute_coupling_ICB_fluid(b_displ_inner_core, &
+! b_accel_inner_core, &
+! ibool_inner_core,ibelm_top_inner_core, &
+! b_accel_outer_core, &
+! normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+! wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+! RHO_BOTTOM_OC,minus_g_icb, &
+! NSPEC2D_TOP(IREGION_INNER_CORE))
+! endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ iphase = 1 ! initialize the non blocking communication counter
+ iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+ enddo
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + two_omega_earth*veloc_crust_mantle(2,i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - two_omega_earth*veloc_crust_mantle(1,i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + two_omega_earth*veloc_crust_mantle(2,i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - two_omega_earth*veloc_crust_mantle(1,i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+! ------------------- new non blocking implementation -------------------
+
+! if (SIMULATION_TYPE == 3) then
+
+! ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+! b_iphase = 1 ! initialize the non blocking communication counter
+! b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+! b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+! ! compute internal forces in the solid regions
+
+! ! for anisotropy and gravity, x y and z contain r theta and phi
+
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT, &
+! hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! else
+! call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_crust_mantle,b_accel_crust_mantle, &
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! is_on_a_slice_edge_crust_mantle,b_icall, &
+! b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+! muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+! b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+! b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+! size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+! size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+! endif
+
+! ! Deville routine
+! if( USE_DEVILLE_PRODUCTS_VAL ) then
+! call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! else
+! call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+! b_displ_inner_core,b_accel_inner_core, &
+! xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core, &
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+! is_on_a_slice_edge_inner_core,b_icall, &
+! b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+! myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+! nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+! hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+! kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+! c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+! c13store_inner_core,c44store_inner_core, &
+! b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+! one_minus_sum_beta_inner_core, &
+! b_alphaval,b_betaval,b_gammaval, &
+! factor_common_inner_core, &
+! size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+! size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+! endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+! do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+! call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+! iproc_xi,iproc_eta,ichunk,addressing, &
+! iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+! npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+! iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+! iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+! npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+! iboolfaces_inner_core,iboolcorner_inner_core, &
+! iprocfrom_faces,iprocto_faces, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+! b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+! NUMMSGS_FACES,NCORNERSCHUNKS, &
+! NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+! NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+! enddo
+
+! !---
+! !--- use buffers to assemble forces with the central cube
+! !---
+
+! if(INCLUDE_CENTRAL_CUBE) then
+! do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+! call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+! npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+! receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+! ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+! enddo
+! endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+! if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+! do i=1,NGLOB_CRUST_MANTLE
+! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+! enddo
+
+! else
+
+! do i=1,NGLOB_CRUST_MANTLE
+! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+! enddo
+
+! endif
+
+! endif ! SIMULATION_TYPE == 3
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ call compute_coupling_ocean(accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+! if(SIMULATION_TYPE == 3) then
+! call compute_coupling_ocean(b_accel_crust_mantle, &
+! rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+! rmass_ocean_load,normal_top_crust_mantle, &
+! ibool_crust_mantle,ibelm_top_crust_mantle, &
+! updated_dof_ocean_load,NGLOB_XY, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+! ABSORBING_CONDITIONS)
+! endif
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*veloc_inner_core(2,i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*veloc_inner_core(1,i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+
+! if (SIMULATION_TYPE == 3) then
+! ! mantle
+! do i=1,NGLOB_CRUST_MANTLE
+! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+! enddo
+! ! inner core
+! do i=1,NGLOB_INNER_CORE
+! b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+! + b_two_omega_earth*b_veloc_inner_core(2,i)
+! b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+! - b_two_omega_earth*b_veloc_inner_core(1,i)
+! b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+! enddo
+! endif ! SIMULATION_TYPE == 3
+
+! ! restores last time snapshot saved for backward/reconstruction of wavefields
+! ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+! ! and adjoint sources will become more complicated
+! ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+! if(SIMULATION_TYPE == 3 .and. it == 1) then
+! call read_forward_arrays(myrank, &
+! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+! b_R_memory_crust_mantle,b_R_memory_inner_core, &
+! b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+! b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+! endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 1) then
+ call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ else if (SIMULATION_TYPE == 2) then
+ call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ hxir_store,hetar_store,hgammar_store, &
+ hpxir_store,hpetar_store,hpgammar_store, &
+ tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ moment_der,sloc_der,stshift_der,shdur_der, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+ ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+ NSTEP,it,nit_written)
+
+! else if (SIMULATION_TYPE == 3) then
+! call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+! nu,hxir_store,hetar_store,hgammar_store, &
+! scale_displ,ibool_crust_mantle, &
+! ispec_selected_rec,number_receiver_global, &
+! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+! seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+if(UNDO_ATT_WITH_STORE)then
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ elseif(SIMULATION_TYPE == 2)then ! case of SIMULATION_TYPE == 2
+ if( nrec_local > 0 ) &
+ call write_adj_seismograms(seismograms,number_receiver_global, &
+ nrec_local,it,nit_written,DT, &
+ NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
+ nit_written = it
+ endif
+!ZN seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+else
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ else ! case of SIMULATION_TYPE == 2
+ if( nrec_local > 0 ) &
+ call write_adj_seismograms(seismograms,number_receiver_global, &
+ nrec_local,it,nit_written,DT, &
+ NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
+ nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+! kernel calculations
+! if (SIMULATION_TYPE == 3) then
+! ! crust mantle
+! call compute_kernels_crust_mantle(ibool_crust_mantle, &
+! rho_kl_crust_mantle,beta_kl_crust_mantle, &
+! alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+! accel_crust_mantle,b_displ_crust_mantle, &
+! epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
+! eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
+! deltat)
+
+! ! outer core
+! call compute_kernels_outer_core(ibool_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core, &
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! displ_outer_core,accel_outer_core, &
+! b_displ_outer_core,b_accel_outer_core, &
+! vector_accel_outer_core,vector_displ_outer_core, &
+! b_vector_displ_outer_core, &
+! div_displ_outer_core,b_div_displ_outer_core, &
+! rhostore_outer_core,kappavstore_outer_core, &
+! rho_kl_outer_core,alpha_kl_outer_core, &
+! deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+! deltat)
+
+! ! inner core
+! call compute_kernels_inner_core(ibool_inner_core, &
+! rho_kl_inner_core,beta_kl_inner_core, &
+! alpha_kl_inner_core, &
+! accel_inner_core,b_displ_inner_core, &
+! epsilondev_inner_core,b_epsilondev_inner_core, &
+! eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
+! deltat)
+
+! ! NOISE TOMOGRAPHY --- source strength kernel
+! if (NOISE_TOMOGRAPHY == 3) &
+! call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
+! Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
+! normal_x_noise,normal_y_noise,normal_z_noise, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+! ibelm_top_crust_mantle)
+
+! ! --- boundary kernels ------
+! if (SAVE_BOUNDARY_MESH) then
+! fluid_solid_boundary = .false.
+! iregion_code = IREGION_CRUST_MANTLE
+
+! ! Moho
+! if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
+
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
+
+! moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
+! endif
+
+! ! d400
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
+
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
+
+! d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
+
+! ! d670
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
+
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
+
+! d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
+
+! ! CMB
+! fluid_solid_boundary = .true.
+! iregion_code = IREGION_CRUST_MANTLE
+! call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+! b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+! ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+! c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+! c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+! c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+! c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+! k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
+! cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
+
+! iregion_code = IREGION_OUTER_CORE
+! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+! b_vector_displ_outer_core,nspec_outer_core, &
+! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core,&
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! k_bot,ibelm_top_outer_core,normal_top_outer_core, &
+! cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
+
+! cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
+
+! ! ICB
+! fluid_solid_boundary = .true.
+! call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+! b_vector_displ_outer_core,nspec_outer_core, &
+! iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+! xix_outer_core,xiy_outer_core,xiz_outer_core, &
+! etax_outer_core,etay_outer_core,etaz_outer_core,&
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
+! icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
+
+! iregion_code = IREGION_INNER_CORE
+! call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
+! b_displ_inner_core,nspec_inner_core,iregion_code, &
+! ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
+! xix_inner_core,xiy_inner_core,xiz_inner_core, &
+! etax_inner_core,etay_inner_core,etaz_inner_core,&
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
+! rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+! dummy_array,dummy_array,dummy_array, &
+! c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array,dummy_array, &
+! c33store_inner_core,dummy_array,dummy_array, &
+! dummy_array,c44store_inner_core,dummy_array,dummy_array, &
+! dummy_array,dummy_array,dummy_array, &
+! k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
+! icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
+
+! icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
+! endif
+
+! ! approximate hessian
+! if( APPROXIMATE_HESS_KL ) then
+! call compute_kernels_hessian(ibool_crust_mantle, &
+! hess_kl_crust_mantle,&
+! accel_crust_mantle,b_accel_crust_mantle, &
+! deltat)
+! endif
+
+! endif ! end of if computing kernels
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! first step of noise tomography, i.e., save a surface movie at every time step
+ ! modified from the subroutine 'write_movie_surface'
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ call noise_save_surface_movie(displ_crust_mantle, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
+ endif
+
+ ! save movie on surface
+ if( MOVIE_SURFACE ) then
+ if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ ! save velocity here to avoid static offset on displacement for movies
+ call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
+ scale_displ,displ_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
+ endif
+ endif
+
+
+ ! save movie in full 3D mesh
+ if(MOVIE_VOLUME ) then
+ if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
+ .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
+
+ if (MOVIE_VOLUME_TYPE == 1) then ! output strains
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
+ ! output the Time Integral of Strain, or \mu*TIS
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
+ call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
+ div_displ_outer_core, &
+ accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
+ eps_trace_over_3_inner_core, &
+ epsilondev_crust_mantle,epsilondev_inner_core, &
+ LOCAL_PATH, &
+ displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
+ accel_crust_mantle,accel_inner_core, &
+ ibool_crust_mantle,ibool_inner_core)
+
+ else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
+ scalingval = scale_displ
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
+ scalingval = scale_veloc
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else
+
+ call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
+
+ endif ! MOVIE_VOLUME_TYPE
+ endif
+ endif ! MOVIE_VOLUME
+
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,979 +0,0 @@
-
-!! DK DK
-!! DK DK this first part handles the case SIMULATION_TYPE == 3
-!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
-!! DK DK
-
- ! Newmark time scheme update
-
- ! backward field
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif ! SIMULATION_TYPE == 3
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
- if (SIMULATION_TYPE == 3) then
- call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
- endif
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
-
- if (SIMULATION_TYPE == 3) then
- ! note on backward/reconstructed wavefields:
- ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
- ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
- ! to a time (NSTEP - (it-1) - 1)*DT - t0
- ! for reconstructing the rotational contributions
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
- else
- time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
- endif
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
- endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- if (SIMULATION_TYPE == 3) then
- call compute_stacey_outer_core_backward(ichunk, &
- NSTEP,it,ibool_outer_core, &
- b_accel_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
-! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
-! NSTEP,it,ibool_outer_core, &
-! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
-! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
-! jacobian2D_bottom_outer_core, &
-! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
-! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
-! ibelm_bottom_outer_core, &
-! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
-! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
-! nimin_outer_core,nimax_outer_core, &
-! njmin_outer_core,njmax_outer_core, &
-! nkmin_xi_outer_core,nkmin_eta_outer_core, &
-! NSPEC2D_BOTTOM, &
-! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
-! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
-! reclen_zmin, &
-! reclen_xmin_outer_core,reclen_xmax_outer_core, &
-! reclen_ymin_outer_core,reclen_ymax_outer_core, &
-! nabs_zmin_oc, &
-! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
-! absorb_zmin_outer_core, &
-! absorb_xmin_outer_core,absorb_xmax_outer_core, &
-! absorb_ymin_outer_core,absorb_ymax_outer_core)
- endif
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- if (SIMULATION_TYPE == 3) then
- call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- NSPEC2D_TOP(IREGION_OUTER_CORE))
- endif
- endif
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- if (SIMULATION_TYPE == 3) then
- call compute_coupling_fluid_ICB(b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
- endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! ------------------- new non blocking implementation -------------------
-
- if (SIMULATION_TYPE == 3) then
-
- ! outer core
- b_iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
- enddo
-
-! ------------------- new non blocking implementation -------------------
-
- ! Newmark time scheme - corrector for fluid parts
- do i=1,NGLOB_OUTER_CORE
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
- enddo
-
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if (SIMULATION_TYPE == 3 ) then
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_iphase_CC = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
- endif
-
- if (SIMULATION_TYPE == 3) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
- endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- if(SIMULATION_TYPE == 3) then
- call compute_stacey_crust_mantle_backward(ichunk, &
- NSTEP,it,ibool_crust_mantle, &
- b_accel_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-! call compute_stacey_crust_mantle(ichunk, &
-! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
-! veloc_crust_mantle,b_accel_crust_mantle, &
-! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
-! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
-! wgllwgll_xz,wgllwgll_yz, &
-! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
-! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
-! rho_vp_crust_mantle,rho_vs_crust_mantle, &
-! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
-! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
-! nimin_crust_mantle,nimax_crust_mantle, &
-! njmin_crust_mantle,njmax_crust_mantle, &
-! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
-! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
-! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
-! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
-! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
-! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
-! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
-! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
- endif
- endif ! Stacey conditions
-
- ! add adjoint sources and add sources for backward/reconstructed wavefield
- if (SIMULATION_TYPE == 3) &
- call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! NOISE_TOMOGRAPHY
-! if ( NOISE_TOMOGRAPHY == 1 ) then
-! ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
-! ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
-! ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
-! ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
-! call add_source_master_rec_noise(myrank,nrec, &
-! NSTEP,accel_crust_mantle,noise_sourcearray, &
-! ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
-! it,irec_master_noise)
-! else if ( NOISE_TOMOGRAPHY == 2 ) then
-! ! second step of noise tomography, i.e., read the surface movie saved at every timestep
-! ! use the movie to drive the ensemble forward wavefield
-! call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
-! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
-! ibelm_top_crust_mantle,ibool_crust_mantle, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
-! NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
-! ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
-! ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
-! ! note the ensemble forward sources are generally distributed on the surface of the earth
-! ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
-! ! therefore, we must add it here, before applying the inverse of mass matrix
-! else
- if ( NOISE_TOMOGRAPHY == 3 ) then
- ! third step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to reconstruct the ensemble forward wavefield
- ! the ensemble adjoint wavefield is done as usual
- ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
- call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- if(SIMULATION_TYPE == 3) then
- call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
- b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
- endif
- endif
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- if(SIMULATION_TYPE == 3) then
- call compute_coupling_ICB_fluid(b_displ_inner_core, &
- b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- NSPEC2D_TOP(IREGION_INNER_CORE))
- endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
-! ------------------- new non blocking implementation -------------------
-
- if (SIMULATION_TYPE == 3) then
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- b_iphase = 1 ! initialize the non blocking communication counter
- b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
- enddo
-
-! !---
-! !--- use buffers to assemble forces with the central cube
-! !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
-! ------------------- new non blocking implementation -------------------
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
- endif ! SIMULATION_TYPE == 3
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) then
- if(SIMULATION_TYPE == 3) then
- call compute_coupling_ocean(b_accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
- endif
- endif
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! Newmark time scheme - corrector for elastic parts
-
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + b_two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - b_two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
- enddo
- endif ! SIMULATION_TYPE == 3
-
- ! restores last time snapshot saved for backward/reconstruction of wavefields
- ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
- ! and adjoint sources will become more complicated
- ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
- if(SIMULATION_TYPE == 3 .and. it == 1) then
- call read_forward_arrays(myrank, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
- endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
-! if (SIMULATION_TYPE == 1) then
-! call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
-! nu,hxir_store,hetar_store,hgammar_store, &
-! scale_displ,ibool_crust_mantle, &
-! ispec_selected_rec,number_receiver_global, &
-! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
-! seismograms)
-
-! else if (SIMULATION_TYPE == 2) then
-! call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
-! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
-! nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
-! hxir_store,hetar_store,hgammar_store, &
-! hpxir_store,hpetar_store,hpgammar_store, &
-! tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! moment_der,sloc_der,stshift_der,shdur_der, &
-! NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
-! ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
-! NSTEP,it,nit_written)
-
-! else
- if (SIMULATION_TYPE == 3) then
- call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
-! else ! case of SIMULATION_TYPE == 2
-! if( nrec_local > 0 ) &
-! call write_adj_seismograms(seismograms,number_receiver_global, &
-! nrec_local,it,nit_written,DT, &
-! NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
-! nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_classical.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,979 @@
+
+!! DK DK
+!! DK DK this first part handles the case SIMULATION_TYPE == 3
+!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! backward field
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + b_deltatover2*b_accel_outer_core(i)
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + b_deltatover2*b_accel_inner_core(:,i)
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ if (SIMULATION_TYPE == 3) then
+ call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+
+ if (SIMULATION_TYPE == 3) then
+ ! note on backward/reconstructed wavefields:
+ ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+ ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+ ! to a time (NSTEP - (it-1) - 1)*DT - t0
+ ! for reconstructing the rotational contributions
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+ endif
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_stacey_outer_core_backward(ichunk, &
+ NSTEP,it,ibool_outer_core, &
+ b_accel_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+! NSTEP,it,ibool_outer_core, &
+! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+! jacobian2D_bottom_outer_core, &
+! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+! ibelm_bottom_outer_core, &
+! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+! nimin_outer_core,nimax_outer_core, &
+! njmin_outer_core,njmax_outer_core, &
+! nkmin_xi_outer_core,nkmin_eta_outer_core, &
+! NSPEC2D_BOTTOM, &
+! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+! reclen_zmin, &
+! reclen_xmin_outer_core,reclen_xmax_outer_core, &
+! reclen_ymin_outer_core,reclen_ymax_outer_core, &
+! nabs_zmin_oc, &
+! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+! absorb_zmin_outer_core, &
+! absorb_xmin_outer_core,absorb_xmax_outer_core, &
+! absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+ endif
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_coupling_fluid_ICB(b_displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! outer core
+ b_iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+ ! Newmark time scheme - corrector for fluid parts
+ do i=1,NGLOB_OUTER_CORE
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+ enddo
+
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if (SIMULATION_TYPE == 3 ) then
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_stacey_crust_mantle_backward(ichunk, &
+ NSTEP,it,ibool_crust_mantle, &
+ b_accel_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+! call compute_stacey_crust_mantle(ichunk, &
+! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
+! veloc_crust_mantle,b_accel_crust_mantle, &
+! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+! wgllwgll_xz,wgllwgll_yz, &
+! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+! rho_vp_crust_mantle,rho_vs_crust_mantle, &
+! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+! nimin_crust_mantle,nimax_crust_mantle, &
+! njmin_crust_mantle,njmax_crust_mantle, &
+! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+ endif
+ endif ! Stacey conditions
+
+ ! add adjoint sources and add sources for backward/reconstructed wavefield
+ if (SIMULATION_TYPE == 3) &
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! NOISE_TOMOGRAPHY
+! if ( NOISE_TOMOGRAPHY == 1 ) then
+! ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+! ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+! ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+! ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+! call add_source_master_rec_noise(myrank,nrec, &
+! NSTEP,accel_crust_mantle,noise_sourcearray, &
+! ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+! it,irec_master_noise)
+! else if ( NOISE_TOMOGRAPHY == 2 ) then
+! ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+! ! use the movie to drive the ensemble forward wavefield
+! call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
+! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+! ibelm_top_crust_mantle,ibool_crust_mantle, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+! NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
+! ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
+! ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
+! ! note the ensemble forward sources are generally distributed on the surface of the earth
+! ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
+! ! therefore, we must add it here, before applying the inverse of mass matrix
+! else
+ if ( NOISE_TOMOGRAPHY == 3 ) then
+ ! third step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to reconstruct the ensemble forward wavefield
+ ! the ensemble adjoint wavefield is done as usual
+ ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
+ call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
+ b_accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+ endif
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_ICB_fluid(b_displ_inner_core, &
+ b_accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ NSPEC2D_TOP(IREGION_INNER_CORE))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ b_iphase = 1 ! initialize the non blocking communication counter
+ b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+ enddo
+
+! !---
+! !--- use buffers to assemble forces with the central cube
+! !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+ endif ! SIMULATION_TYPE == 3
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_ocean(b_accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! restores last time snapshot saved for backward/reconstruction of wavefields
+ ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+ ! and adjoint sources will become more complicated
+ ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+ if(SIMULATION_TYPE == 3 .and. it == 1) then
+ call read_forward_arrays(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+ endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+! if (SIMULATION_TYPE == 1) then
+! call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+! nu,hxir_store,hetar_store,hgammar_store, &
+! scale_displ,ibool_crust_mantle, &
+! ispec_selected_rec,number_receiver_global, &
+! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+! seismograms)
+
+! else if (SIMULATION_TYPE == 2) then
+! call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+! nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+! hxir_store,hetar_store,hgammar_store, &
+! hpxir_store,hpetar_store,hpgammar_store, &
+! tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! moment_der,sloc_der,stshift_der,shdur_der, &
+! NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+! ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+! NSTEP,it,nit_written)
+
+! else
+ if (SIMULATION_TYPE == 3) then
+ call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+! else ! case of SIMULATION_TYPE == 2
+! if( nrec_local > 0 ) &
+! call write_adj_seismograms(seismograms,number_receiver_global, &
+! nrec_local,it,nit_written,DT, &
+! NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
+! nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,1061 +0,0 @@
-
-!! DK DK
-!! DK DK this first part handles the case SIMULATION_TYPE == 3
-!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
-!! DK DK
-
- ! Newmark time scheme update
-
- ! backward field
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif ! SIMULATION_TYPE == 3
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
- if (SIMULATION_TYPE == 3) then
- call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
- endif
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
-
- if (SIMULATION_TYPE == 3) then
- ! note on backward/reconstructed wavefields:
- ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
- ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
- ! to a time (NSTEP - (it-1) - 1)*DT - t0
- ! for reconstructing the rotational contributions
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
-if(UNDO_ATT_WITH_STORE)then
- time = sngl((dble(NSTEP-(iteration_on_subset*NT_DUMP-it_of_this_subset+1))*DT-t0)*scale_t_inv)
-endif
- else
- time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
-if(UNDO_ATT_WITH_STORE)then
- time = (dble(NSTEP-(iteration_on_subset*NT_DUMP-it_of_this_subset+1))*DT-t0)*scale_t_inv
-endif
- endif
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
- endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- if (SIMULATION_TYPE == 3) then
-if(UNDO_ATT_WITH_STORE)then
- call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
- it,ibool_outer_core, &
- b_veloc_outer_core,b_accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
-else
- call compute_stacey_outer_core_backward(ichunk, &
- NSTEP,it,ibool_outer_core, &
- b_accel_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
-endif
-! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
-! NSTEP,it,ibool_outer_core, &
-! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
-! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
-! jacobian2D_bottom_outer_core, &
-! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
-! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
-! ibelm_bottom_outer_core, &
-! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
-! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
-! nimin_outer_core,nimax_outer_core, &
-! njmin_outer_core,njmax_outer_core, &
-! nkmin_xi_outer_core,nkmin_eta_outer_core, &
-! NSPEC2D_BOTTOM, &
-! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
-! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
-! reclen_zmin, &
-! reclen_xmin_outer_core,reclen_xmax_outer_core, &
-! reclen_ymin_outer_core,reclen_ymax_outer_core, &
-! nabs_zmin_oc, &
-! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
-! absorb_zmin_outer_core, &
-! absorb_xmin_outer_core,absorb_xmax_outer_core, &
-! absorb_ymin_outer_core,absorb_ymax_outer_core)
- endif
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- if (SIMULATION_TYPE == 3) then
- call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- NSPEC2D_TOP(IREGION_OUTER_CORE))
- endif
- endif
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- if (SIMULATION_TYPE == 3) then
- call compute_coupling_fluid_ICB(b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
- endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! ------------------- new non blocking implementation -------------------
-
- if (SIMULATION_TYPE == 3) then
-
- ! outer core
- b_iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
- enddo
-
-! ------------------- new non blocking implementation -------------------
-
- ! Newmark time scheme - corrector for fluid parts
- do i=1,NGLOB_OUTER_CORE
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
- enddo
-
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if (SIMULATION_TYPE == 3 ) then
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_iphase_CC = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
- endif
-
- if (SIMULATION_TYPE == 3) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
- endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- if(SIMULATION_TYPE == 3) then
-if(UNDO_ATT_WITH_STORE)then
- call compute_stacey_crust_mantle_forward(ichunk, &
- it,SAVE_FORWARD,ibool_crust_mantle, &
- b_veloc_crust_mantle,b_accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-else
- call compute_stacey_crust_mantle_backward(ichunk, &
- NSTEP,it,ibool_crust_mantle, &
- b_accel_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-endif
-! call compute_stacey_crust_mantle(ichunk, &
-! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
-! veloc_crust_mantle,b_accel_crust_mantle, &
-! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
-! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
-! wgllwgll_xz,wgllwgll_yz, &
-! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
-! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
-! rho_vp_crust_mantle,rho_vs_crust_mantle, &
-! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
-! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
-! nimin_crust_mantle,nimax_crust_mantle, &
-! njmin_crust_mantle,njmax_crust_mantle, &
-! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
-! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
-! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
-! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
-! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
-! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
-! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
-! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
- endif
- endif ! Stacey conditions
-
- ! add adjoint sources and add sources for backward/reconstructed wavefield
- if (SIMULATION_TYPE == 3) then
-if(UNDO_ATT_WITH_STORE)then
- call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,iteration_on_subset*NT_DUMP-it_of_this_subset+1, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-else
- call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-endif
- endif
-
- ! NOISE_TOMOGRAPHY
-! if ( NOISE_TOMOGRAPHY == 1 ) then
-! ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
-! ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
-! ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
-! ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
-! call add_source_master_rec_noise(myrank,nrec, &
-! NSTEP,accel_crust_mantle,noise_sourcearray, &
-! ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
-! it,irec_master_noise)
-! else if ( NOISE_TOMOGRAPHY == 2 ) then
-! ! second step of noise tomography, i.e., read the surface movie saved at every timestep
-! ! use the movie to drive the ensemble forward wavefield
-! call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
-! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
-! ibelm_top_crust_mantle,ibool_crust_mantle, &
-! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
-! NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
-! ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
-! ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
-! ! note the ensemble forward sources are generally distributed on the surface of the earth
-! ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
-! ! therefore, we must add it here, before applying the inverse of mass matrix
-! else
-if(.not. UNDO_ATT_WITH_STORE)then
- if ( NOISE_TOMOGRAPHY == 3 ) then
- ! third step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to reconstruct the ensemble forward wavefield
- ! the ensemble adjoint wavefield is done as usual
- ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
- call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- if(SIMULATION_TYPE == 3) then
- call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
- b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
- endif
- endif
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- if(SIMULATION_TYPE == 3) then
- call compute_coupling_ICB_fluid(b_displ_inner_core, &
- b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- NSPEC2D_TOP(IREGION_INNER_CORE))
- endif
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
-! ------------------- new non blocking implementation -------------------
-
- if (SIMULATION_TYPE == 3) then
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- b_iphase = 1 ! initialize the non blocking communication counter
- b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
- enddo
-
-! !---
-! !--- use buffers to assemble forces with the central cube
-! !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
-! ------------------- new non blocking implementation -------------------
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
- endif ! SIMULATION_TYPE == 3
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) then
- if(SIMULATION_TYPE == 3) then
- call compute_coupling_ocean(b_accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
- endif
- endif
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! Newmark time scheme - corrector for elastic parts
-
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + b_two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - b_two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
- enddo
- endif ! SIMULATION_TYPE == 3
-
- ! restores last time snapshot saved for backward/reconstruction of wavefields
- ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
- ! and adjoint sources will become more complicated
- ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
-if(.not. UNDO_ATT_WITH_STORE)then
- if(SIMULATION_TYPE == 3 .and. it == 1) then
- call read_forward_arrays(myrank, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
- endif
-endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
-! if (SIMULATION_TYPE == 1) then
-! call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
-! nu,hxir_store,hetar_store,hgammar_store, &
-! scale_displ,ibool_crust_mantle, &
-! ispec_selected_rec,number_receiver_global, &
-! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
-! seismograms)
-
-! else if (SIMULATION_TYPE == 2) then
-! call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
-! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
-! nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
-! hxir_store,hetar_store,hgammar_store, &
-! hpxir_store,hpetar_store,hpgammar_store, &
-! tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
-! hprime_xx,hprime_yy,hprime_zz, &
-! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
-! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
-! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-! moment_der,sloc_der,stshift_der,shdur_der, &
-! NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
-! ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
-! NSTEP,it,nit_written)
-
-! else
- if (SIMULATION_TYPE == 3) then
- call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- do irec_local = 1,nrec_local
- do i = 1,seismo_current/NT_DUMP
- do j = 1,NT_DUMP/2
- do k = 1,3
- seismograms_temp(k) = seismograms(k,irec_local,(i-1)*NT_DUMP + j)
- seismograms(k,irec_local,(i-1)*NT_DUMP + j) = seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1))
- seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1)) = seismograms_temp(k)
- enddo
- enddo
- enddo
- enddo
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
-! else ! case of SIMULATION_TYPE == 2
-! if( nrec_local > 0 ) &
-! call write_adj_seismograms(seismograms,number_receiver_global, &
-! nrec_local,it,nit_written,DT, &
-! NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
-! nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,1061 @@
+
+!! DK DK
+!! DK DK this first part handles the case SIMULATION_TYPE == 3
+!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! backward field
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + b_deltatover2*b_accel_outer_core(i)
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + b_deltatover2*b_accel_inner_core(:,i)
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ if (SIMULATION_TYPE == 3) then
+ call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+
+ if (SIMULATION_TYPE == 3) then
+ ! note on backward/reconstructed wavefields:
+ ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+ ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+ ! to a time (NSTEP - (it-1) - 1)*DT - t0
+ ! for reconstructing the rotational contributions
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+if(UNDO_ATT_WITH_STORE)then
+ time = sngl((dble(NSTEP-(iteration_on_subset*NT_DUMP-it_of_this_subset+1))*DT-t0)*scale_t_inv)
+endif
+ else
+ time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+if(UNDO_ATT_WITH_STORE)then
+ time = (dble(NSTEP-(iteration_on_subset*NT_DUMP-it_of_this_subset+1))*DT-t0)*scale_t_inv
+endif
+ endif
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if (SIMULATION_TYPE == 3) then
+if(UNDO_ATT_WITH_STORE)then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ b_veloc_outer_core,b_accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+else
+ call compute_stacey_outer_core_backward(ichunk, &
+ NSTEP,it,ibool_outer_core, &
+ b_accel_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+endif
+! call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+! NSTEP,it,ibool_outer_core, &
+! veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+! vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+! jacobian2D_bottom_outer_core, &
+! jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+! jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+! ibelm_bottom_outer_core, &
+! ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+! ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+! nimin_outer_core,nimax_outer_core, &
+! njmin_outer_core,njmax_outer_core, &
+! nkmin_xi_outer_core,nkmin_eta_outer_core, &
+! NSPEC2D_BOTTOM, &
+! nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+! nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+! reclen_zmin, &
+! reclen_xmin_outer_core,reclen_xmax_outer_core, &
+! reclen_ymin_outer_core,reclen_ymax_outer_core, &
+! nabs_zmin_oc, &
+! nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+! absorb_zmin_outer_core, &
+! absorb_xmin_outer_core,absorb_xmax_outer_core, &
+! absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+ endif
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_coupling_fluid_ICB(b_displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! outer core
+ b_iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+ ! Newmark time scheme - corrector for fluid parts
+ do i=1,NGLOB_OUTER_CORE
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+ enddo
+
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if (SIMULATION_TYPE == 3 ) then
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if(SIMULATION_TYPE == 3) then
+if(UNDO_ATT_WITH_STORE)then
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ b_veloc_crust_mantle,b_accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+else
+ call compute_stacey_crust_mantle_backward(ichunk, &
+ NSTEP,it,ibool_crust_mantle, &
+ b_accel_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+endif
+! call compute_stacey_crust_mantle(ichunk, &
+! NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
+! veloc_crust_mantle,b_accel_crust_mantle, &
+! jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+! jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+! wgllwgll_xz,wgllwgll_yz, &
+! normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+! normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+! rho_vp_crust_mantle,rho_vs_crust_mantle, &
+! ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+! ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+! nimin_crust_mantle,nimax_crust_mantle, &
+! njmin_crust_mantle,njmax_crust_mantle, &
+! nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+! nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+! nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+! reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+! reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+! nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+! absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+! absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+ endif
+ endif ! Stacey conditions
+
+ ! add adjoint sources and add sources for backward/reconstructed wavefield
+ if (SIMULATION_TYPE == 3) then
+if(UNDO_ATT_WITH_STORE)then
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,iteration_on_subset*NT_DUMP-it_of_this_subset+1, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+else
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+endif
+ endif
+
+ ! NOISE_TOMOGRAPHY
+! if ( NOISE_TOMOGRAPHY == 1 ) then
+! ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+! ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+! ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+! ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+! call add_source_master_rec_noise(myrank,nrec, &
+! NSTEP,accel_crust_mantle,noise_sourcearray, &
+! ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+! it,irec_master_noise)
+! else if ( NOISE_TOMOGRAPHY == 2 ) then
+! ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+! ! use the movie to drive the ensemble forward wavefield
+! call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
+! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+! ibelm_top_crust_mantle,ibool_crust_mantle, &
+! NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+! NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
+! ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
+! ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
+! ! note the ensemble forward sources are generally distributed on the surface of the earth
+! ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
+! ! therefore, we must add it here, before applying the inverse of mass matrix
+! else
+if(.not. UNDO_ATT_WITH_STORE)then
+ if ( NOISE_TOMOGRAPHY == 3 ) then
+ ! third step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to reconstruct the ensemble forward wavefield
+ ! the ensemble adjoint wavefield is done as usual
+ ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
+ call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
+ b_accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+ endif
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_ICB_fluid(b_displ_inner_core, &
+ b_accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ NSPEC2D_TOP(IREGION_INNER_CORE))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ b_iphase = 1 ! initialize the non blocking communication counter
+ b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+ enddo
+
+! !---
+! !--- use buffers to assemble forces with the central cube
+! !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+ endif ! SIMULATION_TYPE == 3
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_ocean(b_accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! restores last time snapshot saved for backward/reconstruction of wavefields
+ ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+ ! and adjoint sources will become more complicated
+ ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+if(.not. UNDO_ATT_WITH_STORE)then
+ if(SIMULATION_TYPE == 3 .and. it == 1) then
+ call read_forward_arrays(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+ endif
+endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+! if (SIMULATION_TYPE == 1) then
+! call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+! nu,hxir_store,hetar_store,hgammar_store, &
+! scale_displ,ibool_crust_mantle, &
+! ispec_selected_rec,number_receiver_global, &
+! seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+! seismograms)
+
+! else if (SIMULATION_TYPE == 2) then
+! call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+! eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+! nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+! hxir_store,hetar_store,hgammar_store, &
+! hpxir_store,hpetar_store,hpgammar_store, &
+! tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+! hprime_xx,hprime_yy,hprime_zz, &
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+! moment_der,sloc_der,stshift_der,shdur_der, &
+! NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+! ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+! NSTEP,it,nit_written)
+
+! else
+ if (SIMULATION_TYPE == 3) then
+ call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ do irec_local = 1,nrec_local
+ do i = 1,seismo_current/NT_DUMP
+ do j = 1,NT_DUMP/2
+ do k = 1,3
+ seismograms_temp(k) = seismograms(k,irec_local,(i-1)*NT_DUMP + j)
+ seismograms(k,irec_local,(i-1)*NT_DUMP + j) = seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1))
+ seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1)) = seismograms_temp(k)
+ enddo
+ enddo
+ enddo
+ enddo
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+! else ! case of SIMULATION_TYPE == 2
+! if( nrec_local > 0 ) &
+! call write_adj_seismograms(seismograms,number_receiver_global, &
+! nrec_local,it,nit_written,DT, &
+! NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
+! nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,838 +0,0 @@
-
-!! DK DK
-!! DK DK this should be written in the future, starting from a copy of part1_classical.f90 once part1_classical.f90 is debugged
-!! DK DK
-
- ! Newmark time scheme update
-
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + deltat*b_veloc_crust_mantle(:,i) + deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + deltat*b_veloc_outer_core(i) + deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + deltat*b_veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
- if (SIMULATION_TYPE == 3) then
- call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- b_eps_trace_over_3_crust_mantle,b_epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
- endif
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
-
- iphase = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
- it,ibool_outer_core, &
- b_veloc_outer_core,b_accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- NSPEC2D_TOP(IREGION_OUTER_CORE))
- endif
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- call compute_coupling_fluid_ICB(b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
- endif
-
- ! assemble all the contributions between slices using MPI
-
- ! outer core
- iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
- enddo
-
- ! multiply by the inverse of the mass matrix and update velocity
- do i=1,NGLOB_OUTER_CORE
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + deltatover2*b_accel_outer_core(i)
- enddo
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- iphase = 0 ! do not start any non blocking communications at this stage
- iphase_CC = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- call compute_stacey_crust_mantle_forward(ichunk, &
- it,SAVE_FORWARD,ibool_crust_mantle, &
- b_veloc_crust_mantle,b_accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
-
- endif ! Stacey conditions
-
- ! add the sources
- if (SIMULATION_TYPE == 3) &
- call compute_add_sources(myrank,NSOURCES, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,NSTEP-(iteration_on_subset*NT_DUMP-it_of_this_subset), &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
-if(.not. UNDO_ATT_WITH_STORE)then
- if ( NOISE_TOMOGRAPHY == 3 ) then
- ! third step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to reconstruct the ensemble forward wavefield
- ! the ensemble adjoint wavefield is done as usual
- ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
- call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) then
- call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
- b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-
- endif
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) then
- call compute_coupling_ICB_fluid(b_displ_inner_core, &
- b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- NSPEC2D_TOP(IREGION_INNER_CORE))
-
- endif
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- iphase = 1 ! initialize the non blocking communication counter
- iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
- enddo
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,iphase_CC)
- enddo
- endif ! end of assembling forces with the central cube
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) then
- call compute_coupling_ocean(b_accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
- endif
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
- ! Newmark time scheme - corrector for elastic parts
-
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + deltatover2*b_accel_inner_core(:,i)
- enddo
-
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
- if (SIMULATION_TYPE == 3) then
- call compute_seismograms(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
-if(UNDO_ATT_WITH_STORE)then
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- do irec_local = 1,nrec_local
- do i = 1,seismo_current/NT_DUMP
- do j = 1,NT_DUMP/2
- do k = 1,3
- seismograms_temp(k) = seismograms(k,irec_local,(i-1)*NT_DUMP + j)
- seismograms(k,irec_local,(i-1)*NT_DUMP + j) = seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1))
- seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1)) = seismograms_temp(k)
- enddo
- enddo
- enddo
- enddo
- if (SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-endif
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part2_undo_att_changed_from_forward.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,838 @@
+
+!! DK DK
+!! DK DK this should be written in the future, starting from a copy of part1_classical.f90 once part1_classical.f90 is debugged
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + deltat*b_veloc_crust_mantle(:,i) + deltatsqover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + deltatover2*b_accel_crust_mantle(:,i)
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + deltat*b_veloc_outer_core(i) + deltatsqover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + deltatover2*b_accel_outer_core(i)
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + deltat*b_veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + deltatover2*b_accel_inner_core(:,i)
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ if (SIMULATION_TYPE == 3) then
+ call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ b_eps_trace_over_3_crust_mantle,b_epsilondev_crust_mantle, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT-t0)*scale_t_inv
+ endif
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ b_veloc_outer_core,b_accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_fluid_CMB(b_displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_fluid_ICB(b_displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+ ! outer core
+ iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+ enddo
+
+ ! multiply by the inverse of the mass matrix and update velocity
+ do i=1,NGLOB_OUTER_CORE
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + deltatover2*b_accel_outer_core(i)
+ enddo
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ iphase_CC = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ b_veloc_crust_mantle,b_accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+
+ endif ! Stacey conditions
+
+ ! add the sources
+ if (SIMULATION_TYPE == 3) &
+ call compute_add_sources(myrank,NSOURCES, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,NSTEP-(iteration_on_subset*NT_DUMP-it_of_this_subset), &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+if(.not. UNDO_ATT_WITH_STORE)then
+ if ( NOISE_TOMOGRAPHY == 3 ) then
+ ! third step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to reconstruct the ensemble forward wavefield
+ ! the ensemble adjoint wavefield is done as usual
+ ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
+ call noise_read_add_surface_movie(nmovie_points,b_accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_CMB_fluid(b_displ_crust_mantle, &
+ b_accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_ICB_fluid(b_displ_inner_core, &
+ b_accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ NSPEC2D_TOP(IREGION_INNER_CORE))
+
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ iphase = 1 ! initialize the non blocking communication counter
+ iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+ enddo
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ call compute_coupling_ocean(b_accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + deltatover2*b_accel_inner_core(:,i)
+ enddo
+
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_seismograms(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+if(UNDO_ATT_WITH_STORE)then
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ do irec_local = 1,nrec_local
+ do i = 1,seismo_current/NT_DUMP
+ do j = 1,NT_DUMP/2
+ do k = 1,3
+ seismograms_temp(k) = seismograms(k,irec_local,(i-1)*NT_DUMP + j)
+ seismograms(k,irec_local,(i-1)*NT_DUMP + j) = seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1))
+ seismograms(k,irec_local,(i-1)*NT_DUMP + (NT_DUMP-j+1)) = seismograms_temp(k)
+ enddo
+ enddo
+ enddo
+ enddo
+ if (SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,257 +0,0 @@
-
-!! DK DK for kernel calculations
-
-
-! kernel calculations
- if (SIMULATION_TYPE == 3) then
- ! crust mantle
- call compute_kernels_crust_mantle(ibool_crust_mantle, &
- rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
- accel_crust_mantle,b_displ_crust_mantle, &
- epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
- deltat)
-
- ! outer core
- call compute_kernels_outer_core(ibool_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- hprime_xx,hprime_yy,hprime_zz, &
- displ_outer_core,accel_outer_core, &
- b_displ_outer_core,b_accel_outer_core, &
- vector_accel_outer_core,vector_displ_outer_core, &
- b_vector_displ_outer_core, &
- div_displ_outer_core,b_div_displ_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- deltat)
-
- ! inner core
- call compute_kernels_inner_core(ibool_inner_core, &
- rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
- accel_inner_core,b_displ_inner_core, &
- epsilondev_inner_core,b_epsilondev_inner_core, &
- eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
- deltat)
-
- ! NOISE TOMOGRAPHY --- source strength kernel
- if (NOISE_TOMOGRAPHY == 3) &
- call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
- Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
- normal_x_noise,normal_y_noise,normal_z_noise, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- ibelm_top_crust_mantle)
-
- ! --- boundary kernels ------
- if (SAVE_BOUNDARY_MESH) then
- fluid_solid_boundary = .false.
- iregion_code = IREGION_CRUST_MANTLE
-
- ! Moho
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
-
- moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
- endif
-
- ! d400
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
-
- d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
-
- ! d670
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
-
- d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
-
- ! CMB
- fluid_solid_boundary = .true.
- iregion_code = IREGION_CRUST_MANTLE
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
- cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
-
- iregion_code = IREGION_OUTER_CORE
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_outer_core,normal_top_outer_core, &
- cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
-
- cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
-
- ! ICB
- fluid_solid_boundary = .true.
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
- icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
-
- iregion_code = IREGION_INNER_CORE
- call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
- b_displ_inner_core,nspec_inner_core,iregion_code, &
- ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core,&
- gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- c33store_inner_core,dummy_array,dummy_array, &
- dummy_array,c44store_inner_core,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
- icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
-
- icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- call compute_kernels_hessian(ibool_crust_mantle, &
- hess_kl_crust_mantle,&
- accel_crust_mantle,b_accel_crust_mantle, &
- deltat)
- endif
-
- endif ! end of if computing kernels
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part3_kernel_computation.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,257 @@
+
+!! DK DK for kernel calculations
+
+
+! kernel calculations
+ if (SIMULATION_TYPE == 3) then
+ ! crust mantle
+ call compute_kernels_crust_mantle(ibool_crust_mantle, &
+ rho_kl_crust_mantle,beta_kl_crust_mantle, &
+ alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+ accel_crust_mantle,b_displ_crust_mantle, &
+ epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
+ deltat)
+
+ ! outer core
+ call compute_kernels_outer_core(ibool_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ displ_outer_core,accel_outer_core, &
+ b_displ_outer_core,b_accel_outer_core, &
+ vector_accel_outer_core,vector_displ_outer_core, &
+ b_vector_displ_outer_core, &
+ div_displ_outer_core,b_div_displ_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+ deltat)
+
+ ! inner core
+ call compute_kernels_inner_core(ibool_inner_core, &
+ rho_kl_inner_core,beta_kl_inner_core, &
+ alpha_kl_inner_core, &
+ accel_inner_core,b_displ_inner_core, &
+ epsilondev_inner_core,b_epsilondev_inner_core, &
+ eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
+ deltat)
+
+ ! NOISE TOMOGRAPHY --- source strength kernel
+ if (NOISE_TOMOGRAPHY == 3) &
+ call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
+ Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
+ normal_x_noise,normal_y_noise,normal_z_noise, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ ibelm_top_crust_mantle)
+
+ ! --- boundary kernels ------
+ if (SAVE_BOUNDARY_MESH) then
+ fluid_solid_boundary = .false.
+ iregion_code = IREGION_CRUST_MANTLE
+
+ ! Moho
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
+
+ moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
+ endif
+
+ ! d400
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
+
+ d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
+
+ ! d670
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
+
+ d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
+
+ ! CMB
+ fluid_solid_boundary = .true.
+ iregion_code = IREGION_CRUST_MANTLE
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
+ cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
+
+ iregion_code = IREGION_OUTER_CORE
+ call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+ b_vector_displ_outer_core,nspec_outer_core, &
+ iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core,&
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_bot,ibelm_top_outer_core,normal_top_outer_core, &
+ cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
+
+ cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
+
+ ! ICB
+ fluid_solid_boundary = .true.
+ call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+ b_vector_displ_outer_core,nspec_outer_core, &
+ iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core,&
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
+ icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
+
+ iregion_code = IREGION_INNER_CORE
+ call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
+ b_displ_inner_core,nspec_inner_core,iregion_code, &
+ ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core,&
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+ dummy_array,dummy_array,dummy_array, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ c33store_inner_core,dummy_array,dummy_array, &
+ dummy_array,c44store_inner_core,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
+ icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
+
+ icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
+ endif
+
+ ! approximate hessian
+ if( APPROXIMATE_HESS_KL ) then
+ call compute_kernels_hessian(ibool_crust_mantle, &
+ hess_kl_crust_mantle,&
+ accel_crust_mantle,b_accel_crust_mantle, &
+ deltat)
+ endif
+
+ endif ! end of if computing kernels
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,60 +0,0 @@
-
- ! synchronize all processes
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error synchronize saving forward')
-
- ! dump kernel arrays
- if (SIMULATION_TYPE == 3) then
-
- ! crust mantle
- if (SAVE_REGULAR_KL) then
- call save_regular_kernels_crust_mantle(myrank, &
- npoints_slice, hxir_reg, hetar_reg, hgammar_reg, &
- scale_t,scale_displ, &
- cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
- alpha_kl_crust_mantle,beta_kl_crust_mantle, &
- ystore_crust_mantle,zstore_crust_mantle, &
- rhostore_crust_mantle,muvstore_crust_mantle, &
- kappavstore_crust_mantle,ibool_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle, &
- eta_anisostore_crust_mantle,ispec_is_tiso_crust_mantle,LOCAL_PATH)
- else
- call save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
- cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
- alpha_kl_crust_mantle,beta_kl_crust_mantle, &
- ystore_crust_mantle,zstore_crust_mantle, &
- rhostore_crust_mantle,muvstore_crust_mantle, &
- kappavstore_crust_mantle,ibool_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle, &
- eta_anisostore_crust_mantle,ispec_is_tiso_crust_mantle,LOCAL_PATH)
- endif
-
- ! noise strength kernel
- if (NOISE_TOMOGRAPHY == 3) then
- call save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
- endif
-
- ! outer core
- call save_kernels_outer_core(myrank,scale_t,scale_displ, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core,LOCAL_PATH)
-
- ! inner core
- call save_kernels_inner_core(myrank,scale_t,scale_displ, &
- rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
- rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core,LOCAL_PATH)
-
- ! boundary kernel
- if (SAVE_BOUNDARY_MESH) then
- call save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
- moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl,LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL) then
- stop "APPROXIMATE_HESS_KL is not support for undoing att" !ZN
- call save_kernels_hessian(myrank,scale_t,scale_displ,hess_kl_crust_mantle,LOCAL_PATH)
- endif
- endif
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/part4_save_kernel.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,60 @@
+
+ ! synchronize all processes
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error synchronize saving forward')
+
+ ! dump kernel arrays
+ if (SIMULATION_TYPE == 3) then
+
+ ! crust mantle
+ if (SAVE_REGULAR_KL) then
+ call save_regular_kernels_crust_mantle(myrank, &
+ npoints_slice, hxir_reg, hetar_reg, hgammar_reg, &
+ scale_t,scale_displ, &
+ cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
+ alpha_kl_crust_mantle,beta_kl_crust_mantle, &
+ ystore_crust_mantle,zstore_crust_mantle, &
+ rhostore_crust_mantle,muvstore_crust_mantle, &
+ kappavstore_crust_mantle,ibool_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle, &
+ eta_anisostore_crust_mantle,ispec_is_tiso_crust_mantle,LOCAL_PATH)
+ else
+ call save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
+ cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
+ alpha_kl_crust_mantle,beta_kl_crust_mantle, &
+ ystore_crust_mantle,zstore_crust_mantle, &
+ rhostore_crust_mantle,muvstore_crust_mantle, &
+ kappavstore_crust_mantle,ibool_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle, &
+ eta_anisostore_crust_mantle,ispec_is_tiso_crust_mantle,LOCAL_PATH)
+ endif
+
+ ! noise strength kernel
+ if (NOISE_TOMOGRAPHY == 3) then
+ call save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
+ endif
+
+ ! outer core
+ call save_kernels_outer_core(myrank,scale_t,scale_displ, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core,LOCAL_PATH)
+
+ ! inner core
+ call save_kernels_inner_core(myrank,scale_t,scale_displ, &
+ rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
+ rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core,LOCAL_PATH)
+
+ ! boundary kernel
+ if (SAVE_BOUNDARY_MESH) then
+ call save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
+ moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl,LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
+ endif
+
+ ! approximate hessian
+ if( APPROXIMATE_HESS_KL) then
+ stop "APPROXIMATE_HESS_KL is not support for undoing att" !ZN
+ call save_kernels_hessian(myrank,scale_t,scale_displ,hess_kl_crust_mantle,LOCAL_PATH)
+ endif
+ endif
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/setup/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/setup/constants.h.in 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/setup/constants.h.in 2013-06-15 00:48:57 UTC (rev 22299)
@@ -50,8 +50,9 @@
integer, parameter :: ELEMENTS_NONBLOCKING_CM_IC = 1500
integer, parameter :: ELEMENTS_NONBLOCKING_OC = 3000
-!! DK DK if UNDO_ATT
- integer, parameter :: NT_500 = 50 !! DK DK how often we dump restart files to undo attenuation
+!! DK DK to undo attenuation
+ logical, parameter :: UNDO_ATT = .true. ! .false.
+ integer, parameter :: NT_DUMP = 50 !! DK DK how often we dump restart files to undo attenuation
!*********************************************************************************************************
! added these parameters for the future GPU version of the solver with mesh coloring
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,359 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! compute the optimal interval at which to dump restart files to disk to undo attenuation in an exact way
-
-! Dimitri Komatitsch and Zhinan Xie, CNRS Marseille, France, June 2013.
-
- program xcompute_optimized_dumping
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION,CASE_3D, &
- ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
-
- character(len=150) LOCAL_PATH,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- nglob
-
- double precision :: static_memory_size
-
- integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
-
- integer :: iregion
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
- integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
-
- integer :: NT_DUMP_optimal_to_use,number_of_dumpings_to_do
- double precision :: gigabytes_avail_per_core,percentage_to_use_per_core,what_we_can_use_in_GB,size_to_store_at_each_time_step, &
- disk_size_of_each_dumping
-
-! ************** PROGRAM STARTS HERE **************
-
-! read the parameter file and compute additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
-
- if(SIMULATION_TYPE /= 3) stop 'optimal dumping interval calculation can only be done when SIMULATION_TYPE == 3 in the Par_file'
-
-! count the total number of sources in the CMTSOLUTION file
- call count_number_of_sources(NSOURCES)
-
- do iregion=1,MAX_NUM_REGIONS
- NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
- enddo
-
- if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
- maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
- endif
-
-! evaluate the amount of static memory needed by the solver
- call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
- TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
- ONE_CRUST,doubling_index,this_region_has_a_doubling,&
- ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
- NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
-
- NGLOB1D_RADIAL_TEMP(:) = &
- (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
-
- print *,'number of processors = ',NPROCTOT
- print *
- print *,'maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
- print *
- print *,'total elements per slice = ',sum(NSPEC)
- print *,'total points per slice = ',sum(nglob)
- print *
- print *,'number of time steps = ',NSTEP
-
- print *,'approximate static memory needed by the solver:'
- print *,'----------------------------------------------'
- print *
- print *,'(lower bound, usually the real amount used is 5% to 10% higher)'
- print *
- print *,'(you can get a more precise estimate of the size used per MPI process'
- print *,' by typing "size -d bin/xspecfem3D"'
- print *,' after compiling the code with the DATA/Par_file you plan to use)'
- print *
- print *,'size of static arrays per slice = ',static_memory_size/1.d6,' MB'
- print *,' = ',static_memory_size/1048576.d0,' MiB'
- print *,' = ',static_memory_size/1.d9,' GB'
- print *,' = ',static_memory_size/1073741824.d0,' GiB'
- print *
-
- if(static_memory_size*dble(NPROCTOT)/1.d6 < 10000.d0) then
- print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1.d6,' MB'
- print *,' = ',static_memory_size*dble(NPROCTOT)/1048576.d0,' MiB'
- print *,' = ',static_memory_size*dble(NPROCTOT)/1.d9,' GB'
- else
- print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1.d9,' GB'
- endif
- print *,' = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GiB'
- print *,' = ',static_memory_size*dble(NPROCTOT)/1.d12,' TB'
- print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TiB'
- print *
-
- print *,'How much memory (in GB) is installed on your machine per CPU core?'
- print *,' (or per GPU card or per INTEL MIC Phi board)?'
- print *,' (beware, this value MUST be given per core, i.e. per MPI thread, i.e. per MPI rank, NOT per node)'
- read(*,*) gigabytes_avail_per_core
-
- if(gigabytes_avail_per_core < 0.1d0) stop 'less than 100 MB per core does not seem realistic; exiting...'
- if(gigabytes_avail_per_core > 32.d0) stop 'more than 32 GB per core does not seem realistic; exiting...'
-
- print *
- print *,'What percentage of this total do you allow us to use, keeping in mind that you'
- print *,'need to leave some memory available for the GNU/Linux system to run?'
- print *,' (a typical value is 90%; 92% to 95% is probably OK too; 85% is very safe)'
- read(*,*) percentage_to_use_per_core
-
- if(percentage_to_use_per_core < 50.d0) stop 'less than 50% does not seem realistic; exiting...'
- if(percentage_to_use_per_core > 96.d0) stop 'more than 96% is risky; exiting...'
-
- what_we_can_use_in_GB = gigabytes_avail_per_core * percentage_to_use_per_core / 100.d0
-
-! convert static_memory_size to GB
- static_memory_size = static_memory_size / 1.d9
-
- print *
- print *,'without undoing of attenuation you are using ',static_memory_size,' GB per core'
-
- if(static_memory_size >= gigabytes_avail_per_core) &
- stop 'you are using more memory than what you told us is installed!!! there is an error'
-
- if(static_memory_size >= what_we_can_use_in_GB) &
- stop 'you are using more memory than what you allowed us to use!!! there is an error'
-
-! compute the size to store in memory at each time step
- size_to_store_at_each_time_step = 0
-
-! displ_crust_mantle
- size_to_store_at_each_time_step = size_to_store_at_each_time_step + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
-
-! displ_inner_core
- size_to_store_at_each_time_step = size_to_store_at_each_time_step + dble(NDIM)*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
-
-! displ_outer_core and accel_outer_core (both being scalar arrays)
- size_to_store_at_each_time_step = size_to_store_at_each_time_step + 2.d0*NGLOB(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
-
-! convert to GB
- size_to_store_at_each_time_step = size_to_store_at_each_time_step / 1.d9
-
- print *
- print *,'each time step to store in memory to undo attenuation requires storing ',size_to_store_at_each_time_step,' GB per core'
-
- print *
- print *,'*******************************************************************************'
- print *,'the optimal value to put in setup/constants.h is thus:'
- NT_DUMP_optimal_to_use = int((what_we_can_use_in_GB - static_memory_size) / size_to_store_at_each_time_step)
- print *
- print *,'NT_DUMP = ',NT_DUMP_optimal_to_use
- print *
- print *,'thus please edit that file, put this value in it and recompile the whole code'
- print *,'with "make clean ; make all"'
- print *,'*******************************************************************************'
-
-! compute the size of files to dump to disk
- disk_size_of_each_dumping = 0
-
-! displ_crust_mantle, veloc_crust_mantle, accel_crust_mantle
- disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
-
-! displ_inner_core, veloc_inner_core, accel_inner_core
- disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*dble(NDIM)*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
-
-! displ_outer_core, veloc_outer_core, accel_outer_core (all scalar arrays)
- disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*NGLOB(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
-
-! A_array_rotation,B_array_rotation
- if (ROTATION) disk_size_of_each_dumping = disk_size_of_each_dumping + &
- dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL)
-
- if (ATTENUATION) then
-! R_memory_crust_mantle
- disk_size_of_each_dumping = disk_size_of_each_dumping + 5.d0*dble(N_SLS)*dble(NGLLX)* &
- dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
-
-! R_memory_inner_core
- disk_size_of_each_dumping = disk_size_of_each_dumping + 5.d0*dble(N_SLS)*dble(NGLLX)* &
- dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
- endif
-
-! convert to GB
- disk_size_of_each_dumping = disk_size_of_each_dumping / 1.d9
-
-!! DK DK this formula could be made more precise here; currently in some cases it can probably be off by +1 or -1
- number_of_dumpings_to_do = nint(NSTEP / dble(NT_DUMP_optimal_to_use))
-
- print *
- print *,'we will need to save a total of ',number_of_dumpings_to_do,' dumpings (restart files) to disk'
-
- print *
- print *,'each dumping on the disk to undo attenuation requires storing ',disk_size_of_each_dumping,' GB per core'
-
- print *
- print *,'ALL dumpings on the disk require storing ',disk_size_of_each_dumping*number_of_dumpings_to_do,' GB per core'
-
- print *
- print *,'each dumping on the disk requires storing ',disk_size_of_each_dumping*NPROCTOT, &
- ' GB for all cores'
-
- print *
- print *,'*******************************************************************************'
- print *,'ALL dumpings on the disk require storing (WITHOUT epsilondev) ', &
- disk_size_of_each_dumping*number_of_dumpings_to_do*NPROCTOT,' GB for all cores'
- print *,'*******************************************************************************'
- print *
-
-! convert back from GB
- disk_size_of_each_dumping = disk_size_of_each_dumping * 1.d9
-
-! epsilondev_crust_mantle
- disk_size_of_each_dumping = disk_size_of_each_dumping + &
- 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
-
-! epsilondev_inner_core
- disk_size_of_each_dumping = disk_size_of_each_dumping + &
- 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
-
-! convert to GB
- disk_size_of_each_dumping = disk_size_of_each_dumping / 1.d9
-
-!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
-!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
-!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
-!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
- print *
- print *,'ALL dumpings on the disk require storing (WITH epsilondev) ', &
- disk_size_of_each_dumping*number_of_dumpings_to_do*NPROCTOT,' GB to disk for all cores'
-
-#ifndef UNDO_ATT
- print *
- print *,'*******************************************************************************'
- print *,'BEWARE, -DUNDO_ATT not used to compile the code, and thus undoing is currently'
- print *,'turned off, i.e. the above estimates are currently NOT USED.'
- print *,'*******************************************************************************'
- print *
-#endif
-
- end program xcompute_optimized_dumping
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,359 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and CNRS / INRIA / University of Pau, France
+! (c) Princeton University and CNRS / INRIA / University of Pau
+! April 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the optimal interval at which to dump restart files to disk to undo attenuation in an exact way
+
+! Dimitri Komatitsch and Zhinan Xie, CNRS Marseille, France, June 2013.
+
+ program xcompute_optimized_dumping
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,CASE_3D, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
+
+ character(len=150) LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+ double precision :: static_memory_size
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+ integer :: iregion
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+ integer :: NT_DUMP_optimal_to_use,number_of_dumpings_to_do
+ double precision :: gigabytes_avail_per_core,percentage_to_use_per_core,what_we_can_use_in_GB,size_to_store_at_each_time_step, &
+ disk_size_of_each_dumping
+
+! ************** PROGRAM STARTS HERE **************
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
+ SAVE_REGULAR_KL)
+
+ if(SIMULATION_TYPE /= 3) stop 'optimal dumping interval calculation can only be done when SIMULATION_TYPE == 3 in the Par_file'
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ do iregion=1,MAX_NUM_REGIONS
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
+ maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
+ endif
+
+! evaluate the amount of static memory needed by the solver
+ call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ NGLOB1D_RADIAL_TEMP(:) = &
+ (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+ print *,'number of processors = ',NPROCTOT
+ print *
+ print *,'maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
+ print *
+ print *,'total elements per slice = ',sum(NSPEC)
+ print *,'total points per slice = ',sum(nglob)
+ print *
+ print *,'number of time steps = ',NSTEP
+
+ print *,'approximate static memory needed by the solver:'
+ print *,'----------------------------------------------'
+ print *
+ print *,'(lower bound, usually the real amount used is 5% to 10% higher)'
+ print *
+ print *,'(you can get a more precise estimate of the size used per MPI process'
+ print *,' by typing "size -d bin/xspecfem3D"'
+ print *,' after compiling the code with the DATA/Par_file you plan to use)'
+ print *
+ print *,'size of static arrays per slice = ',static_memory_size/1.d6,' MB'
+ print *,' = ',static_memory_size/1048576.d0,' MiB'
+ print *,' = ',static_memory_size/1.d9,' GB'
+ print *,' = ',static_memory_size/1073741824.d0,' GiB'
+ print *
+
+ if(static_memory_size*dble(NPROCTOT)/1.d6 < 10000.d0) then
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1.d6,' MB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1048576.d0,' MiB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1.d9,' GB'
+ else
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1.d9,' GB'
+ endif
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GiB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1.d12,' TB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TiB'
+ print *
+
+ print *,'How much memory (in GB) is installed on your machine per CPU core?'
+ print *,' (or per GPU card or per INTEL MIC Phi board)?'
+ print *,' (beware, this value MUST be given per core, i.e. per MPI thread, i.e. per MPI rank, NOT per node)'
+ read(*,*) gigabytes_avail_per_core
+
+ if(gigabytes_avail_per_core < 0.1d0) stop 'less than 100 MB per core does not seem realistic; exiting...'
+ if(gigabytes_avail_per_core > 32.d0) stop 'more than 32 GB per core does not seem realistic; exiting...'
+
+ print *
+ print *,'What percentage of this total do you allow us to use, keeping in mind that you'
+ print *,'need to leave some memory available for the GNU/Linux system to run?'
+ print *,' (a typical value is 90%; 92% to 95% is probably OK too; 85% is very safe)'
+ read(*,*) percentage_to_use_per_core
+
+ if(percentage_to_use_per_core < 50.d0) stop 'less than 50% does not seem realistic; exiting...'
+ if(percentage_to_use_per_core > 96.d0) stop 'more than 96% is risky; exiting...'
+
+ what_we_can_use_in_GB = gigabytes_avail_per_core * percentage_to_use_per_core / 100.d0
+
+! convert static_memory_size to GB
+ static_memory_size = static_memory_size / 1.d9
+
+ print *
+ print *,'without undoing of attenuation you are using ',static_memory_size,' GB per core'
+
+ if(static_memory_size >= gigabytes_avail_per_core) &
+ stop 'you are using more memory than what you told us is installed!!! there is an error'
+
+ if(static_memory_size >= what_we_can_use_in_GB) &
+ stop 'you are using more memory than what you allowed us to use!!! there is an error'
+
+! compute the size to store in memory at each time step
+ size_to_store_at_each_time_step = 0
+
+! displ_crust_mantle
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
+
+! displ_inner_core
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step + dble(NDIM)*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
+
+! displ_outer_core and accel_outer_core (both being scalar arrays)
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step + 2.d0*NGLOB(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
+
+! convert to GB
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step / 1.d9
+
+ print *
+ print *,'each time step to store in memory to undo attenuation requires storing ',size_to_store_at_each_time_step,' GB per core'
+
+ print *
+ print *,'*******************************************************************************'
+ print *,'the optimal value to put in setup/constants.h is thus:'
+ NT_DUMP_optimal_to_use = int((what_we_can_use_in_GB - static_memory_size) / size_to_store_at_each_time_step)
+ print *
+ print *,'NT_DUMP = ',NT_DUMP_optimal_to_use
+ print *
+ print *,'thus please edit that file, put this value in it and recompile the whole code'
+ print *,'with "make clean ; make all"'
+ print *,'*******************************************************************************'
+
+! compute the size of files to dump to disk
+ disk_size_of_each_dumping = 0
+
+! displ_crust_mantle, veloc_crust_mantle, accel_crust_mantle
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
+
+! displ_inner_core, veloc_inner_core, accel_inner_core
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*dble(NDIM)*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
+
+! displ_outer_core, veloc_outer_core, accel_outer_core (all scalar arrays)
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*NGLOB(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
+
+! A_array_rotation,B_array_rotation
+ if (ROTATION) disk_size_of_each_dumping = disk_size_of_each_dumping + &
+ dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL)
+
+ if (ATTENUATION) then
+! R_memory_crust_mantle
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
+
+! R_memory_inner_core
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
+ endif
+
+! convert to GB
+ disk_size_of_each_dumping = disk_size_of_each_dumping / 1.d9
+
+!! DK DK this formula could be made more precise here; currently in some cases it can probably be off by +1 or -1
+ number_of_dumpings_to_do = nint(NSTEP / dble(NT_DUMP_optimal_to_use))
+
+ print *
+ print *,'we will need to save a total of ',number_of_dumpings_to_do,' dumpings (restart files) to disk'
+
+ print *
+ print *,'each dumping on the disk to undo attenuation requires storing ',disk_size_of_each_dumping,' GB per core'
+
+ print *
+ print *,'ALL dumpings on the disk require storing ',disk_size_of_each_dumping*number_of_dumpings_to_do,' GB per core'
+
+ print *
+ print *,'each dumping on the disk requires storing ',disk_size_of_each_dumping*NPROCTOT, &
+ ' GB for all cores'
+
+ print *
+ print *,'*******************************************************************************'
+ print *,'ALL dumpings on the disk require storing (WITHOUT epsilondev) ', &
+ disk_size_of_each_dumping*number_of_dumpings_to_do*NPROCTOT,' GB for all cores'
+ print *,'*******************************************************************************'
+ print *
+
+! convert back from GB
+ disk_size_of_each_dumping = disk_size_of_each_dumping * 1.d9
+
+! epsilondev_crust_mantle
+ disk_size_of_each_dumping = disk_size_of_each_dumping + &
+ 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! epsilondev_inner_core
+ disk_size_of_each_dumping = disk_size_of_each_dumping + &
+ 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! convert to GB
+ disk_size_of_each_dumping = disk_size_of_each_dumping / 1.d9
+
+!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
+!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
+!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
+!! DK DK remove this tomorrow if Zhinan confirms that it is OK to do so
+ print *
+ print *,'ALL dumpings on the disk require storing (WITH epsilondev) ', &
+ disk_size_of_each_dumping*number_of_dumpings_to_do*NPROCTOT,' GB to disk for all cores'
+
+ if(.not. UNDO_ATT) then
+ print *
+ print *,'*******************************************************************************'
+ print *,'BEWARE, UNDO_ATT is .false. and thus undoing is currently'
+ print *,'turned off, i.e. the above estimates are currently NOT USED.'
+ print *,'*******************************************************************************'
+ print *
+ endif
+
+ end program xcompute_optimized_dumping
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/rules.mk
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/rules.mk 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/compute_optimized_dumping_undo_att/rules.mk 2013-06-15 00:48:57 UTC (rev 22299)
@@ -80,6 +80,6 @@
## compute_optimized_dumping_undo_att objects
##
-$O/compute_optimized_dumping_undo_att.o: $S/compute_optimized_dumping_undo_att.F90
- ${FCCOMPILE_CHECK} -c -o $O/compute_optimized_dumping_undo_att.o ${FCFLAGS_f90} $S/compute_optimized_dumping_undo_att.F90
+$O/compute_optimized_dumping_undo_att.o: $S/compute_optimized_dumping_undo_att.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_optimized_dumping_undo_att.o ${FCFLAGS_f90} $S/compute_optimized_dumping_undo_att.f90
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -1,2382 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,&
- MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
- this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
- HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
- USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
-
-
- implicit none
-
- include "constants.h"
-
-
-! parameters read from parameter file
- integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
-
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
- HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,&
- MOVIE_SOUTH_DEG,RECORD_LENGTH_IN_MINUTES
-
- logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
- MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- ABSORBING_CONDITIONS,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
-
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
-
-! parameters to be computed based upon parameters above read from file
- integer NSTEP,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,REFERENCE_1D_MODEL,THREE_D_MODEL
-
- double precision DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400, &
- R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
- RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- double precision MOVIE_TOP,MOVIE_BOTTOM,MOVIE_EAST,MOVIE_WEST,&
- MOVIE_NORTH,MOVIE_SOUTH
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ONE_CRUST,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE, &
- EMULATE_ONLY
-
- integer NEX_MAX
-
- double precision ELEMENT_WIDTH
-
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB
-
- integer nblocks_xi,nblocks_eta
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
- double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
-
-! honor PREM Moho or not
-! doing so drastically reduces the stability condition and therefore the time step
- logical :: HONOR_1D_SPHERICAL_MOHO,CASE_3D
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum, tmp_sum_xi, tmp_sum_eta
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_vol, nglob_surf, nglob_edge
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
-
- integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
-
-
- ! reads in Par_file values
- call read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
- NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
- HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM,RECORD_LENGTH_IN_MINUTES, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG,&
- ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
- MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
-
- ! converts values to radians
- MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
- MOVIE_WEST = MOVIE_WEST_DEG * DEGREES_TO_RADIANS
- MOVIE_NORTH = (90.0d0 - MOVIE_NORTH_DEG) * DEGREES_TO_RADIANS ! converting from latitude to colatitude
- MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS
- ! converts movie top/bottom depths to radii
- MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
- MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
-
- ! include central cube or not
- ! use regular cubed sphere instead of cube for large distances
- if(NCHUNKS == 6) then
- INCLUDE_CENTRAL_CUBE = .true.
- INFLATE_CENTRAL_CUBE = .false.
- else
- INCLUDE_CENTRAL_CUBE = .false.
- INFLATE_CENTRAL_CUBE = .true.
- endif
-
- if(.not. EMULATE_ONLY) then
- NEX_XI = NEX_XI_read
- NEX_ETA = NEX_ETA_read
- NPROC_XI = NPROC_XI_read
- NPROC_ETA = NPROC_ETA_read
- else
- ! this is used in UTILS/estimate_best_values_runs.f90 only, to estimate memory use
- NEX_ETA = NEX_XI
- NPROC_ETA = NPROC_XI
- endif
-
- ! turns on/off corresponding 1-D/3-D model flags
- ! and sets radius for each discontinuity and ocean density values
- call get_model_parameters(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
- OCEANS,TOPOGRAPHY, &
- ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400,R600,R670,R771, &
- RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
- R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
-
-
- ! sets time step size and number of layers
- ! right distribution is determined based upon maximum value of NEX
- NEX_MAX = max(NEX_XI,NEX_ETA)
- call rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
- NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
- NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
-
- ! compute total number of time steps, rounded to next multiple of 100
- NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
-
-!! DK DK UNDO_ATT make sure NSTEP is a multiple of NT_DUMP
-#ifdef UNDO_ATT
- if(mod(NSTEP,NT_DUMP) /= 0) NSTEP = (NSTEP/NT_DUMP + 1)*NT_DUMP
-#endif
-
-! if doing benchmark runs to measure scaling of the code for a limited number of time steps only
- if (DO_BENCHMARK_RUN_ONLY) NSTEP = NSTEP_FOR_BENCHMARK
-
-!<YANGL
- if ( NOISE_TOMOGRAPHY /= 0 ) NSTEP = 2*NSTEP-1 ! time steps needs to be doubled, due to +/- branches
-!>YANGL
-
- ! subsets used to save seismograms must not be larger than the whole time series,
- ! otherwise we waste memory
- if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
-
- ! computes a default hdur_movie that creates nice looking movies.
- ! Sets HDUR_MOVIE as the minimum period the mesh can resolve
- if(HDUR_MOVIE <= TINYVAL) &
- HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, &
- 240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0)
-
-
- ! checks parameters
- call rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
- NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
- ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
-
- ! check that mesh can be coarsened in depth three or four times
- CUT_SUPERBRICK_XI=.false.
- CUT_SUPERBRICK_ETA=.false.
-
- if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then
- if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8'
- if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8'
- if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI'
- if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA'
- if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
- if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
- else if (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then
- if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16'
- if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16'
- if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI'
- if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA'
- if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
- if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
- else
- if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32'
- if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32'
- if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI'
- if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA'
- if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
- if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
- endif
-
- ELEMENT_WIDTH = ANGULAR_WIDTH_XI_IN_DEGREES/dble(NEX_MAX) * DEGREES_TO_RADIANS
-
-!
-!--- compute additional parameters
-!
-
- ! number of elements horizontally in each slice (i.e. per processor)
- ! these two values MUST be equal in all cases
- NEX_PER_PROC_XI = NEX_XI / NPROC_XI
- NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
-
- ! total number of processors in each of the six chunks
- NPROC = NPROC_XI * NPROC_ETA
-
- ! total number of processors in the full Earth composed of the six chunks
- NPROCTOT = NCHUNKS * NPROC
-
-
- ! definition of general mesh parameters
- call rcp_define_all_layers(NER_CRUST,NER_80_MOHO,NER_220_80,&
- NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,&
- RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
- ONE_CRUST,ner,ratio_sampling_array,&
- NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
- r_bottom,r_top,this_region_has_a_doubling,&
- ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
- elem_doubling_bottom_outer_core,&
- DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
- doubling_index,rmins,rmaxs)
-
-
- ! calculates number of elements (NSPEC)
- call rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
- NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- ner,ratio_sampling_array,this_region_has_a_doubling, &
- ifirst_region,ilast_region,iter_region,iter_layer,&
- doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
- NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
- last_doubling_layer, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
- nglob_edge_v,to_remove)
-
-
- ! calculates number of points (NGLOB)
- call rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
- nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
- this_region_has_a_doubling,&
- ifirst_region, ilast_region, iter_region, iter_layer, &
- doubling, padding, tmp_sum, &
- INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
- NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-
-
- end subroutine read_compute_parameters
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
- NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
- NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
-
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
-
- integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB
-
- integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL
-
- double precision DT
- double precision R_CENTRAL_CUBE
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
-
- logical ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL,ANISOTROPIC_INNER_CORE
-
-! local variables
- integer multiplication_factor
-
- !----
- !---- case prem_onecrust by default
- !----
- if (SUPPRESS_CRUSTAL_MESH) then
- multiplication_factor=2
- else
- multiplication_factor=1
- endif
-
- ! element width = 0.5625000 degrees = 62.54715 km
- if(NEX_MAX*multiplication_factor <= 160) then
- ! time step
- DT = 0.252d0
-
- ! attenuation period range
- MIN_ATTENUATION_PERIOD = 30
- MAX_ATTENUATION_PERIOD = 1500
-
- ! number of element layers in each mesh region
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 2
- NER_400_220 = 2
- NER_600_400 = 2
- NER_670_600 = 1
- NER_771_670 = 1
- NER_TOPDDOUBLEPRIME_771 = 15
- NER_CMB_TOPDDOUBLEPRIME = 1
- NER_OUTER_CORE = 16
- NER_TOP_CENTRAL_CUBE_ICB = 2
-
- ! radius of central cube
- R_CENTRAL_CUBE = 950000.d0
-
- ! element width = 0.3515625 degrees = 39.09196 km
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.225d0
-
- MIN_ATTENUATION_PERIOD = 20
- MAX_ATTENUATION_PERIOD = 1000
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 2
- NER_400_220 = 3
- NER_600_400 = 3
- NER_670_600 = 1
- NER_771_670 = 1
- NER_TOPDDOUBLEPRIME_771 = 22
- NER_CMB_TOPDDOUBLEPRIME = 2
- NER_OUTER_CORE = 24
- NER_TOP_CENTRAL_CUBE_ICB = 3
- R_CENTRAL_CUBE = 965000.d0
-
- ! element width = 0.2812500 degrees = 31.27357 km
- else if(NEX_MAX*multiplication_factor <= 320) then
- DT = 0.16d0
-
- MIN_ATTENUATION_PERIOD = 15
- MAX_ATTENUATION_PERIOD = 750
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 3
- NER_400_220 = 4
- NER_600_400 = 4
- NER_670_600 = 1
- NER_771_670 = 2
- NER_TOPDDOUBLEPRIME_771 = 29
- NER_CMB_TOPDDOUBLEPRIME = 2
- NER_OUTER_CORE = 32
- NER_TOP_CENTRAL_CUBE_ICB = 4
- R_CENTRAL_CUBE = 940000.d0
-
- ! element width = 0.1875000 degrees = 20.84905 km
- else if(NEX_MAX*multiplication_factor <= 480) then
- DT = 0.11d0
-
- MIN_ATTENUATION_PERIOD = 10
- MAX_ATTENUATION_PERIOD = 500
-
- NER_CRUST = 1
- NER_80_MOHO = 2
- NER_220_80 = 4
- NER_400_220 = 5
- NER_600_400 = 6
- NER_670_600 = 2
- NER_771_670 = 2
- NER_TOPDDOUBLEPRIME_771 = 44
- NER_CMB_TOPDDOUBLEPRIME = 3
- NER_OUTER_CORE = 48
- NER_TOP_CENTRAL_CUBE_ICB = 5
- R_CENTRAL_CUBE = 988000.d0
-
- ! element width = 0.1757812 degrees = 19.54598 km
- else if(NEX_MAX*multiplication_factor <= 512) then
- DT = 0.1125d0
-
- MIN_ATTENUATION_PERIOD = 9
- MAX_ATTENUATION_PERIOD = 500
-
- NER_CRUST = 1
- NER_80_MOHO = 2
- NER_220_80 = 4
- NER_400_220 = 6
- NER_600_400 = 6
- NER_670_600 = 2
- NER_771_670 = 3
- NER_TOPDDOUBLEPRIME_771 = 47
- NER_CMB_TOPDDOUBLEPRIME = 3
- NER_OUTER_CORE = 51
- NER_TOP_CENTRAL_CUBE_ICB = 5
- R_CENTRAL_CUBE = 1010000.d0
-
- ! element width = 0.1406250 degrees = 15.63679 km
- else if(NEX_MAX*multiplication_factor <= 640) then
- DT = 0.09d0
-
- MIN_ATTENUATION_PERIOD = 8
- MAX_ATTENUATION_PERIOD = 400
-
- NER_CRUST = 2
- NER_80_MOHO = 3
- NER_220_80 = 5
- NER_400_220 = 7
- NER_600_400 = 8
- NER_670_600 = 3
- NER_771_670 = 3
- NER_TOPDDOUBLEPRIME_771 = 59
- NER_CMB_TOPDDOUBLEPRIME = 4
- NER_OUTER_CORE = 64
- NER_TOP_CENTRAL_CUBE_ICB = 6
- R_CENTRAL_CUBE = 1020000.d0
-
- ! element width = 0.1041667 degrees = 11.58280 km
- else if(NEX_MAX*multiplication_factor <= 864) then
- DT = 0.0667d0
-
- MIN_ATTENUATION_PERIOD = 6
- MAX_ATTENUATION_PERIOD = 300
-
- NER_CRUST = 2
- NER_80_MOHO = 4
- NER_220_80 = 6
- NER_400_220 = 10
- NER_600_400 = 10
- NER_670_600 = 3
- NER_771_670 = 4
- NER_TOPDDOUBLEPRIME_771 = 79
- NER_CMB_TOPDDOUBLEPRIME = 5
- NER_OUTER_CORE = 86
- NER_TOP_CENTRAL_CUBE_ICB = 9
- R_CENTRAL_CUBE = 990000.d0
-
- ! element width = 7.8125000E-02 degrees = 8.687103 km
- else if(NEX_MAX*multiplication_factor <= 1152) then
- DT = 0.05d0
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = 3
- NER_80_MOHO = 6
- NER_220_80 = 8
- NER_400_220 = 13
- NER_600_400 = 13
- NER_670_600 = 4
- NER_771_670 = 6
- NER_TOPDDOUBLEPRIME_771 = 106
- NER_CMB_TOPDDOUBLEPRIME = 7
- NER_OUTER_CORE = 116
- NER_TOP_CENTRAL_CUBE_ICB = 12
- R_CENTRAL_CUBE = 985000.d0
-
- ! element width = 7.2115384E-02 degrees = 8.018865 km
- else if(NEX_MAX*multiplication_factor <= 1248) then
- DT = 0.0462d0
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = 3
- NER_80_MOHO = 6
- NER_220_80 = 9
- NER_400_220 = 14
- NER_600_400 = 14
- NER_670_600 = 5
- NER_771_670 = 6
- NER_TOPDDOUBLEPRIME_771 = 114
- NER_CMB_TOPDDOUBLEPRIME = 8
- NER_OUTER_CORE = 124
- NER_TOP_CENTRAL_CUBE_ICB = 13
- R_CENTRAL_CUBE = 985000.d0
-
- else
-
- ! scale with respect to 1248 if above that limit
- DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
- NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
- NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
- NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
- NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
- NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
- NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
- NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
- NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
- NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
- NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
- R_CENTRAL_CUBE = 985000.d0
-
- !! removed this limit else
- !! removed this limit stop 'problem with this value of NEX_MAX'
- endif
-
- !> Hejun
- ! avoids elongated elements below the 670-discontinuity,
- ! since for model REFERENCE_MODEL_1DREF,
- ! the 670-discontinuity is moved up to 650 km depth.
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF) then
- NER_771_670 = NER_771_670 + 1
- endif
-
- !----
- !---- change some values in the case of regular PREM with two crustal layers or of 3D models
- !----
-
- ! case of regular PREM with two crustal layers: change the time step for small meshes
- ! because of a different size of elements in the radial direction in the crust
- if (HONOR_1D_SPHERICAL_MOHO) then
- ! 1D models honor 1D spherical moho
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST < 2 ) NER_CRUST = 2
- ! makes time step smaller
- if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.20d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.20d0
- endif
- endif
- else
- ! 3D models: must have two element layers for crust
- if (NER_CRUST < 2 ) NER_CRUST = 2
- ! makes time step smaller
- if(NEX_MAX*multiplication_factor <= 80) then
- DT = 0.125d0
- else if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.15d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.17d0
- else if(NEX_MAX*multiplication_factor <= 320) then
- DT = 0.155d0
- endif
- endif
-
- if( .not. ATTENUATION_RANGE_PREDEFINED ) then
- call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
- endif
-
- if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
- ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
- NEX_MAX > 1248) then
-
- call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
- NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
- NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
- R_CENTRAL_CUBE, CASE_3D, CRUSTAL, &
- HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
-
- call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
-
- call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
-
- !! DK DK suppressed because this routine should not write anything to the screen
- ! write(*,*)'##############################################################'
- ! write(*,*)
- ! write(*,*)' Auto Radial Meshing Code '
- ! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
- ! write(*,*)' This should only be invoked for chunks less than 90 degrees'
- ! write(*,*)' and for chunks greater than 1248 elements wide'
- ! write(*,*)
- ! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
- ! write(*,*)'NEX: ', NEX_MAX
- ! write(*,*)'NER_CRUST: ', NER_CRUST
- ! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
- ! write(*,*)'NER_220_80: ', NER_220_80
- ! write(*,*)'NER_400_220: ', NER_400_220
- ! write(*,*)'NER_600_400: ', NER_600_400
- ! write(*,*)'NER_670_600: ', NER_670_600
- ! write(*,*)'NER_771_670: ', NER_771_670
- ! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
- ! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
- ! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
- ! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
- ! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
- ! write(*,*)'multiplication factor: ', multiplication_factor
- ! write(*,*)
- ! write(*,*)'DT: ',DT
- ! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
- ! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
- ! write(*,*)
- ! write(*,*)'##############################################################'
-
- if (HONOR_1D_SPHERICAL_MOHO) then
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST < 2 ) NER_CRUST = 2
- endif
- else
- ! case 3D
- if (NER_CRUST < 2 ) NER_CRUST = 2
- endif
-
- endif
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
-
- ! time step reductions are based on empirical values (..somehow)
-
- ! following models need special attention, at least for global simulations:
- if( NCHUNKS == 6 ) then
-
- ! makes time step smaller for this ref model, otherwise becomes unstable in fluid
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) &
- DT = DT*(1.d0 - 0.3d0)
-
- ! using inner core anisotropy, simulations might become unstable in solid
- if( ANISOTROPIC_INNER_CORE ) then
- ! DT = DT*(1.d0 - 0.1d0) not working yet...
- stop 'anisotropic inner core - unstable feature, uncomment this line in read_compute_parameters.f90'
- endif
-
- endif
-
- ! following models need special attention, regardless of number of chunks:
- ! it makes the time step smaller for this ref model, otherwise becomes unstable in fluid
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) &
- DT = DT*(1.d0 - 0.8d0) ! *0.20d0
-
-
- if( ITYPE_CRUSTAL_MODEL == ICRUST_CRUSTMAPS ) &
- DT = DT*(1.d0 - 0.3d0)
-
- ! decreases time step as otherwise the solution might become unstable for rougher/unsmoothed models
- ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) &
- ! DT = DT * (1.d0 - 0.2d0)
-
- ! takes a 5% safety margin on the maximum stable time step
- ! which was obtained by trial and error
- DT = DT * (1.d0 - 0.05d0)
-
- ! adapts number of element layers in crust and time step for regional simulations
- if( REGIONAL_MOHO_MESH ) then
- ! hard coded number of crustal element layers and time step
-
- ! checks
- if( NCHUNKS > 1 ) stop 'regional moho mesh: NCHUNKS error in rcp_set_timestep_and_layers'
- if( HONOR_1D_SPHERICAL_MOHO ) return
-
- ! original values
- !print*,'NER:',NER_CRUST
- !print*,'DT:',DT
-
- ! enforce 3 element layers
- NER_CRUST = 3
-
- ! increased stability, empirical
- DT = DT*(1.d0 + 0.5d0)
-
- if( REGIONAL_MOHO_MESH_EUROPE ) DT = 0.17 ! europe
- if( REGIONAL_MOHO_MESH_ASIA ) DT = 0.15 ! asia & middle east
-
- endif
-
-
- end subroutine rcp_set_timestep_and_layers
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
- NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
- ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
-
- implicit none
-
- include "constants.h"
-
- integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
-
- logical ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS,&
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM
-
-
-! checks parameters
-
- if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
- stop 'NCHUNKS must be either 1, 2, 3 or 6'
-
- ! this MUST be 90 degrees for two chunks or more to match geometrically
- if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) &
- stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk'
-
- ! this can be any value in the case of two chunks
- if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) &
- stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks'
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) &
- stop 'cannot have absorbing conditions in the full Earth'
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) &
- stop 'absorbing conditions not supported for three chunks yet'
-
- if(ATTENUATION_3D .and. .not. ATTENUATION) &
- stop 'need ATTENUATION to use ATTENUATION_3D'
-
- if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
- stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5, check the Par_file'
-
- ! check that reals are either 4 or 8 bytes
- if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) &
- stop 'wrong size of CUSTOM_REAL for reals'
-
- ! check that the parameter file is correct
- if(NGNOD /= 27) &
- stop 'number of control nodes must be 27'
- if(NGNOD == 27 .and. NGNOD2D /= 9) &
- stop 'elements with 27 points should have NGNOD2D = 9'
-
- ! for the number of standard linear solids for attenuation
- if(N_SLS /= 3) &
- stop 'number of SLS must be 3'
-
- ! check number of slices in each direction
- if(NCHUNKS < 1) &
- stop 'must have at least one chunk'
- if(NPROC_XI < 1) &
- stop 'NPROC_XI must be at least 1'
- if(NPROC_ETA < 1) &
- stop 'NPROC_ETA must be at least 1'
-
- ! check number of chunks
- if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
- stop 'only one, two, three or six chunks can be meshed'
-
- ! check that the central cube can be included
- if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) &
- stop 'need six chunks to include central cube'
-
- ! check that sphere can be cut into slices without getting negative Jacobian
- if(NEX_XI < 48) &
- stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian'
- if(NEX_ETA < 48) &
- stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian'
-
- ! check that topology is correct if more than two chunks
- if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) &
- stop 'must have NEX_XI = NEX_ETA for more than two chunks'
-
- if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) &
- stop 'must have NPROC_XI = NPROC_ETA for more than two chunks'
-
- ! support for only one slice per chunk has been discontinued when there is more than one chunk
- ! because it induces topological problems, and we are not interested in using small meshes
- if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
-
- end subroutine rcp_check_parameters
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine rcp_define_all_layers(NER_CRUST,NER_80_MOHO,NER_220_80,&
- NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,&
- RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
- ONE_CRUST,ner,ratio_sampling_array,&
- NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
- r_bottom,r_top,this_region_has_a_doubling,&
- ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
- elem_doubling_bottom_outer_core,&
- DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
- doubling_index,rmins,rmaxs)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! definition of general mesh parameters below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB
- integer NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer
-
- double precision RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- logical ONE_CRUST
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
- double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
-
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-
-
-! find element below top of which we should implement the second doubling in the mantle
-! locate element closest to optimal value
- distance_min = HUGEVAL
- do ielem = 2,NER_TOPDDOUBLEPRIME_771
- zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771)
- distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_mantle = ielem
- distance_min = distance
- DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-
-! find element below top of which we should implement the third doubling in the middle of the outer core
-! locate element closest to optimal value
- distance_min = HUGEVAL
-! start at element number 4 because we need at least two elements below for the fourth doubling
-! implemented at the bottom of the outer core
- do ielem = 4,NER_OUTER_CORE
- zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
- distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_middle_outer_core = ielem
- distance_min = distance
- DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-
- if (ADD_4TH_DOUBLING) then
-! find element below top of which we should implement the fourth doubling in the middle of the outer core
-! locate element closest to optimal value
- distance_min = HUGEVAL
-! end two elements before the top because we need at least two elements above for the third doubling
-! implemented in the middle of the outer core
- do ielem = 2,NER_OUTER_CORE-2
- zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
- distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_bottom_outer_core = ielem
- distance_min = distance
- DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-! make sure that the two doublings in the outer core are found in the right order
- if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) &
- stop 'error in location of the two doublings in the outer core'
- endif
-
- ratio_sampling_array(15) = 0
-
-! define all the layers of the mesh
- if (.not. ADD_4TH_DOUBLING) then
-
- ! default case:
- ! no fourth doubling at the bottom of the outer core
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ! suppress the crustal layers
- ! will be replaced by an extension of the mantle: R_EARTH is not modified,
- ! but no more crustal doubling
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 1
-
- ! now only one region
- ner( 1) = NER_CRUST + NER_80_MOHO
- ner( 2) = 0
- ner( 3) = 0
-
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:9) = 1
- ratio_sampling_array(10:12) = 2
- ratio_sampling_array(13:14) = 4
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- last_doubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = R80_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMIDDLE_CRUST !!!! now fictitious
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:13) = RCMB / R_EARTH
- rmins(12:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- else if (ONE_CRUST) then
-
- ! 1D models:
- ! in order to increase stability and therefore to allow cheaper
- ! simulations (larger time step), 1D models can be run with just one average crustal
- ! layer instead of two.
-
- NUMBER_OF_MESH_LAYERS = 13
- layer_offset = 0
-
- ner( 1) = NER_CRUST
- ner( 2) = NER_80_MOHO
- ner( 3) = NER_220_80
- ner( 4) = NER_400_220
- ner( 5) = NER_600_400
- ner( 6) = NER_670_600
- ner( 7) = NER_771_670
- ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner( 9) = elem_doubling_mantle
- ner(10) = NER_CMB_TOPDDOUBLEPRIME
- ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(12) = elem_doubling_middle_outer_core
- ner(13) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1) = 1
- ratio_sampling_array(2:8) = 2
- ratio_sampling_array(9:11) = 4
- ratio_sampling_array(12:13) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1) = IFLAG_CRUST
- doubling_index(2) = IFLAG_80_MOHO
- doubling_index(3) = IFLAG_220_80
- doubling_index(4:6) = IFLAG_670_220
- doubling_index(7:10) = IFLAG_MANTLE_NORMAL
- doubling_index(11:12) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(13) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(2) = .true.
- this_region_has_a_doubling(9) = .true.
- this_region_has_a_doubling(12) = .true.
- last_doubling_layer = 12
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
- !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
- !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
- !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
- !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
- !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(2) = R80_FICTITIOUS_IN_MESHER
-
- r_top(3) = R80_FICTITIOUS_IN_MESHER
- r_bottom(3) = R220
-
- r_top(4) = R220
- r_bottom(4) = R400
-
- r_top(5) = R400
- r_bottom(5) = R600
-
- r_top(6) = R600
- r_bottom(6) = R670
-
- r_top(7) = R670
- r_bottom(7) = R771
-
- r_top(8) = R771
- r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(9) = RTOPDDOUBLEPRIME
-
- r_top(10) = RTOPDDOUBLEPRIME
- r_bottom(10) = RCMB
-
- r_top(11) = RCMB
- r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(12) = RICB
-
- r_top(13) = RICB
- r_bottom(13) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(2) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R220 / R_EARTH
-
- rmaxs(4) = R220 / R_EARTH
- rmins(4) = R400 / R_EARTH
-
- rmaxs(5) = R400 / R_EARTH
- rmins(5) = R600 / R_EARTH
-
- rmaxs(6) = R600 / R_EARTH
- rmins(6) = R670 / R_EARTH
-
- rmaxs(7) = R670 / R_EARTH
- rmins(7) = R771 / R_EARTH
-
- rmaxs(8:9) = R771 / R_EARTH
- rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(10) = RCMB / R_EARTH
-
- rmaxs(11:12) = RCMB / R_EARTH
- rmins(11:12) = RICB / R_EARTH
-
- rmaxs(13) = RICB / R_EARTH
- rmins(13) = R_CENTRAL_CUBE / R_EARTH
-
- else
-
- ! default case for 3D models:
- ! contains the crustal layers
- ! doubling at the base of the crust
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 1
- if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
- ner( 1) = ceiling (NER_CRUST / 2.d0)
- ner( 2) = floor (NER_CRUST / 2.d0)
- else
- ner( 1) = floor (NER_CRUST / 2.d0) ! regional mesh: ner(1) = 1 since NER_CRUST=3
- ner( 2) = ceiling (NER_CRUST / 2.d0) ! ner(2) = 2
- endif
- ner( 3) = NER_80_MOHO
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:2) = 1
- ratio_sampling_array(3:9) = 2
- ratio_sampling_array(10:12) = 4
- ratio_sampling_array(13:14) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:2) = IFLAG_CRUST
- doubling_index(3) = IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(3) = .true.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_has_a_doubling(14) = .false.
- last_doubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMIDDLE_CRUST
-
- r_top(2) = RMIDDLE_CRUST
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMIDDLE_CRUST / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:13) = RCMB / R_EARTH
- rmins(12:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- endif
- else
-
- ! 4th doubling case:
- ! includes fourth doubling at the bottom of the outer core
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ! suppress the crustal layers
- ! will be replaced by an extension of the mantle: R_EARTH is not modified,
- ! but no more crustal doubling
-
- NUMBER_OF_MESH_LAYERS = 15
- layer_offset = 1
-
- ! now only one region
- ner( 1) = NER_CRUST + NER_80_MOHO
- ner( 2) = 0
- ner( 3) = 0
-
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(14) = elem_doubling_bottom_outer_core
- ner(15) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:9) = 1
- ratio_sampling_array(10:12) = 2
- ratio_sampling_array(13) = 4
- ratio_sampling_array(14:15) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(15) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_has_a_doubling(14) = .true.
- last_doubling_layer = 14
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = R80_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMIDDLE_CRUST !!!! now fictitious
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(14) = RICB
-
- r_top(15) = RICB
- r_bottom(15) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:14) = RCMB / R_EARTH
- rmins(12:14) = RICB / R_EARTH
-
- rmaxs(15) = RICB / R_EARTH
- rmins(15) = R_CENTRAL_CUBE / R_EARTH
-
- else if (ONE_CRUST) then
-
- ! 1D models:
- ! in order to increase stability and therefore to allow cheaper
- ! simulations (larger time step), 1D models can be run with just one average crustal
- ! layer instead of two.
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 0
-
- ner( 1) = NER_CRUST
- ner( 2) = NER_80_MOHO
- ner( 3) = NER_220_80
- ner( 4) = NER_400_220
- ner( 5) = NER_600_400
- ner( 6) = NER_670_600
- ner( 7) = NER_771_670
- ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner( 9) = elem_doubling_mantle
- ner(10) = NER_CMB_TOPDDOUBLEPRIME
- ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(12) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(13) = elem_doubling_bottom_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1) = 1
- ratio_sampling_array(2:8) = 2
- ratio_sampling_array(9:11) = 4
- ratio_sampling_array(12) = 8
- ratio_sampling_array(13:14) = 16
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1) = IFLAG_CRUST
- doubling_index(2) = IFLAG_80_MOHO
- doubling_index(3) = IFLAG_220_80
- doubling_index(4:6) = IFLAG_670_220
- doubling_index(7:10) = IFLAG_MANTLE_NORMAL
- doubling_index(11:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(2) = .true.
- this_region_has_a_doubling(9) = .true.
- this_region_has_a_doubling(12) = .true.
- this_region_has_a_doubling(13) = .true.
- last_doubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
- !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
- !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
- !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
- !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
- !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(2) = R80_FICTITIOUS_IN_MESHER
-
- r_top(3) = R80_FICTITIOUS_IN_MESHER
- r_bottom(3) = R220
-
- r_top(4) = R220
- r_bottom(4) = R400
-
- r_top(5) = R400
- r_bottom(5) = R600
-
- r_top(6) = R600
- r_bottom(6) = R670
-
- r_top(7) = R670
- r_bottom(7) = R771
-
- r_top(8) = R771
- r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(9) = RTOPDDOUBLEPRIME
-
- r_top(10) = RTOPDDOUBLEPRIME
- r_bottom(10) = RCMB
-
- r_top(11) = RCMB
- r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(12) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(2) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R220 / R_EARTH
-
- rmaxs(4) = R220 / R_EARTH
- rmins(4) = R400 / R_EARTH
-
- rmaxs(5) = R400 / R_EARTH
- rmins(5) = R600 / R_EARTH
-
- rmaxs(6) = R600 / R_EARTH
- rmins(6) = R670 / R_EARTH
-
- rmaxs(7) = R670 / R_EARTH
- rmins(7) = R771 / R_EARTH
-
- rmaxs(8:9) = R771 / R_EARTH
- rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(10) = RCMB / R_EARTH
-
- rmaxs(11:13) = RCMB / R_EARTH
- rmins(11:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- else
-
- ! for 3D models:
- ! contains the crustal layers
- ! doubling at the base of the crust
-
- NUMBER_OF_MESH_LAYERS = 15
- layer_offset = 1
- if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
- ner( 1) = ceiling (NER_CRUST / 2.d0)
- ner( 2) = floor (NER_CRUST / 2.d0)
- else
- ner( 1) = floor (NER_CRUST / 2.d0)
- ner( 2) = ceiling (NER_CRUST / 2.d0)
- endif
- ner( 3) = NER_80_MOHO
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(14) = elem_doubling_bottom_outer_core
- ner(15) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:2) = 1
- ratio_sampling_array(3:9) = 2
- ratio_sampling_array(10:12) = 4
- ratio_sampling_array(13) = 8
- ratio_sampling_array(14:15) = 16
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:2) = IFLAG_CRUST
- doubling_index(3) = IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(15) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(3) = .true.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_has_a_doubling(14) = .true.
- last_doubling_layer = 14
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMIDDLE_CRUST
-
- r_top(2) = RMIDDLE_CRUST
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(14) = RICB
-
- r_top(15) = RICB
- r_bottom(15) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMIDDLE_CRUST / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:14) = RCMB / R_EARTH
- rmins(12:14) = RICB / R_EARTH
-
- rmaxs(15) = RICB / R_EARTH
- rmins(15) = R_CENTRAL_CUBE / R_EARTH
- endif
- endif
-
-
- end subroutine rcp_define_all_layers
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
- NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- ner,ratio_sampling_array,this_region_has_a_doubling, &
- ifirst_region,ilast_region,iter_region,iter_layer, &
- doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
- NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
- last_doubling_layer, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
- nglob_edge_v,to_remove)
-
-
- implicit none
-
- include "constants.h"
-
-
-! parameters to be computed based upon parameters above read from file
- integer NPROC,NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
-
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
-
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, tmp_sum, tmp_sum_xi, tmp_sum_eta
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf
-
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- logical :: INCLUDE_CENTRAL_CUBE
- integer :: last_doubling_layer
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
-
- integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of elements (NSPEC) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ratio_divide_central_cube = maxval(ratio_sampling_array(1:NUMBER_OF_MESH_LAYERS))
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 1D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- ! theoretical number of spectral elements in radial direction
- do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- NSPEC1D_RADIAL(iter_region) = sum(ner(ifirst_region:ilast_region))
- enddo
-
- ! difference of radial number of element for outer core if the superbrick is cut
- DIFF_NSPEC1D_RADIAL(:,:) = 0
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC1D_RADIAL(2,1) = 1
- DIFF_NSPEC1D_RADIAL(3,1) = 2
- DIFF_NSPEC1D_RADIAL(4,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(2,2) = 2
- DIFF_NSPEC1D_RADIAL(3,2) = 1
-
- DIFF_NSPEC1D_RADIAL(1,3) = 1
- DIFF_NSPEC1D_RADIAL(3,3) = 1
- DIFF_NSPEC1D_RADIAL(4,3) = 2
-
- DIFF_NSPEC1D_RADIAL(1,4) = 2
- DIFF_NSPEC1D_RADIAL(2,4) = 1
- DIFF_NSPEC1D_RADIAL(4,4) = 1
- else
- DIFF_NSPEC1D_RADIAL(2,1) = 1
- DIFF_NSPEC1D_RADIAL(3,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(4,2) = 1
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC1D_RADIAL(3,1) = 1
- DIFF_NSPEC1D_RADIAL(4,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(2,2) = 1
- endif
- endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 2D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! exact number of surface elements for faces along XI and ETA
-
- do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum_xi = 0
- tmp_sum_eta = 0
- tmp_sum_nglob2D_xi = 0
- tmp_sum_nglob2D_eta = 0
- do iter_layer = ifirst_region, ilast_region
- if (this_region_has_a_doubling(iter_layer)) then
- if (iter_region == IREGION_OUTER_CORE .and. iter_layer == last_doubling_layer) then
- ! simple brick
- divider = 1
- nglob_surf = 6*NGLLX**2 - 7*NGLLX + 2
- nglob_edges_h = 2*(NGLLX-1)+1 + NGLLX
- ! minimum value to be safe
- nglob_edge_v = NGLLX-2
- nb_lay_sb = 2
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
- else
- ! double brick
- divider = 2
- if (ner(iter_layer) == 1) then
- nglob_surf = 6*NGLLX**2 - 8*NGLLX + 3
- nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
- nglob_edge_v = NGLLX-2
- nb_lay_sb = 1
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
- else
- nglob_surf = 8*NGLLX**2 - 11*NGLLX + 4
- nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
- nglob_edge_v = 2*(NGLLX-1)+1 -2
- nb_lay_sb = 2
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
- divider = 2
- endif
- endif
- doubling = 1
- to_remove = 1
- else
- if (iter_layer /= ifirst_region) then
- to_remove = 0
- else
- to_remove = 1
- endif
- ! dummy values to avoid a warning
- nglob_surf = 0
- nglob_edges_h = 0
- nglob_edge_v = 0
- divider = 1
- doubling = 0
- nb_lay_sb = 0
- nspec2D_xi_sb = 0
- nspec2D_eta_sb = 0
- endif
-
- tmp_sum_xi = tmp_sum_xi + ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * (nspec2D_xi_sb/2))
-
- tmp_sum_eta = tmp_sum_eta + ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * (nspec2D_eta_sb/2))
-
- tmp_sum_nglob2D_xi = tmp_sum_nglob2D_xi + (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
- ((((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
- ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))*(ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
- (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
- doubling * (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
- ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
-
- tmp_sum_nglob2D_eta = tmp_sum_nglob2D_eta + (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
- ((((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
- ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))* &
- (ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
- (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
- doubling * (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
- ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
-
- enddo ! iter_layer
-
- NSPEC2D_XI(iter_region) = tmp_sum_xi
- NSPEC2D_ETA(iter_region) = tmp_sum_eta
-
- NGLOB2DMAX_YMIN_YMAX(iter_region) = tmp_sum_nglob2D_xi
- NGLOB2DMAX_XMIN_XMAX(iter_region) = tmp_sum_nglob2D_eta
-
- if (iter_region == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE) then
- NSPEC2D_XI(iter_region) = NSPEC2D_XI(iter_region) + &
- ((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
- NSPEC2D_ETA(iter_region) = NSPEC2D_ETA(iter_region) + &
- ((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
-
- NGLOB2DMAX_YMIN_YMAX(iter_region) = NGLOB2DMAX_YMIN_YMAX(iter_region) + &
- (((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
-
- NGLOB2DMAX_XMIN_XMAX(iter_region) = NGLOB2DMAX_XMIN_XMAX(iter_region) + &
- (((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
- endif
- enddo ! iter_region
-
- ! difference of number of surface elements along xi or eta for outer core if the superbrick is cut
- DIFF_NSPEC2D_XI(:,:) = 0
- DIFF_NSPEC2D_ETA(:,:) = 0
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC2D_XI(2,1) = 2
- DIFF_NSPEC2D_XI(1,2) = 2
- DIFF_NSPEC2D_XI(2,3) = 2
- DIFF_NSPEC2D_XI(1,4) = 2
-
- DIFF_NSPEC2D_ETA(2,1) = 1
- DIFF_NSPEC2D_ETA(2,2) = 1
- DIFF_NSPEC2D_ETA(1,3) = 1
- DIFF_NSPEC2D_ETA(1,4) = 1
- else
- DIFF_NSPEC2D_ETA(2,1) = 1
- DIFF_NSPEC2D_ETA(1,2) = 1
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC2D_XI(2,1) = 2
- DIFF_NSPEC2D_XI(1,2) = 2
- endif
- endif
- DIFF_NSPEC2D_XI(:,:) = DIFF_NSPEC2D_XI(:,:) * (NEX_PER_PROC_XI / ratio_divide_central_cube)
- DIFF_NSPEC2D_ETA(:,:) = DIFF_NSPEC2D_ETA(:,:) * (NEX_PER_PROC_ETA / ratio_divide_central_cube)
-
-! exact number of surface elements on the bottom and top boundaries
-
- ! in the crust and mantle
- NSPEC2D_TOP(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(1))*(NEX_ETA/ratio_sampling_array(1))/NPROC
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(10+layer_offset))*&
- (NEX_ETA/ratio_sampling_array(10+layer_offset))/NPROC
-
- ! in the outer core with mesh doubling
- if (ADD_4TH_DOUBLING) then
- NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/4))*(NEX_ETA/(ratio_divide_central_cube/4))/NPROC
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- else
- NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/2))*(NEX_ETA/(ratio_divide_central_cube/2))/NPROC
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- endif
-
- ! in the top of the inner core
- NSPEC2D_TOP(IREGION_INNER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- NSPEC2D_BOTTOM(IREGION_INNER_CORE) = NSPEC2D_TOP(IREGION_INNER_CORE)
-
- ! maximum number of surface elements on vertical boundaries of the slices
- NSPEC2DMAX_XMIN_XMAX(:) = NSPEC2D_ETA(:)
- NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_ETA(:,:))
- NSPEC2DMAX_YMIN_YMAX(:) = NSPEC2D_XI(:)
- NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_XI(:,:))
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 3D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! exact number of spectral elements in each region
-
- do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum = 0;
- do iter_layer = ifirst_region, ilast_region
- if (this_region_has_a_doubling(iter_layer)) then
- if (ner(iter_layer) == 1) then
- nb_lay_sb = 1
- nspec_sb = NSPEC_SUPERBRICK_1L
- else
- nb_lay_sb = 2
- nspec_sb = NSPEC_DOUBLING_SUPERBRICK
- endif
- doubling = 1
- else
- doubling = 0
- nb_lay_sb = 0
- nspec_sb = 0
- endif
- tmp_sum = tmp_sum + (((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
- (nspec_sb/4))) / NPROC
- enddo
- NSPEC(iter_region) = tmp_sum
- enddo
-
- if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + &
- (NEX_PER_PROC_XI / ratio_divide_central_cube) * &
- (NEX_PER_PROC_ETA / ratio_divide_central_cube) * &
- (NEX_XI / ratio_divide_central_cube)
-
- if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere, try to recompile :) '
-
-
- end subroutine rcp_count_elements
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
- nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
- this_region_has_a_doubling,&
- ifirst_region, ilast_region, iter_region, iter_layer, &
- doubling, padding, tmp_sum, &
- INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
- NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of points (NGLOB) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
-
-! parameters to be computed based upon parameters above read from file
- integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, dimension(MAX_NUM_REGIONS) :: &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB
-
- integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
- integer nblocks_xi,nblocks_eta
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,INCLUDE_CENTRAL_CUBE
- integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 1D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! theoretical number of Gauss-Lobatto points in radial direction
- NGLOB1D_RADIAL(:) = NSPEC1D_RADIAL(:)*(NGLLZ-1)+1
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 2D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 2-D addressing and buffers for summation between slices
-! we add one to number of points because of the flag after the last point
- NGLOB2DMAX_XMIN_XMAX(:) = NGLOB2DMAX_XMIN_XMAX(:) + 1
- NGLOB2DMAX_YMIN_YMAX(:) = NGLOB2DMAX_YMIN_YMAX(:) + 1
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 3D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! exact number of global points in each region
-
-! initialize array
- NGLOB(:) = 0
-
-! in the inner core (no doubling region + eventually central cube)
- if(INCLUDE_CENTRAL_CUBE) then
- NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
- *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
- *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1)
- else
- NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
- *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
- *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB)*(NGLLZ-1)+1)
- endif
-
-! in the crust-mantle and outercore
- do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum = 0;
- do iter_layer = ifirst_region, ilast_region
- nglob_int_surf_eta=0
- nglob_int_surf_xi=0
- nglob_ext_surf = 0
- nglob_center_edge = 0
- nglob_corner_edge = 0
- nglob_border_edge = 0
- if (this_region_has_a_doubling(iter_layer)) then
- if (iter_region == IREGION_OUTER_CORE .and. iter_layer == last_doubling_layer .and. &
- (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
- doubling = 1
- normal_doubling = 0
- cut_doubling = 1
- nb_lay_sb = 2
- nglob_edge = 0
- nglob_surf = 0
- nglob_vol = 8*NGLLX**3 - 12*NGLLX**2 + 6*NGLLX - 1
- nglob_int_surf_eta = 6*NGLLX**2 - 7*NGLLX + 2
- nglob_int_surf_xi = 5*NGLLX**2 - 5*NGLLX + 1
- nglob_ext_surf = 4*NGLLX**2-4*NGLLX+1
- nglob_center_edge = 4*(NGLLX-1)+1
- nglob_corner_edge = 2*(NGLLX-1)+1
- nglob_border_edge = 3*(NGLLX-1)+1
- else
- if (ner(iter_layer) == 1) then
- nb_lay_sb = 1
- nglob_vol = 28*NGLLX**3 - 62*NGLLX**2 + 47*NGLLX - 12
- nglob_surf = 6*NGLLX**2-8*NGLLX+3
- nglob_edge = NGLLX
- else
- nb_lay_sb = 2
- nglob_vol = 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13
- nglob_surf = 8*NGLLX**2-11*NGLLX+4
- nglob_edge = 2*NGLLX-1
- endif
- doubling = 1
- normal_doubling = 1
- cut_doubling = 0
- endif
- padding = -1
- else
- doubling = 0
- normal_doubling = 0
- cut_doubling = 0
- padding = 0
- nb_lay_sb = 0
- nglob_vol = 0
- nglob_surf = 0
- nglob_edge = 0
- endif
- if (iter_layer == ilast_region) padding = padding +1
- nblocks_xi = NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)
- nblocks_eta = NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)
-
- tmp_sum = tmp_sum + &
- ((nblocks_xi)*(NGLLX-1)+1) * ((nblocks_eta)*(NGLLX-1)+1) * ((ner(iter_layer) - doubling*nb_lay_sb)*(NGLLX-1)+padding)+&
- normal_doubling * ((((nblocks_xi*nblocks_eta)/4)*nglob_vol) - &
- (((nblocks_eta/2-1)*nblocks_xi/2+(nblocks_xi/2-1)*nblocks_eta/2)*nglob_surf) + &
- ((nblocks_eta/2-1)*(nblocks_xi/2-1)*nglob_edge)) + &
- cut_doubling*(nglob_vol*(nblocks_xi*nblocks_eta) - &
- ( nblocks_eta*(int(nblocks_xi/2)*nglob_int_surf_xi + int((nblocks_xi-1)/2)*nglob_ext_surf) + &
- nblocks_xi*(int(nblocks_eta/2)*nglob_int_surf_eta + int((nblocks_eta-1)/2)*nglob_ext_surf)&
- ) + &
- ( int(nblocks_xi/2)*int(nblocks_eta/2)*nglob_center_edge + &
- int((nblocks_xi-1)/2)*int((nblocks_eta-1)/2)*nglob_corner_edge + &
- ((int(nblocks_eta/2)*int((nblocks_xi-1)/2))+(int((nblocks_eta-1)/2)*int(nblocks_xi/2)))*nglob_border_edge&
- ))
- enddo
- NGLOB(iter_region) = tmp_sum
- enddo
-
-!!! example :
-!!! nblocks_xi/2=5
-!!! ____________________________________
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! nblocks_eta/2=3 I______+______+______+______+______I
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! I______+______+______+______+______I
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! I______I______I______I______I______I
-!!!
-!!! NGLOB for this doubling layer = 3*5*Volume - ((3-1)*5+(5-1)*3)*Surface + (3-1)*(5-1)*Edge
-!!!
-!!! 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13 -> nb GLL points in a superbrick (Volume)
-!!! 8*NGLLX**2-11*NGLLX+4 -> nb GLL points on a superbrick side (Surface)
-!!! 2*NGLLX-1 -> nb GLL points on a corner edge of a superbrick (Edge)
-
-!!! for the one layer superbrick :
-!!! NGLOB = 28.NGLL^3 - 62.NGLL^2 + 47.NGLL - 12 (Volume)
-!!! NGLOB = 6.NGLL^2 - 8.NGLL + 3 (Surface)
-!!! NGLOB = NGLL (Edge)
-!!!
-!!! those results were obtained by using the script UTILS/doubling_brick/count_nglob_analytical.pl
-!!! with an opendx file of the superbrick's geometry
-
-!!! for the basic doubling bricks (two layers)
-!!! NGLOB = 8.NGLL^3 - 12.NGLL^2 + 6.NGLL - 1 (VOLUME)
-!!! NGLOB = 5.NGLL^2 - 5.NGLL + 1 (SURFACE 1)
-!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
-
- end subroutine rcp_count_points
-
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.f90 (from rev 22294, seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.F90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/read_compute_parameters.f90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -0,0 +1,2380 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and CNRS / INRIA / University of Pau, France
+! (c) Princeton University and CNRS / INRIA / University of Pau
+! April 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,&
+ MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
+ this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
+ HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
+ USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY,NOISE_TOMOGRAPHY,&
+ SAVE_REGULAR_KL)
+
+
+ implicit none
+
+ include "constants.h"
+
+
+! parameters read from parameter file
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
+ HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
+ MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,&
+ MOVIE_SOUTH_DEG,RECORD_LENGTH_IN_MINUTES
+
+ logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
+ MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters to be computed based upon parameters above read from file
+ integer NSTEP,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ double precision DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400, &
+ R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
+ RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+
+ double precision MOVIE_TOP,MOVIE_BOTTOM,MOVIE_EAST,MOVIE_WEST,&
+ MOVIE_NORTH,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ONE_CRUST,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE, &
+ EMULATE_ONLY
+
+ integer NEX_MAX
+
+ double precision ELEMENT_WIDTH
+
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB
+
+ integer nblocks_xi,nblocks_eta
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
+ double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
+
+! honor PREM Moho or not
+! doing so drastically reduces the stability condition and therefore the time step
+ logical :: HONOR_1D_SPHERICAL_MOHO,CASE_3D
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum, tmp_sum_xi, tmp_sum_eta
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_vol, nglob_surf, nglob_edge
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+ integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
+
+
+ ! reads in Par_file values
+ call read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
+ NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
+ HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM,RECORD_LENGTH_IN_MINUTES, &
+ MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG,&
+ ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
+ MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY,&
+ SAVE_REGULAR_KL)
+
+ ! converts values to radians
+ MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
+ MOVIE_WEST = MOVIE_WEST_DEG * DEGREES_TO_RADIANS
+ MOVIE_NORTH = (90.0d0 - MOVIE_NORTH_DEG) * DEGREES_TO_RADIANS ! converting from latitude to colatitude
+ MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS
+ ! converts movie top/bottom depths to radii
+ MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
+ MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
+
+ ! include central cube or not
+ ! use regular cubed sphere instead of cube for large distances
+ if(NCHUNKS == 6) then
+ INCLUDE_CENTRAL_CUBE = .true.
+ INFLATE_CENTRAL_CUBE = .false.
+ else
+ INCLUDE_CENTRAL_CUBE = .false.
+ INFLATE_CENTRAL_CUBE = .true.
+ endif
+
+ if(.not. EMULATE_ONLY) then
+ NEX_XI = NEX_XI_read
+ NEX_ETA = NEX_ETA_read
+ NPROC_XI = NPROC_XI_read
+ NPROC_ETA = NPROC_ETA_read
+ else
+ ! this is used in UTILS/estimate_best_values_runs.f90 only, to estimate memory use
+ NEX_ETA = NEX_XI
+ NPROC_ETA = NPROC_XI
+ endif
+
+ ! turns on/off corresponding 1-D/3-D model flags
+ ! and sets radius for each discontinuity and ocean density values
+ call get_model_parameters(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
+ OCEANS,TOPOGRAPHY, &
+ ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400,R600,R670,R771, &
+ RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
+ R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
+
+
+ ! sets time step size and number of layers
+ ! right distribution is determined based upon maximum value of NEX
+ NEX_MAX = max(NEX_XI,NEX_ETA)
+ call rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
+ NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
+ NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
+ NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
+ ANISOTROPIC_INNER_CORE)
+
+ ! compute total number of time steps, rounded to next multiple of 100
+ NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
+
+!! DK DK make sure NSTEP is a multiple of NT_DUMP
+ if(UNDO_ATT .and. mod(NSTEP,NT_DUMP) /= 0) NSTEP = (NSTEP/NT_DUMP + 1)*NT_DUMP
+
+! if doing benchmark runs to measure scaling of the code for a limited number of time steps only
+ if (DO_BENCHMARK_RUN_ONLY) NSTEP = NSTEP_FOR_BENCHMARK
+
+!<YANGL
+ if ( NOISE_TOMOGRAPHY /= 0 ) NSTEP = 2*NSTEP-1 ! time steps needs to be doubled, due to +/- branches
+!>YANGL
+
+ ! subsets used to save seismograms must not be larger than the whole time series,
+ ! otherwise we waste memory
+ if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
+
+ ! computes a default hdur_movie that creates nice looking movies.
+ ! Sets HDUR_MOVIE as the minimum period the mesh can resolve
+ if(HDUR_MOVIE <= TINYVAL) &
+ HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, &
+ 240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0)
+
+
+ ! checks parameters
+ call rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
+ NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
+
+ ! check that mesh can be coarsened in depth three or four times
+ CUT_SUPERBRICK_XI=.false.
+ CUT_SUPERBRICK_ETA=.false.
+
+ if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8'
+ if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8'
+ if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI'
+ if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA'
+ if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ else if (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16'
+ if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16'
+ if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI'
+ if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA'
+ if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ else
+ if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32'
+ if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32'
+ if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI'
+ if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA'
+ if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ endif
+
+ ELEMENT_WIDTH = ANGULAR_WIDTH_XI_IN_DEGREES/dble(NEX_MAX) * DEGREES_TO_RADIANS
+
+!
+!--- compute additional parameters
+!
+
+ ! number of elements horizontally in each slice (i.e. per processor)
+ ! these two values MUST be equal in all cases
+ NEX_PER_PROC_XI = NEX_XI / NPROC_XI
+ NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
+
+ ! total number of processors in each of the six chunks
+ NPROC = NPROC_XI * NPROC_ETA
+
+ ! total number of processors in the full Earth composed of the six chunks
+ NPROCTOT = NCHUNKS * NPROC
+
+
+ ! definition of general mesh parameters
+ call rcp_define_all_layers(NER_CRUST,NER_80_MOHO,NER_220_80,&
+ NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,&
+ RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
+ ONE_CRUST,ner,ratio_sampling_array,&
+ NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
+ r_bottom,r_top,this_region_has_a_doubling,&
+ ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
+ elem_doubling_bottom_outer_core,&
+ DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
+ doubling_index,rmins,rmaxs)
+
+
+ ! calculates number of elements (NSPEC)
+ call rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
+ NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ ner,ratio_sampling_array,this_region_has_a_doubling, &
+ ifirst_region,ilast_region,iter_region,iter_layer,&
+ doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
+ NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_surf, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
+ last_doubling_layer, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
+ nglob_edge_v,to_remove)
+
+
+ ! calculates number of points (NGLOB)
+ call rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
+ nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
+ this_region_has_a_doubling,&
+ ifirst_region, ilast_region, iter_region, iter_layer, &
+ doubling, padding, tmp_sum, &
+ INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
+ NUMBER_OF_MESH_LAYERS,layer_offset, &
+ nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
+
+
+
+ end subroutine read_compute_parameters
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
+ NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
+ NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
+ NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
+ ANISOTROPIC_INNER_CORE)
+
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
+
+ integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB
+
+ integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL
+
+ double precision DT
+ double precision R_CENTRAL_CUBE
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
+
+ logical ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL,ANISOTROPIC_INNER_CORE
+
+! local variables
+ integer multiplication_factor
+
+ !----
+ !---- case prem_onecrust by default
+ !----
+ if (SUPPRESS_CRUSTAL_MESH) then
+ multiplication_factor=2
+ else
+ multiplication_factor=1
+ endif
+
+ ! element width = 0.5625000 degrees = 62.54715 km
+ if(NEX_MAX*multiplication_factor <= 160) then
+ ! time step
+ DT = 0.252d0
+
+ ! attenuation period range
+ MIN_ATTENUATION_PERIOD = 30
+ MAX_ATTENUATION_PERIOD = 1500
+
+ ! number of element layers in each mesh region
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 2
+ NER_600_400 = 2
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 15
+ NER_CMB_TOPDDOUBLEPRIME = 1
+ NER_OUTER_CORE = 16
+ NER_TOP_CENTRAL_CUBE_ICB = 2
+
+ ! radius of central cube
+ R_CENTRAL_CUBE = 950000.d0
+
+ ! element width = 0.3515625 degrees = 39.09196 km
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.225d0
+
+ MIN_ATTENUATION_PERIOD = 20
+ MAX_ATTENUATION_PERIOD = 1000
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 3
+ NER_600_400 = 3
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 22
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 24
+ NER_TOP_CENTRAL_CUBE_ICB = 3
+ R_CENTRAL_CUBE = 965000.d0
+
+ ! element width = 0.2812500 degrees = 31.27357 km
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.16d0
+
+ MIN_ATTENUATION_PERIOD = 15
+ MAX_ATTENUATION_PERIOD = 750
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 3
+ NER_400_220 = 4
+ NER_600_400 = 4
+ NER_670_600 = 1
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 29
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 32
+ NER_TOP_CENTRAL_CUBE_ICB = 4
+ R_CENTRAL_CUBE = 940000.d0
+
+ ! element width = 0.1875000 degrees = 20.84905 km
+ else if(NEX_MAX*multiplication_factor <= 480) then
+ DT = 0.11d0
+
+ MIN_ATTENUATION_PERIOD = 10
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 5
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 44
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 48
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 988000.d0
+
+ ! element width = 0.1757812 degrees = 19.54598 km
+ else if(NEX_MAX*multiplication_factor <= 512) then
+ DT = 0.1125d0
+
+ MIN_ATTENUATION_PERIOD = 9
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 6
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 47
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 51
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 1010000.d0
+
+ ! element width = 0.1406250 degrees = 15.63679 km
+ else if(NEX_MAX*multiplication_factor <= 640) then
+ DT = 0.09d0
+
+ MIN_ATTENUATION_PERIOD = 8
+ MAX_ATTENUATION_PERIOD = 400
+
+ NER_CRUST = 2
+ NER_80_MOHO = 3
+ NER_220_80 = 5
+ NER_400_220 = 7
+ NER_600_400 = 8
+ NER_670_600 = 3
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 59
+ NER_CMB_TOPDDOUBLEPRIME = 4
+ NER_OUTER_CORE = 64
+ NER_TOP_CENTRAL_CUBE_ICB = 6
+ R_CENTRAL_CUBE = 1020000.d0
+
+ ! element width = 0.1041667 degrees = 11.58280 km
+ else if(NEX_MAX*multiplication_factor <= 864) then
+ DT = 0.0667d0
+
+ MIN_ATTENUATION_PERIOD = 6
+ MAX_ATTENUATION_PERIOD = 300
+
+ NER_CRUST = 2
+ NER_80_MOHO = 4
+ NER_220_80 = 6
+ NER_400_220 = 10
+ NER_600_400 = 10
+ NER_670_600 = 3
+ NER_771_670 = 4
+ NER_TOPDDOUBLEPRIME_771 = 79
+ NER_CMB_TOPDDOUBLEPRIME = 5
+ NER_OUTER_CORE = 86
+ NER_TOP_CENTRAL_CUBE_ICB = 9
+ R_CENTRAL_CUBE = 990000.d0
+
+ ! element width = 7.8125000E-02 degrees = 8.687103 km
+ else if(NEX_MAX*multiplication_factor <= 1152) then
+ DT = 0.05d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 8
+ NER_400_220 = 13
+ NER_600_400 = 13
+ NER_670_600 = 4
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 106
+ NER_CMB_TOPDDOUBLEPRIME = 7
+ NER_OUTER_CORE = 116
+ NER_TOP_CENTRAL_CUBE_ICB = 12
+ R_CENTRAL_CUBE = 985000.d0
+
+ ! element width = 7.2115384E-02 degrees = 8.018865 km
+ else if(NEX_MAX*multiplication_factor <= 1248) then
+ DT = 0.0462d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 9
+ NER_400_220 = 14
+ NER_600_400 = 14
+ NER_670_600 = 5
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 114
+ NER_CMB_TOPDDOUBLEPRIME = 8
+ NER_OUTER_CORE = 124
+ NER_TOP_CENTRAL_CUBE_ICB = 13
+ R_CENTRAL_CUBE = 985000.d0
+
+ else
+
+ ! scale with respect to 1248 if above that limit
+ DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
+ NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
+ NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
+ NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
+ NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
+ NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
+ R_CENTRAL_CUBE = 985000.d0
+
+ !! removed this limit else
+ !! removed this limit stop 'problem with this value of NEX_MAX'
+ endif
+
+ !> Hejun
+ ! avoids elongated elements below the 670-discontinuity,
+ ! since for model REFERENCE_MODEL_1DREF,
+ ! the 670-discontinuity is moved up to 650 km depth.
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF) then
+ NER_771_670 = NER_771_670 + 1
+ endif
+
+ !----
+ !---- change some values in the case of regular PREM with two crustal layers or of 3D models
+ !----
+
+ ! case of regular PREM with two crustal layers: change the time step for small meshes
+ ! because of a different size of elements in the radial direction in the crust
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ ! 1D models honor 1D spherical moho
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST < 2 ) NER_CRUST = 2
+ ! makes time step smaller
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.20d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.20d0
+ endif
+ endif
+ else
+ ! 3D models: must have two element layers for crust
+ if (NER_CRUST < 2 ) NER_CRUST = 2
+ ! makes time step smaller
+ if(NEX_MAX*multiplication_factor <= 80) then
+ DT = 0.125d0
+ else if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.15d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.17d0
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.155d0
+ endif
+ endif
+
+ if( .not. ATTENUATION_RANGE_PREDEFINED ) then
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+ endif
+
+ if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
+ ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
+ NEX_MAX > 1248) then
+
+ call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
+ R_CENTRAL_CUBE, CASE_3D, CRUSTAL, &
+ HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
+
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+
+ call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
+
+ !! DK DK suppressed because this routine should not write anything to the screen
+ ! write(*,*)'##############################################################'
+ ! write(*,*)
+ ! write(*,*)' Auto Radial Meshing Code '
+ ! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
+ ! write(*,*)' This should only be invoked for chunks less than 90 degrees'
+ ! write(*,*)' and for chunks greater than 1248 elements wide'
+ ! write(*,*)
+ ! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
+ ! write(*,*)'NEX: ', NEX_MAX
+ ! write(*,*)'NER_CRUST: ', NER_CRUST
+ ! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
+ ! write(*,*)'NER_220_80: ', NER_220_80
+ ! write(*,*)'NER_400_220: ', NER_400_220
+ ! write(*,*)'NER_600_400: ', NER_600_400
+ ! write(*,*)'NER_670_600: ', NER_670_600
+ ! write(*,*)'NER_771_670: ', NER_771_670
+ ! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
+ ! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
+ ! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
+ ! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
+ ! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
+ ! write(*,*)'multiplication factor: ', multiplication_factor
+ ! write(*,*)
+ ! write(*,*)'DT: ',DT
+ ! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
+ ! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
+ ! write(*,*)
+ ! write(*,*)'##############################################################'
+
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST < 2 ) NER_CRUST = 2
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST < 2 ) NER_CRUST = 2
+ endif
+
+ endif
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+
+ ! time step reductions are based on empirical values (..somehow)
+
+ ! following models need special attention, at least for global simulations:
+ if( NCHUNKS == 6 ) then
+
+ ! makes time step smaller for this ref model, otherwise becomes unstable in fluid
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) &
+ DT = DT*(1.d0 - 0.3d0)
+
+ ! using inner core anisotropy, simulations might become unstable in solid
+ if( ANISOTROPIC_INNER_CORE ) then
+ ! DT = DT*(1.d0 - 0.1d0) not working yet...
+ stop 'anisotropic inner core - unstable feature, uncomment this line in read_compute_parameters.f90'
+ endif
+
+ endif
+
+ ! following models need special attention, regardless of number of chunks:
+ ! it makes the time step smaller for this ref model, otherwise becomes unstable in fluid
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) &
+ DT = DT*(1.d0 - 0.8d0) ! *0.20d0
+
+
+ if( ITYPE_CRUSTAL_MODEL == ICRUST_CRUSTMAPS ) &
+ DT = DT*(1.d0 - 0.3d0)
+
+ ! decreases time step as otherwise the solution might become unstable for rougher/unsmoothed models
+ ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) &
+ ! DT = DT * (1.d0 - 0.2d0)
+
+ ! takes a 5% safety margin on the maximum stable time step
+ ! which was obtained by trial and error
+ DT = DT * (1.d0 - 0.05d0)
+
+ ! adapts number of element layers in crust and time step for regional simulations
+ if( REGIONAL_MOHO_MESH ) then
+ ! hard coded number of crustal element layers and time step
+
+ ! checks
+ if( NCHUNKS > 1 ) stop 'regional moho mesh: NCHUNKS error in rcp_set_timestep_and_layers'
+ if( HONOR_1D_SPHERICAL_MOHO ) return
+
+ ! original values
+ !print*,'NER:',NER_CRUST
+ !print*,'DT:',DT
+
+ ! enforce 3 element layers
+ NER_CRUST = 3
+
+ ! increased stability, empirical
+ DT = DT*(1.d0 + 0.5d0)
+
+ if( REGIONAL_MOHO_MESH_EUROPE ) DT = 0.17 ! europe
+ if( REGIONAL_MOHO_MESH_ASIA ) DT = 0.15 ! asia & middle east
+
+ endif
+
+
+ end subroutine rcp_set_timestep_and_layers
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
+ NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
+
+ logical ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS,&
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM
+
+
+! checks parameters
+
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'NCHUNKS must be either 1, 2, 3 or 6'
+
+ ! this MUST be 90 degrees for two chunks or more to match geometrically
+ if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk'
+
+ ! this can be any value in the case of two chunks
+ if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) &
+ stop 'cannot have absorbing conditions in the full Earth'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) &
+ stop 'absorbing conditions not supported for three chunks yet'
+
+ if(ATTENUATION_3D .and. .not. ATTENUATION) &
+ stop 'need ATTENUATION to use ATTENUATION_3D'
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5, check the Par_file'
+
+ ! check that reals are either 4 or 8 bytes
+ if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) &
+ stop 'wrong size of CUSTOM_REAL for reals'
+
+ ! check that the parameter file is correct
+ if(NGNOD /= 27) &
+ stop 'number of control nodes must be 27'
+ if(NGNOD == 27 .and. NGNOD2D /= 9) &
+ stop 'elements with 27 points should have NGNOD2D = 9'
+
+ ! for the number of standard linear solids for attenuation
+ if(N_SLS /= 3) &
+ stop 'number of SLS must be 3'
+
+ ! check number of slices in each direction
+ if(NCHUNKS < 1) &
+ stop 'must have at least one chunk'
+ if(NPROC_XI < 1) &
+ stop 'NPROC_XI must be at least 1'
+ if(NPROC_ETA < 1) &
+ stop 'NPROC_ETA must be at least 1'
+
+ ! check number of chunks
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'only one, two, three or six chunks can be meshed'
+
+ ! check that the central cube can be included
+ if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) &
+ stop 'need six chunks to include central cube'
+
+ ! check that sphere can be cut into slices without getting negative Jacobian
+ if(NEX_XI < 48) &
+ stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian'
+ if(NEX_ETA < 48) &
+ stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian'
+
+ ! check that topology is correct if more than two chunks
+ if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) &
+ stop 'must have NEX_XI = NEX_ETA for more than two chunks'
+
+ if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) &
+ stop 'must have NPROC_XI = NPROC_ETA for more than two chunks'
+
+ ! support for only one slice per chunk has been discontinued when there is more than one chunk
+ ! because it induces topological problems, and we are not interested in using small meshes
+ if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
+
+ end subroutine rcp_check_parameters
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine rcp_define_all_layers(NER_CRUST,NER_80_MOHO,NER_220_80,&
+ NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,&
+ RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
+ ONE_CRUST,ner,ratio_sampling_array,&
+ NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
+ r_bottom,r_top,this_region_has_a_doubling,&
+ ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
+ elem_doubling_bottom_outer_core,&
+ DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
+ doubling_index,rmins,rmaxs)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! definition of general mesh parameters below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB
+ integer NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer
+
+ double precision RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+
+ logical ONE_CRUST
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
+ double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
+
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+
+
+! find element below top of which we should implement the second doubling in the mantle
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+ do ielem = 2,NER_TOPDDOUBLEPRIME_771
+ zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771)
+ distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_mantle = ielem
+ distance_min = distance
+ DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+
+! find element below top of which we should implement the third doubling in the middle of the outer core
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+! start at element number 4 because we need at least two elements below for the fourth doubling
+! implemented at the bottom of the outer core
+ do ielem = 4,NER_OUTER_CORE
+ zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
+ distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_middle_outer_core = ielem
+ distance_min = distance
+ DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+
+ if (ADD_4TH_DOUBLING) then
+! find element below top of which we should implement the fourth doubling in the middle of the outer core
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+! end two elements before the top because we need at least two elements above for the third doubling
+! implemented in the middle of the outer core
+ do ielem = 2,NER_OUTER_CORE-2
+ zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
+ distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_bottom_outer_core = ielem
+ distance_min = distance
+ DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+! make sure that the two doublings in the outer core are found in the right order
+ if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) &
+ stop 'error in location of the two doublings in the outer core'
+ endif
+
+ ratio_sampling_array(15) = 0
+
+! define all the layers of the mesh
+ if (.not. ADD_4TH_DOUBLING) then
+
+ ! default case:
+ ! no fourth doubling at the bottom of the outer core
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ! suppress the crustal layers
+ ! will be replaced by an extension of the mantle: R_EARTH is not modified,
+ ! but no more crustal doubling
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 1
+
+ ! now only one region
+ ner( 1) = NER_CRUST + NER_80_MOHO
+ ner( 2) = 0
+ ner( 3) = 0
+
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:9) = 1
+ ratio_sampling_array(10:12) = 2
+ ratio_sampling_array(13:14) = 4
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ last_doubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = R80_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMIDDLE_CRUST !!!! now fictitious
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+ r_bottom(3) = R80_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+ rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:13) = RCMB / R_EARTH
+ rmins(12:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ else if (ONE_CRUST) then
+
+ ! 1D models:
+ ! in order to increase stability and therefore to allow cheaper
+ ! simulations (larger time step), 1D models can be run with just one average crustal
+ ! layer instead of two.
+
+ NUMBER_OF_MESH_LAYERS = 13
+ layer_offset = 0
+
+ ner( 1) = NER_CRUST
+ ner( 2) = NER_80_MOHO
+ ner( 3) = NER_220_80
+ ner( 4) = NER_400_220
+ ner( 5) = NER_600_400
+ ner( 6) = NER_670_600
+ ner( 7) = NER_771_670
+ ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner( 9) = elem_doubling_mantle
+ ner(10) = NER_CMB_TOPDDOUBLEPRIME
+ ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(12) = elem_doubling_middle_outer_core
+ ner(13) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1) = 1
+ ratio_sampling_array(2:8) = 2
+ ratio_sampling_array(9:11) = 4
+ ratio_sampling_array(12:13) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1) = IFLAG_CRUST
+ doubling_index(2) = IFLAG_80_MOHO
+ doubling_index(3) = IFLAG_220_80
+ doubling_index(4:6) = IFLAG_670_220
+ doubling_index(7:10) = IFLAG_MANTLE_NORMAL
+ doubling_index(11:12) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(13) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(2) = .true.
+ this_region_has_a_doubling(9) = .true.
+ this_region_has_a_doubling(12) = .true.
+ last_doubling_layer = 12
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
+ !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
+ !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
+ !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
+ !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
+ !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(2) = R80_FICTITIOUS_IN_MESHER
+
+ r_top(3) = R80_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R220
+
+ r_top(4) = R220
+ r_bottom(4) = R400
+
+ r_top(5) = R400
+ r_bottom(5) = R600
+
+ r_top(6) = R600
+ r_bottom(6) = R670
+
+ r_top(7) = R670
+ r_bottom(7) = R771
+
+ r_top(8) = R771
+ r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(9) = RTOPDDOUBLEPRIME
+
+ r_top(10) = RTOPDDOUBLEPRIME
+ r_bottom(10) = RCMB
+
+ r_top(11) = RCMB
+ r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(12) = RICB
+
+ r_top(13) = RICB
+ r_bottom(13) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(2) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R220 / R_EARTH
+
+ rmaxs(4) = R220 / R_EARTH
+ rmins(4) = R400 / R_EARTH
+
+ rmaxs(5) = R400 / R_EARTH
+ rmins(5) = R600 / R_EARTH
+
+ rmaxs(6) = R600 / R_EARTH
+ rmins(6) = R670 / R_EARTH
+
+ rmaxs(7) = R670 / R_EARTH
+ rmins(7) = R771 / R_EARTH
+
+ rmaxs(8:9) = R771 / R_EARTH
+ rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(10) = RCMB / R_EARTH
+
+ rmaxs(11:12) = RCMB / R_EARTH
+ rmins(11:12) = RICB / R_EARTH
+
+ rmaxs(13) = RICB / R_EARTH
+ rmins(13) = R_CENTRAL_CUBE / R_EARTH
+
+ else
+
+ ! default case for 3D models:
+ ! contains the crustal layers
+ ! doubling at the base of the crust
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 1
+ if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
+ ner( 1) = ceiling (NER_CRUST / 2.d0)
+ ner( 2) = floor (NER_CRUST / 2.d0)
+ else
+ ner( 1) = floor (NER_CRUST / 2.d0) ! regional mesh: ner(1) = 1 since NER_CRUST=3
+ ner( 2) = ceiling (NER_CRUST / 2.d0) ! ner(2) = 2
+ endif
+ ner( 3) = NER_80_MOHO
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:2) = 1
+ ratio_sampling_array(3:9) = 2
+ ratio_sampling_array(10:12) = 4
+ ratio_sampling_array(13:14) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:2) = IFLAG_CRUST
+ doubling_index(3) = IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(3) = .true.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_has_a_doubling(14) = .false.
+ last_doubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMIDDLE_CRUST
+
+ r_top(2) = RMIDDLE_CRUST
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R80_FICTITIOUS_IN_MESHER
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMIDDLE_CRUST / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:13) = RCMB / R_EARTH
+ rmins(12:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ endif
+ else
+
+ ! 4th doubling case:
+ ! includes fourth doubling at the bottom of the outer core
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ! suppress the crustal layers
+ ! will be replaced by an extension of the mantle: R_EARTH is not modified,
+ ! but no more crustal doubling
+
+ NUMBER_OF_MESH_LAYERS = 15
+ layer_offset = 1
+
+ ! now only one region
+ ner( 1) = NER_CRUST + NER_80_MOHO
+ ner( 2) = 0
+ ner( 3) = 0
+
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(14) = elem_doubling_bottom_outer_core
+ ner(15) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:9) = 1
+ ratio_sampling_array(10:12) = 2
+ ratio_sampling_array(13) = 4
+ ratio_sampling_array(14:15) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(15) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_has_a_doubling(14) = .true.
+ last_doubling_layer = 14
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = R80_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMIDDLE_CRUST !!!! now fictitious
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+ r_bottom(3) = R80_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(14) = RICB
+
+ r_top(15) = RICB
+ r_bottom(15) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+ rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:14) = RCMB / R_EARTH
+ rmins(12:14) = RICB / R_EARTH
+
+ rmaxs(15) = RICB / R_EARTH
+ rmins(15) = R_CENTRAL_CUBE / R_EARTH
+
+ else if (ONE_CRUST) then
+
+ ! 1D models:
+ ! in order to increase stability and therefore to allow cheaper
+ ! simulations (larger time step), 1D models can be run with just one average crustal
+ ! layer instead of two.
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 0
+
+ ner( 1) = NER_CRUST
+ ner( 2) = NER_80_MOHO
+ ner( 3) = NER_220_80
+ ner( 4) = NER_400_220
+ ner( 5) = NER_600_400
+ ner( 6) = NER_670_600
+ ner( 7) = NER_771_670
+ ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner( 9) = elem_doubling_mantle
+ ner(10) = NER_CMB_TOPDDOUBLEPRIME
+ ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(12) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(13) = elem_doubling_bottom_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1) = 1
+ ratio_sampling_array(2:8) = 2
+ ratio_sampling_array(9:11) = 4
+ ratio_sampling_array(12) = 8
+ ratio_sampling_array(13:14) = 16
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1) = IFLAG_CRUST
+ doubling_index(2) = IFLAG_80_MOHO
+ doubling_index(3) = IFLAG_220_80
+ doubling_index(4:6) = IFLAG_670_220
+ doubling_index(7:10) = IFLAG_MANTLE_NORMAL
+ doubling_index(11:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(2) = .true.
+ this_region_has_a_doubling(9) = .true.
+ this_region_has_a_doubling(12) = .true.
+ this_region_has_a_doubling(13) = .true.
+ last_doubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
+ !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
+ !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
+ !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
+ !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
+ !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(2) = R80_FICTITIOUS_IN_MESHER
+
+ r_top(3) = R80_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R220
+
+ r_top(4) = R220
+ r_bottom(4) = R400
+
+ r_top(5) = R400
+ r_bottom(5) = R600
+
+ r_top(6) = R600
+ r_bottom(6) = R670
+
+ r_top(7) = R670
+ r_bottom(7) = R771
+
+ r_top(8) = R771
+ r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(9) = RTOPDDOUBLEPRIME
+
+ r_top(10) = RTOPDDOUBLEPRIME
+ r_bottom(10) = RCMB
+
+ r_top(11) = RCMB
+ r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(12) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(2) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R220 / R_EARTH
+
+ rmaxs(4) = R220 / R_EARTH
+ rmins(4) = R400 / R_EARTH
+
+ rmaxs(5) = R400 / R_EARTH
+ rmins(5) = R600 / R_EARTH
+
+ rmaxs(6) = R600 / R_EARTH
+ rmins(6) = R670 / R_EARTH
+
+ rmaxs(7) = R670 / R_EARTH
+ rmins(7) = R771 / R_EARTH
+
+ rmaxs(8:9) = R771 / R_EARTH
+ rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(10) = RCMB / R_EARTH
+
+ rmaxs(11:13) = RCMB / R_EARTH
+ rmins(11:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ else
+
+ ! for 3D models:
+ ! contains the crustal layers
+ ! doubling at the base of the crust
+
+ NUMBER_OF_MESH_LAYERS = 15
+ layer_offset = 1
+ if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
+ ner( 1) = ceiling (NER_CRUST / 2.d0)
+ ner( 2) = floor (NER_CRUST / 2.d0)
+ else
+ ner( 1) = floor (NER_CRUST / 2.d0)
+ ner( 2) = ceiling (NER_CRUST / 2.d0)
+ endif
+ ner( 3) = NER_80_MOHO
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(14) = elem_doubling_bottom_outer_core
+ ner(15) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:2) = 1
+ ratio_sampling_array(3:9) = 2
+ ratio_sampling_array(10:12) = 4
+ ratio_sampling_array(13) = 8
+ ratio_sampling_array(14:15) = 16
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:2) = IFLAG_CRUST
+ doubling_index(3) = IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(15) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(3) = .true.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_has_a_doubling(14) = .true.
+ last_doubling_layer = 14
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMIDDLE_CRUST
+
+ r_top(2) = RMIDDLE_CRUST
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R80_FICTITIOUS_IN_MESHER
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(14) = RICB
+
+ r_top(15) = RICB
+ r_bottom(15) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMIDDLE_CRUST / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:14) = RCMB / R_EARTH
+ rmins(12:14) = RICB / R_EARTH
+
+ rmaxs(15) = RICB / R_EARTH
+ rmins(15) = R_CENTRAL_CUBE / R_EARTH
+ endif
+ endif
+
+
+ end subroutine rcp_define_all_layers
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
+ NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ ner,ratio_sampling_array,this_region_has_a_doubling, &
+ ifirst_region,ilast_region,iter_region,iter_layer, &
+ doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
+ NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_surf, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
+ last_doubling_layer, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
+ nglob_edge_v,to_remove)
+
+
+ implicit none
+
+ include "constants.h"
+
+
+! parameters to be computed based upon parameters above read from file
+ integer NPROC,NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+
+
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, tmp_sum, tmp_sum_xi, tmp_sum_eta
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_surf
+
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ logical :: INCLUDE_CENTRAL_CUBE
+ integer :: last_doubling_layer
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+ integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of elements (NSPEC) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ratio_divide_central_cube = maxval(ratio_sampling_array(1:NUMBER_OF_MESH_LAYERS))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 1D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ ! theoretical number of spectral elements in radial direction
+ do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ NSPEC1D_RADIAL(iter_region) = sum(ner(ifirst_region:ilast_region))
+ enddo
+
+ ! difference of radial number of element for outer core if the superbrick is cut
+ DIFF_NSPEC1D_RADIAL(:,:) = 0
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC1D_RADIAL(2,1) = 1
+ DIFF_NSPEC1D_RADIAL(3,1) = 2
+ DIFF_NSPEC1D_RADIAL(4,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(2,2) = 2
+ DIFF_NSPEC1D_RADIAL(3,2) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,3) = 1
+ DIFF_NSPEC1D_RADIAL(3,3) = 1
+ DIFF_NSPEC1D_RADIAL(4,3) = 2
+
+ DIFF_NSPEC1D_RADIAL(1,4) = 2
+ DIFF_NSPEC1D_RADIAL(2,4) = 1
+ DIFF_NSPEC1D_RADIAL(4,4) = 1
+ else
+ DIFF_NSPEC1D_RADIAL(2,1) = 1
+ DIFF_NSPEC1D_RADIAL(3,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(4,2) = 1
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC1D_RADIAL(3,1) = 1
+ DIFF_NSPEC1D_RADIAL(4,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(2,2) = 1
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 2D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ! exact number of surface elements for faces along XI and ETA
+
+ do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum_xi = 0
+ tmp_sum_eta = 0
+ tmp_sum_nglob2D_xi = 0
+ tmp_sum_nglob2D_eta = 0
+ do iter_layer = ifirst_region, ilast_region
+ if (this_region_has_a_doubling(iter_layer)) then
+ if (iter_region == IREGION_OUTER_CORE .and. iter_layer == last_doubling_layer) then
+ ! simple brick
+ divider = 1
+ nglob_surf = 6*NGLLX**2 - 7*NGLLX + 2
+ nglob_edges_h = 2*(NGLLX-1)+1 + NGLLX
+ ! minimum value to be safe
+ nglob_edge_v = NGLLX-2
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ else
+ ! double brick
+ divider = 2
+ if (ner(iter_layer) == 1) then
+ nglob_surf = 6*NGLLX**2 - 8*NGLLX + 3
+ nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
+ nglob_edge_v = NGLLX-2
+ nb_lay_sb = 1
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
+ else
+ nglob_surf = 8*NGLLX**2 - 11*NGLLX + 4
+ nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
+ nglob_edge_v = 2*(NGLLX-1)+1 -2
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ divider = 2
+ endif
+ endif
+ doubling = 1
+ to_remove = 1
+ else
+ if (iter_layer /= ifirst_region) then
+ to_remove = 0
+ else
+ to_remove = 1
+ endif
+ ! dummy values to avoid a warning
+ nglob_surf = 0
+ nglob_edges_h = 0
+ nglob_edge_v = 0
+ divider = 1
+ doubling = 0
+ nb_lay_sb = 0
+ nspec2D_xi_sb = 0
+ nspec2D_eta_sb = 0
+ endif
+
+ tmp_sum_xi = tmp_sum_xi + ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * (nspec2D_xi_sb/2))
+
+ tmp_sum_eta = tmp_sum_eta + ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * (nspec2D_eta_sb/2))
+
+ tmp_sum_nglob2D_xi = tmp_sum_nglob2D_xi + (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
+ ((((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
+ ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))*(ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
+ (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
+ doubling * (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
+ ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
+
+ tmp_sum_nglob2D_eta = tmp_sum_nglob2D_eta + (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
+ ((((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
+ ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))* &
+ (ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
+ (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
+ doubling * (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
+ ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
+
+ enddo ! iter_layer
+
+ NSPEC2D_XI(iter_region) = tmp_sum_xi
+ NSPEC2D_ETA(iter_region) = tmp_sum_eta
+
+ NGLOB2DMAX_YMIN_YMAX(iter_region) = tmp_sum_nglob2D_xi
+ NGLOB2DMAX_XMIN_XMAX(iter_region) = tmp_sum_nglob2D_eta
+
+ if (iter_region == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE) then
+ NSPEC2D_XI(iter_region) = NSPEC2D_XI(iter_region) + &
+ ((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
+ NSPEC2D_ETA(iter_region) = NSPEC2D_ETA(iter_region) + &
+ ((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
+
+ NGLOB2DMAX_YMIN_YMAX(iter_region) = NGLOB2DMAX_YMIN_YMAX(iter_region) + &
+ (((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
+
+ NGLOB2DMAX_XMIN_XMAX(iter_region) = NGLOB2DMAX_XMIN_XMAX(iter_region) + &
+ (((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
+ endif
+ enddo ! iter_region
+
+ ! difference of number of surface elements along xi or eta for outer core if the superbrick is cut
+ DIFF_NSPEC2D_XI(:,:) = 0
+ DIFF_NSPEC2D_ETA(:,:) = 0
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC2D_XI(2,1) = 2
+ DIFF_NSPEC2D_XI(1,2) = 2
+ DIFF_NSPEC2D_XI(2,3) = 2
+ DIFF_NSPEC2D_XI(1,4) = 2
+
+ DIFF_NSPEC2D_ETA(2,1) = 1
+ DIFF_NSPEC2D_ETA(2,2) = 1
+ DIFF_NSPEC2D_ETA(1,3) = 1
+ DIFF_NSPEC2D_ETA(1,4) = 1
+ else
+ DIFF_NSPEC2D_ETA(2,1) = 1
+ DIFF_NSPEC2D_ETA(1,2) = 1
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC2D_XI(2,1) = 2
+ DIFF_NSPEC2D_XI(1,2) = 2
+ endif
+ endif
+ DIFF_NSPEC2D_XI(:,:) = DIFF_NSPEC2D_XI(:,:) * (NEX_PER_PROC_XI / ratio_divide_central_cube)
+ DIFF_NSPEC2D_ETA(:,:) = DIFF_NSPEC2D_ETA(:,:) * (NEX_PER_PROC_ETA / ratio_divide_central_cube)
+
+! exact number of surface elements on the bottom and top boundaries
+
+ ! in the crust and mantle
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(1))*(NEX_ETA/ratio_sampling_array(1))/NPROC
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(10+layer_offset))*&
+ (NEX_ETA/ratio_sampling_array(10+layer_offset))/NPROC
+
+ ! in the outer core with mesh doubling
+ if (ADD_4TH_DOUBLING) then
+ NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/4))*(NEX_ETA/(ratio_divide_central_cube/4))/NPROC
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ else
+ NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/2))*(NEX_ETA/(ratio_divide_central_cube/2))/NPROC
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ endif
+
+ ! in the top of the inner core
+ NSPEC2D_TOP(IREGION_INNER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ NSPEC2D_BOTTOM(IREGION_INNER_CORE) = NSPEC2D_TOP(IREGION_INNER_CORE)
+
+ ! maximum number of surface elements on vertical boundaries of the slices
+ NSPEC2DMAX_XMIN_XMAX(:) = NSPEC2D_ETA(:)
+ NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_ETA(:,:))
+ NSPEC2DMAX_YMIN_YMAX(:) = NSPEC2D_XI(:)
+ NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_XI(:,:))
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 3D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ! exact number of spectral elements in each region
+
+ do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum = 0;
+ do iter_layer = ifirst_region, ilast_region
+ if (this_region_has_a_doubling(iter_layer)) then
+ if (ner(iter_layer) == 1) then
+ nb_lay_sb = 1
+ nspec_sb = NSPEC_SUPERBRICK_1L
+ else
+ nb_lay_sb = 2
+ nspec_sb = NSPEC_DOUBLING_SUPERBRICK
+ endif
+ doubling = 1
+ else
+ doubling = 0
+ nb_lay_sb = 0
+ nspec_sb = 0
+ endif
+ tmp_sum = tmp_sum + (((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
+ (nspec_sb/4))) / NPROC
+ enddo
+ NSPEC(iter_region) = tmp_sum
+ enddo
+
+ if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + &
+ (NEX_PER_PROC_XI / ratio_divide_central_cube) * &
+ (NEX_PER_PROC_ETA / ratio_divide_central_cube) * &
+ (NEX_XI / ratio_divide_central_cube)
+
+ if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere, try to recompile :) '
+
+
+ end subroutine rcp_count_elements
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
+ nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
+ this_region_has_a_doubling,&
+ ifirst_region, ilast_region, iter_region, iter_layer, &
+ doubling, padding, tmp_sum, &
+ INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
+ NUMBER_OF_MESH_LAYERS,layer_offset, &
+ nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of points (NGLOB) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+
+! parameters to be computed based upon parameters above read from file
+ integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, dimension(MAX_NUM_REGIONS) :: &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB
+
+ integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
+ integer nblocks_xi,nblocks_eta
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset, &
+ nb_lay_sb, nglob_vol, nglob_surf, nglob_edge
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,INCLUDE_CENTRAL_CUBE
+ integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 1D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! theoretical number of Gauss-Lobatto points in radial direction
+ NGLOB1D_RADIAL(:) = NSPEC1D_RADIAL(:)*(NGLLZ-1)+1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 2D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 2-D addressing and buffers for summation between slices
+! we add one to number of points because of the flag after the last point
+ NGLOB2DMAX_XMIN_XMAX(:) = NGLOB2DMAX_XMIN_XMAX(:) + 1
+ NGLOB2DMAX_YMIN_YMAX(:) = NGLOB2DMAX_YMIN_YMAX(:) + 1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 3D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of global points in each region
+
+! initialize array
+ NGLOB(:) = 0
+
+! in the inner core (no doubling region + eventually central cube)
+ if(INCLUDE_CENTRAL_CUBE) then
+ NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
+ *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1)
+ else
+ NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
+ *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB)*(NGLLZ-1)+1)
+ endif
+
+! in the crust-mantle and outercore
+ do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum = 0;
+ do iter_layer = ifirst_region, ilast_region
+ nglob_int_surf_eta=0
+ nglob_int_surf_xi=0
+ nglob_ext_surf = 0
+ nglob_center_edge = 0
+ nglob_corner_edge = 0
+ nglob_border_edge = 0
+ if (this_region_has_a_doubling(iter_layer)) then
+ if (iter_region == IREGION_OUTER_CORE .and. iter_layer == last_doubling_layer .and. &
+ (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ doubling = 1
+ normal_doubling = 0
+ cut_doubling = 1
+ nb_lay_sb = 2
+ nglob_edge = 0
+ nglob_surf = 0
+ nglob_vol = 8*NGLLX**3 - 12*NGLLX**2 + 6*NGLLX - 1
+ nglob_int_surf_eta = 6*NGLLX**2 - 7*NGLLX + 2
+ nglob_int_surf_xi = 5*NGLLX**2 - 5*NGLLX + 1
+ nglob_ext_surf = 4*NGLLX**2-4*NGLLX+1
+ nglob_center_edge = 4*(NGLLX-1)+1
+ nglob_corner_edge = 2*(NGLLX-1)+1
+ nglob_border_edge = 3*(NGLLX-1)+1
+ else
+ if (ner(iter_layer) == 1) then
+ nb_lay_sb = 1
+ nglob_vol = 28*NGLLX**3 - 62*NGLLX**2 + 47*NGLLX - 12
+ nglob_surf = 6*NGLLX**2-8*NGLLX+3
+ nglob_edge = NGLLX
+ else
+ nb_lay_sb = 2
+ nglob_vol = 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13
+ nglob_surf = 8*NGLLX**2-11*NGLLX+4
+ nglob_edge = 2*NGLLX-1
+ endif
+ doubling = 1
+ normal_doubling = 1
+ cut_doubling = 0
+ endif
+ padding = -1
+ else
+ doubling = 0
+ normal_doubling = 0
+ cut_doubling = 0
+ padding = 0
+ nb_lay_sb = 0
+ nglob_vol = 0
+ nglob_surf = 0
+ nglob_edge = 0
+ endif
+ if (iter_layer == ilast_region) padding = padding +1
+ nblocks_xi = NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)
+ nblocks_eta = NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)
+
+ tmp_sum = tmp_sum + &
+ ((nblocks_xi)*(NGLLX-1)+1) * ((nblocks_eta)*(NGLLX-1)+1) * ((ner(iter_layer) - doubling*nb_lay_sb)*(NGLLX-1)+padding)+&
+ normal_doubling * ((((nblocks_xi*nblocks_eta)/4)*nglob_vol) - &
+ (((nblocks_eta/2-1)*nblocks_xi/2+(nblocks_xi/2-1)*nblocks_eta/2)*nglob_surf) + &
+ ((nblocks_eta/2-1)*(nblocks_xi/2-1)*nglob_edge)) + &
+ cut_doubling*(nglob_vol*(nblocks_xi*nblocks_eta) - &
+ ( nblocks_eta*(int(nblocks_xi/2)*nglob_int_surf_xi + int((nblocks_xi-1)/2)*nglob_ext_surf) + &
+ nblocks_xi*(int(nblocks_eta/2)*nglob_int_surf_eta + int((nblocks_eta-1)/2)*nglob_ext_surf)&
+ ) + &
+ ( int(nblocks_xi/2)*int(nblocks_eta/2)*nglob_center_edge + &
+ int((nblocks_xi-1)/2)*int((nblocks_eta-1)/2)*nglob_corner_edge + &
+ ((int(nblocks_eta/2)*int((nblocks_xi-1)/2))+(int((nblocks_eta-1)/2)*int(nblocks_xi/2)))*nglob_border_edge&
+ ))
+ enddo
+ NGLOB(iter_region) = tmp_sum
+ enddo
+
+!!! example :
+!!! nblocks_xi/2=5
+!!! ____________________________________
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! nblocks_eta/2=3 I______+______+______+______+______I
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! I______+______+______+______+______I
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! I______I______I______I______I______I
+!!!
+!!! NGLOB for this doubling layer = 3*5*Volume - ((3-1)*5+(5-1)*3)*Surface + (3-1)*(5-1)*Edge
+!!!
+!!! 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13 -> nb GLL points in a superbrick (Volume)
+!!! 8*NGLLX**2-11*NGLLX+4 -> nb GLL points on a superbrick side (Surface)
+!!! 2*NGLLX-1 -> nb GLL points on a corner edge of a superbrick (Edge)
+
+!!! for the one layer superbrick :
+!!! NGLOB = 28.NGLL^3 - 62.NGLL^2 + 47.NGLL - 12 (Volume)
+!!! NGLOB = 6.NGLL^2 - 8.NGLL + 3 (Surface)
+!!! NGLOB = NGLL (Edge)
+!!!
+!!! those results were obtained by using the script UTILS/doubling_brick/count_nglob_analytical.pl
+!!! with an opendx file of the superbrick's geometry
+
+!!! for the basic doubling bricks (two layers)
+!!! NGLOB = 8.NGLL^3 - 12.NGLL^2 + 6.NGLL - 1 (VOLUME)
+!!! NGLOB = 5.NGLL^2 - 5.NGLL + 1 (SURFACE 1)
+!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
+
+ end subroutine rcp_count_points
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/rules.mk
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/rules.mk 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/shared/rules.mk 2013-06-15 00:48:57 UTC (rev 22299)
@@ -134,8 +134,8 @@
$O/param_reader.o: $S/param_reader.c ${SETUP}/config.h
${CC} -c $(CPPFLAGS) $(CFLAGS) -o $O/param_reader.o $S/param_reader.c
-$O/read_compute_parameters.o: ${SETUP}/constants.h $S/read_compute_parameters.F90
- ${FCCOMPILE_CHECK} -c -o $O/read_compute_parameters.o ${FCFLAGS_f90} $S/read_compute_parameters.F90
+$O/read_compute_parameters.o: ${SETUP}/constants.h $S/read_compute_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/read_compute_parameters.o ${FCFLAGS_f90} $S/read_compute_parameters.f90
$O/read_parameter_file.o: ${SETUP}/constants.h $S/read_parameter_file.f90
${FCCOMPILE_CHECK} -c -o $O/read_parameter_file.o ${FCFLAGS_f90} $S/read_parameter_file.f90
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/specfem3D/specfem3D.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/specfem3D/specfem3D.F90 2013-06-15 00:20:38 UTC (rev 22298)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/undo_att/src/specfem3D/specfem3D.F90 2013-06-15 00:48:57 UTC (rev 22299)
@@ -925,7 +925,6 @@
integer :: iteration_on_subset,it_of_this_subset,j,irec_local,k
integer :: it_temp,seismo_current_temp
- logical :: UNDO_ATT_WITH_STORE
real(kind=CUSTOM_REAL), dimension(3) :: seismograms_temp
include "declaration_part_for_backward_wavefield_simulation.f90"
@@ -1871,12 +1870,12 @@
two_omega_earth,A_array_rotation,B_array_rotation, &
b_two_omega_earth, SIMULATION_TYPE)
-#ifdef UNDO_ATT
+ if(UNDO_ATT) then
b_deltat = deltat
b_deltatover2 = deltatover2
b_deltatsqover2 = deltatsqover2
b_two_omega_earth = two_omega_earth
-#endif
+ endif
! precomputes gravity factors
call prepare_timerun_gravity(myrank, &
@@ -1903,11 +1902,11 @@
alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
deltat,b_deltat,LOCAL_PATH)
-#ifdef UNDO_ATT
+ if(UNDO_ATT) then
b_alphaval = alphaval
b_betaval = betaval
b_gammaval = gammaval
-#endif
+ endif
endif
@@ -2039,8 +2038,8 @@
! note: for SIMULATION_TYPE 3 simulations, the stored wavefields
! will be read in the time loop after the Newmark time scheme update.
! this makes indexing and timing easier to match with adjoint wavefields indexing.
-#ifdef UNDO_ATT
- if(NUMBER_OF_THIS_RUN > 1) stop 'currently we do not support NUMBER_OF_THIS_RUN > 1 in the case of UNDO_ATT'
+if(UNDO_ATT) then
+ if(NUMBER_OF_THIS_RUN > 1) stop 'we currently do not support NUMBER_OF_THIS_RUN > 1 in the case of UNDO_ATT'
! define correct time steps if restart files
if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > NSTEP) &
stop 'number of restart runs can not be less than 1 or greater than NSTEP'
@@ -2054,7 +2053,7 @@
! Last run may be a bit larger
it_end = NSTEP
endif
-#else
+else
call read_forward_arrays_startrun(myrank,NSTEP, &
SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
it_begin,it_end, &
@@ -2070,7 +2069,7 @@
b_R_memory_crust_mantle,b_R_memory_inner_core, &
b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
-#endif
+endif
! NOISE TOMOGRAPHY
@@ -2146,7 +2145,7 @@
! ************* MAIN LOOP OVER THE TIME STEPS *************
! *********************************************************
-#ifndef UNDO_ATT
+if(.not. UNDO_ATT) then
do it = it_begin,it_end
@@ -2157,65 +2156,32 @@
!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
!! DK DK
- include "part1_classical.F90"
+ include "part1_classical.f90"
!! DK DK
!! DK DK this first part handles the case SIMULATION_TYPE == 3
!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
!! DK DK
- include "part2_classical.F90"
+ include "part2_classical.f90"
!! DK DK empty file for now
- include "part3_kernel_computation.F90"
+ include "part3_kernel_computation.f90"
!
!---- end of time iteration loop
!
enddo ! end of main time loop
-! ifdef UNDO_ATT
-#else
+else ! if UNDO_ATT
!! DK DK this should not be difficult to fix and test, but not done yet by lack of time
- if(NUMBER_OF_RUNS /= 1) stop 'NUMBER_OF_RUNS should be == 1 for now when using compile flag UNDO_ATT'
+ if(NUMBER_OF_RUNS /= 1) stop 'NUMBER_OF_RUNS should be == 1 for now when using UNDO_ATT'
!
!-------------------------------------------------------------------------------
!
-!Old part of Dimitri
-!! DK DK it = 0
-!! DK DK do iteration_on_subset = 1, NSTEP / NT_DUMP
-!! DK DK do it_of_this_subset = 1, NT_DUMP
-!! DK DK
-!! DK DK it = it + 1
-!! DK DK! if(myrank == 0) print *,'doing time step ',it
-!! DK DK
-!! DK DK ! update position in seismograms
-!! DK DK seismo_current = seismo_current + 1
-!! DK DK
-!! DK DK!! DK DK
-!! DK DK!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
-!! DK DK!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
-!! DK DK!! DK DK
-!! DK DK include "part1_undo_att.F90"
-!! DK DK
-!! DK DK!! DK DK
-!! DK DK!! DK DK this first part handles the case SIMULATION_TYPE == 3
-!! DK DK!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
-!! DK DK!! DK DK
-!! DK DK include "part2_undo_att.F90"
-!! DK DK
-!! DK DK include "part3_kernel_computation.F90"
-!! DK DK
-!!! DK DK
-!! DK DK!---- end of time iteration loop
-!! DK DK!
-!! DK DK enddo
-!! DK DK enddo ! end of main time loop
-!
-!-------------------------------------------------------------------------------
-!
-!New part of ZN
+
+! New part of ZN
if(SIMULATION_TYPE == 1)then
it = 0
do iteration_on_subset = 1, NSTEP / NT_DUMP
@@ -2235,7 +2201,7 @@
seismo_current = seismo_current + 1
- include "part1_undo_att.F90"
+ include "part1_undo_att.f90"
enddo
enddo
@@ -2255,7 +2221,7 @@
seismo_current = seismo_current + 1
- include "part1_undo_att.F90"
+ include "part1_undo_att.f90"
! save source derivatives for adjoint simulations
if (SIMULATION_TYPE == 2 .and. nrec_local > 0) then
@@ -2269,10 +2235,6 @@
if(SIMULATION_TYPE == 3)then
-#ifdef UNDO_ATT
- UNDO_ATT_WITH_STORE = .true.
-#endif
-
allocate(displ_crust_mantle_store_buffer(NDIM,NGLOB_CRUST_MANTLE,NT_DUMP),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating displ_crust_mantle_store_buffer')
allocate(displ_outer_core_store_store_buffer(NGLOB_OUTER_CORE,NT_DUMP),stat=ier)
@@ -2301,7 +2263,7 @@
it = it + 1
seismo_current = seismo_current + 1
- include "part2_undo_att.F90"
+ include "part2_undo_att.f90"
displ_crust_mantle_store_buffer(:,:,it_of_this_subset) = b_displ_crust_mantle(:,:)
displ_outer_core_store_store_buffer(:,it_of_this_subset) = b_displ_outer_core(:)
@@ -2335,7 +2297,7 @@
seismo_current = seismo_current + 1
- include "part1_undo_att.F90"
+ include "part1_undo_att.f90"
call compute_strain_crust_mantle(displ_crust_mantle,hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
@@ -2361,14 +2323,14 @@
gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
b_epsilondev_inner_core,b_eps_trace_over_3_inner_core)
- include "part3_kernel_computation.F90"
+ include "part3_kernel_computation.f90"
enddo
enddo ! end of main time loop
endif
-#endif
+endif
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -2376,7 +2338,9 @@
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
- !ZN need to be remove for undoing att
+
+ !ZN need to be removed for undoing att
+
! synchronize all processes, waits until all processes have written their seismograms
call MPI_BARRIER(MPI_COMM_WORLD,ier)
if( ier /= 0 ) call exit_mpi(myrank,'error synchronize after time loop')
@@ -2452,11 +2416,9 @@
call MPI_BARRIER(MPI_COMM_WORLD,ier)
if( ier /= 0 ) call exit_mpi(myrank,'error synchronize closing snapshots')
-#ifdef UNDO_ATT
!ZN we move this part of code inside the time loop above
-#else
! save files to local disk or tape system if restart file
- call save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
+ if(.not. UNDO_ATT) call save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
displ_inner_core,veloc_inner_core,accel_inner_core, &
@@ -2464,7 +2426,6 @@
R_memory_crust_mantle,R_memory_inner_core, &
epsilondev_crust_mantle,epsilondev_inner_core, &
A_array_rotation,B_array_rotation,LOCAL_PATH)
-#endif
! synchronize all processes
call MPI_BARRIER(MPI_COMM_WORLD,ier)
More information about the CIG-COMMITS
mailing list