From b0e6799f7f8f375ab22117b66909994acf962602 Mon Sep 17 00:00:00 2001 From: Dimitri Komatitsch Date: Sat, 16 Jun 2018 20:49:48 +0200 Subject: [PATCH] automatically added checking of the return value of all allocate() statements in the code; added this using a Perl script; the script added a total of 2431 checking statements --- src/auxiliaries/combine_surf_data.f90 | 46 +- src/auxiliaries/combine_vol_data.F90 | 39 +- .../combine_vol_data_vtk_binary.F90 | 28 +- .../convolve_source_timefunction.f90 | 25 +- .../create_movie_shakemap_AVS_DX_GMT.f90 | 60 +- .../detect_duplicates_stations_file.f90 | 46 +- ...t_and_combine_vol_data_on_regular_grid.f90 | 7 +- src/check_mesh_quality/check_mesh_quality.f90 | 44 +- src/decompose_mesh/decompose_mesh.F90 | 32 + src/decompose_mesh/fault_scotch.f90 | 24 +- src/decompose_mesh/module_database.f90 | 27 +- src/decompose_mesh/module_mesh.f90 | 43 +- src/decompose_mesh/module_partition.f90 | 35 +- src/decompose_mesh/part_decompose_mesh.F90 | 18 + .../program_decompose_mesh_mpi.f90 | 79 ++- src/decompose_mesh/rules.mk | 1 + .../create_mass_matrices.f90 | 8 + .../create_regions_mesh.f90 | 276 +++++--- .../fault_generate_databases.f90 | 84 ++- src/generate_databases/get_MPI.f90 | 9 + .../get_absorbing_boundary.F90 | 10 +- .../get_coupling_surfaces.f90 | 33 + src/generate_databases/get_perm_color.f90 | 10 +- src/generate_databases/model_coupled.f90 | 15 +- src/generate_databases/model_gll.f90 | 3 + src/generate_databases/model_gll_adios.F90 | 3 + src/generate_databases/model_ipati.f90 | 6 + src/generate_databases/model_ipati_adios.F90 | 6 + .../model_salton_trough.f90 | 1 + src/generate_databases/model_sep.f90 | 11 +- src/generate_databases/model_tomography.f90 | 24 +- .../pml_set_local_dampingcoeff.f90 | 12 + src/generate_databases/read_parameters.f90 | 2 + .../read_partition_files.f90 | 21 + .../read_partition_files_adios.F90 | 34 +- src/generate_databases/save_arrays_solver.F90 | 10 + .../save_arrays_solver_adios.F90 | 4 + src/generate_databases/setup_color_perm.f90 | 19 + src/generate_databases/setup_mesh.f90 | 4 + .../adjoint_source/adjoint_source_mod.f90 | 55 +- ...nstantaneous_phase_envelope_misfit_mod.f90 | 174 +++-- .../adjoint_source/signal_processing_mod.f90 | 10 +- .../elastic_tensor_tools_mod.f90 | 8 +- .../input_output/IO_model_mod.f90 | 42 +- .../input_output/Teleseismic_IO.f90 | 136 ++-- .../input_output/input_output_mod.f90 | 287 +++++--- .../input_output/interpolation_mod.f90 | 62 +- .../input_output/mesh_tools_mod.f90 | 33 +- .../passive_imaging_format_mod.f90 | 15 +- .../inversion_scheme/family_parameter_mod.f90 | 11 +- .../inversion_scheme/fwi_iteration_mod.f90 | 17 +- .../inversion_scheme/inversion_scheme_mod.f90 | 6 + .../inversion_scheme/iso_parameters.f90 | 5 +- .../inversion_scheme/vti_parameters.f90 | 6 +- .../projection_on_FD_grid_mod.f90 | 68 +- .../regularization/regularization_FD_mod.f90 | 11 +- .../regularization/regularization_SEM_mod.f90 | 122 +++- .../regularization_interface.f90 | 28 +- .../specfem_interface_mod.F90 | 136 ++-- .../CMT3D/cmt3d/cmt3d_flexwin.f90 | 1 + src/meshfem3D/check_mesh_quality.f90 | 1 + src/meshfem3D/chunk_earth_mesh_mod.f90 | 61 +- src/meshfem3D/create_CPML_regions.f90 | 18 +- src/meshfem3D/create_interfaces_mesh.f90 | 3 + src/meshfem3D/create_meshfem_mesh.f90 | 24 + src/meshfem3D/determine_cavity.f90 | 62 +- src/meshfem3D/earth_chunk.f90 | 86 ++- src/meshfem3D/meshfem3D.F90 | 7 + src/meshfem3D/read_mesh_parameter_file.f90 | 3 + src/meshfem3D/save_databases.F90 | 18 +- src/shared/assemble_MPI_scalar.f90 | 8 + src/shared/check_mesh_resolution.f90 | 4 + src/shared/detect_surface.f90 | 3 + src/shared/get_attenuation_model.f90 | 16 +- src/shared/get_global.f90 | 4 + src/shared/prepare_assemble_MPI.f90 | 1 + src/shared/safe_alloc_mod.f90 | 25 + src/shared/search_kdtree.f90 | 3 + src/shared/write_VTK_data.f90 | 2 + src/specfem3D/assemble_MPI_vector.f90 | 8 + src/specfem3D/couple_with_injection.f90 | 108 ++- src/specfem3D/create_color_image.f90 | 26 +- src/specfem3D/detect_mesh_surfaces.f90 | 17 +- src/specfem3D/fault_solver_common.f90 | 79 ++- src/specfem3D/fault_solver_dynamic.f90 | 185 +++-- src/specfem3D/fault_solver_kinematic.f90 | 31 +- src/specfem3D/get_elevation.f90 | 9 +- src/specfem3D/gravity_perturbation.f90 | 29 +- src/specfem3D/initialize_simulation.F90 | 76 ++- src/specfem3D/iterate_time.F90 | 8 +- src/specfem3D/locate_MPI_slice.f90 | 31 +- src/specfem3D/locate_point.f90 | 2 + src/specfem3D/locate_receivers.f90 | 47 +- src/specfem3D/make_gravity.f90 | 5 +- src/specfem3D/pml_allocate_arrays.f90 | 268 ++++++-- src/specfem3D/pml_output_VTKs.f90 | 4 + src/specfem3D/prepare_attenuation.f90 | 2 + src/specfem3D/prepare_gravity.f90 | 5 +- src/specfem3D/prepare_noise.f90 | 6 + src/specfem3D/prepare_timerun.F90 | 68 +- src/specfem3D/read_mesh_databases.F90 | 645 +++++++++++++----- src/specfem3D/read_mesh_databases_adios.F90 | 350 +++++++--- src/specfem3D/save_adjoint_kernels.f90 | 19 +- src/specfem3D/setup_GLL_points.f90 | 24 +- src/specfem3D/setup_movie_meshes.f90 | 50 +- src/specfem3D/setup_sources_receivers.f90 | 143 ++-- src/specfem3D/surface_or_volume_integral.f90 | 3 + src/specfem3D/vtk_window.F90 | 36 +- src/specfem3D/write_movie_output.F90 | 12 +- src/specfem3D/write_output_ASDF.f90 | 65 +- src/specfem3D/write_output_SU.f90 | 1 + src/specfem3D/write_seismograms.f90 | 1 + src/tomography/add_model_iso.f90 | 7 +- src/tomography/compute_kernel_integral.f90 | 17 +- src/tomography/get_cg_direction.f90 | 10 +- src/tomography/get_sd_direction.f90 | 17 +- src/tomography/model_update.f90 | 172 +++-- .../clip_sem.f90 | 23 +- .../combine_sem.f90 | 23 +- .../smooth_sem.F90 | 130 +++- src/tomography/read_kernels.f90 | 17 +- src/tomography/read_kernels_cg.f90 | 20 +- src/tomography/read_model.f90 | 25 +- src/tomography/save_external_bin_m_up.f90 | 7 +- src/tomography/sum_kernels.f90 | 26 +- src/tomography/sum_preconditioned_kernels.f90 | 34 +- utils/clean_listings_specfem.pl | 2 + ...is_also_how_to_prepare_the_source_code.txt | 50 ++ ...e_error_code_to_all_allocate_statements.pl | 92 +++ ...e_changed_automatically_with_our_script.pl | 69 ++ 130 files changed, 4356 insertions(+), 1489 deletions(-) create mode 100644 utils/instructions_on_how_to_add_checks_of_all_allocate_statements_automatically_here_is_also_how_to_prepare_the_source_code.txt create mode 100755 utils/script_to_add_a_line_to_check_the_error_code_to_all_allocate_statements.pl create mode 100755 utils/script_to_visualize_all_the_allocate_statements_that_will_be_changed_automatically_with_our_script.pl diff --git a/src/auxiliaries/combine_surf_data.f90 b/src/auxiliaries/combine_surf_data.f90 index 895289a66..0d802d7f8 100644 --- a/src/auxiliaries/combine_surf_data.f90 +++ b/src/auxiliaries/combine_surf_data.f90 @@ -164,12 +164,18 @@ program combine_surf_data nglob = NGLOB_AB ! allocates arrays - allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(mask_ibool(NGLOB_AB)) - allocate(num_ibool(NGLOB_AB)) - allocate(xstore(NGLOB_AB)) - allocate(ystore(NGLOB_AB)) + allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1107') + allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1108') + allocate(num_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1109') + allocate(xstore(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1110') + allocate(ystore(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1111') allocate(zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1112') if (ier /= 0) stop 'error allocating array ibool etc.' ! surface file @@ -185,6 +191,7 @@ program combine_surf_data if (it == 1) then allocate(ibelm_surf(nspec_surf),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1113') if (ier /= 0) stop 'error allocating array ibelm_surf' endif read(28) ibelm_surf @@ -194,9 +201,11 @@ program combine_surf_data if (it == 1) then if (FILE_ARRAY_IS_3D) then allocate(data_3D(NGLLX,NGLLY,NGLLZ,NSPEC_AB),dat3D(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1114') if (ier /= 0) stop 'error allocating array data_3D' else allocate(data_2D(NGLLX,NGLLY,nspec_surf),dat2D(NGLLX,NGLLY,nspec_surf),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1115') if (ier /= 0) stop 'error allocating array data_2D' endif endif @@ -325,9 +334,12 @@ program combine_surf_data nglob = NGLOB_AB ! allocates arrays - allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(mask_ibool(NGLOB_AB)) + allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1116') + allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1117') allocate(num_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1118') if (ier /= 0) stop 'error allocating array ibool etc.' @@ -413,3 +425,23 @@ program combine_surf_data end program combine_surf_data +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/src/auxiliaries/combine_vol_data.F90 b/src/auxiliaries/combine_vol_data.F90 index f7bdb06c8..aa9b96705 100644 --- a/src/auxiliaries/combine_vol_data.F90 +++ b/src/auxiliaries/combine_vol_data.F90 @@ -172,8 +172,10 @@ program combine_vol_data ! ibool and global point arrays file allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1141') if (ier /= 0) stop 'error allocating array ibool' allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1142') if (ier /= 0) stop 'error allocating array xstore etc.' if (ADIOS_FOR_MESH) then @@ -192,10 +194,12 @@ program combine_vol_data allocate(data_sp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1143') if (ier /= 0) stop 'error allocating single precision data array' if (CUSTOM_REAL == SIZE_DOUBLE) then allocate(data_dp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1144') if (ier /= 0) stop 'error allocating double precision data array' endif @@ -287,6 +291,7 @@ program combine_vol_data ! ibool file allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1145') if (ADIOS_FOR_MESH) then call read_ibool_adios_mesh(mesh_handle, ibool_offset, & @@ -444,6 +449,7 @@ subroutine cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH, & ! gets ibool if (.not. HIGH_RESOLUTION_MESH) then allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1146') if (ier /= 0) stop 'error allocating array ibool' if (ADIOS_FOR_MESH) then @@ -472,6 +478,7 @@ subroutine cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH, & ! mark element corners (global AVS or DX points) allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1147') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool = .false. do ispec=1,NSPEC_AB @@ -541,6 +548,7 @@ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat, & write(IOVTK, '(a,i12,a)') 'POINTS ', npp, ' float' ! creates array to hold point data allocate(total_dat(npp),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1148') if (ier /= 0) stop 'error allocating total dat array' total_dat(:) = 0.0 #else @@ -552,6 +560,7 @@ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat, & ! writes our corner point locations allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1149') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. numpoin = 0 @@ -733,6 +742,7 @@ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat write(IOVTK, '(a,i12,a)') 'POINTS ', npp, ' float' ! creates array to hold point data allocate(total_dat(npp),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1150') if (ier /= 0) stop 'error allocating total dat array' total_dat(:) = 0.0 #else @@ -744,6 +754,7 @@ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat ! writes out point locations and values allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1151') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. @@ -811,8 +822,10 @@ subroutine cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool, & endif ! writes out element indices - allocate(mask_ibool(NGLOB_AB)) + allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1152') allocate(num_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1153') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. @@ -941,8 +954,10 @@ subroutine cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, & endif ! sets numbering num_ibool respecting mask - allocate(mask_ibool(NGLOB_AB)) + allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1154') allocate(num_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1155') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. @@ -1010,3 +1025,23 @@ subroutine cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, & end subroutine cvd_write_GLL_elements +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/src/auxiliaries/combine_vol_data_vtk_binary.F90 b/src/auxiliaries/combine_vol_data_vtk_binary.F90 index 37d34a596..cb0ef13cd 100644 --- a/src/auxiliaries/combine_vol_data_vtk_binary.F90 +++ b/src/auxiliaries/combine_vol_data_vtk_binary.F90 @@ -119,7 +119,8 @@ program combine_vol_data ! writes point and scalar information ! loops over slices (process partitions) np = 0 - allocate(pts(3*npp)) + allocate(pts(3*npp),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1156') do it = 1, num_node iproc = node_list(it) @@ -134,8 +135,10 @@ program combine_vol_data ! ibool and global point arrays file allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1157') if (ier /= 0) stop 'error allocating array ibool' allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1158') if (ier /= 0) stop 'error allocating array xstore etc.' read(27) NSPEC_IRREGULAR @@ -146,10 +149,12 @@ program combine_vol_data close(27) allocate(data_sp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1159') if (ier /= 0) stop 'error allocating single precision data array' if (CUSTOM_REAL == SIZE_DOUBLE) then allocate(data_dp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1160') if (ier /= 0) stop 'error allocating double precision data array' endif @@ -208,7 +213,8 @@ program combine_vol_data ne = 0 np = 0 - allocate(conn(8,nee)) + allocate(conn(8,nee),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1161') do it = 1, num_node @@ -225,6 +231,7 @@ program combine_vol_data read(27) NGLOB_AB ! ibool file allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1162') if (ier /= 0) stop 'error allocating array ibool' read(27) NSPEC_IRREGULAR read(27) ibool @@ -257,7 +264,8 @@ program combine_vol_data endif print *, 'Total number of elements: ', ne - allocate(celltype(nee)) + allocate(celltype(nee),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1163') celltype=12 call write_unstructured_mesh(mesh_file,len_trim(mesh_file), 1, npp, pts, nee, celltype, conn, & @@ -322,6 +330,7 @@ subroutine cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH, & ! gets ibool if (.not. HIGH_RESOLUTION_MESH) then allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1164') if (ier /= 0) stop 'error allocating array ibool' read(27) NSPEC_IRREGULAR read(27) ibool @@ -344,6 +353,7 @@ subroutine cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH, & ! mark element corners (global AVS or DX points) allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1165') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool = .false. do ispec=1,NSPEC_AB @@ -410,6 +420,7 @@ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat, & ! writes out total number of points if (it == 1) then allocate(total_dat(npp),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1166') if (ier /= 0) stop 'error allocating total dat array' total_dat(:) = 0.0 @@ -417,6 +428,7 @@ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat, & ! writes our corner point locations allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1167') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. numpoin = 0 @@ -562,6 +574,7 @@ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat ! writes out total number of points if (it == 1) then allocate(total_dat(npp),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1168') if (ier /= 0) stop 'error allocating total dat array' total_dat(:) = 0.0 @@ -569,6 +582,7 @@ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat ! writes out point locations and values allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1169') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. @@ -629,8 +643,10 @@ subroutine cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool, & endif ! writes out element indices - allocate(mask_ibool(NGLOB_AB)) + allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1170') allocate(num_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1171') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. @@ -740,8 +756,10 @@ subroutine cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, & endif ! sets numbering num_ibool respecting mask - allocate(mask_ibool(NGLOB_AB)) + allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1172') allocate(num_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1173') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. diff --git a/src/auxiliaries/convolve_source_timefunction.f90 b/src/auxiliaries/convolve_source_timefunction.f90 index 4dcbde80e..2bb3e9f69 100644 --- a/src/auxiliaries/convolve_source_timefunction.f90 +++ b/src/auxiliaries/convolve_source_timefunction.f90 @@ -39,7 +39,7 @@ program convolve_source_time_function implicit none - integer :: i,j,N_j,number_remove,nlines + integer :: i,j,N_j,number_remove,nlines,ier double precision :: alpha,dt,tau_j,source,exponentval,t1,t2,displ1,displ2,gamma,height,half_duration_triangle @@ -55,7 +55,8 @@ program convolve_source_time_function close(33) ! allocate arrays - allocate(timeval(nlines),sem(nlines),sem_fil(nlines)) + allocate(timeval(nlines),sem(nlines),sem_fil(nlines),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1181') ! read the input seismogram do i = 1,nlines @@ -133,3 +134,23 @@ program convolve_source_time_function end program convolve_source_time_function +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/src/auxiliaries/create_movie_shakemap_AVS_DX_GMT.f90 b/src/auxiliaries/create_movie_shakemap_AVS_DX_GMT.f90 index 525ed6754..1ac1f8582 100644 --- a/src/auxiliaries/create_movie_shakemap_AVS_DX_GMT.f90 +++ b/src/auxiliaries/create_movie_shakemap_AVS_DX_GMT.f90 @@ -276,34 +276,56 @@ program create_movie_shakemap npointot = NGNOD2D_FOUR_CORNERS_AVS_DX * nspectot_AVS_max ! allocate arrays for sorting routine - allocate(iglob(npointot)) - allocate(locval(npointot)) - allocate(ifseg(npointot)) - allocate(xp(npointot)) - allocate(yp(npointot)) - allocate(zp(npointot)) - allocate(xp_save(npointot)) - allocate(yp_save(npointot)) - allocate(zp_save(npointot)) - allocate(field_display(npointot)) - allocate(mask_point(npointot)) + allocate(iglob(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1119') + allocate(locval(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1120') + allocate(ifseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1121') + allocate(xp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1122') + allocate(yp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1123') + allocate(zp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1124') + allocate(xp_save(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1125') + allocate(yp_save(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1126') + allocate(zp_save(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1127') + allocate(field_display(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1128') + allocate(mask_point(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1129') allocate(ireorder(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1130') if (ier /= 0) stop 'error allocating arrays for sorting routine' ! allocates data arrays - allocate(store_val_x(ilocnum)) - allocate(store_val_y(ilocnum)) - allocate(store_val_z(ilocnum)) - allocate(store_val_ux(ilocnum)) - allocate(store_val_uy(ilocnum)) + allocate(store_val_x(ilocnum),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1131') + allocate(store_val_y(ilocnum),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1132') + allocate(store_val_z(ilocnum),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1133') + allocate(store_val_ux(ilocnum),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1134') + allocate(store_val_uy(ilocnum),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1135') allocate(store_val_uz(ilocnum),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1136') if (ier /= 0) stop 'error allocating arrays for data arrays' if (USE_HIGHRES_FOR_MOVIES) then - allocate(x(NGLLX,NGLLY)) - allocate(y(NGLLX,NGLLY)) - allocate(z(NGLLX,NGLLY)) + allocate(x(NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1137') + allocate(y(NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1138') + allocate(z(NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1139') allocate(display(NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1140') if (ier /= 0) stop 'error allocating arrays for highres' endif diff --git a/src/auxiliaries/detect_duplicates_stations_file.f90 b/src/auxiliaries/detect_duplicates_stations_file.f90 index 2fa124d0a..00b79fc0d 100644 --- a/src/auxiliaries/detect_duplicates_stations_file.f90 +++ b/src/auxiliaries/detect_duplicates_stations_file.f90 @@ -19,11 +19,8 @@ program detect_duplicates_stations_file ! input station file to filter character(len=150), parameter :: STATIONS_FILE = '../../DATA/STATIONS' -! character(len=150), parameter :: STATIONS_FILE = 'STATIONS_all_20June2008' -! character(len=150), parameter :: STATIONS_FILE = 'STATIONS_SUBSET_35' -! character(len=150), parameter :: STATIONS_FILE = 'STATIONS_FULL_758' - integer :: irec,irec2,nrec,ios + integer :: irec,irec2,nrec,ios,ier character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: network_name @@ -47,13 +44,20 @@ program detect_duplicates_stations_file print *,'the input station file contains ',nrec,' stations' print * - allocate(stlat(nrec)) - allocate(stlon(nrec)) - allocate(stele(nrec)) - allocate(stbur(nrec)) - allocate(station_name(nrec)) - allocate(network_name(nrec)) - allocate(is_a_duplicate(nrec)) + allocate(stlat(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1174') + allocate(stlon(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1175') + allocate(stele(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1176') + allocate(stbur(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1177') + allocate(station_name(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1178') + allocate(network_name(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1179') + allocate(is_a_duplicate(nrec),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1180') is_a_duplicate(:) = .false. @@ -115,3 +119,23 @@ program detect_duplicates_stations_file end program detect_duplicates_stations_file +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/src/auxiliaries/project_and_combine_vol_data_on_regular_grid.f90 b/src/auxiliaries/project_and_combine_vol_data_on_regular_grid.f90 index 3811e3c39..92d4c40bf 100644 --- a/src/auxiliaries/project_and_combine_vol_data_on_regular_grid.f90 +++ b/src/auxiliaries/project_and_combine_vol_data_on_regular_grid.f90 @@ -97,8 +97,10 @@ program project_and_combine_vol_data_on_regular_grid read(27) NSPEC_AB read(27) NGLOB_AB allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1102') if (ier /= 0) stop 'error allocating array ibool' allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1103') if (ier /= 0) stop 'error allocating array xstore etc.' read(27) NSPEC_IRREGULAR @@ -113,7 +115,8 @@ program project_and_combine_vol_data_on_regular_grid call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA) call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA) call compute_interpolation_coeff_FD_SEM(projection_fd, myrank) - allocate(model_on_FD_grid(projection_fd%nx, projection_fd%ny, projection_fd%nz)) + allocate(model_on_FD_grid(projection_fd%nx, projection_fd%ny, projection_fd%nz),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1104') if (myrank == 0) then print *, 'Grid size is : ',projection_fd%nx, projection_fd%ny, projection_fd%nz @@ -121,9 +124,11 @@ program project_and_combine_vol_data_on_regular_grid ! Get data to project allocate(data_sp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1105') if (ier /= 0) stop 'error allocating single precision data array' if (CUSTOM_REAL == SIZE_DOUBLE) then allocate(data_dp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1106') if (ier /= 0) stop 'error allocating double precision data array' endif diff --git a/src/check_mesh_quality/check_mesh_quality.f90 b/src/check_mesh_quality/check_mesh_quality.f90 index c124072e2..ae71ae453 100644 --- a/src/check_mesh_quality/check_mesh_quality.f90 +++ b/src/check_mesh_quality/check_mesh_quality.f90 @@ -164,15 +164,19 @@ program check_mesh_quality yigll(:) = xigll(:) zigll(:) = xigll(:) - allocate(dershape3D(NDIM,NGNOD,local_NGLLX_always_5,local_NGLLY_always_5,local_NGLLZ_always_5)) + allocate(dershape3D(NDIM,NGNOD,local_NGLLX_always_5,local_NGLLY_always_5,local_NGLLZ_always_5),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1094') ! compute the derivatives of the 3D shape functions for a 8-node or 27-node element call local_version_of_get_shape3D(dershape3D,xigll,yigll,zigll,NGNOD, & local_NGLLX_always_5,local_NGLLY_always_5,local_NGLLZ_always_5) - allocate(xelm(NGNOD)) - allocate(yelm(NGNOD)) - allocate(zelm(NGNOD)) + allocate(xelm(NGNOD),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1095') + allocate(yelm(NGNOD),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1096') + allocate(zelm(NGNOD),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1097') if (NGNOD == 8) then print * @@ -191,9 +195,12 @@ program check_mesh_quality read(10,*) NGLOB print *,' number of points: ',NGLOB - allocate(x(NGLOB)) - allocate(y(NGLOB)) - allocate(z(NGLOB)) + allocate(x(NGLOB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1098') + allocate(y(NGLOB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1099') + allocate(z(NGLOB),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1100') x(:) = 0.d0 y(:) = 0.d0 @@ -237,7 +244,8 @@ program check_mesh_quality read(10,*) NSPEC print *,' number of elements: ',NSPEC - allocate(ibool(NGNOD,NSPEC)) + allocate(ibool(NGNOD,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1101') ibool(:,:) = 0 do i = 1,NSPEC @@ -1158,3 +1166,23 @@ subroutine local_version_of_calc_jacobian(xelm,yelm,zelm,dershape3D,found_a_nega end subroutine local_version_of_calc_jacobian +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/src/decompose_mesh/decompose_mesh.F90 b/src/decompose_mesh/decompose_mesh.F90 index abfbffeff..ae0a7546e 100644 --- a/src/decompose_mesh/decompose_mesh.F90 +++ b/src/decompose_mesh/decompose_mesh.F90 @@ -171,6 +171,7 @@ subroutine read_mesh_files() if (nnodes < 1) stop 'Error: nnodes < 1' allocate(nodes_coords(3,nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 85') if (ier /= 0) stop 'Error allocating array nodes_coords' do inode = 1, nnodes ! format: #id_node #x_coordinate #y_coordinate #z_coordinate @@ -201,6 +202,7 @@ subroutine read_mesh_files() if (nspec < 1) stop 'Error: nspec < 1' allocate(elmnts(NGNOD,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 86') if (ier /= 0) stop 'Error allocating array elmnts' do ispec = 1, nspec ! format: # element_id #id_node1 ... #id_node8 @@ -237,6 +239,7 @@ subroutine read_mesh_files() if (ier /= 0) stop 'Error opening materials_file' allocate(mat(2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 87') if (ier /= 0) stop 'Error allocating array mat' mat(:,:) = 0 @@ -309,6 +312,7 @@ subroutine read_mesh_files() stop 'Error positive material id exceeds bounds for defined materials' endif allocate(mat_prop(16,count_def_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 88') if (ier /= 0) stop 'Error allocating array mat_prop' mat_prop(:,:) = 0.d0 @@ -320,6 +324,7 @@ subroutine read_mesh_files() stop 'Error negative material id exceeds bounds for undefined materials' endif allocate(undef_mat_prop(6,count_undef_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 89') if (ier /= 0) stop 'Error allocating array undef_mat_prop' undef_mat_prop(:,:) = '' @@ -586,8 +591,10 @@ subroutine read_mesh_files() ! thus here the idea is that if some of the absorbing files do not exist because there are no absorbing ! conditions for this mesh then the array is created nonetheless, but with a dummy size of 0 allocate(ibelm_xmin(nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 90') if (ier /= 0) stop 'Error allocating array ibelm_xmin' allocate(nodes_ibelm_xmin(NGNOD2D,nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 91') if (ier /= 0) stop 'Error allocating array nodes_ibelm_xmin' do ispec2D = 1,nspec2D_xmin ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -613,8 +620,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_xmax endif allocate(ibelm_xmax(nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 92') if (ier /= 0) stop 'Error allocating array ibelm_xmax' allocate(nodes_ibelm_xmax(NGNOD2D,nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 93') if (ier /= 0) stop 'Error allocating array nodes_ibelm_xmax' do ispec2D = 1,nspec2D_xmax ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -633,8 +642,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_ymin endif allocate(ibelm_ymin(nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 94') if (ier /= 0) stop 'Error allocating array ibelm_ymin' allocate(nodes_ibelm_ymin(NGNOD2D,nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 95') if (ier /= 0) stop 'Error allocating array nodes_ibelm_ymin' do ispec2D = 1,nspec2D_ymin ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -653,8 +664,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_ymax endif allocate(ibelm_ymax(nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 96') if (ier /= 0) stop 'Error allocating array ibelm_ymax' allocate(nodes_ibelm_ymax(NGNOD2D,nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 97') if (ier /= 0) stop 'Error allocating array nodes_ibelm_ymax' do ispec2D = 1,nspec2D_ymax ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -673,8 +686,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_bottom endif allocate(ibelm_bottom(nspec2D_bottom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 98') if (ier /= 0) stop 'Error allocating array ibelm_bottom' allocate(nodes_ibelm_bottom(NGNOD2D,nspec2D_bottom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 99') if (ier /= 0) stop 'Error allocating array nodes_ibelm_bottom' do ispec2D = 1,nspec2D_bottom ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -724,8 +739,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_top endif allocate(ibelm_top(nspec2D_top),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 100') if (ier /= 0) stop 'Error allocating array ibelm_top' allocate(nodes_ibelm_top(NGNOD2D,nspec2D_top),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 101') if (ier /= 0) stop 'Error allocating array nodes_ibelm_top' do ispec2D = 1,nspec2D_top ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -763,9 +780,11 @@ subroutine read_mesh_files() ! C-PML spectral elements global indexing allocate(CPML_to_spec(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 102') if (ier /= 0) stop 'Error allocating array CPML_to_spec' ! C-PML regions (see below) allocate(CPML_regions(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 103') if (ier /= 0) stop 'Error allocating array CPML_regions' do ispec_CPML=1,nspec_cpml ! elements are stored with #id_cpml_regions increasing order: @@ -786,6 +805,7 @@ subroutine read_mesh_files() ! sets mask of C-PML elements for all elements in this partition allocate(is_CPML(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 104') if (ier /= 0) stop 'Error allocating array is_CPML' is_CPML(:) = .false. do ispec_CPML=1,nspec_cpml @@ -804,8 +824,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_moho endif allocate(ibelm_moho(nspec2D_moho),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 105') if (ier /= 0) stop 'Error allocating array ibelm_moho' allocate(nodes_ibelm_moho(NGNOD2D,nspec2D_moho),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 106') if (ier /= 0) stop 'Error allocating array nodes_ibelm_moho' do ispec2D = 1,nspec2D_moho ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -832,6 +854,7 @@ subroutine check_valence() ! allocate temporary array allocate(used_nodes_elmnts(nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 107') if (ier /= 0) stop 'Error allocating array used_nodes_elmnts' used_nodes_elmnts(:) = 0 @@ -886,12 +909,16 @@ subroutine scotch_partitioning() ! determines maximum neighbors based on "ncommonnodes" common nodes allocate(xadj(1:nspec+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 108') if (ier /= 0) stop 'Error allocating array xadj' allocate(adjncy(1:sup_neighbor*nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 109') if (ier /= 0) stop 'Error allocating array adjncy' allocate(nnodes_elmnts(1:nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 110') if (ier /= 0) stop 'Error allocating array nnodes_elmnts' allocate(nodes_elmnts(1:nsize*nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 111') if (ier /= 0) stop 'Error allocating array nodes_elmnts' print *, 'mesh2dual:' @@ -909,16 +936,19 @@ subroutine scotch_partitioning() ! allocates & initializes partioning of elements allocate(part(1:nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 112') if (ier /= 0) stop 'Error allocating array part' part(:) = -1 ! initializes ! elements load array allocate(elmnts_load(1:nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 113') if (ier /= 0) stop 'Error allocating array elmnts_load' ! gets materials id associations allocate(num_material(1:nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 114') if (ier /= 0) stop 'Error allocating array num_material' ! note: num_material can be negative for tomographic material elements ! (which are counted then as elastic elements) @@ -1099,8 +1129,10 @@ subroutine write_mesh_databases() integer :: ier allocate(my_interfaces(0:ninterfaces-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 115') if (ier /= 0) stop 'Error allocating array my_interfaces' allocate(my_nb_interfaces(0:ninterfaces-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 116') if (ier /= 0) stop 'Error allocating array my_nb_interfaces' if (COUPLE_WITH_INJECTION_TECHNIQUE .or. MESH_A_CHUNK_OF_THE_EARTH) open(124,file='Numglob2loc_elmn.txt') diff --git a/src/decompose_mesh/fault_scotch.f90 b/src/decompose_mesh/fault_scotch.f90 index 7b63b5098..2cad7909d 100644 --- a/src/decompose_mesh/fault_scotch.f90 +++ b/src/decompose_mesh/fault_scotch.f90 @@ -77,7 +77,8 @@ subroutine read_fault_files(localpath_name) ANY_FAULT = (nbfaults > 0) if (.not. ANY_FAULT) return - allocate(faults(nbfaults)) + allocate(faults(nbfaults),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 78') ! NOTE: asumes that the fault ids follow a contiguous numbering, starting at 1, with unit increment ! The user must assign that numbering during mesh generation do iflt = 1 , nbfaults @@ -122,10 +123,14 @@ subroutine read_single_fault_file(f,ifault,localpath_name) read(101,*) nspec_side1,nspec_side2 if (nspec_side1 /= nspec_side2) stop 'Number of fault nodes at do not match.' f%nspec = nspec_side1 - allocate(f%ispec1(f%nspec)) - allocate(f%ispec2(f%nspec)) - allocate(f%inodes1(NGNOD2D,f%nspec)) - allocate(f%inodes2(NGNOD2D,f%nspec)) + allocate(f%ispec1(f%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 79') + allocate(f%ispec2(f%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 80') + allocate(f%inodes1(NGNOD2D,f%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 81') + allocate(f%inodes2(NGNOD2D,f%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 82') do e=1,f%nspec read(101,*) f%ispec1(e),f%inodes1(:,e) enddo @@ -150,8 +155,10 @@ subroutine save_nodes_coords(nodes_coords,nnodes) integer, intent(in) :: nnodes double precision, dimension(3,nnodes), intent(in) :: nodes_coords + integer :: ier - allocate(nodes_coords_open(3,nnodes)) + allocate(nodes_coords_open(3,nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 83') nodes_coords_open = nodes_coords end subroutine save_nodes_coords @@ -353,7 +360,7 @@ subroutine fault_repartition_not_parallel (nelmnts, nnodes, elmnts, nsize, nproc integer, dimension(0:nnodes-1) :: nnodes_elmnts integer, dimension(0:nsize*nnodes-1) :: nodes_elmnts integer :: i,ipart,nproc_null,nproc_null_final - integer :: k1, k2, k,e,iflt,inode + integer :: k1, k2, k,e,iflt,inode,ier integer, dimension(:), allocatable :: elem_proc_null ! downloading processor 0 @@ -364,7 +371,8 @@ subroutine fault_repartition_not_parallel (nelmnts, nnodes, elmnts, nsize, nproc if (nproc_null /= 0) then - allocate(elem_proc_null(nproc_null)) + allocate(elem_proc_null(nproc_null),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 84') ! Filling up proc = 0 elements nproc_null = 0 do i = 0,nelmnts-1 diff --git a/src/decompose_mesh/module_database.f90 b/src/decompose_mesh/module_database.f90 index 11ef01d8f..5ba2f9c42 100644 --- a/src/decompose_mesh/module_database.f90 +++ b/src/decompose_mesh/module_database.f90 @@ -64,7 +64,8 @@ subroutine prepare_database(myrank, elmnts, nE) call compute_adjcy_table(myrank, elmnts, nE) if (myrank == 0) write(27,*) ' COMPUTE ADJACENCY ' - allocate(node_loc(NGNOD2D)) + allocate(node_loc(NGNOD2D),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 58') end subroutine prepare_database @@ -161,7 +162,8 @@ subroutine write_database(myrank, ipart, elmnts, nodes_coords, elmnts_glob, num ! write element connectivity in my partition ----- write(IIN_database) nE_loc - allocate(loc_elmnt(NGNOD)) + allocate(loc_elmnt(NGNOD),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 59') do iE_loc = 1, nE_loc iE = iE_loc ! loc2glob_elmnt(iE_loc) do inode =1, NGNOD @@ -233,8 +235,10 @@ subroutine write_database(myrank, ipart, elmnts, nodes_coords, elmnts_glob, num ! write MPI interfaces ----- npart=maxval(ipart(:)) - allocate(istored(npart),islice_neigh(npart)) - allocate(num_element_in_boundary_partition(npart)) + allocate(istored(npart),islice_neigh(npart),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 60') + allocate(num_element_in_boundary_partition(npart),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 61') istored(:)=0 islice_neigh(:)=0 num_element_in_boundary_partition(:)=0 @@ -260,8 +264,10 @@ subroutine write_database(myrank, ipart, elmnts, nodes_coords, elmnts_glob, num max_element_b_partition = maxval(num_element_in_boundary_partition) !write(*,*) myrank, max_element_b_partition,nb_stored_slice - allocate( my_interfaces_ext_mesh(6,max_element_b_partition,nb_stored_slice)) - allocate(liste_comm_nodes(NGNOD2D), ie_bnd_stored(npart)) + allocate( my_interfaces_ext_mesh(6,max_element_b_partition,nb_stored_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 62') + allocate(liste_comm_nodes(NGNOD2D), ie_bnd_stored(npart),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 63') ie_bnd_stored(:)=0 my_interfaces_ext_mesh(:,:,:)=-99 do iE = 1, nE !! loop over all elements @@ -423,8 +429,10 @@ subroutine compute_adjcy_table(myrank, elmnts, nE) max_element_to_store = 8 * max_elmnts_by_node ! over estimate the number of ! neighbors element ! evalute the size of the adjacency table - allocate(stored_elements(max_element_to_store)) - allocate(nb_neigh(nE_loc)) + allocate(stored_elements(max_element_to_store),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 64') + allocate(nb_neigh(nE_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 65') do iE_loc=1,nE_loc !! loop on all element in partition iE = loc2glob_elmnt(iE_loc) nb_element_stored = 0 @@ -441,7 +449,8 @@ subroutine compute_adjcy_table(myrank, elmnts, nE) enddo size_adjacency = sum(nb_neigh(:)) - allocate(adjcy(size_adjacency),id_adjcy(0:nE_loc)) + allocate(adjcy(size_adjacency),id_adjcy(0:nE_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 66') id_adjcy(0) = 0 do iE_loc=1, nE_loc !! loop on all element in partition iE = loc2glob_elmnt(iE_loc) diff --git a/src/decompose_mesh/module_mesh.f90 b/src/decompose_mesh/module_mesh.f90 index 67943b606..80c673925 100644 --- a/src/decompose_mesh/module_mesh.f90 +++ b/src/decompose_mesh/module_mesh.f90 @@ -118,6 +118,7 @@ subroutine read_mesh_files() read(98,*) nnodes_glob if (nnodes_glob < 1) stop 'Error: nnodes < 1' allocate(nodes_coords_glob(3,nnodes_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 117') if (ier /= 0) stop 'Error allocating array nodes_coords' do inode = 1, nnodes_glob ! format: #id_node #x_coordinate #y_coordinate #z_coordinate @@ -150,6 +151,7 @@ subroutine read_mesh_files() if (nspec_glob < 1) stop 'Error: nspec < 1' allocate(elmnts_glob(NGNOD,nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 118') if (ier /= 0) stop 'Error allocating array elmnts' do ispec = 1, nspec_glob ! format: # element_id #id_node1 ... #id_node8 @@ -187,6 +189,7 @@ subroutine read_mesh_files() status='old', form='formatted',iostat=ier) if (ier /= 0) stop 'Error opening materials_file' allocate(mat(2,nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 119') if (ier /= 0) stop 'Error allocating array mat' mat(:,:) = 0 do ispec = 1, nspec_glob @@ -199,6 +202,7 @@ subroutine read_mesh_files() ! gets materials id associations allocate(num_material(1:nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 120') if (ier /= 0) stop 'Error allocating array num_material' ! note: num_material can be negative for tomographic material elements ! (which are counted then as elastic elements) @@ -265,6 +269,7 @@ subroutine read_mesh_files() stop 'Error positive material id exceeds bounds for defined materials' endif allocate(mat_prop(16,count_def_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 121') if (ier /= 0) stop 'Error allocating array mat_prop' mat_prop(:,:) = 0.d0 @@ -276,6 +281,7 @@ subroutine read_mesh_files() stop 'Error negative material id exceeds bounds for undefined materials' endif allocate(undef_mat_prop(6,count_undef_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 122') if (ier /= 0) stop 'Error allocating array undef_mat_prop' undef_mat_prop(:,:) = '' @@ -540,8 +546,10 @@ subroutine read_mesh_files() ! thus here the idea is that if some of the absorbing files do not exist because there are no absorbing ! conditions for this mesh then the array is created nonetheless, but with a dummy size of 0 allocate(ibelm_xmin(nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 123') if (ier /= 0) stop 'Error allocating array ibelm_xmin' allocate(nodes_ibelm_xmin(NGNOD2D,nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 124') if (ier /= 0) stop 'Error allocating array nodes_ibelm_xmin' do ispec2D = 1,nspec2D_xmin ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -566,8 +574,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_xmax endif allocate(ibelm_xmax(nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 125') if (ier /= 0) stop 'Error allocating array ibelm_xmax' allocate(nodes_ibelm_xmax(NGNOD2D,nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 126') if (ier /= 0) stop 'Error allocating array nodes_ibelm_xmax' do ispec2D = 1,nspec2D_xmax ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -585,8 +595,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_ymin endif allocate(ibelm_ymin(nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 127') if (ier /= 0) stop 'Error allocating array ibelm_ymin' allocate(nodes_ibelm_ymin(NGNOD2D,nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 128') if (ier /= 0) stop 'Error allocating array nodes_ibelm_ymin' do ispec2D = 1,nspec2D_ymin ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -604,8 +616,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_ymax endif allocate(ibelm_ymax(nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 129') if (ier /= 0) stop 'Error allocating array ibelm_ymax' allocate(nodes_ibelm_ymax(NGNOD2D,nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 130') if (ier /= 0) stop 'Error allocating array nodes_ibelm_ymax' do ispec2D = 1,nspec2D_ymax ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -623,8 +637,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_bottom endif allocate(ibelm_bottom(nspec2D_bottom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 131') if (ier /= 0) stop 'Error allocating array ibelm_bottom' allocate(nodes_ibelm_bottom(NGNOD2D,nspec2D_bottom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 132') if (ier /= 0) stop 'Error allocating array nodes_ibelm_bottom' do ispec2D = 1,nspec2D_bottom ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -642,8 +658,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_top endif allocate(ibelm_top(nspec2D_top),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 133') if (ier /= 0) stop 'Error allocating array ibelm_top' allocate(nodes_ibelm_top(NGNOD2D,nspec2D_top),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 134') if (ier /= 0) stop 'Error allocating array nodes_ibelm_top' do ispec2D = 1,nspec2D_top ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -677,9 +695,11 @@ subroutine read_mesh_files() ! C-PML spectral elements global indexing allocate(cpml_to_spec(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 135') if (ier /= 0) stop 'Error allocating array CPML_to_spec' ! C-PML regions (see below) allocate(cpml_regions(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 136') if (ier /= 0) stop 'Error allocating array CPML_regions' do ispec_cpml=1,nspec_cpml ! elements are stored with #id_cpml_regions increasing order: @@ -700,6 +720,7 @@ subroutine read_mesh_files() ! sets mask of C-PML elements for all elements in this partition allocate(is_cpml(nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 137') if (ier /= 0) stop 'Error allocating array is_CPML' is_cpml(:) = .false. do ispec_cpml=1,nspec_cpml @@ -717,8 +738,10 @@ subroutine read_mesh_files() read(98,*) nspec2D_moho endif allocate(ibelm_moho(nspec2D_moho),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 138') if (ier /= 0) stop 'Error allocating array ibelm_moho' allocate(nodes_ibelm_moho(NGNOD2D,nspec2D_moho),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 139') if (ier /= 0) stop 'Error allocating array nodes_ibelm_moho' do ispec2D = 1,nspec2D_moho ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face @@ -746,7 +769,10 @@ subroutine compute_load_elemnts() !! implicit none - allocate(load_elmnts(nspec_glob)) + integer :: ier + + allocate(load_elmnts(nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 140') call acoustic_elastic_poro_load (load_elmnts,nspec_glob,count_def_mat,count_undef_mat, & num_material,mat_prop,undef_mat_prop,ATTENUATION) @@ -787,15 +813,16 @@ subroutine acoustic_elastic_poro_load (elmnts_load,nspec,count_def_mat,count_und ! load weights double precision, dimension(1:nspec), intent(out) :: elmnts_load - ! local parameters logical, dimension(:), allocatable :: is_acoustic, is_elastic, is_poroelastic - integer :: i,el,idomain_id - - - allocate(is_acoustic(-count_undef_mat:count_def_mat)) - allocate(is_elastic(-count_undef_mat:count_def_mat)) - allocate(is_poroelastic(-count_undef_mat:count_def_mat)) + integer :: i,el,idomain_id,ier + + allocate(is_acoustic(-count_undef_mat:count_def_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 141') + allocate(is_elastic(-count_undef_mat:count_def_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 142') + allocate(is_poroelastic(-count_undef_mat:count_def_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 143') ! initializes flags is_acoustic(:) = .false. diff --git a/src/decompose_mesh/module_partition.f90 b/src/decompose_mesh/module_partition.f90 index 666ba89ca..b371e1870 100644 --- a/src/decompose_mesh/module_partition.f90 +++ b/src/decompose_mesh/module_partition.f90 @@ -71,11 +71,12 @@ subroutine decompose_mesh(elmnts, nodes_coords, load_elmnts, nspec, nnodes, npa integer, dimension(:), allocatable :: nEipart_1, nEipart_2, nEipart_3 integer :: nE_1, nE_2, nE_3 integer :: kpart_2, kpart_3, p1, p2, p3 - integer :: i, iE, idir, num_original_element + integer :: i, iE, idir, num_original_element, ier ! nE=nspec - allocate(ipart(nE)) + allocate(ipart(nE),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 67') ipart(:)=-1 xmin = minval(nodes_coords(1,:)) @@ -93,16 +94,20 @@ subroutine decompose_mesh(elmnts, nodes_coords, load_elmnts, nspec, nnodes, npa write(27,*) WRITE(27,*) ' xmin, ymin, zmin ', xmin, ymin, zmin write(27,*) ' sizes, nspec, nnodes ', nspec, nnodes - allocate(elmnts_center(3,nE)) + allocate(elmnts_center(3,nE),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 68') write(27,*) call compute_elmnts_center(elmnts_center, elmnts, nodes_coords, nspec, nnodes) ! partition in direction 1 on the whole mesh idir=1 nE_1=nE - allocate(sum_load_1(nE_1),cri_load_1(nE_1)) - allocate(ipart_1(nE_1), nEipart_1(nE_1), iperm_1(nE_1)) - allocate(load_elmnts_1(nE_1), elmnts_center_1(3,nE_1), old_num_1(nE_1)) + allocate(sum_load_1(nE_1),cri_load_1(nE_1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 69') + allocate(ipart_1(nE_1), nEipart_1(nE_1), iperm_1(nE_1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 70') + allocate(load_elmnts_1(nE_1), elmnts_center_1(3,nE_1), old_num_1(nE_1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 71') elmnts_center_1(:,:)=elmnts_center(:,:) load_elmnts_1(:)=load_elmnts(:) do i=1,nE @@ -120,9 +125,12 @@ subroutine decompose_mesh(elmnts, nodes_coords, load_elmnts, nspec, nnodes, npa idir = 2 nE_2 = nEipart_1(kpart_2) - allocate(sum_load_2(nE_2), cri_load_2(nE_2)) - allocate(load_elmnts_2(nE_2), elmnts_center_2(3,nE_2)) - allocate(ipart_2(nE_2), nEipart_2(npart_2), iperm_2(nE_2), old_num_2(nE_2)) + allocate(sum_load_2(nE_2), cri_load_2(nE_2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 72') + allocate(load_elmnts_2(nE_2), elmnts_center_2(3,nE_2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 73') + allocate(ipart_2(nE_2), nEipart_2(npart_2), iperm_2(nE_2), old_num_2(nE_2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 74') call extract_partition(load_elmnts_2, elmnts_center_2, old_num_2, nE_2, & ipart_1, load_elmnts_1, elmnts_center_1, old_num_1, kpart_2, nE_1) @@ -135,9 +143,12 @@ subroutine decompose_mesh(elmnts, nodes_coords, load_elmnts, nspec, nnodes, npa idir = 3 nE_3 = nEipart_2(kpart_3) - allocate(sum_load_3(nE_3), cri_load_3(nE_3)) - allocate(load_elmnts_3(nE_3), elmnts_center_3(3,nE_3)) - allocate(ipart_3(nE_3), nEipart_3(npart_3), iperm_3(nE_3), old_num_3(nE_3)) + allocate(sum_load_3(nE_3), cri_load_3(nE_3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 75') + allocate(load_elmnts_3(nE_3), elmnts_center_3(3,nE_3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 76') + allocate(ipart_3(nE_3), nEipart_3(npart_3), iperm_3(nE_3), old_num_3(nE_3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 77') call extract_partition(load_elmnts_3, elmnts_center_3, old_num_3, nE_3, & ipart_2, load_elmnts_2, elmnts_center_2, old_num_2, kpart_3, nE_2) diff --git a/src/decompose_mesh/part_decompose_mesh.F90 b/src/decompose_mesh/part_decompose_mesh.F90 index 4a9ab11b0..2cfbf08c6 100644 --- a/src/decompose_mesh/part_decompose_mesh.F90 +++ b/src/decompose_mesh/part_decompose_mesh.F90 @@ -171,6 +171,7 @@ subroutine build_glob2loc_elmnts(nspec, part, glob2loc_elmnts,nparts) ! allocates local numbering array allocate(glob2loc_elmnts(0:nspec-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 40') if (ier /= 0) stop 'error allocating array glob2loc_elmnts' ! initializes number of local elements per partition @@ -217,6 +218,7 @@ subroutine build_glob2loc_nodes(nspec, nnodes, nsize, nnodes_elmnts, nodes_elmnt integer :: ier allocate(glob2loc_nodes_nparts(0:nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 41') if (ier /= 0) stop 'error allocating array glob2loc_nodes_nparts' size_glob2loc_nodes = 0 @@ -240,8 +242,10 @@ subroutine build_glob2loc_nodes(nspec, nnodes, nsize, nnodes_elmnts, nodes_elmnt glob2loc_nodes_nparts(nnodes) = size_glob2loc_nodes allocate(glob2loc_nodes_parts(0:glob2loc_nodes_nparts(nnodes)-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 42') if (ier /= 0) stop 'error allocating array glob2loc_nodes_parts' allocate(glob2loc_nodes(0:glob2loc_nodes_nparts(nnodes)-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 43') if (ier /= 0) stop 'error allocating array glob2loc_nodes' glob2loc_nodes(0) = 0 @@ -313,6 +317,7 @@ subroutine build_interfaces(nspec, sup_neighbor, part, elmnts, xadj, adjncy, & enddo allocate(tab_size_interfaces(0:ninterfaces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 44') if (ier /= 0) stop 'error allocating array tab_size_interfaces' tab_size_interfaces(:) = 0 @@ -349,6 +354,7 @@ subroutine build_interfaces(nspec, sup_neighbor, part, elmnts, xadj, adjncy, & num_edge = 0 allocate(tab_interfaces(0:(tab_size_interfaces(ninterfaces)*7-1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 45') if (ier /= 0) stop 'error allocating array tab_interfaces' tab_interfaces(:) = 0 @@ -1177,12 +1183,16 @@ subroutine poro_elastic_repartitioning (nspec, nnodes, elmnts, & ! gets neighbors by 4 common nodes (face) allocate(xadj(0:nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 46') if (ier /= 0) stop 'error allocating array xadj' allocate(adjncy(0:sup_neighbor*nspec-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 47') if (ier /= 0) stop 'error allocating array adjncy' allocate(nnodes_elmnts(0:nnodes-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 48') if (ier /= 0) stop 'error allocating array nnodes_elmnts' allocate(nodes_elmnts(0:nsize*nnodes-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 49') if (ier /= 0) stop 'error allocating array nodes_elmnts' call mesh2dual_ncommonnodes(nspec, nnodes, nsize, sup_neighbor, & elmnts, xadj, adjncy, nnodes_elmnts, & @@ -1206,6 +1216,7 @@ subroutine poro_elastic_repartitioning (nspec, nnodes, elmnts, & ! coupled elements allocate(faces_coupled(2,nfaces_coupled),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 50') if (ier /= 0) stop 'error allocating array faces_coupled' faces_coupled(:,:) = -1 @@ -1305,9 +1316,11 @@ subroutine moho_surface_repartitioning (nspec, nnodes, elmnts, & ! temporary flag arrays ! element ids start from 0 allocate( is_moho(0:nspec-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 51') if (ier /= 0) stop 'error allocating array is_moho' ! node ids start from 0 allocate( node_is_moho(0:nnodes-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 52') if (ier /= 0) stop 'error allocating array node_is_moho' is_moho(:) = .false. @@ -1353,13 +1366,17 @@ subroutine moho_surface_repartitioning (nspec, nnodes, elmnts, & ! gets neighbors by 4 common nodes (face) ! contains number of adjacent elements (neighbors) allocate(xadj(0:nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 53') if (ier /= 0) stop 'error allocating array xadj' ! contains all element id indices of adjacent elements allocate(adjncy(0:sup_neighbor*nspec-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 54') if (ier /= 0) stop 'error allocating array adjncy' allocate(nnodes_elmnts(0:nnodes-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 55') if (ier /= 0) stop 'error allocating array nnodes_elmnts' allocate(nodes_elmnts(0:nsize*nnodes-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 56') if (ier /= 0) stop 'error allocating array nodes_elmnts' call mesh2dual_ncommonnodes(nspec, nnodes, nsize, sup_neighbor, & @@ -1379,6 +1396,7 @@ subroutine moho_surface_repartitioning (nspec, nnodes, elmnts, & ! coupled elements allocate(faces_coupled(2,nfaces_coupled),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 57') if (ier /= 0) stop 'error allocating array faces_coupled' faces_coupled(:,:) = -1 diff --git a/src/decompose_mesh/program_decompose_mesh_mpi.f90 b/src/decompose_mesh/program_decompose_mesh_mpi.f90 index a342a6788..033259af5 100644 --- a/src/decompose_mesh/program_decompose_mesh_mpi.f90 +++ b/src/decompose_mesh/program_decompose_mesh_mpi.f90 @@ -47,6 +47,8 @@ program xdecompose_mesh_mpi ! number of proc in each direction integer :: npartX, npartY, npartZ + integer :: ier + ! MPI initialization call init_mpi() call world_size(sizeprocs) @@ -112,7 +114,8 @@ program xdecompose_mesh_mpi call bcast_all_singlei(nspec_glob) if (myrank > 0) then - allocate(ipart(nspec_glob)) + allocate(ipart(nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1') endif call bcast_all_i(ipart, nspec_glob) call send_partition_mesh_to_all(myrank, ipart, npartX*npartY*npartZ) @@ -160,7 +163,7 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) integer, intent(in) :: myrank, npart integer, dimension(nspec_glob), intent(in) :: ipart - integer :: iE, kE, iE_loc + integer :: iE, kE, iE_loc, ier integer :: nE integer :: irank integer :: ivertex, inode, inode_loc @@ -174,7 +177,7 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) integer, dimension(:), allocatable :: nelmnts_by_node_glob integer, dimension(:,:), allocatable :: elmnts_by_node_glob logical, dimension(:), allocatable :: stored_node - integer, dimension(1) :: nE_loc_for_shut_up_compiler + integer, dimension(1) :: nE_loc_for_shut_up_compiler ! glob dimension call bcast_all_singlei(nspec_glob) @@ -195,7 +198,8 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) !! ----------------------------- COMPUTE ELEMENT BY NODE CONNECTIVITY --------------- if (myrank == 0) then ! evaluate max element by node - allocate(nelmnts_by_node_glob(nnodes_glob)) + allocate(nelmnts_by_node_glob(nnodes_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2') nelmnts_by_node_glob(:)=0 do iE=1,nE do inode=1,NGNOD @@ -207,7 +211,8 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) ! compute elments by node table max_elmnts_by_node = maxval(nelmnts_by_node_glob) nelmnts_by_node_glob(:)=0 - allocate(elmnts_by_node_glob(max_elmnts_by_node, nnodes_glob)) + allocate(elmnts_by_node_glob(max_elmnts_by_node, nnodes_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 3') elmnts_by_node_glob(:,:)=-1 do iE=1,nE do inode=1,NGNOD @@ -220,8 +225,10 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) call bcast_all_singlei(max_elmnts_by_node) ! count the number of nodes in each partition - allocate(nnodes_in_partition(npart)) - allocate(stored_node(npart)) + allocate(nnodes_in_partition(npart),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 4') + allocate(stored_node(npart),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 5') nnodes_in_partition(:)=0 if (myrank == 0 ) then do inode = 1, nnodes_glob @@ -241,12 +248,15 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) nnodes = nnodes_in_partition(myrank+1) ! splitted dual mesh, not really distribued because of use glob numbering - allocate(elmnts_by_node(max_elmnts_by_node,nnodes), nelmnts_by_node(nnodes)) + allocate(elmnts_by_node(max_elmnts_by_node,nnodes), nelmnts_by_node(nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 6') elmnts_by_node(:,:)=-1 ! global to local numbering - allocate(loc2glob_nodes(nnodes), glob2loc_nodes(nnodes_glob)) - allocate(nodes_coords(3,nnodes)) + allocate(loc2glob_nodes(nnodes), glob2loc_nodes(nnodes_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 7') + allocate(nodes_coords(3,nnodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 8') nnodes_loc = nnodes glob2loc_nodes(:)=-1 loc2glob_nodes(:)=-1 @@ -272,11 +282,16 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) do irank = 1, npart - 1 - allocate(buffer_to_send(max_elmnts_by_node,nnodes_in_partition(irank+1))) - allocate(buffer_to_send1(nnodes_in_partition(irank+1))) - allocate(buffer_to_send2(nnodes_in_partition(irank+1))) - allocate(buffer_to_send3(nnodes_glob)) - allocate(dp_buffer_to_send(3,nnodes_in_partition(irank+1))) + allocate(buffer_to_send(max_elmnts_by_node,nnodes_in_partition(irank+1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 9') + allocate(buffer_to_send1(nnodes_in_partition(irank+1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 10') + allocate(buffer_to_send2(nnodes_in_partition(irank+1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 11') + allocate(buffer_to_send3(nnodes_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 12') + allocate(dp_buffer_to_send(3,nnodes_in_partition(irank+1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 13') inode_loc = 0 do inode = 1, nnodes_glob not_stored=.true. @@ -331,7 +346,8 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) endif enddo - allocate(loc2glob_elmnt(nE_loc), glob2loc_elmnt(nE)) + allocate(loc2glob_elmnt(nE_loc), glob2loc_elmnt(nE),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 14') glob2loc_elmnt(:)=-1 ! list of element in my partition @@ -343,13 +359,15 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) glob2loc_elmnt(iE) = iE_loc endif enddo - allocate(nE_irank(npart)) + allocate(nE_irank(npart),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 15') nE_irank(:)=0 nE_loc_for_shut_up_compiler(1) = nE_loc call gather_all_all_i(nE_loc_for_shut_up_compiler, 1, nE_irank, 1, npart) nspec=nE_loc !! global varailble to be saved - allocate(elmnts(NGNOD,nE_loc)) + allocate(elmnts(NGNOD,nE_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 16') if ( myrank == 0 ) then irank = 0 @@ -363,7 +381,8 @@ subroutine send_partition_mesh_to_all(myrank, ipart, npart) enddo do irank = 1, npart - 1 - allocate(buffer_to_send(NGNOD, nE_irank(irank+1))) + allocate(buffer_to_send(NGNOD, nE_irank(irank+1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 17') iE_loc=0 do iE = 1, nE if (ipart(iE) == irank +1 ) then @@ -406,65 +425,87 @@ subroutine send_mesh_to_all(myrank) if (myrank > 0) then allocate(elmnts_glob(NGNOD,nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 18') if (ier /= 0) then write(*,*) 'Error ', myrank, NGNOD,nspec_glob stop 'Error allocating array elmnts' endif allocate(mat(2,nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 19') if (ier /= 0) stop 'Error allocating array mat' allocate(num_material(1:nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 20') if (ier /= 0) stop 'Error allocating array num_material' allocate(mat_prop(16,count_def_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 21') if (ier /= 0) stop 'Error allocating array mat_prop' allocate(undef_mat_prop(6,count_undef_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 22') if (ier /= 0) stop 'Error allocating array undef_mat_prop' allocate(ibelm_xmin(nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 23') if (ier /= 0) stop 'Error allocating array ibelm_xmin' allocate(nodes_ibelm_xmin(NGNOD2D,nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 24') if (ier /= 0) stop 'Error allocating array nodes_ibelm_xmin' allocate(ibelm_xmax(nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 25') if (ier /= 0) stop 'Error allocating array ibelm_xmax' allocate(nodes_ibelm_xmax(NGNOD2D,nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 26') if (ier /= 0) stop 'Error allocating array nodes_ibelm_xmax' allocate(ibelm_ymin(nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 27') if (ier /= 0) stop 'Error allocating array ibelm_ymin' allocate(nodes_ibelm_ymin(NGNOD2D,nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 28') if (ier /= 0) stop 'Error allocating array nodes_ibelm_ymin' allocate(ibelm_ymax(nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 29') if (ier /= 0) stop 'Error allocating array ibelm_ymax' allocate(nodes_ibelm_ymax(NGNOD2D,nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 30') if (ier /= 0) stop 'Error allocating array nodes_ibelm_ymax' allocate(ibelm_bottom(nspec2D_bottom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 31') if (ier /= 0) stop 'Error allocating array ibelm_bottom' allocate(nodes_ibelm_bottom(NGNOD2D,nspec2D_bottom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 32') if (ier /= 0) stop 'Error allocating array nodes_ibelm_bottom' allocate(ibelm_top(nspec2D_top),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 33') if (ier /= 0) stop 'Error allocating array ibelm_top' allocate(nodes_ibelm_top(NGNOD2D,nspec2D_top),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 34') if (ier /= 0) stop 'Error allocating array nodes_ibelm_top' allocate(cpml_to_spec(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 35') if (ier /= 0) stop 'Error allocating array CPML_to_spec' ! C-PML regions (see below) allocate(cpml_regions(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 36') if (ier /= 0) stop 'Error allocating array CPML_regions' allocate(is_cpml(nspec_glob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 37') if (ier /= 0) stop 'Error allocating array is_CPML' allocate(ibelm_moho(nspec2D_moho),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 38') if (ier /= 0) stop 'Error allocating array ibelm_moho' allocate(nodes_ibelm_moho(NGNOD2D,nspec2D_moho),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 39') if (ier /= 0) stop 'Error allocating array nodes_ibelm_moho' endif diff --git a/src/decompose_mesh/rules.mk b/src/decompose_mesh/rules.mk index 337063480..94afb8636 100644 --- a/src/decompose_mesh/rules.mk +++ b/src/decompose_mesh/rules.mk @@ -58,6 +58,7 @@ decompose_mesh_MODULES = \ decompose_mesh_SHARED_OBJECTS = \ $O/shared_par.shared_module.o \ $O/param_reader.cc.o \ + $O/exit_mpi.shared.o \ $O/read_parameter_file.shared.o \ $O/read_value_parameters.shared.o \ $O/sort_array_coordinates.shared.o \ diff --git a/src/generate_databases/create_mass_matrices.f90 b/src/generate_databases/create_mass_matrices.f90 index ee32c9d2b..e587a2a19 100644 --- a/src/generate_databases/create_mass_matrices.f90 +++ b/src/generate_databases/create_mass_matrices.f90 @@ -58,6 +58,7 @@ subroutine create_mass_matrices(nglob,nspec,ibool,PML_CONDITIONS,STACEY_ABSORBIN if (ELASTIC_SIMULATION) then ! allocates memory allocate(rmass(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 660') if (ier /= 0) call exit_MPI_without_rank('error allocating array rmass') rmass(:) = 0._CUSTOM_REAL @@ -90,6 +91,7 @@ subroutine create_mass_matrices(nglob,nspec,ibool,PML_CONDITIONS,STACEY_ABSORBIN if (ACOUSTIC_SIMULATION) then ! allocates memory allocate(rmass_acoustic(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 661') if (ier /= 0) call exit_MPI_without_rank('error allocating array rmass_acoustic') rmass_acoustic(:) = 0._CUSTOM_REAL @@ -123,8 +125,10 @@ subroutine create_mass_matrices(nglob,nspec,ibool,PML_CONDITIONS,STACEY_ABSORBIN if (POROELASTIC_SIMULATION) then ! allocates memory allocate(rmass_solid_poroelastic(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 662') if (ier /= 0) call exit_MPI_without_rank('error in allocate rmass_solid_poroelastic') allocate(rmass_fluid_poroelastic(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 663') if (ier /= 0) call exit_MPI_without_rank('error in allocate rmass_fluid_poroelastic') rmass_solid_poroelastic(:) = 0._CUSTOM_REAL rmass_fluid_poroelastic(:) = 0._CUSTOM_REAL @@ -214,6 +218,7 @@ subroutine create_mass_matrices_ocean_load(nglob,nspec,ibool) ! adding ocean load mass matrix at ocean bottom NGLOB_OCEAN = nglob allocate(rmass_ocean_load(NGLOB_OCEAN),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 664') if (ier /= 0) stop 'error allocating array rmass_ocean_load' ! create ocean load mass matrix for degrees of freedom at ocean bottom @@ -281,6 +286,7 @@ subroutine create_mass_matrices_ocean_load(nglob,nspec,ibool) ! allocate dummy array if no oceans NGLOB_OCEAN = 1 allocate(rmass_ocean_load(NGLOB_OCEAN),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 665') if (ier /= 0) stop 'error allocating dummy array rmass_ocean_load' endif @@ -323,6 +329,7 @@ subroutine create_mass_matrices_Stacey(nglob,nspec,ibool) ! elastic domains if (ELASTIC_SIMULATION) then allocate( rmassx(nglob_xy), rmassy(nglob_xy), rmassz(nglob_xy), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 666') if (ier /= 0) stop 'error in allocate 21' rmassx(:) = 0._CUSTOM_REAL rmassy(:) = 0._CUSTOM_REAL @@ -332,6 +339,7 @@ subroutine create_mass_matrices_Stacey(nglob,nspec,ibool) ! acoustic domains if (ACOUSTIC_SIMULATION) then allocate( rmassz_acoustic(nglob_xy), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 667') if (ier /= 0) stop 'error in allocate 22' rmassz_acoustic(:) = 0._CUSTOM_REAL endif diff --git a/src/generate_databases/create_regions_mesh.f90 b/src/generate_databases/create_regions_mesh.f90 index 26a4a22e2..d6f851206 100644 --- a/src/generate_databases/create_regions_mesh.f90 +++ b/src/generate_databases/create_regions_mesh.f90 @@ -412,13 +412,16 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & real, dimension(NGNOD) :: xelm_real,yelm_real,zelm_real allocate(xelm(NGNOD),yelm(NGNOD),zelm(NGNOD),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 723') if (ier /= 0) stop 'error allocating array xelm etc.' ! attenuation allocate(qkappa_attenuation_store(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 724') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') allocate(qmu_attenuation_store(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 725') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! create the name for the database of the current slide and region @@ -426,44 +429,64 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & ! Gauss-Lobatto-Legendre points of integration allocate(xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 726') if (ier /= 0) stop 'error allocating array xigll etc.' ! Gauss-Lobatto-Legendre weights of integration allocate(wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 727') if (ier /= 0) stop 'error allocating array wxgll etc.' ! 3D shape functions and their derivatives - allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)) + allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 728') allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 729') if (ier /= 0) stop 'error allocating array shape3D etc.' ! 2D shape functions and their derivatives - allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ)) - allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ)) - allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY)) + allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 730') + allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 731') + allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 732') allocate(shape2D_top(NGNOD2D,NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 733') if (ier /= 0) stop 'error allocating array shape2D_x etc.' - allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)) - allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)) - allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)) + allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 734') + allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 735') + allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 736') allocate(dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 737') if (ier /= 0) stop 'error allocating array dershape2D_x etc.' - allocate(wgllwgll_xy(NGLLX,NGLLY)) - allocate(wgllwgll_xz(NGLLX,NGLLZ)) + allocate(wgllwgll_xy(NGLLX,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 738') + allocate(wgllwgll_xz(NGLLX,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 739') allocate(wgllwgll_yz(NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 740') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! Stacey - allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec)) + allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 741') allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 742') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! array with model density - allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec)) - allocate(kappastore(NGLLX,NGLLY,NGLLZ,nspec)) + allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 743') + allocate(kappastore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 744') allocate(mustore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 745') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') !EB EB April 2018 : we should find a way to know if there are any poroelastic @@ -476,20 +499,30 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & ! endif ! array with poroelastic model - allocate(rhoarraystore(2,NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(kappaarraystore(3,NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(etastore(NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(tortstore(NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(phistore(NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(rho_vpI(NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(rho_vpII(NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) - allocate(rho_vsI(NGLLX,NGLLY,NGLLZ,NSPEC_PORO)) + allocate(rhoarraystore(2,NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 746') + allocate(kappaarraystore(3,NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 747') + allocate(etastore(NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 748') + allocate(tortstore(NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 749') + allocate(phistore(NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 750') + allocate(rho_vpI(NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 751') + allocate(rho_vpII(NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 752') + allocate(rho_vsI(NGLLX,NGLLY,NGLLZ,NSPEC_PORO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 753') allocate(permstore(6,NGLLX,NGLLY,NGLLZ,NSPEC_PORO), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 754') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! get the number of regular and irregular elements any_regular_elem = .false. - allocate(irregular_element_number(nspec)) + allocate(irregular_element_number(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 755') irregular_element_number(:) = 0 nspec_irregular = nspec @@ -506,28 +539,48 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & enddo if (nspec_irregular == 0) then - allocate(xixstore(1,1,1,1)) - allocate(xiystore(1,1,1,1)) - allocate(xizstore(1,1,1,1)) - allocate(etaxstore(1,1,1,1)) - allocate(etaystore(1,1,1,1)) - allocate(etazstore(1,1,1,1)) - allocate(gammaxstore(1,1,1,1)) - allocate(gammaystore(1,1,1,1)) - allocate(gammazstore(1,1,1,1)) + allocate(xixstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 756') + allocate(xiystore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 757') + allocate(xizstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 758') + allocate(etaxstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 759') + allocate(etaystore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 760') + allocate(etazstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 761') + allocate(gammaxstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 762') + allocate(gammaystore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 763') + allocate(gammazstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 764') allocate(jacobianstore(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 765') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') else - allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) - allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec_irregular)) + allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 766') + allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 767') + allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 768') + allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 769') + allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 770') + allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 771') + allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 772') + allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 773') + allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 774') allocate(jacobianstore(NGLLX,NGLLY,NGLLZ,nspec_irregular),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 775') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') endif @@ -543,10 +596,14 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & if (BOTTOM_FREE_SURFACE) num_abs_boundary_faces = num_abs_boundary_faces - nspec2D_bottom ! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ) - allocate(abs_boundary_ispec(num_abs_boundary_faces)) - allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)) - allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)) + allocate(abs_boundary_ispec(num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 776') + allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 777') + allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 778') allocate(abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 779') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! free surface faces @@ -558,10 +615,14 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & if (STACEY_INSTEAD_OF_FREE_SURFACE) num_free_surface_faces = num_free_surface_faces - nspec2D_top endif ! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ) - allocate(free_surface_ispec(num_free_surface_faces)) - allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)) - allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces)) + allocate(free_surface_ispec(num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 780') + allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 781') + allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 782') allocate(free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 783') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! array with anisotropy @@ -570,33 +631,57 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & else NSPEC_ANISO = 1 endif - allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) + allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 784') + allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 785') + allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 786') + allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 787') + allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 788') + allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 789') + allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 790') + allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 791') + allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 792') + allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 793') + allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 794') + allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 795') + allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 796') + allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 797') + allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 798') + allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 799') + allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 800') + allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 801') + allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 802') + allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 803') allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 804') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! material flags - allocate(ispec_is_acoustic(nspec)) - allocate(ispec_is_elastic(nspec)) + allocate(ispec_is_acoustic(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 805') + allocate(ispec_is_elastic(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 806') allocate(ispec_is_poroelastic(nspec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 807') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! initializes Moho surface @@ -761,11 +846,16 @@ subroutine crm_ext_setup_indexing(ibool, & double precision :: x_min,x_max ! allocate memory for arrays - allocate(locval(npointot)) - allocate(ifseg(npointot)) - allocate(xp(npointot)) - allocate(yp(npointot)) + allocate(locval(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 808') + allocate(ifseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 809') + allocate(xp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 810') + allocate(yp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 811') allocate(zp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 812') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! creates temporary global point arrays @@ -809,9 +899,12 @@ subroutine crm_ext_setup_indexing(ibool, & ! unique global point locations nglob_dummy = nglob - allocate(xstore_dummy(nglob_dummy)) - allocate(ystore_dummy(nglob_dummy)) + allocate(xstore_dummy(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 813') + allocate(ystore_dummy(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 814') allocate(zstore_dummy(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 815') if (ier /= 0) stop 'error in allocate' do ispec = 1, nspec do k = 1, NGLLZ @@ -891,8 +984,10 @@ subroutine crm_setup_moho( myrank,nspec, & reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/)) ! top ! temporary arrays for passing information - allocate(iglob_is_surface(nglob_dummy)) + allocate(iglob_is_surface(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 816') allocate(iglob_normals(NDIM,nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 817') if (ier /= 0) stop 'error allocating array iglob_is_surface' iglob_is_surface = 0 @@ -957,20 +1052,28 @@ subroutine crm_setup_moho( myrank,nspec, & ! stores moho elements NSPEC2D_MOHO = nspec2D_moho_ext - allocate(ibelm_moho_bot(NSPEC2D_MOHO)) - allocate(ibelm_moho_top(NSPEC2D_MOHO)) - allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO)) - allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO)) - allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO)) + allocate(ibelm_moho_bot(NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 818') + allocate(ibelm_moho_top(NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 819') + allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 820') + allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 821') + allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 822') allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 823') if (ier /= 0) stop 'error allocating ibelm_moho_bot' ibelm_moho_bot = 0 ibelm_moho_top = 0 ! element flags - allocate(is_moho_top(nspec)) + allocate(is_moho_top(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 824') allocate(is_moho_bot(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 825') if (ier /= 0) stop 'error allocating is_moho_top' is_moho_top = .false. is_moho_bot = .false. @@ -1205,10 +1308,12 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & ! allocates arrays allocate(ispec_is_inner(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 826') if (ier /= 0) stop 'error allocating array ispec_is_inner' ! temporary array allocate(iglob_is_inner(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 827') if (ier /= 0) stop 'error allocating temporary array iglob_is_inner' ! initialize flags @@ -1264,6 +1369,7 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & if (num_phase_ispec_acoustic < 0) stop 'error acoustic simulation: num_phase_ispec_acoustic is < zero' allocate( phase_ispec_inner_acoustic(num_phase_ispec_acoustic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 828') if (ier /= 0) stop 'error allocating array phase_ispec_inner_acoustic' phase_ispec_inner_acoustic(:,:) = 0 @@ -1284,6 +1390,7 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & ! allocates dummy array num_phase_ispec_acoustic = 0 allocate( phase_ispec_inner_acoustic(num_phase_ispec_acoustic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 829') if (ier /= 0) stop 'error allocating dummy array phase_ispec_inner_acoustic' phase_ispec_inner_acoustic(:,:) = 0 endif @@ -1308,6 +1415,7 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & if (num_phase_ispec_elastic < 0) stop 'error elastic simulation: num_phase_ispec_elastic is < zero' allocate( phase_ispec_inner_elastic(num_phase_ispec_elastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 830') if (ier /= 0) stop 'error allocating array phase_ispec_inner_elastic' phase_ispec_inner_elastic(:,:) = 0 @@ -1328,6 +1436,7 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & ! allocates dummy array num_phase_ispec_elastic = 0 allocate( phase_ispec_inner_elastic(num_phase_ispec_elastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 831') if (ier /= 0) stop 'error allocating dummy array phase_ispec_inner_elastic' phase_ispec_inner_elastic(:,:) = 0 endif @@ -1350,6 +1459,7 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & ! stores indices of inner and outer elements for faster(?) computation num_phase_ispec_poroelastic = max(nspec_inner_poroelastic,nspec_outer_poroelastic) allocate( phase_ispec_inner_poroelastic(num_phase_ispec_poroelastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 832') if (ier /= 0) stop 'error allocating array phase_ispec_inner_poroelastic' nspec_inner_poroelastic = 0 nspec_outer_poroelastic = 0 @@ -1368,6 +1478,7 @@ subroutine crm_setup_inner_outer_elemnts(myrank,nspec, & ! allocates dummy array num_phase_ispec_poroelastic = 0 allocate( phase_ispec_inner_poroelastic(num_phase_ispec_poroelastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 833') if (ier /= 0) stop 'error allocating dummy array phase_ispec_inner_poroelastic' phase_ispec_inner_poroelastic(:,:) = 0 endif @@ -1407,14 +1518,17 @@ subroutine crm_setup_mesh_surface() integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy ! allocates mesh surface arrays - allocate(ispec_is_surface_external_mesh(NSPEC_AB)) + allocate(ispec_is_surface_external_mesh(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 834') allocate(iglob_is_surface_external_mesh(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 835') if (ier /= 0) stop 'error allocating array' nfaces_surface = 0 ! collects MPI interfaces for detection max_nibool_interfaces_ext_mesh = maxval(nibool_interfaces_ext_mesh) allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 836') if (ier /= 0) stop 'error allocating array' do i = 1, num_interfaces_ext_mesh diff --git a/src/generate_databases/fault_generate_databases.f90 b/src/generate_databases/fault_generate_databases.f90 index 168a48338..bd222508b 100644 --- a/src/generate_databases/fault_generate_databases.f90 +++ b/src/generate_databases/fault_generate_databases.f90 @@ -113,7 +113,8 @@ subroutine fault_read_input(prname,myrank) ANY_FAULT = (nb > 0) if (.not. ANY_FAULT) return - allocate(fault_db(nb)) + allocate(fault_db(nb),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 868') do i=1,nb read(IIN_PAR,*) fault_db(i)%eta enddo @@ -137,10 +138,14 @@ subroutine fault_read_input(prname,myrank) ANY_FAULT_IN_THIS_PROC = .true. - allocate(fault_db(iflt)%ispec1(nspec)) - allocate(fault_db(iflt)%inodes1(NGNOD2D,nspec)) - allocate(fault_db(iflt)%ispec2(nspec)) - allocate(fault_db(iflt)%inodes2(NGNOD2D,nspec)) + allocate(fault_db(iflt)%ispec1(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 869') + allocate(fault_db(iflt)%inodes1(NGNOD2D,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 870') + allocate(fault_db(iflt)%ispec2(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 871') + allocate(fault_db(iflt)%inodes2(NGNOD2D,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 872') do i=1,nspec read(IIN_PAR) fault_db(iflt)%ispec1(i), fault_db(iflt)%inodes1(:,i) @@ -161,7 +166,8 @@ subroutine fault_read_input(prname,myrank) ! read nodes coordinates of the original version of the mesh, in which faults are open read(IIN_PAR) nnodes_coords_open - allocate(nodes_coords_open(NDIM,nnodes_coords_open)) + allocate(nodes_coords_open(NDIM,nnodes_coords_open),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 873') do i = 1, nnodes_coords_open read(IIN_PAR) dummy_node, nodes_coords_open(:,i) enddo @@ -231,10 +237,12 @@ subroutine setup_iface(fdb,nnodes_ext_mesh,nodes_coords_ext_mesh,nspec,nglob,ibo integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool real(kind=CUSTOM_REAL), dimension(NGNOD2D) :: xcoord,ycoord,zcoord - integer :: icorner,e + integer :: icorner,e,ier - allocate(fdb%iface1(fdb%nspec)) - allocate(fdb%iface2(fdb%nspec)) + allocate(fdb%iface1(fdb%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 874') + allocate(fdb%iface2(fdb%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 875') do e=1,fdb%nspec ! side 1 do icorner=1,NGNOD2D @@ -265,11 +273,13 @@ subroutine setup_ijk(fdb) type(fault_db_type), intent(inout) :: fdb - integer :: e,i,j,igll + integer :: e,i,j,igll,ier integer :: ijk_face1(3,NGLLX,NGLLY), ijk_face2(3,NGLLX,NGLLY) - allocate(fdb%ijk1(3,NGLLX*NGLLY,fdb%nspec)) - allocate(fdb%ijk2(3,NGLLX*NGLLY,fdb%nspec)) + allocate(fdb%ijk1(3,NGLLX*NGLLY,fdb%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 876') + allocate(fdb%ijk2(3,NGLLX*NGLLY,fdb%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 877') do e=1,fdb%nspec call get_element_face_gll_indices(fdb%iface1(e),ijk_face1,NGLLX,NGLLY) @@ -291,10 +301,12 @@ subroutine setup_Kelvin_Voigt_eta(fdb,nspec) type(fault_db_type), intent(in) :: fdb integer, intent(in) :: nspec ! number of spectral elements in each block + integer :: ier if (fdb%eta > 0.0_CUSTOM_REAL) then if (.not. allocated(Kelvin_Voigt_eta)) then - allocate(Kelvin_Voigt_eta(nspec)) + allocate(Kelvin_Voigt_eta(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 878') Kelvin_Voigt_eta(:) = 0.0_CUSTOM_REAL endif Kelvin_Voigt_eta(fdb%ispec1) = fdb%eta @@ -321,7 +333,7 @@ subroutine setup_ibools(fdb,xstore,ystore,zstore,nspec,npointot) double precision :: xp(npointot),yp(npointot),zp(npointot),xmin,xmax integer :: locval(npointot) logical :: ifseg(npointot) - integer :: ispec,k,igll,ie,je,ke,e + integer :: ispec,k,igll,ie,je,ke,e,ier xmin = minval(nodes_coords_ext_mesh(1,:)) xmax = maxval(nodes_coords_ext_mesh(1,:)) @@ -339,7 +351,8 @@ subroutine setup_ibools(fdb,xstore,ystore,zstore,nspec,npointot) zp(k) = zstore(ie,je,ke,ispec) enddo enddo - allocate( fdb%ibool1(NGLLSQUARE,fdb%nspec) ) + allocate( fdb%ibool1(NGLLSQUARE,fdb%nspec) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 879') call get_global(npointot,xp,yp,zp,fdb%ibool1,locval,ifseg,fdb%nglob,xmin,xmax) ! xp,yp,zp need to be recomputed on side 2 @@ -359,7 +372,8 @@ subroutine setup_ibools(fdb,xstore,ystore,zstore,nspec,npointot) zp(k) = zstore(ie,je,ke,ispec) enddo enddo - allocate( fdb%ibool2(NGLLSQUARE,fdb%nspec) ) + allocate( fdb%ibool2(NGLLSQUARE,fdb%nspec) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 880') call get_global(npointot,xp,yp,zp,fdb%ibool2,locval,ifseg,fdb%nglob,xmin,xmax) end subroutine setup_ibools @@ -372,10 +386,12 @@ subroutine setup_ibulks(fdb,ibool,nspec) type(fault_db_type), intent(inout) :: fdb integer, intent(in) :: nspec, ibool(NGLLX,NGLLY,NGLLZ,nspec) - integer :: e,k, K1, K2, ie,je,ke + integer :: e,k, K1, K2, ie,je,ke,ier - allocate( fdb%ibulk1(fdb%nglob) ) - allocate( fdb%ibulk2(fdb%nglob) ) + allocate( fdb%ibulk1(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 881') + allocate( fdb%ibulk2(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 882') do e=1, fdb%nspec do k=1, NGLLSQUARE @@ -430,14 +446,20 @@ subroutine save_fault_xyzcoord_ibulk(fdb) type(fault_db_type), intent(inout) :: fdb - integer :: K1, K2, i - - allocate( fdb%xcoordbulk1(fdb%nglob) ) - allocate( fdb%ycoordbulk1(fdb%nglob) ) - allocate( fdb%zcoordbulk1(fdb%nglob) ) - allocate( fdb%xcoordbulk2(fdb%nglob) ) - allocate( fdb%ycoordbulk2(fdb%nglob) ) - allocate( fdb%zcoordbulk2(fdb%nglob) ) + integer :: K1, K2, i, ier + + allocate( fdb%xcoordbulk1(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 883') + allocate( fdb%ycoordbulk1(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 884') + allocate( fdb%zcoordbulk1(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 885') + allocate( fdb%xcoordbulk2(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 886') + allocate( fdb%ycoordbulk2(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 887') + allocate( fdb%zcoordbulk2(fdb%nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 888') do i=1, fdb%nglob K1 =fdb%ibulk1(i) @@ -475,11 +497,13 @@ subroutine setup_normal_jacobian(fdb,ibool,nspec,nglob,myrank) real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY) real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY) integer,dimension(NGNOD2D) :: iglob_corners_ref - integer :: ispec_flt,ispec,i,j,k,igll + integer :: ispec_flt,ispec,i,j,k,igll,ier integer :: iface_ref,icorner - allocate(fdb%normal(NDIM,NGLLSQUARE,fdb%nspec)) - allocate(fdb%jacobian2Dw(NGLLSQUARE,fdb%nspec)) + allocate(fdb%normal(NDIM,NGLLSQUARE,fdb%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 889') + allocate(fdb%jacobian2Dw(NGLLSQUARE,fdb%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 890') do ispec_flt=1,fdb%nspec diff --git a/src/generate_databases/get_MPI.f90 b/src/generate_databases/get_MPI.f90 index b685ddde9..2bd0033b4 100644 --- a/src/generate_databases/get_MPI.f90 +++ b/src/generate_databases/get_MPI.f90 @@ -98,18 +98,25 @@ subroutine get_MPI(myrank,nglob,nspec,ibool, & do iinterface = 1, num_interfaces_ext_mesh allocate(xp(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 891') if (ier /= 0) stop 'error allocating array xp' allocate(yp(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 892') if (ier /= 0) stop 'error allocating array yp' allocate(zp(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 893') if (ier /= 0) stop 'error allocating array zp' allocate(locval(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 894') if (ier /= 0) stop 'error allocating array locval' allocate(ifseg(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 895') if (ier /= 0) stop 'error allocating array ifseg' allocate(reorder_interface_ext_mesh(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 896') if (ier /= 0) stop 'error allocating array reorder_interface_ext_mesh' allocate(ninseg_ext_mesh(nibool_interfaces_ext_mesh(iinterface)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 897') if (ier /= 0) stop 'error allocating array ninseg_ext_mesh' ! gets x,y,z coordinates of global points on MPI interface @@ -155,6 +162,7 @@ subroutine get_MPI(myrank,nglob,nspec,ibool, & ! checks with assembly of test fields allocate(test_flag(nglob),test_flag_cr(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 898') if (ier /= 0) stop 'error allocating array test_flag etc.' test_flag(:) = 0 test_flag_cr(:) = 0._CUSTOM_REAL @@ -183,6 +191,7 @@ subroutine get_MPI(myrank,nglob,nspec,ibool, & ! sets up MPI communications max_nibool_interfaces_ext_mesh = maxval( nibool_interfaces_ext_mesh(:) ) allocate(ibool_interfaces_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 899') if (ier /= 0) stop 'error allocating array ibool_interfaces_dummy' countval = 0 diff --git a/src/generate_databases/get_absorbing_boundary.F90 b/src/generate_databases/get_absorbing_boundary.F90 index 7ec0ee740..5059c9c00 100644 --- a/src/generate_databases/get_absorbing_boundary.F90 +++ b/src/generate_databases/get_absorbing_boundary.F90 @@ -101,10 +101,14 @@ subroutine get_absorbing_boundary(myrank,nspec,ibool, & if (COUPLE_WITH_INJECTION_TECHNIQUE .or. MESH_A_CHUNK_OF_THE_EARTH) then ! allocate temporary flag array - allocate(iboun(6,nspec)) - allocate(xcoord_iboun(NGNOD2D,6,nspec)) - allocate(ycoord_iboun(NGNOD2D,6,nspec)) + allocate(iboun(6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 900') + allocate(xcoord_iboun(NGNOD2D,6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 901') + allocate(ycoord_iboun(NGNOD2D,6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 902') allocate(zcoord_iboun(NGNOD2D,6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 903') if (ier /= 0) stop 'not enough memory to allocate arrays' iboun(:,:) = .false. diff --git a/src/generate_databases/get_coupling_surfaces.f90 b/src/generate_databases/get_coupling_surfaces.f90 index 23647abcd..35fc5f190 100644 --- a/src/generate_databases/get_coupling_surfaces.f90 +++ b/src/generate_databases/get_coupling_surfaces.f90 @@ -64,10 +64,13 @@ subroutine get_coupling_surfaces(myrank,nspec,ibool,NPROC, & ! sets flags for acoustic / elastic / poroelastic on global points allocate(acoustic_flag(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 690') if (ier /= 0) stop 'error allocating array acoustic_flag' allocate(elastic_flag(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 691') if (ier /= 0) stop 'error allocating array elastic_flag' allocate(poroelastic_flag(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 692') if (ier /= 0) stop 'error allocating array poroelastic_flag' acoustic_flag(:) = 0 @@ -117,6 +120,7 @@ subroutine get_coupling_surfaces(myrank,nspec,ibool,NPROC, & ! sets up MPI communications max_nibool_interfaces_ext_mesh = maxval( nibool_interfaces_ext_mesh(:) ) allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 693') if (ier /= 0) stop 'error allocating array ibool_interfaces_ext_mesh_dummy' do i = 1, num_interfaces_ext_mesh ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,i) @@ -227,12 +231,16 @@ subroutine get_coupling_surfaces_ac_el(myrank,nspec,ibool,elastic_flag) ! allocates temporary arrays allocate(tmp_normal(NDIM,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 694') if (ier /= 0) stop 'error allocating array tmp_normal' allocate(tmp_jacobian2Dw(NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 695') if (ier /= 0) stop 'error allocating array tmp_jacobian2Dw' allocate(tmp_ijk(3,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 696') if (ier /= 0) stop 'error allocating array tmp_ijk' allocate(tmp_ispec(nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 697') if (ier /= 0) stop 'error allocating array tmp_ispec' tmp_ispec(:) = 0 tmp_ijk(:,:,:) = 0 @@ -240,6 +248,7 @@ subroutine get_coupling_surfaces_ac_el(myrank,nspec,ibool,elastic_flag) tmp_jacobian2Dw(:,:) = 0.0 allocate(mask_ibool(nglob_dummy),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 698') if (ier /= 0) stop 'error allocating array mask_ibool' mask_ibool(:) = .false. @@ -351,12 +360,16 @@ subroutine get_coupling_surfaces_ac_el(myrank,nspec,ibool,elastic_flag) ! for acoustic-elastic interface num_coupling_ac_el_faces = inum allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 699') if (ier /= 0) stop 'error allocating array coupling_ac_el_normal' allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 700') if (ier /= 0) stop 'error allocating array coupling_ac_el_jacobian2Dw' allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 701') if (ier /= 0) stop 'error allocating array coupling_ac_el_ijk' allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 702') if (ier /= 0) stop 'error allocating array coupling_ac_el_ispec' do inum = 1,num_coupling_ac_el_faces coupling_ac_el_normal(:,:,inum) = tmp_normal(:,:,inum) @@ -431,12 +444,16 @@ subroutine get_coupling_surfaces_ac_poro(myrank,nspec,ibool,acoustic_flag) ! allocates temporary arrays allocate(tmp_normal(NDIM,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 703') if (ier /= 0) stop 'error allocating array tmp_normal' allocate(tmp_jacobian2Dw(NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 704') if (ier /= 0) stop 'error allocating array tmp_jacobian2Dw' allocate(tmp_ijk(3,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 705') if (ier /= 0) stop 'error allocating array tmp_ijk' allocate(tmp_ispec(nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 706') if (ier /= 0) stop 'error allocating array tmp_ispec' tmp_ispec(:) = 0 tmp_ijk(:,:,:) = 0 @@ -517,12 +534,16 @@ subroutine get_coupling_surfaces_ac_poro(myrank,nspec,ibool,acoustic_flag) ! is pointing outward the acoustic element num_coupling_ac_po_faces = inum allocate(coupling_ac_po_normal(NDIM,NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 707') if (ier /= 0) stop 'error allocating array coupling_ac_po_normal' allocate(coupling_ac_po_jacobian2Dw(NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 708') if (ier /= 0) stop 'error allocating array coupling_ac_po_jacobian2Dw' allocate(coupling_ac_po_ijk(3,NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 709') if (ier /= 0) stop 'error allocating array coupling_ac_po_ijk' allocate(coupling_ac_po_ispec(num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 710') if (ier /= 0) stop 'error allocating array coupling_ac_po_ispec' do inum = 1,num_coupling_ac_po_faces coupling_ac_po_normal(:,:,inum) = tmp_normal(:,:,inum) @@ -595,16 +616,22 @@ subroutine get_coupling_surfaces_el_poro(myrank,nspec,ibool,elastic_flag) ! allocates temporary arrays allocate(tmp_normal(NDIM,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 711') if (ier /= 0) stop 'error allocating array tmp_normal' allocate(tmp_jacobian2Dw(NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 712') if (ier /= 0) stop 'error allocating array tmp_jacobian2Dw' allocate(tmp_ijk(3,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 713') if (ier /= 0) stop 'error allocating array tmp_ijk' allocate(tmp_ijk_el(3,NGLLSQUARE,nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 714') if (ier /= 0) stop 'error allocating array tmp_ijk_el' allocate(tmp_ispec(nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 715') if (ier /= 0) stop 'error allocating array tmp_ispec' allocate(tmp_ispec_el(nspec*6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 716') if (ier /= 0) stop 'error allocating array tmp_ispec_el' tmp_ispec(:) = 0 tmp_ispec_el(:) = 0 @@ -716,16 +743,22 @@ subroutine get_coupling_surfaces_el_poro(myrank,nspec,ibool,elastic_flag) ! is pointing outward the poroelastic element num_coupling_el_po_faces = inum allocate(coupling_el_po_normal(NDIM,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 717') if (ier /= 0) stop 'error allocating array coupling_el_po_normal' allocate(coupling_el_po_jacobian2Dw(NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 718') if (ier /= 0) stop 'error allocating array coupling_el_po_jacobian2Dw' allocate(coupling_el_po_ijk(3,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 719') if (ier /= 0) stop 'error allocating array coupling_el_po_ijk' allocate(coupling_po_el_ijk(3,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 720') if (ier /= 0) stop 'error allocating array coupling_po_el_ijk' allocate(coupling_el_po_ispec(num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 721') if (ier /= 0) stop 'error allocating array coupling_el_po_ispec' allocate(coupling_po_el_ispec(num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 722') if (ier /= 0) stop 'error allocating array coupling_po_el_ispec' do inum = 1,num_coupling_el_po_faces coupling_el_po_normal(:,:,inum) = tmp_normal(:,:,inum) diff --git a/src/generate_databases/get_perm_color.f90 b/src/generate_databases/get_perm_color.f90 index 91d7ea7b5..5e932c78c 100644 --- a/src/generate_databases/get_perm_color.f90 +++ b/src/generate_databases/get_perm_color.f90 @@ -194,6 +194,7 @@ subroutine get_color_faster(ibool, is_on_a_slice_edge, ispec_is_d, & ! allocates mask allocate(mask_ibool(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 578') if (ier /= 0) stop 'error allocating mask_ibool array' ! entry point for fail-safe mechanism when Droux 1993 fails @@ -448,6 +449,7 @@ subroutine count_mesh_valence(ibool,is_on_a_slice_edge,ispec_is_d, & ! allocates count array allocate(count_ibool(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 579') if (ier /= 0) stop 'error allocating count_ibool array' ! valence numbers of the mesh @@ -595,8 +597,10 @@ subroutine balance_colors_Droux(ibool,is_on_a_slice_edge,ispec_is_d, & icolormax = ncolors ! allocates temporary arrays - allocate(nb_elems_in_this_color(ncolors)) + allocate(nb_elems_in_this_color(ncolors),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 580') allocate(icolor_conflict_found(ncolors),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 581') if (ier /= 0) stop 'error allocating nb_elems_in_this_color arrays' nb_elems_in_this_color(:) = 0 @@ -759,8 +763,10 @@ subroutine balance_colors_simple(ibool,is_on_a_slice_edge,ispec_is_d, & ncolors = nb_colors_outer_elements + nb_colors_inner_elements ! allocates temporary arrays - allocate(nb_elems_in_this_color(ncolors)) + allocate(nb_elems_in_this_color(ncolors),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 582') allocate(icolor_conflict_found(ncolors),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 583') if (ier /= 0) stop 'error allocating nb_elems_in_this_color arrays' !! DK DK do it for outer elements diff --git a/src/generate_databases/model_coupled.f90 b/src/generate_databases/model_coupled.f90 index b9dfdeb6b..7a87dc774 100644 --- a/src/generate_databases/model_coupled.f90 +++ b/src/generate_databases/model_coupled.f90 @@ -113,7 +113,8 @@ subroutine read_model_for_coupling_or_chunk(myrank) endif read(27,*) ndeg_poly - allocate(smooth_vp(0:ndeg_poly),smooth_vs(0:ndeg_poly)) + allocate(smooth_vp(0:ndeg_poly),smooth_vs(0:ndeg_poly),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 620') do i = ndeg_poly,0,-1 read(27,*) aa,bb,cc smooth_vp(i) = aa @@ -132,10 +133,14 @@ subroutine read_model_for_coupling_or_chunk(myrank) endif read(27,*) nlayer,ncoeff - allocate(vpv_1D(nlayer,ncoeff)) - allocate(vsv_1D(nlayer,ncoeff)) - allocate(density_1D(nlayer,ncoeff)) - allocate(zlayer(nlayer)) + allocate(vpv_1D(nlayer,ncoeff),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 621') + allocate(vsv_1D(nlayer,ncoeff),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 622') + allocate(density_1D(nlayer,ncoeff),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 623') + allocate(zlayer(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 624') do i = 1,nlayer read(27,*) zlayer(i) read(27,*) vpv_1D(i,:) diff --git a/src/generate_databases/model_gll.f90 b/src/generate_databases/model_gll.f90 index a8e49a86f..eaa197fe7 100644 --- a/src/generate_databases/model_gll.f90 +++ b/src/generate_databases/model_gll.f90 @@ -65,6 +65,7 @@ subroutine model_gll(myrank,nspec,LOCAL_PATH) ! density allocate(rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 647') if (ier /= 0) stop 'error allocating array rho_read' ! user output @@ -82,6 +83,7 @@ subroutine model_gll(myrank,nspec,LOCAL_PATH) ! vp allocate(vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 648') if (ier /= 0) stop 'error allocating array vp_read' ! user output @@ -99,6 +101,7 @@ subroutine model_gll(myrank,nspec,LOCAL_PATH) ! vs allocate(vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 649') if (ier /= 0) stop 'error allocating array vs_read' ! user output diff --git a/src/generate_databases/model_gll_adios.F90 b/src/generate_databases/model_gll_adios.F90 index 2825c69a1..fa38dc179 100644 --- a/src/generate_databases/model_gll_adios.F90 +++ b/src/generate_databases/model_gll_adios.F90 @@ -65,12 +65,15 @@ subroutine model_gll_adios(myrank,nspec,LOCAL_PATH) ! density allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 617') if (ier /= 0) stop 'error allocating array rho_read' ! vp allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 618') if (ier /= 0) stop 'error allocating array vp_read' ! vs allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 619') if (ier /= 0) stop 'error allocating array vs_read' !-------------------------------------. diff --git a/src/generate_databases/model_ipati.f90 b/src/generate_databases/model_ipati.f90 index c79e5f49e..e9dd62c1a 100644 --- a/src/generate_databases/model_ipati.f90 +++ b/src/generate_databases/model_ipati.f90 @@ -66,6 +66,7 @@ subroutine model_ipati(myrank,nspec,LOCAL_PATH) ! density allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 609') if (ier /= 0) stop 'error allocating array rho_read' filename = prname_lp(1:len_trim(prname_lp))//'rho.bin' @@ -80,6 +81,7 @@ subroutine model_ipati(myrank,nspec,LOCAL_PATH) ! vp allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 610') if (ier /= 0) stop 'error allocating array vp_read' filename = prname_lp(1:len_trim(prname_lp))//'vp.bin' @@ -94,6 +96,7 @@ subroutine model_ipati(myrank,nspec,LOCAL_PATH) ! vs scaled from vp allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 611') if (ier /= 0) stop 'error allocating array vs_read' ! scaling @@ -148,6 +151,7 @@ subroutine model_ipati_water(myrank,nspec,LOCAL_PATH) ! density allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 612') if (ier /= 0) stop 'error allocating array rho_read' filename = prname_lp(1:len_trim(prname_lp))//'rho.bin' @@ -162,6 +166,7 @@ subroutine model_ipati_water(myrank,nspec,LOCAL_PATH) ! vp allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 613') if (ier /= 0) stop 'error allocating array vp_read' filename = prname_lp(1:len_trim(prname_lp))//'vp.bin' @@ -176,6 +181,7 @@ subroutine model_ipati_water(myrank,nspec,LOCAL_PATH) ! vs scaled from vp allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 614') if (ier /= 0) stop 'error allocating array vs_read' ! scaling diff --git a/src/generate_databases/model_ipati_adios.F90 b/src/generate_databases/model_ipati_adios.F90 index ab88e4390..1205e67d7 100644 --- a/src/generate_databases/model_ipati_adios.F90 +++ b/src/generate_databases/model_ipati_adios.F90 @@ -68,12 +68,15 @@ subroutine model_ipati_adios(myrank,nspec,LOCAL_PATH) ! density allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 572') if (ier /= 0) stop 'error allocating array rho_read' ! vp allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 573') if (ier /= 0) stop 'error allocating array vp_read' ! vs scaled from vp allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 574') if (ier /= 0) stop 'error allocating array vs_read' call read_model_vp_rho_adios(myrank, nspec, LOCAL_PATH, & @@ -126,12 +129,15 @@ subroutine model_ipati_water_adios(myrank,nspec,LOCAL_PATH) ! density allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 575') if (ier /= 0) stop 'error allocating array rho_read' ! vp allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 576') if (ier /= 0) stop 'error allocating array vp_read' ! vs scaled from vp allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 577') if (ier /= 0) stop 'error allocating array vs_read' call read_model_vp_rho_adios(myrank, nspec, LOCAL_PATH, & diff --git a/src/generate_databases/model_salton_trough.f90 b/src/generate_databases/model_salton_trough.f90 index a1fc2fb98..f0b9c032c 100644 --- a/src/generate_databases/model_salton_trough.f90 +++ b/src/generate_databases/model_salton_trough.f90 @@ -66,6 +66,7 @@ subroutine model_salton_trough_broadcast(myrank) allocate(vp_array(GOCAD_ST_NU,GOCAD_ST_NV,GOCAD_ST_NW),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 867') if (ier /= 0) call exit_mpi(myrank,'error allocating vp_array for salton') ! the variables read are declared and stored in structure diff --git a/src/generate_databases/model_sep.f90 b/src/generate_databases/model_sep.f90 index ce0687801..228f9214c 100644 --- a/src/generate_databases/model_sep.f90 +++ b/src/generate_databases/model_sep.f90 @@ -48,7 +48,7 @@ subroutine model_sep() real(kind=4), allocatable, dimension(:,:,:) :: vp_sep, vs_sep, rho_sep integer :: NX, NY, NZ real :: OX, OY, OZ, DX, DY, DZ - integer :: NX_alt, NY_alt, NZ_alt + integer :: NX_alt, NY_alt, NZ_alt,ier real :: OX_alt, OY_alt, OZ_alt, DX_alt, DY_alt, DZ_alt character(len=512) :: sep_header_name_vp, sep_header_name_vs, & sep_header_name_rho @@ -118,7 +118,8 @@ subroutine model_sep() ! Read VP | !---------' ! Read available SEP files, assign default values for unfound files. - allocate(vp_sep(ni, nj, NZ)) + allocate(vp_sep(ni, nj, NZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 625') call read_sep_binary_mpiio(trim(SEP_MODEL_DIRECTORY) // "/" // sep_bin_vp, & NX, NY, NZ, ni, nj, NZ, & imin, jmin, kmin, vp_sep) @@ -131,7 +132,8 @@ subroutine model_sep() ! Read VS | !---------' if (vs_exists) then - allocate(vs_sep(ni, nj, NZ)) + allocate(vs_sep(ni, nj, NZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 626') call read_sep_binary_mpiio(trim(SEP_MODEL_DIRECTORY) // "/" // sep_bin_vs, & NX, NY, NZ, ni, nj, NZ, & imin, jmin, kmin, vs_sep) @@ -143,7 +145,8 @@ subroutine model_sep() ! Read RHO | !----------' if (rho_exists) then - allocate(rho_sep(ni, nj, NZ)) + allocate(rho_sep(ni, nj, NZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 627') call read_sep_binary_mpiio(trim(SEP_MODEL_DIRECTORY) // "/" // sep_bin_rho, & NX, NY, NZ, ni, nj, NZ, & imin, jmin, kmin, rho_sep) diff --git a/src/generate_databases/model_tomography.f90 b/src/generate_databases/model_tomography.f90 index a1b8b39af..eeeea103f 100644 --- a/src/generate_databases/model_tomography.f90 +++ b/src/generate_databases/model_tomography.f90 @@ -161,6 +161,7 @@ subroutine init_tomography_files() ! data format flag allocate(materials_with_q(nmaterials),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 853') if (ier /= 0) stop 'Error allocating array materials_with_q' materials_with_q(:) = .false. @@ -280,30 +281,41 @@ subroutine init_tomography_files() ! allocates models dimensions allocate(ORIG_X(NFILES_TOMO),ORIG_Y(NFILES_TOMO),ORIG_Z(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 854') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo arrays') allocate(SPACING_X(NFILES_TOMO),SPACING_Y(NFILES_TOMO),SPACING_Z(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 855') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo arrays') ! allocate models parameter records - allocate(vp_tomography(NFILES_TOMO,nrecord_max)) - allocate(vs_tomography(NFILES_TOMO,nrecord_max)) - allocate(rho_tomography(NFILES_TOMO,nrecord_max)) + allocate(vp_tomography(NFILES_TOMO,nrecord_max),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 856') + allocate(vs_tomography(NFILES_TOMO,nrecord_max),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 857') + allocate(rho_tomography(NFILES_TOMO,nrecord_max),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 858') allocate(z_tomography(NFILES_TOMO,nrecord_max),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 859') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo arrays') ! allocate models entries allocate(NX(NFILES_TOMO),NY(NFILES_TOMO),NZ(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 860') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo arrays') allocate(nrecord(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 861') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo arrays') ! allocate models min/max statistics - allocate(VP_MIN(NFILES_TOMO),VS_MIN(NFILES_TOMO),RHO_MIN(NFILES_TOMO)) + allocate(VP_MIN(NFILES_TOMO),VS_MIN(NFILES_TOMO),RHO_MIN(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 862') allocate(VP_MAX(NFILES_TOMO),VS_MAX(NFILES_TOMO),RHO_MAX(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 863') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo arrays') ! q values allocate(tomo_has_q_values(NFILES_TOMO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 864') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo q-flag array') tomo_has_q_values(:) = .false. ! stores data format flag @@ -314,8 +326,10 @@ subroutine init_tomography_files() ! only allocate q arrays if needed if (any(tomo_has_q_values)) then - allocate(qp_tomography(NFILES_TOMO,nrecord_max)) + allocate(qp_tomography(NFILES_TOMO,nrecord_max),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 865') allocate(qs_tomography(NFILES_TOMO,nrecord_max),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 866') if (ier /= 0) call exit_MPI(myrank_tomo,'not enough memory to allocate tomo q-value arrays') endif diff --git a/src/generate_databases/pml_set_local_dampingcoeff.f90 b/src/generate_databases/pml_set_local_dampingcoeff.f90 index c2dac3629..83e2cade7 100644 --- a/src/generate_databases/pml_set_local_dampingcoeff.f90 +++ b/src/generate_databases/pml_set_local_dampingcoeff.f90 @@ -95,24 +95,33 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) ! stores damping profiles allocate(d_store_x(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 841') if (ier /= 0) stop 'error allocating array d_store_x' allocate(d_store_y(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 842') if (ier /= 0) stop 'error allocating array d_store_y' allocate(d_store_z(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 843') if (ier /= 0) stop 'error allocating array d_store_z' ! stores auxiliary coefficients allocate(K_store_x(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 844') if (ier /= 0) stop 'error allocating array K_store_x' allocate(K_store_y(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 845') if (ier /= 0) stop 'error allocating array K_store_y' allocate(K_store_z(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 846') if (ier /= 0) stop 'error allocating array K_store_z' allocate(alpha_store_x(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 847') if (ier /= 0) stop 'error allocating array alpha_store_x' allocate(alpha_store_y(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 848') if (ier /= 0) stop 'error allocating array alpha_store_y' allocate(alpha_store_z(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 849') if (ier /= 0) stop 'error allocating array alpha_store_z' K_store_x(:,:,:,:) = ZERO @@ -1819,6 +1828,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) !mask all points belong interior computational domain allocate(mask_ibool_interior_domain(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 850') if (ier /= 0) stop 'error allocating array mask_ibool_interior_domain' mask_ibool_interior_domain = .false. do ispec = 1,nspec @@ -1848,6 +1858,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) if (nglob_interface_PML_acoustic > 0) then allocate(points_interface_PML_acoustic(nglob_interface_PML_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 851') if (ier /= 0) stop 'error allocating array points_interface_PML_acoustic' points_interface_PML_acoustic = 0 nglob_interface_PML_acoustic = 0 @@ -1887,6 +1898,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) if (nglob_interface_PML_elastic > 0) then allocate(points_interface_PML_elastic(nglob_interface_PML_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 852') if (ier /= 0) stop 'error allocating array points_interface_PML_elastic' points_interface_PML_elastic = 0 nglob_interface_PML_elastic = 0 diff --git a/src/generate_databases/read_parameters.f90 b/src/generate_databases/read_parameters.f90 index d774e2e5c..dd1743b09 100644 --- a/src/generate_databases/read_parameters.f90 +++ b/src/generate_databases/read_parameters.f90 @@ -220,6 +220,7 @@ subroutine read_topography() NY_TOPO = NY_TOPO_FILE allocate(itopo_bathy(NX_TOPO,NY_TOPO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 615') if (ier /= 0) stop 'error allocating array itopo_bathy' call read_topo_bathy_file(itopo_bathy,NX_TOPO,NY_TOPO) @@ -234,6 +235,7 @@ subroutine read_topography() NX_TOPO = 1 NY_TOPO = 1 allocate(itopo_bathy(NX_TOPO,NY_TOPO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 616') if (ier /= 0) stop 'error allocating dummy array itopo_bathy' endif diff --git a/src/generate_databases/read_partition_files.f90 b/src/generate_databases/read_partition_files.f90 index 0cd9790a8..d8e733a5f 100644 --- a/src/generate_databases/read_partition_files.f90 +++ b/src/generate_databases/read_partition_files.f90 @@ -53,6 +53,7 @@ subroutine read_partition_files read(IIN) nnodes_ext_mesh allocate(nodes_coords_ext_mesh(NDIM,nnodes_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 584') if (ier /= 0) stop 'Error allocating array nodes_coords_ext_mesh' do inode = 1, nnodes_ext_mesh @@ -71,6 +72,7 @@ subroutine read_partition_files read(IIN) nmat_ext_mesh, nundefMat_ext_mesh allocate(materials_ext_mesh(16,nmat_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 585') if (ier /= 0) stop 'Error allocating array materials_ext_mesh' materials_ext_mesh(:,:) = 0.d0 @@ -95,6 +97,7 @@ subroutine read_partition_files call synchronize_all() allocate(undef_mat_prop(6,nundefMat_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 586') if (ier /= 0) stop 'Error allocating array undef_mat_prop' do imat = 1, nundefMat_ext_mesh ! format example tomography: @@ -114,8 +117,10 @@ subroutine read_partition_files ! element indexing read(IIN) nelmnts_ext_mesh allocate(elmnts_ext_mesh(NGNOD,nelmnts_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 587') if (ier /= 0) stop 'Error allocating array elmnts_ext_mesh' allocate(mat_ext_mesh(2,nelmnts_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 588') if (ier /= 0) stop 'Error allocating array mat_ext_mesh' ! reads in material association for each spectral element and corner node indices @@ -161,36 +166,42 @@ subroutine read_partition_files NSPEC2D_TOP = nspec2D_top_ext allocate(ibelm_xmin(nspec2D_xmin),nodes_ibelm_xmin(NGNOD2D,nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 589') if (ier /= 0) stop 'Error allocating array ibelm_xmin etc.' do ispec2D = 1,nspec2D_xmin read(IIN) ibelm_xmin(ispec2D),(nodes_ibelm_xmin(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_xmax(nspec2D_xmax),nodes_ibelm_xmax(NGNOD2D,nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 590') if (ier /= 0) stop 'Error allocating array ibelm_xmax etc.' do ispec2D = 1,nspec2D_xmax read(IIN) ibelm_xmax(ispec2D),(nodes_ibelm_xmax(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_ymin(nspec2D_ymin),nodes_ibelm_ymin(NGNOD2D,nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 591') if (ier /= 0) stop 'Error allocating array ibelm_ymin' do ispec2D = 1,nspec2D_ymin read(IIN) ibelm_ymin(ispec2D),(nodes_ibelm_ymin(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_ymax(nspec2D_ymax),nodes_ibelm_ymax(NGNOD2D,nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 592') if (ier /= 0) stop 'Error allocating array ibelm_ymax etc.' do ispec2D = 1,nspec2D_ymax read(IIN) ibelm_ymax(ispec2D),(nodes_ibelm_ymax(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_bottom(nspec2D_bottom_ext),nodes_ibelm_bottom(NGNOD2D,nspec2D_bottom_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 593') if (ier /= 0) stop 'Error allocating array ibelm_bottom etc.' do ispec2D = 1,nspec2D_bottom_ext read(IIN) ibelm_bottom(ispec2D),(nodes_ibelm_bottom(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_top(nspec2D_top_ext),nodes_ibelm_top(NGNOD2D,nspec2D_top_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 594') if (ier /= 0) stop 'Error allocating array ibelm_top etc.' do ispec2D = 1,nspec2D_top_ext read(IIN) ibelm_top(ispec2D),(nodes_ibelm_top(j,ispec2D),j=1,NGNOD2D) @@ -237,8 +248,10 @@ subroutine read_partition_files ! reads C-PML regions and C-PML spectral elements global indexing allocate(CPML_to_spec(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 595') if (ier /= 0) stop 'Error allocating array CPML_to_spec' allocate(CPML_regions(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 596') if (ier /= 0) stop 'Error allocating array CPML_regions' do i=1,nspec_cpml @@ -256,6 +269,7 @@ subroutine read_partition_files ! reads mask of C-PML elements for all elements in this partition allocate(is_CPML(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 597') if (ier /= 0) stop 'Error allocating array is_CPML' do i=1,NSPEC_AB @@ -274,14 +288,19 @@ subroutine read_partition_files ! allocates interfaces allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 598') if (ier /= 0) stop 'Error allocating array my_neighbors_ext_mesh' allocate(my_nelmnts_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 599') if (ier /= 0) stop 'Error allocating array my_nelmnts_neighbors_ext_mesh' allocate(my_interfaces_ext_mesh(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 600') if (ier /= 0) stop 'Error allocating array my_interfaces_ext_mesh' allocate(ibool_interfaces_ext_mesh(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 601') if (ier /= 0) stop 'Error allocating array ibool_interfaces_ext_mesh' allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 602') if (ier /= 0) stop 'Error allocating array nibool_interfaces_ext_mesh' ! loops over MPI interfaces with other partitions @@ -329,6 +348,7 @@ subroutine read_partition_files ! reads in element informations allocate(ibelm_moho(nspec2D_moho_ext),nodes_ibelm_moho(NGNOD2D,nspec2D_moho_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 603') if (ier /= 0) stop 'Error allocating array ibelm_moho etc.' do ispec2D = 1,nspec2D_moho_ext ! format: #element_id #node_id1 #node_id2 #node_id3 #node_id4 @@ -344,6 +364,7 @@ subroutine read_partition_files ! allocate dummy array nspec2D_moho_ext = 0 allocate(ibelm_moho(nspec2D_moho_ext),nodes_ibelm_moho(NGNOD2D,nspec2D_moho_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 604') if (ier /= 0) stop 'Error allocating dumy array ibelm_moho etc.' endif diff --git a/src/generate_databases/read_partition_files_adios.F90 b/src/generate_databases/read_partition_files_adios.F90 index d3665ed96..bc319865c 100644 --- a/src/generate_databases/read_partition_files_adios.F90 +++ b/src/generate_databases/read_partition_files_adios.F90 @@ -156,46 +156,68 @@ subroutine read_partition_files_adios() ! Allocate arrays with previously read values | !---------------------------------------------' allocate(nodes_coords_ext_mesh(NDIM,nnodes_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 668') if (ier /= 0) stop 'error allocating array nodes_coords_ext_mesh' allocate(materials_ext_mesh(16,nmat_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 669') if (ier /= 0) stop 'error allocating array materials_ext_mesh' allocate(undef_mat_prop(6,nundefMat_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 670') if (ier /= 0) stop 'error allocating array undef_mat_prop' allocate(elmnts_ext_mesh(NGNOD,nelmnts_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 671') if (ier /= 0) stop 'error allocating array elmnts_ext_mesh' allocate(mat_ext_mesh(2,nelmnts_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 672') if (ier /= 0) stop 'error allocating array mat_ext_mesh' - allocate(ibelm_xmin(nspec2D_xmin)) + allocate(ibelm_xmin(nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 673') allocate(nodes_ibelm_xmin(NGNOD2D,nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 674') if (ier /= 0) stop 'error allocating array ibelm_xmin etc.' - allocate(ibelm_xmax(nspec2D_xmax)) + allocate(ibelm_xmax(nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 675') allocate(nodes_ibelm_xmax(NGNOD2D,nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 676') if (ier /= 0) stop 'error allocating array ibelm_xmax etc.' - allocate(ibelm_ymin(nspec2D_ymin)) + allocate(ibelm_ymin(nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 677') allocate(nodes_ibelm_ymin(NGNOD2D,nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 678') if (ier /= 0) stop 'error allocating array ibelm_ymin' - allocate(ibelm_ymax(nspec2D_ymax)) + allocate(ibelm_ymax(nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 679') allocate(nodes_ibelm_ymax(NGNOD2D,nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 680') if (ier /= 0) stop 'error allocating array ibelm_ymax etc.' - allocate(ibelm_bottom(nspec2D_bottom_ext)) + allocate(ibelm_bottom(nspec2D_bottom_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 681') allocate(nodes_ibelm_bottom(NGNOD2D,nspec2D_bottom_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 682') if (ier /= 0) stop 'error allocating array ibelm_bottom etc.' - allocate(ibelm_top(nspec2D_top_ext)) + allocate(ibelm_top(nspec2D_top_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 683') allocate(nodes_ibelm_top(NGNOD2D,nspec2D_top_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 684') if (ier /= 0) stop 'error allocating array ibelm_top etc.' ! allocates interfaces allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 685') if (ier /= 0) stop 'error allocating array my_neighbors_ext_mesh' allocate(my_nelmnts_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 686') if (ier /= 0) stop 'error allocating array my_nelmnts_neighbors_ext_mesh' allocate(my_interfaces_ext_mesh(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 687') if (ier /= 0) stop 'error allocating array my_interfaces_ext_mesh' allocate(ibool_interfaces_ext_mesh(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 688') if (ier /= 0) stop 'error allocating array ibool_interfaces_ext_mesh' allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 689') if (ier /= 0) stop 'error allocating array nibool_interfaces_ext_mesh' !------------------------. diff --git a/src/generate_databases/save_arrays_solver.F90 b/src/generate_databases/save_arrays_solver.F90 index 2b4f2bb89..50635d2d4 100644 --- a/src/generate_databases/save_arrays_solver.F90 +++ b/src/generate_databases/save_arrays_solver.F90 @@ -259,6 +259,7 @@ subroutine save_arrays_solver_ext_mesh(nspec,nglob,APPROXIMATE_OCEAN_LOAD,ibool, max_nibool_interfaces_ext_mesh = maxval(nibool_interfaces_ext_mesh(:)) allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 650') if (ier /= 0) stop 'error allocating array' do i = 1, num_interfaces_ext_mesh ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,i) @@ -452,6 +453,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) close(IOUT) allocate(v_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 651') if (ier /= 0) call exit_MPI_without_rank('error allocating array') ! vp (for checking the mesh and model) @@ -544,6 +546,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) if (num_free_surface_faces > 0) then ! saves free surface interface points allocate( iglob_tmp(NGLLSQUARE*num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 652') if (ier /= 0) stop 'error allocating array iglob_tmp' inum = 0 iglob_tmp(:) = 0 @@ -570,6 +573,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves points on acoustic-elastic coupling interface num_points = NGLLSQUARE*num_coupling_ac_el_faces allocate( iglob_tmp(num_points),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 653') if (ier /= 0) stop 'error allocating array iglob_tmp' inum = 0 iglob_tmp(:) = 0 @@ -588,6 +592,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves acoustic/elastic flag allocate(v_tmp_i(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 654') if (ier /= 0) stop 'error allocating array v_tmp_i' do i = 1,nspec if (ispec_is_acoustic(i)) then @@ -610,6 +615,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves points on acoustic-poroelastic coupling interface num_points = NGLLSQUARE*num_coupling_ac_po_faces allocate( iglob_tmp(num_points),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 655') if (ier /= 0) stop 'error allocating array iglob_tmp' inum = 0 iglob_tmp(:) = 0 @@ -628,6 +634,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves acoustic/poroelastic flag allocate(v_tmp_i(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 656') if (ier /= 0) stop 'error allocating array v_tmp_i' do i = 1,nspec if (ispec_is_acoustic(i)) then @@ -650,6 +657,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves points on elastic-poroelastic coupling interface num_points = NGLLSQUARE*num_coupling_el_po_faces allocate( iglob_tmp(num_points),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 657') if (ier /= 0) stop 'error allocating array iglob_tmp' inum = 0 iglob_tmp(:) = 0 @@ -668,6 +676,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves elastic/poroelastic flag allocate(v_tmp_i(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 658') if (ier /= 0) stop 'error allocating array v_tmp_i' do i=1,nspec if (ispec_is_elastic(i)) then @@ -690,6 +699,7 @@ subroutine save_arrays_solver_files(nspec,nglob,ibool) ! saves MPI interface points num_points = sum(nibool_interfaces_ext_mesh(1:num_interfaces_ext_mesh)) allocate( iglob_tmp(num_points),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 659') if (ier /= 0) stop 'error allocating array iglob_tmp' inum = 0 iglob_tmp(:) = 0 diff --git a/src/generate_databases/save_arrays_solver_adios.F90 b/src/generate_databases/save_arrays_solver_adios.F90 index b87a823f7..c0cf51c23 100644 --- a/src/generate_databases/save_arrays_solver_adios.F90 +++ b/src/generate_databases/save_arrays_solver_adios.F90 @@ -136,6 +136,7 @@ subroutine save_arrays_solver_ext_mesh_adios(nspec, nglob, & max_nibool_interfaces_ext_mesh = maxval(nibool_interfaces_ext_mesh(:)) allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 837') if (ier /= 0) stop 'error allocating array' do i = 1, num_interfaces_ext_mesh ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,i) @@ -1429,10 +1430,13 @@ subroutine save_arrays_solver_files_adios(nspec,nglob,ibool, nspec_wmax, & ! Set up the model values to write | !----------------------------------' allocate( vp_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 838') if (ier /= 0) call exit_MPI_without_rank('error allocating array') allocate( vs_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 839') if (ier /= 0) call exit_MPI_without_rank('error allocating array') allocate( rho_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 840') if (ier /= 0) call exit_MPI_without_rank('error allocating array') ! vp (for checking the mesh and model) !minimum = minval( abs(rho_vp) ) diff --git a/src/generate_databases/setup_color_perm.f90 b/src/generate_databases/setup_color_perm.f90 index ea09162af..705e1af83 100644 --- a/src/generate_databases/setup_color_perm.f90 +++ b/src/generate_databases/setup_color_perm.f90 @@ -58,6 +58,7 @@ subroutine setup_color_perm(myrank,nspec,nglob,ibool,ANISOTROPY,SAVE_MESH_FILES) ! creates coloring of elements allocate(perm(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 628') if (ier /= 0) stop 'error allocating temporary perm array' perm(:) = 0 @@ -73,6 +74,7 @@ subroutine setup_color_perm(myrank,nspec,nglob,ibool,ANISOTROPY,SAVE_MESH_FILES) else ! allocates dummy arrays allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 629') if (ier /= 0) stop 'error allocating num_elem_colors_acoustic array' endif @@ -87,6 +89,7 @@ subroutine setup_color_perm(myrank,nspec,nglob,ibool,ANISOTROPY,SAVE_MESH_FILES) SAVE_MESH_FILES) else allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 630') if (ier /= 0) stop 'error allocating num_elem_colors_elastic array' endif @@ -110,8 +113,10 @@ subroutine setup_color_perm(myrank,nspec,nglob,ibool,ANISOTROPY,SAVE_MESH_FILES) ! allocates dummy arrays allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 631') if (ier /= 0) stop 'error allocating num_elem_colors_acoustic array' allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 632') if (ier /= 0) stop 'error allocating num_elem_colors_elastic array' endif ! USE_MESH_COLORING_GPU @@ -175,13 +180,16 @@ subroutine setup_color(myrank,nspec,nglob,ibool,perm,ispec_is_d,idomain, & ! allocates temporary array with colors allocate(color(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 633') if (ier /= 0) stop 'error allocating temporary color array' allocate(first_elem_number_in_this_color(MAX_NUMBER_OF_COLORS + 1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 634') if (ier /= 0) stop 'error allocating first_elem_number_in_this_color array' ! flags for elements on outer rims ! opposite to what is stored in ispec_is_inner allocate(is_on_a_slice_edge(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 635') if (ier /= 0) stop 'error allocating is_on_a_slice_edge array' do ispec = 1,nspec is_on_a_slice_edge(ispec) = .not. ispec_is_inner(ispec) @@ -201,6 +209,7 @@ subroutine setup_color(myrank,nspec,nglob,ibool,perm,ispec_is_d,idomain, & = nspec_domain + 1 allocate(num_of_elems_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 636') if (ier /= 0) stop 'error allocating num_of_elems_in_this_color array' num_of_elems_in_this_color(:) = 0 @@ -278,6 +287,7 @@ subroutine setup_color(myrank,nspec,nglob,ibool,perm,ispec_is_d,idomain, & if (nspec_inner > 0) nb_colors_inner_elements = 1 allocate(num_of_elems_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 637') if (ier /= 0) stop 'error allocating num_of_elems_in_this_color array' if (nspec_outer > 0) num_of_elems_in_this_color(1) = nspec_outer @@ -310,6 +320,7 @@ subroutine setup_color(myrank,nspec,nglob,ibool,perm,ispec_is_d,idomain, & num_colors_inner_acoustic = nb_colors_inner_elements allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 638') if (ier /= 0) stop 'error allocating num_elem_colors_acoustic array' num_elem_colors_acoustic(:) = num_of_elems_in_this_color(:) @@ -320,6 +331,7 @@ subroutine setup_color(myrank,nspec,nglob,ibool,perm,ispec_is_d,idomain, & num_colors_inner_elastic = nb_colors_inner_elements allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 639') if (ier /= 0) stop 'error allocating num_elem_colors_elastic array' num_elem_colors_elastic(:) = num_of_elems_in_this_color(:) @@ -434,6 +446,7 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ ! sorts array according to permutation allocate(temp_perm_global(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 640') if (ier /= 0) stop 'error temp_perm_global array' ! global ordering @@ -519,6 +532,7 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ ! checks if every element was uniquely set allocate(mask_global(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 641') if (ier /= 0) stop 'error allocating temporary mask_global' mask_global(:) = .false. icounter = 0 ! counts permutations @@ -565,12 +579,14 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ ! permutation of ibool allocate(temp_array_int(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 642') if (ier /= 0) stop 'error allocating temporary temp_array_int' call permute_elements_integer(ibool,temp_array_int,perm,nspec) deallocate(temp_array_int) ! element domain flags allocate(temp_array_logical_1D(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 643') if (ier /= 0) stop 'error allocating temporary temp_array_logical_1D' call permute_elements_logical1D(ispec_is_acoustic,temp_array_logical_1D,perm,nspec) call permute_elements_logical1D(ispec_is_elastic,temp_array_logical_1D,perm,nspec) @@ -580,6 +596,7 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ ! mesh arrays allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 644') if (ier /= 0) stop 'error allocating temporary temp_array_real' call permute_elements_real(xixstore,temp_array_real,perm,nspec) call permute_elements_real(xiystore,temp_array_real,perm,nspec) @@ -686,6 +703,7 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ ! moho surface if (NSPEC2D_MOHO > 0) then allocate(temp_array_logical_1D(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 645') if (ier /= 0) stop 'error allocating temporary temp_array_logical_1D' call permute_elements_logical1D(is_moho_top,temp_array_logical_1D,perm,nspec) call permute_elements_logical1D(is_moho_bot,temp_array_logical_1D,perm,nspec) @@ -706,6 +724,7 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ if (PML_CONDITIONS) then ! element flag allocate(temp_array_logical_1D(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 646') if (ier /= 0) stop 'error allocating temporary temp_array_logical_1D' call permute_elements_logical1D(is_CPML,temp_array_logical_1D,perm,nspec) deallocate(temp_array_logical_1D) diff --git a/src/generate_databases/setup_mesh.f90 b/src/generate_databases/setup_mesh.f90 index 1390ab88d..a55b103a1 100644 --- a/src/generate_databases/setup_mesh.f90 +++ b/src/generate_databases/setup_mesh.f90 @@ -40,12 +40,16 @@ subroutine setup_mesh ! use dynamic allocation to allocate memory for arrays allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 605') if (ier /= 0) stop 'error allocating array ibool' allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 606') if (ier /= 0) stop 'error allocating array xstore' allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 607') if (ier /= 0) stop 'error allocating array ystore' allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 608') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') call memory_eval_mesher(myrank,NSPEC_AB,npointot,nnodes_ext_mesh, & diff --git a/src/inverse_problem_for_model/adjoint_source/adjoint_source_mod.f90 b/src/inverse_problem_for_model/adjoint_source/adjoint_source_mod.f90 index 0121b63fd..167fb6bd8 100644 --- a/src/inverse_problem_for_model/adjoint_source/adjoint_source_mod.f90 +++ b/src/inverse_problem_for_model/adjoint_source/adjoint_source_mod.f90 @@ -157,17 +157,30 @@ end subroutine deallocate_adjoint_source_working_arrays !---------------------------------------------------------------------------------------------------------------------------------- subroutine allocate_adjoint_source_working_arrays() - allocate(residuals(nstep_data)) - allocate(raw_residuals(nstep_data)) - allocate(fil_residuals(nstep_data)) - allocate(filfil_residuals(nstep_data)) - allocate(w_tap(nstep_data)) - allocate(signal(nstep_data)) - allocate(residuals_for_cost(nstep_data)) - allocate(elastic_adjoint_source(NDIM,nstep_data)) - allocate(elastic_misfit(NDIM,nstep_data)) - allocate(data_trace_to_use(nstep_data)) - allocate(wkstmp(nstep_data)) + integer :: ier + + allocate(residuals(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 279') + allocate(raw_residuals(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 280') + allocate(fil_residuals(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 281') + allocate(filfil_residuals(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 282') + allocate(w_tap(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 283') + allocate(signal(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 284') + allocate(residuals_for_cost(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 285') + allocate(elastic_adjoint_source(NDIM,nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 286') + allocate(elastic_misfit(NDIM,nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 287') + allocate(data_trace_to_use(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 288') + allocate(wkstmp(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 289') end subroutine allocate_adjoint_source_working_arrays @@ -204,6 +217,8 @@ subroutine compute_elastic_adjoint_source_displacement(irec_local, ievent, curre double precision :: lat0, lon0, azi0 type(inver), intent(inout) :: inversion_param + integer :: ier + !!---------------------------------------------------------------------------------------------------- !! store residuals and filter --------------------------- @@ -227,16 +242,20 @@ subroutine compute_elastic_adjoint_source_displacement(irec_local, ievent, curre ! Define temporary trace vector if (.not. allocated(trace_cal_1)) then - allocate(trace_cal_1(3,nstep_data)) + allocate(trace_cal_1(3,nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 290') endif if (.not. allocated(trace_cal_2)) then - allocate(trace_cal_2(3,nstep_data)) + allocate(trace_cal_2(3,nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 291') endif if (.not. allocated(trace_obs_1)) then - allocate(trace_obs_1(3,nstep_data)) + allocate(trace_obs_1(3,nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 292') endif if (.not. allocated(trace_obs_2)) then - allocate(trace_obs_2(3,nstep_data)) + allocate(trace_obs_2(3,nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 293') endif lat0 = acqui_simu(ievent)%Origin_chunk_lat lon0 = acqui_simu(ievent)%Origin_chunk_lon @@ -255,7 +274,8 @@ subroutine compute_elastic_adjoint_source_displacement(irec_local, ievent, curre ! Convolve synthetic data with wavelet if (inversion_param%convolution_by_wavelet) then if (.not. allocated(wavelet)) then - allocate(wavelet(nstep_data)) + allocate(wavelet(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 294') endif wavelet = acqui_simu(ievent)%user_source_time_function(1,:) call myconvolution(trace_cal_2(idim,:),wavelet,nstep_data,nstep_data,tmpl,0) @@ -340,7 +360,8 @@ subroutine compute_elastic_adjoint_source_displacement(irec_local, ievent, curre ! Finally cross-correlate residuals with wavelet if (inversion_param%convolution_by_wavelet) then if (.not. allocated(filfil_residuals_tmp)) then - allocate(filfil_residuals_tmp(nstep_data)) + allocate(filfil_residuals_tmp(nstep_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 295') endif filfil_residuals_tmp(:) = filfil_residuals(:) call mycorrelation(filfil_residuals_tmp,wavelet,nstep_data,nstep_data,tmpl,0) diff --git a/src/inverse_problem_for_model/adjoint_source/instantaneous_phase_envelope_misfit_mod.f90 b/src/inverse_problem_for_model/adjoint_source/instantaneous_phase_envelope_misfit_mod.f90 index 7d4de6ee2..7523821d3 100644 --- a/src/inverse_problem_for_model/adjoint_source/instantaneous_phase_envelope_misfit_mod.f90 +++ b/src/inverse_problem_for_model/adjoint_source/instantaneous_phase_envelope_misfit_mod.f90 @@ -108,73 +108,94 @@ subroutine compute_instantaneous_phase_and_envelope_data(giter) if (nrecloc > 0) then if (.not. allocated(envelo_vx)) then - allocate(envelo_vx(nrecloc,nt)) + allocate(envelo_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 221') endif if (.not. allocated(envelo_vy)) then - allocate(envelo_vy(nrecloc,nt)) + allocate(envelo_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 222') endif if (.not. allocated(envelo_vz)) then - allocate(envelo_vz(nrecloc,nt)) + allocate(envelo_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 223') endif if (.not. allocated(envelc_vx)) then - allocate(envelc_vx(nrecloc,nt)) + allocate(envelc_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 224') endif if (.not. allocated(envelc_vy)) then - allocate(envelc_vy(nrecloc,nt)) + allocate(envelc_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 225') endif if (.not. allocated(envelc_vz)) then - allocate(envelc_vz(nrecloc,nt)) + allocate(envelc_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 226') endif if (.not. allocated(denvel_vx)) then - allocate(denvel_vx(nrecloc,nt)) + allocate(denvel_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 227') endif if (.not. allocated(denvel_vy)) then - allocate(denvel_vy(nrecloc,nt)) + allocate(denvel_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 228') endif if (.not. allocated(denvel_vz)) then - allocate(denvel_vz(nrecloc,nt)) + allocate(denvel_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 229') endif if (.not. allocated(dphase_vx)) then - allocate(dphase_vx(nrecloc,nt)) + allocate(dphase_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 230') endif if (.not. allocated(dphase_vy)) then - allocate(dphase_vy(nrecloc,nt)) + allocate(dphase_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 231') endif if (.not. allocated(dphase_vz)) then - allocate(dphase_vz(nrecloc,nt)) + allocate(dphase_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 232') endif if (.not. allocated(danalytic_vx)) then - allocate(danalytic_vx(nrecloc,nt)) + allocate(danalytic_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 233') endif if (.not. allocated(danalytic_vy)) then - allocate(danalytic_vy(nrecloc,nt)) + allocate(danalytic_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 234') endif if (.not. allocated(danalytic_vz)) then - allocate(danalytic_vz(nrecloc,nt)) + allocate(danalytic_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 235') endif if (.not. allocated(an_dobs_vx)) then - allocate(an_dobs_vx(nrecloc,nt)) + allocate(an_dobs_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 236') endif if (.not. allocated(an_dobs_vy)) then - allocate(an_dobs_vy(nrecloc,nt)) + allocate(an_dobs_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 237') endif if (.not. allocated(an_dobs_vz)) then - allocate(an_dobs_vz(nrecloc,nt)) + allocate(an_dobs_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 238') endif if (.not. allocated(an_dcal_vx)) then - allocate(an_dcal_vx(nrecloc,nt)) + allocate(an_dcal_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 239') endif if (.not. allocated(an_dcal_vy)) then - allocate(an_dcal_vy(nrecloc,nt)) + allocate(an_dcal_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 240') endif if (.not. allocated(an_dcal_vz)) then - allocate(an_dcal_vz(nrecloc,nt)) + allocate(an_dcal_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 241') endif !*** 2. Get their analytic signal @@ -238,53 +259,68 @@ subroutine compute_instanteneous_phase_adjoint_source_term if (nrecloc > 0) then if (.not. allocated(srcterm1_vx)) then - allocate(srcterm1_vx(nrecloc,nt)) + allocate(srcterm1_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 242') endif if (.not. allocated(srcterm1_vy)) then - allocate(srcterm1_vy(nrecloc,nt)) + allocate(srcterm1_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 243') endif if (.not. allocated(srcterm1_vz)) then - allocate(srcterm1_vz(nrecloc,nt)) + allocate(srcterm1_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 244') endif if (.not. allocated(srcterm2_vx)) then - allocate(srcterm2_vx(nrecloc,nt)) + allocate(srcterm2_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 245') endif if (.not. allocated(srcterm2_vy)) then - allocate(srcterm2_vy(nrecloc,nt)) + allocate(srcterm2_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 246') endif if (.not. allocated(srcterm2_vz)) then - allocate(srcterm2_vz(nrecloc,nt)) + allocate(srcterm2_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 247') endif if (.not. allocated(srcterm2tmp_vx)) then - allocate(srcterm2tmp_vx(nrecloc,nt)) + allocate(srcterm2tmp_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 248') endif if (.not. allocated(srcterm2tmp_vy)) then - allocate(srcterm2tmp_vy(nrecloc,nt)) + allocate(srcterm2tmp_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 249') endif if (.not. allocated(srcterm2tmp_vz)) then - allocate(srcterm2tmp_vz(nrecloc,nt)) + allocate(srcterm2tmp_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 250') endif if (.not. allocated(ft_tmp_vx)) then - allocate(ft_tmp_vx(nrecloc,nt)) + allocate(ft_tmp_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 251') endif if (.not. allocated(ft_tmp_vy)) then - allocate(ft_tmp_vy(nrecloc,nt)) + allocate(ft_tmp_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 252') endif if (.not. allocated(ft_tmp_vz)) then - allocate(ft_tmp_vz(nrecloc,nt)) + allocate(ft_tmp_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 253') endif if (.not. allocated(IP_adjt_vx)) then - allocate(IP_adjt_vx(nrecloc,nt)) + allocate(IP_adjt_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 254') endif if (.not. allocated(IP_adjt_vy)) then - allocate(IP_adjt_vy(nrecloc,nt)) + allocate(IP_adjt_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 255') endif if (.not. allocated(IP_adjt_vz)) then - allocate(IP_adjt_vz(nrecloc,nt)) + allocate(IP_adjt_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 256') endif !*** 1st term (easy...) remeber, imag(analytic_sig) = hilbert transform @@ -395,53 +431,68 @@ subroutine compute_envelope_adjoint_source_term if (nrecloc > 0) then if (.not. allocated(srcterm1_vx)) then - allocate(srcterm1_vx(nrecloc,nt)) + allocate(srcterm1_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 257') endif if (.not. allocated(srcterm1_vy)) then - allocate(srcterm1_vy(nrecloc,nt)) + allocate(srcterm1_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 258') endif if (.not. allocated(srcterm1_vz)) then - allocate(srcterm1_vz(nrecloc,nt)) + allocate(srcterm1_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 259') endif if (.not. allocated(srcterm2_vx)) then - allocate(srcterm2_vx(nrecloc,nt)) + allocate(srcterm2_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 260') endif if (.not. allocated(srcterm2_vy)) then - allocate(srcterm2_vy(nrecloc,nt)) + allocate(srcterm2_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 261') endif if (.not. allocated(srcterm2_vz)) then - allocate(srcterm2_vz(nrecloc,nt)) + allocate(srcterm2_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 262') endif if (.not. allocated(srcterm2tmp_vx)) then - allocate(srcterm2tmp_vx(nrecloc,nt)) + allocate(srcterm2tmp_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 263') endif if (.not. allocated(srcterm2tmp_vy)) then - allocate(srcterm2tmp_vy(nrecloc,nt)) + allocate(srcterm2tmp_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 264') endif if (.not. allocated(srcterm2tmp_vz)) then - allocate(srcterm2tmp_vz(nrecloc,nt)) + allocate(srcterm2tmp_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 265') endif if (.not. allocated(ft_tmp_vx)) then - allocate(ft_tmp_vx(nrecloc,nt)) + allocate(ft_tmp_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 266') endif if (.not. allocated(ft_tmp_vy)) then - allocate(ft_tmp_vy(nrecloc,nt)) + allocate(ft_tmp_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 267') endif if (.not. allocated(ft_tmp_vz)) then - allocate(ft_tmp_vz(nrecloc,nt)) + allocate(ft_tmp_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 268') endif if (.not. allocated(EN_adjt_vx)) then - allocate(EN_adjt_vx(nrecloc,nt)) + allocate(EN_adjt_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 269') endif if (.not. allocated(EN_adjt_vy)) then - allocate(EN_adjt_vy(nrecloc,nt)) + allocate(EN_adjt_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 270') endif if (.not. allocated(EN_adjt_vz)) then - allocate(EN_adjt_vz(nrecloc,nt)) + allocate(EN_adjt_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 271') endif !*** 1st term (easy...) remeber, imag(analytic_sig) = hilbert transform @@ -547,23 +598,29 @@ subroutine get_analytic_signal integer(kind=si) :: ff, irec, tt if (.not. allocated(ft_dobs_vx)) then - allocate(ft_dobs_vx(nrecloc,nt)) + allocate(ft_dobs_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 272') endif if (.not. allocated(ft_dobs_vy)) then - allocate(ft_dobs_vy(nrecloc,nt)) + allocate(ft_dobs_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 273') endif if (.not. allocated(ft_dobs_vz)) then - allocate(ft_dobs_vz(nrecloc,nt)) + allocate(ft_dobs_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 274') endif if (.not. allocated(ft_dcal_vx)) then - allocate(ft_dcal_vx(nrecloc,nt)) + allocate(ft_dcal_vx(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 275') endif if (.not. allocated(ft_dcal_vy)) then - allocate(ft_dcal_vy(nrecloc,nt)) + allocate(ft_dcal_vy(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 276') endif if (.not. allocated(ft_dcal_vz)) then - allocate(ft_dcal_vz(nrecloc,nt)) + allocate(ft_dcal_vz(nrecloc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 277') endif !*** 1. Compute DFT @@ -602,7 +659,8 @@ subroutine get_analytic_signal !*** 2. Remove negative frequencies if (.not. allocated(hh)) then - allocate(hh(nt)) + allocate(hh(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 278') endif hh(1) = 1. hh(floor(nt/2.)+1) = 1. diff --git a/src/inverse_problem_for_model/adjoint_source/signal_processing_mod.f90 b/src/inverse_problem_for_model/adjoint_source/signal_processing_mod.f90 index 4e33a5f47..e3f2e1cbf 100644 --- a/src/inverse_problem_for_model/adjoint_source/signal_processing_mod.f90 +++ b/src/inverse_problem_for_model/adjoint_source/signal_processing_mod.f90 @@ -264,9 +264,10 @@ subroutine FD2nd(signal, dt, nt) integer, intent(in) :: nt real(kind=CUSTOM_REAL), dimension(:), allocatable, intent(inout) :: signal real(kind=CUSTOM_REAL), dimension(:), allocatable :: wks_signal - integer :: i + integer :: i, ier - allocate(wks_signal(nt)) + allocate(wks_signal(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 296') wks_signal(1:nt)=signal(1:nt) !! laplacian 1D @@ -291,9 +292,10 @@ subroutine apodise_sig(signal, nt, lwa) real(kind=CUSTOM_REAL), dimension(:), allocatable, intent(inout) :: signal real(kind=CUSTOM_REAL), dimension(:), allocatable :: w_tap real(kind=CUSTOM_REAL) :: wh - integer :: i0, i1, i2, i3 + integer :: i0, i1, i2, i3, ier - allocate(w_tap(nt)) + allocate(w_tap(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 297') i0 = 2 i1 = (lwa/100.) * nt + i0 i3 = nt-1 diff --git a/src/inverse_problem_for_model/elastic_tensor_tools_mod.f90 b/src/inverse_problem_for_model/elastic_tensor_tools_mod.f90 index 88757c8b8..06008ea98 100644 --- a/src/inverse_problem_for_model/elastic_tensor_tools_mod.f90 +++ b/src/inverse_problem_for_model/elastic_tensor_tools_mod.f90 @@ -601,11 +601,14 @@ subroutine define_indexing_vec_to_tens() implicit none + integer :: ier + !*** Define indexing to pass from tensor to vector (see browaeys and chevrot 2004) ! IN TENSOR INDEXING if (.not. allocated(ind_vec2tens)) then - allocate(ind_vec2tens(4,21)) + allocate(ind_vec2tens(4,21),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 570') ! Group 1 ind_vec2tens(1:4,1) = (/ 1, 1, 1, 1 /) @@ -646,7 +649,8 @@ subroutine define_indexing_vec_to_tens() ! IN VOIGT INDEXING if (.not. allocated(ind_vec2tens_voigt)) then - allocate(ind_vec2tens_voigt(2,21)) + allocate(ind_vec2tens_voigt(2,21),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 571') ! Group 1 ind_vec2tens_voigt(1:2,1) = (/ 1, 1 /) diff --git a/src/inverse_problem_for_model/input_output/IO_model_mod.f90 b/src/inverse_problem_for_model/input_output/IO_model_mod.f90 index bd0cb6b86..a512243bf 100644 --- a/src/inverse_problem_for_model/input_output/IO_model_mod.f90 +++ b/src/inverse_problem_for_model/input_output/IO_model_mod.f90 @@ -125,6 +125,7 @@ subroutine ReadInputSEMmodel(inversion_param) allocate(wks_model_cij(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 298') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_cij in ReadInputSEMmodel subroutine, IO_model_mod") path_file='OUTPUT_FILES/DATABASES_MPI/proc' @@ -209,12 +210,15 @@ subroutine ReadInputSEMmodel(inversion_param) endif allocate(wks_model_rh(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 299') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_rh in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 300') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vp in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 301') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vs in ReadInputSEMmodel subroutine, IO_model_mod") if (mygroup <= 0) then !! only the fisrt group read model and need to bcast at all other @@ -299,9 +303,11 @@ subroutine ReadInputSEMpriormodel(inversion_param) else allocate(wks_model(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 302') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model in ReadInputSEMpriormodel subroutine, IO_model_mod") allocate(inversion_param%prior_model(NGLLX,NGLLY,NGLLZ,NSPEC_AB, inversion_param%NinvPar), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 303') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vp in ReadInputSEMmodel subroutine, IO_model_mod") @@ -423,12 +429,15 @@ subroutine WriteOuptutSEMmodel(inversion_param) else allocate(wks_model_rh(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 304') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_rh in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 305') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vp in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 306') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vs in ReadInputSEMmodel subroutine, IO_model_mod") wks_model_rh(:,:,:,:)=0._CUSTOM_REAL @@ -629,7 +638,8 @@ subroutine import_FD_model_ACOUSTIC(fd_grid) read(4444,'(a)') vp_file close(4444) - allocate(vp_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd)) + allocate(vp_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 307') open(4444,file=trim(rho_file),access='direct',recl=CUSTOM_REAL*nx_fd*ny_fd*nz_fd) read(4444,rec=1) rho_fd @@ -654,7 +664,8 @@ subroutine import_FD_model_ACOUSTIC(fd_grid) call bcast_all_singlecr(hz_fd) if (myrank > 0) then - allocate(vp_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd)) + allocate(vp_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 308') endif call bcast_all_cr(rho_fd,nx_fd*ny_fd*nz_fd) @@ -750,7 +761,8 @@ subroutine import_FD_model_Elastic_ISO(fd_grid) read(4444,'(a)') vs_file close(4444) - allocate(vp_fd(nx_fd,ny_fd,nz_fd), vs_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd)) + allocate(vp_fd(nx_fd,ny_fd,nz_fd), vs_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 309') open(4444,file=trim(rho_file),access='direct',recl=CUSTOM_REAL*nx_fd*ny_fd*nz_fd) read(4444,rec=1) rho_fd @@ -779,7 +791,8 @@ subroutine import_FD_model_Elastic_ISO(fd_grid) call bcast_all_singlecr(hz_fd) if (myrank > 0) then - allocate(vp_fd(nx_fd,ny_fd,nz_fd), vs_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd)) + allocate(vp_fd(nx_fd,ny_fd,nz_fd), vs_fd(nx_fd,ny_fd,nz_fd), rho_fd(nx_fd,ny_fd,nz_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 310') endif call bcast_all_cr(rho_fd,nx_fd*ny_fd*nz_fd) @@ -901,7 +914,8 @@ subroutine import_FD_model_ANISO(fd_grid, inversion_param) read(4444,'(a)') model_file close(4444) - allocate(model_fd(nx_fd,ny_fd,nz_fd, nb_model_to_read)) + allocate(model_fd(nx_fd,ny_fd,nz_fd, nb_model_to_read),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 311') open(4444,file=trim(model_file),access='direct',recl=CUSTOM_REAL*nx_fd*ny_fd*nz_fd) do i=1,nb_model_to_read @@ -926,7 +940,8 @@ subroutine import_FD_model_ANISO(fd_grid, inversion_param) call bcast_all_ch_array(type_model,1,MAX_STRING_LEN) if (myrank > 0) then - allocate(model_fd(nx_fd, ny_fd, nz_fd, nb_model_to_read)) + allocate(model_fd(nx_fd, ny_fd, nz_fd, nb_model_to_read),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 312') endif call bcast_all_cr(model_fd,nx_fd*ny_fd*nz_fd*nb_model_to_read) @@ -1104,13 +1119,16 @@ subroutine import_FD_model_ANISO(fd_grid, inversion_param) !! DEFINE TOMO GRID LOOKUP TABLES if (.not. allocated(xcrd_fd)) then - allocate(xcrd_fd(nx_fd)) + allocate(xcrd_fd(nx_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 313') endif if (.not. allocated(ycrd_fd)) then - allocate(ycrd_fd(ny_fd)) + allocate(ycrd_fd(ny_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 314') endif if (.not. allocated(zcrd_fd)) then - allocate(zcrd_fd(nz_fd)) + allocate(zcrd_fd(nz_fd),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 315') endif do i=1,nx_fd xcrd_fd(i) = ox_fd + hx_fd * real(i-1) @@ -1315,21 +1333,27 @@ subroutine write_vti_sem_model(ifrq) allocate(wks_model_rh(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 316') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_rh in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 317') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vp in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 318') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_vs in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_ep(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 319') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_ep in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_de(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 320') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_ge in ReadInputSEMmodel subroutine, IO_model_mod") allocate(wks_model_ga(NGLLX,NGLLY,NGLLZ,NSPEC_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 321') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_model_da in ReadInputSEMmodel subroutine, IO_model_mod") wks_model_rh(:,:,:,:) = rhostore(:,:,:,:) diff --git a/src/inverse_problem_for_model/input_output/Teleseismic_IO.f90 b/src/inverse_problem_for_model/input_output/Teleseismic_IO.f90 index a327b7896..0ae895db0 100644 --- a/src/inverse_problem_for_model/input_output/Teleseismic_IO.f90 +++ b/src/inverse_problem_for_model/input_output/Teleseismic_IO.f90 @@ -66,11 +66,15 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) !! 2/ allocate and store type(acqui) acqui_simu if (NEVENT > 0) then - allocate(acqui_simu(NEVENT)) - allocate(mygather(NEVENT)) + allocate(acqui_simu(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 333') + allocate(mygather(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 334') else - allocate(acqui_simu(1)) - allocate(mygather(1)) + allocate(acqui_simu(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 335') + allocate(mygather(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 336') write(*,*) 'ERROR NO EVENTS FOUND IN ACQUISITION FILE ',myrank, mygroup, trim(acqui_file) stop endif @@ -129,7 +133,8 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) if (trim(adjustl(acqui_simu(ievent)%source_wavelet_file)) /= 'undef') then acqui_simu(ievent)%external_source_wavelet=.true. ! note sure if i should use this one.. - allocate(acqui_simu(ievent)%user_source_time_function(1,nt)) + allocate(acqui_simu(ievent)%user_source_time_function(1,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 337') call read_binary_source_signature(acqui_simu(ievent)%source_wavelet_file, & nt, & acqui_simu(ievent)%user_source_time_function(1,:)) @@ -160,11 +165,15 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) acqui_simu(ievent)%zshot = mygather(ievent)%source%ele !is given wrt to earth surface ! Allocate stations array and fill arrays - allocate(acqui_simu(ievent)%station_name(nsta)) - allocate(acqui_simu(ievent)%network_name(nsta)) - allocate(acqui_simu(ievent)%position_station(3,nsta)) + allocate(acqui_simu(ievent)%station_name(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 338') + allocate(acqui_simu(ievent)%network_name(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 339') + allocate(acqui_simu(ievent)%position_station(3,nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 340') !! current geographical coord - allocate(acqui_simu(ievent)%read_station_position(3,nsta)) + allocate(acqui_simu(ievent)%read_station_position(3,nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 341') acqui_simu(ievent)%station_name(:) = mygather(ievent)%stations(:)%name acqui_simu(ievent)%network_name(:) = mygather(ievent)%stations(:)%ntwk acqui_simu(ievent)%position_station(1,:) = mygather(ievent)%stations(:)%x @@ -179,15 +188,19 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) ! Use time picks if needed if (acqui_simu(ievent)%is_time_pick) then - allocate(acqui_simu(ievent)%time_pick(nsta)) + allocate(acqui_simu(ievent)%time_pick(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 342') acqui_simu(ievent)%time_pick(:) = mygather(ievent)%stations(:)%tpick endif ! Compute baz etc. - allocate(acqui_simu(ievent)%baz(nsta)) - allocate(acqui_simu(ievent)%dist(nsta)) + allocate(acqui_simu(ievent)%baz(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 343') + allocate(acqui_simu(ievent)%dist(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 344') !! not used great circle arc not used - allocate(acqui_simu(ievent)%gcarc(nsta)) + allocate(acqui_simu(ievent)%gcarc(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 345') !! not used incidence angle ! allocate((acqui_simu(ievent)%inc(nsta)) select case(trim(adjustl(acqui_simu(ievent)%source_type_modeling))) @@ -233,7 +246,8 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) ! master broadcasts read values call mpi_bcast(nevent, 1, mpi_integer, 0, my_local_mpi_comm_world, ier) if (myrank > 0) then - allocate(acqui_simu(NEVENT)) + allocate(acqui_simu(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 346') endif do ievent = 1, NEVENT @@ -310,7 +324,8 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) call mpi_bcast(acqui_simu(ievent)%external_source_wavelet, 1, mpi_logical, 0, & my_local_mpi_comm_world, ier) if (myrank > 0) then - allocate(acqui_simu(ievent)%user_source_time_function(1,acqui_simu(ievent)%nt_data)) + allocate(acqui_simu(ievent)%user_source_time_function(1,acqui_simu(ievent)%nt_data),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 347') endif call mpi_bcast(acqui_simu(ievent)%user_source_time_function, & acqui_simu(ievent)%nt_data, & @@ -319,10 +334,14 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) ! conditional broadcast for allocatable arrays if (myrank > 0) then - allocate(acqui_simu(ievent)%station_name(acqui_simu(ievent)%nsta_tot)) - allocate(acqui_simu(ievent)%network_name(acqui_simu(ievent)%nsta_tot)) - allocate(acqui_simu(ievent)%position_station(3,acqui_simu(ievent)%nsta_tot)) - allocate(acqui_simu(ievent)%read_station_position(3,acqui_simu(ievent)%nsta_tot)) + allocate(acqui_simu(ievent)%station_name(acqui_simu(ievent)%nsta_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 348') + allocate(acqui_simu(ievent)%network_name(acqui_simu(ievent)%nsta_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 349') + allocate(acqui_simu(ievent)%position_station(3,acqui_simu(ievent)%nsta_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 350') + allocate(acqui_simu(ievent)%read_station_position(3,acqui_simu(ievent)%nsta_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 351') endif !! actually geographic coord nsta = acqui_simu(ievent)%nsta_tot @@ -339,15 +358,19 @@ subroutine read_acqui_teleseismic_file(acqui_file, acqui_simu, myrank) if (acqui_simu(ievent)%is_time_pick) then if (myrank > 0) then - allocate(acqui_simu(ievent)%time_pick(nsta)) + allocate(acqui_simu(ievent)%time_pick(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 352') endif call mpi_bcast(acqui_simu(ievent)%time_pick, nsta, custom_mpi_type, 0, & my_local_mpi_comm_world, ier) endif if (myrank > 0) then - allocate(acqui_simu(ievent)%baz(nsta)) - allocate(acqui_simu(ievent)%dist(nsta)) - allocate(acqui_simu(ievent)%gcarc(nsta)) + allocate(acqui_simu(ievent)%baz(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 353') + allocate(acqui_simu(ievent)%dist(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 354') + allocate(acqui_simu(ievent)%gcarc(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 355') endif call mpi_bcast(acqui_simu(ievent)%baz, nsta, custom_mpi_type, 0, & my_local_mpi_comm_world, ier) @@ -398,7 +421,7 @@ subroutine setup_teleseismic_stations(acqui_simu, myrank) type(acqui), allocatable, dimension(:), intent(inout) :: acqui_simu integer, intent(in) :: myrank - integer :: ievent, ireceiver, nsta_slice, irec_local, NSTA, NEVENT + integer :: ievent, ireceiver, nsta_slice, irec_local, NSTA, NEVENT, ier integer :: ispec_selected, islice_selected, idim double precision :: xi_receiver, eta_receiver, gamma_receiver double precision :: x_found, y_found, z_found @@ -441,20 +464,27 @@ subroutine setup_teleseismic_stations(acqui_simu, myrank) call flush_iunit(INVERSE_LOG_FILE) endif NSTA = acqui_simu(ievent)%nsta_tot - allocate(acqui_simu(ievent)%xi_rec(NSTA)) - allocate(acqui_simu(ievent)%eta_rec(NSTA)) - allocate(acqui_simu(ievent)%gamma_rec(NSTA)) - - allocate(acqui_simu(ievent)%islice_selected_rec(NSTA)) - allocate(acqui_simu(ievent)%ispec_selected_rec(NSTA)) - allocate(acqui_simu(ievent)%number_receiver_global(NSTA)) + allocate(acqui_simu(ievent)%xi_rec(NSTA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 356') + allocate(acqui_simu(ievent)%eta_rec(NSTA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 357') + allocate(acqui_simu(ievent)%gamma_rec(NSTA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 358') + + allocate(acqui_simu(ievent)%islice_selected_rec(NSTA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 359') + allocate(acqui_simu(ievent)%ispec_selected_rec(NSTA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 360') + allocate(acqui_simu(ievent)%number_receiver_global(NSTA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 361') acqui_simu(ievent)%number_receiver_global(:)=-1 acqui_simu(ievent)%ispec_selected_rec(:)=-1 acqui_simu(ievent)%islice_selected_rec(:)=-1 !! SB SB si je comprends bien ce sont des matrices de rotations ? - allocate(acqui_simu(ievent)%nu(NDIM,NDIM,nsta)) + allocate(acqui_simu(ievent)%nu(NDIM,NDIM,nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 362') acqui_simu(ievent)%nu(:,:,:)=0. do idim = 1, NDIM acqui_simu(ievent)%nu(idim,idim,:)=1. @@ -512,21 +542,35 @@ subroutine setup_teleseismic_stations(acqui_simu, myrank) do ievent = 1, NEVENT if (acqui_simu(ievent)%nsta_slice > 0) then - allocate(acqui_simu(ievent)%hxi(NGLLX,acqui_simu(ievent)%nsta_slice)) - allocate(acqui_simu(ievent)%heta(NGLLY,acqui_simu(ievent)%nsta_slice)) - allocate(acqui_simu(ievent)%hgamma(NGLLZ,acqui_simu(ievent)%nsta_slice)) - allocate(acqui_simu(ievent)%hpxi(NGLLX,acqui_simu(ievent)%nsta_slice)) - allocate(acqui_simu(ievent)%hpeta(NGLLY,acqui_simu(ievent)%nsta_slice)) - allocate(acqui_simu(ievent)%hpgamma(NGLLZ,acqui_simu(ievent)%nsta_slice)) - allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,acqui_simu(ievent)%nsta_slice)) + allocate(acqui_simu(ievent)%hxi(NGLLX,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 363') + allocate(acqui_simu(ievent)%heta(NGLLY,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 364') + allocate(acqui_simu(ievent)%hgamma(NGLLZ,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 365') + allocate(acqui_simu(ievent)%hpxi(NGLLX,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 366') + allocate(acqui_simu(ievent)%hpeta(NGLLY,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 367') + allocate(acqui_simu(ievent)%hpgamma(NGLLZ,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 368') + allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,acqui_simu(ievent)%nsta_slice),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 369') else - allocate(acqui_simu(ievent)%hxi(1,1)) - allocate(acqui_simu(ievent)%heta(1,1)) - allocate(acqui_simu(ievent)%hgamma(1,1)) - allocate(acqui_simu(ievent)%hpxi(1,1)) - allocate(acqui_simu(ievent)%hpeta(1,1)) - allocate(acqui_simu(ievent)%hpgamma(1,1)) - allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,1)) + allocate(acqui_simu(ievent)%hxi(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 370') + allocate(acqui_simu(ievent)%heta(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 371') + allocate(acqui_simu(ievent)%hgamma(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 372') + allocate(acqui_simu(ievent)%hpxi(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 373') + allocate(acqui_simu(ievent)%hpeta(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 374') + allocate(acqui_simu(ievent)%hpgamma(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 375') + allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 376') endif irec_local=0 diff --git a/src/inverse_problem_for_model/input_output/input_output_mod.f90 b/src/inverse_problem_for_model/input_output/input_output_mod.f90 index 9a5c0f0d8..f13ba15e3 100644 --- a/src/inverse_problem_for_model/input_output/input_output_mod.f90 +++ b/src/inverse_problem_for_model/input_output/input_output_mod.f90 @@ -304,13 +304,13 @@ subroutine read_and_distribute_events_for_simultaneous_runs(NUMBER_OF_SIMULTANEO integer, intent(in) :: NUMBER_OF_SIMULTANEOUS_RUNS integer :: number_of_events_in_acqui_file_ref integer :: nevent_per_group, nevent_remained - integer :: igroup, ievent_in_group, ievent, ievent_global + integer :: igroup, ievent_in_group, ievent, ievent_global, ier integer, dimension(:), allocatable :: nevent_in_group character(len=MAX_LEN_STRING) :: line, prefix_to_path_tmp write(6,*) - write(6,*) ' NUMBER OF SIMULTANEOUS RUN > 0 ' + write(6,*) ' NUMBER OF SIMULTANEOUS RUNS > 0 ' write(6,*) call flush_iunit(6) number_of_events_in_acqui_file_ref=0 @@ -328,7 +328,8 @@ subroutine read_and_distribute_events_for_simultaneous_runs(NUMBER_OF_SIMULTANEO nevent_per_group = number_of_events_in_acqui_file_ref / NUMBER_OF_SIMULTANEOUS_RUNS nevent_remained = mod( number_of_events_in_acqui_file_ref, NUMBER_OF_SIMULTANEOUS_RUNS) - allocate(nevent_in_group(NUMBER_OF_SIMULTANEOUS_RUNS)) + allocate(nevent_in_group(NUMBER_OF_SIMULTANEOUS_RUNS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 392') do ievent=1,NUMBER_OF_SIMULTANEOUS_RUNS if (ievent <= nevent_remained) then nevent_in_group(ievent)= nevent_per_group+1 @@ -559,7 +560,8 @@ subroutine write_bin_sismo_on_disk(ievent, acqui_simu, array_to_write, name_file if (myrank == 0) then NSTA=acqui_simu(ievent)%nsta_tot Nt=acqui_simu(ievent)%Nt_data - allocate(Gather(NSTA,Nt,NDIM)) + allocate(Gather(NSTA,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 393') endif ! not sure if need this sync call synchronize_all() @@ -573,8 +575,10 @@ subroutine write_bin_sismo_on_disk(ievent, acqui_simu, array_to_write, name_file enddo if (nsta_irank > 0) then !! data to receive - allocate(Gather_loc(nsta_irank,Nt,NDIM)) - allocate(irec_global(nsta_irank)) + allocate(Gather_loc(nsta_irank,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 394') + allocate(irec_global(nsta_irank),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 395') irec_local=0 tag = MPI_ANY_TAG call MPI_RECV(Gather_loc, Nt*nsta_irank*NDIM, CUSTOM_MPI_TYPE, irank, tag, my_local_mpi_comm_world, status, ier) @@ -592,8 +596,10 @@ subroutine write_bin_sismo_on_disk(ievent, acqui_simu, array_to_write, name_file if (myrank == irank .and. acqui_simu(ievent)%nsta_slice > 0) then NSTA_LOC=acqui_simu(ievent)%nsta_slice Nt=acqui_simu(ievent)%Nt_data - allocate(Gather_loc(NSTA_LOC,Nt,NDIM)) - allocate(irec_global(NSTA_LOC)) + allocate(Gather_loc(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 396') + allocate(irec_global(NSTA_LOC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 397') do irec_local = 1, NSTA_LOC irec_global(irec_local) = acqui_simu(ievent)%number_receiver_global(irec_local) @@ -694,7 +700,8 @@ subroutine read_data_gather(acqui_simu, myrank) NSTA=acqui_simu(ievent)%nsta_tot Nt=acqui_simu(ievent)%Nt_data - allocate(Gather(NSTA,Nt,NDIM)) + allocate(Gather(NSTA,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 398') Gather(:,:,:) = 0._CUSTOM_REAL ! read gather file open(IINN,file=trim(adjustl(acqui_simu(ievent)%data_file_gather)), access='direct', & @@ -715,13 +722,17 @@ subroutine read_data_gather(acqui_simu, myrank) !! store data gather in my slice if needed NSTA_LOC=acqui_simu(ievent)%nsta_slice - allocate(acqui_simu(ievent)%data_traces(NSTA_LOC,Nt,NDIM)) - allocate(acqui_simu(ievent)%adjoint_sources(NDIM, NSTA_LOC, Nt)) + allocate(acqui_simu(ievent)%data_traces(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 399') + allocate(acqui_simu(ievent)%adjoint_sources(NDIM, NSTA_LOC, Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 400') !! SB SB here weight_trace is allocated with nt = 1 - allocate(acqui_simu(ievent)%weight_trace(NDIM, NSTA_LOC, 1)) + allocate(acqui_simu(ievent)%weight_trace(NDIM, NSTA_LOC, 1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 401') acqui_simu(ievent)%weight_trace(:,:,:)=1._CUSTOM_REAL if (VERBOSE_MODE .or. DEBUG_MODE) then - allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt)) + allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 402') endif irec_local=0 @@ -747,7 +758,8 @@ subroutine read_data_gather(acqui_simu, myrank) ! if there is receiver in slice irank then MPI send data if (nsta_irank > 0) then !! data to send - allocate(Gather_loc(nsta_irank,Nt,NDIM)) + allocate(Gather_loc(nsta_irank,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 403') irec_local=0 do irec = 1, NSTA if (acqui_simu(ievent)%islice_selected_rec(irec) == irank) then @@ -768,12 +780,17 @@ subroutine read_data_gather(acqui_simu, myrank) if (myrank == irank .and. acqui_simu(ievent)%nsta_slice > 0) then NSTA_LOC=acqui_simu(ievent)%nsta_slice Nt=acqui_simu(ievent)%Nt_data - allocate(Gather_loc(NSTA_LOC,Nt,NDIM)) - allocate(acqui_simu(ievent)%data_traces(NSTA_LOC,Nt,NDIM)) - allocate(acqui_simu(ievent)%adjoint_sources(NDIM, NSTA_LOC, Nt)) - allocate(acqui_simu(ievent)%weight_trace(NDIM, NSTA_LOC,1)) + allocate(Gather_loc(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 404') + allocate(acqui_simu(ievent)%data_traces(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 405') + allocate(acqui_simu(ievent)%adjoint_sources(NDIM, NSTA_LOC, Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 406') + allocate(acqui_simu(ievent)%weight_trace(NDIM, NSTA_LOC,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 407') if (VERBOSE_MODE .or. DEBUG_MODE) then - allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt)) + allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 408') endif if (DEBUG_MODE) write(IIDD,*) 'myrank ',myrank,' wait for 0 :', NSTA_LOC,Nt @@ -803,8 +820,10 @@ subroutine read_data_gather(acqui_simu, myrank) if ( use_band_pass_filter) then acqui_simu(ievent)%Nfrq=NIFRQ acqui_simu(ievent)%band_pass_filter=use_band_pass_filter - allocate(acqui_simu(ievent)%fl_event(acqui_simu(ievent)%Nfrq)) - allocate(acqui_simu(ievent)%fh_event(acqui_simu(ievent)%Nfrq)) + allocate(acqui_simu(ievent)%fl_event(acqui_simu(ievent)%Nfrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 409') + allocate(acqui_simu(ievent)%fh_event(acqui_simu(ievent)%Nfrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 410') acqui_simu(ievent)%fl_event(:)=fl(:) acqui_simu(ievent)%fh_event(:)=fh(:) !! WARNING WARNING @@ -866,7 +885,8 @@ subroutine read_pif_data_gather(acqui_simu, inversion_param, myrank) NSTA=acqui_simu(ievent)%nsta_tot Nt=acqui_simu(ievent)%Nt_data - allocate(Gather(NSTA,Nt,NDIM)) + allocate(Gather(NSTA,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 411') Gather(:,:,:) = 0._CUSTOM_REAL !! Read pif gather file component by conponent @@ -892,15 +912,19 @@ subroutine read_pif_data_gather(acqui_simu, inversion_param, myrank) !! store data gather in my slice if needed NSTA_LOC=acqui_simu(ievent)%nsta_slice - allocate(acqui_simu(ievent)%data_traces(ndim,nsta_loc,nt)) - allocate(acqui_simu(ievent)%adjoint_sources(ndim,nsta_loc,nt)) - allocate(acqui_simu(ievent)%weight_trace(ndim,nsta_loc,nt)) + allocate(acqui_simu(ievent)%data_traces(ndim,nsta_loc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 412') + allocate(acqui_simu(ievent)%adjoint_sources(ndim,nsta_loc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 413') + allocate(acqui_simu(ievent)%weight_trace(ndim,nsta_loc,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 414') acqui_simu(ievent)%weight_trace(:,:,:) = 1._CUSTOM_REAL !! manage data taper here ! first windowing if (acqui_simu(ievent)%is_time_pick) then - allocate(weight_loc(nt)) + allocate(weight_loc(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 415') do irec = 1, nsta weight_loc(:) = 1._CUSTOM_REAL it1 = int(floor(acqui_simu(ievent)%time_pick(irec) / acqui_simu(ievent)%dt_data )) @@ -994,7 +1018,8 @@ subroutine read_pif_data_gather(acqui_simu, inversion_param, myrank) end select if (VERBOSE_MODE .or. DEBUG_MODE) then - allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt)) + allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 416') endif irec_local=0 do irec = 1, NSTA @@ -1019,7 +1044,8 @@ subroutine read_pif_data_gather(acqui_simu, inversion_param, myrank) ! if there is receiver in slice irank then MPI send data if (nsta_irank > 0) then !! data to send - allocate(Gather_loc(nsta_irank,Nt,NDIM)) + allocate(Gather_loc(nsta_irank,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 417') irec_local=0 do irec = 1, NSTA if (acqui_simu(ievent)%islice_selected_rec(irec) == irank) then @@ -1040,12 +1066,17 @@ subroutine read_pif_data_gather(acqui_simu, inversion_param, myrank) if (myrank == irank .and. acqui_simu(ievent)%nsta_slice > 0) then NSTA_LOC=acqui_simu(ievent)%nsta_slice Nt=acqui_simu(ievent)%Nt_data - allocate(Gather_loc(NSTA_LOC,Nt,NDIM)) - allocate(acqui_simu(ievent)%data_traces(NSTA_LOC,Nt,NDIM)) - allocate(acqui_simu(ievent)%adjoint_sources(NDIM,NSTA_LOC,Nt)) - allocate( acqui_simu(ievent)%weight_trace(NDIM,NSTA_LOC,nt)) + allocate(Gather_loc(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 418') + allocate(acqui_simu(ievent)%data_traces(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 419') + allocate(acqui_simu(ievent)%adjoint_sources(NDIM,NSTA_LOC,Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 420') + allocate( acqui_simu(ievent)%weight_trace(NDIM,NSTA_LOC,nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 421') if (VERBOSE_MODE .or. DEBUG_MODE) then - allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt)) + allocate(acqui_simu(ievent)%synt_traces(NDIM, NSTA_LOC, Nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 422') endif if (DEBUG_MODE) write(IIDD,*) 'myrank ',myrank,' wait for 0 :', NSTA_LOC,Nt @@ -1075,8 +1106,10 @@ subroutine read_pif_data_gather(acqui_simu, inversion_param, myrank) if ( use_band_pass_filter) then acqui_simu(ievent)%Nfrq=NIFRQ acqui_simu(ievent)%band_pass_filter=use_band_pass_filter - allocate(acqui_simu(ievent)%fl_event(acqui_simu(ievent)%Nfrq)) - allocate(acqui_simu(ievent)%fh_event(acqui_simu(ievent)%Nfrq)) + allocate(acqui_simu(ievent)%fl_event(acqui_simu(ievent)%Nfrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 423') + allocate(acqui_simu(ievent)%fh_event(acqui_simu(ievent)%Nfrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 424') acqui_simu(ievent)%fl_event(:)=fl(:) acqui_simu(ievent)%fh_event(:)=fh(:) !! WARNING WARNING @@ -1127,7 +1160,8 @@ subroutine write_pif_data_gather(ievent, acqui_simu, inversion_param, array_to_w if (myrank == 0) then NSTA=acqui_simu(ievent)%nsta_tot Nt=acqui_simu(ievent)%Nt_data - allocate(Gather(NSTA,Nt,NDIM)) + allocate(Gather(NSTA,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 425') endif ! not sure if need this sync call synchronize_all() @@ -1141,8 +1175,10 @@ subroutine write_pif_data_gather(ievent, acqui_simu, inversion_param, array_to_w enddo if (nsta_irank > 0) then !! data to receive - allocate(Gather_loc(nsta_irank,Nt,NDIM)) - allocate(irec_global(nsta_irank)) + allocate(Gather_loc(nsta_irank,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 426') + allocate(irec_global(nsta_irank),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 427') irec_local=0 tag = MPI_ANY_TAG call MPI_RECV(Gather_loc, Nt*nsta_irank*NDIM, CUSTOM_MPI_TYPE, irank, tag, my_local_mpi_comm_world, status, ier) @@ -1160,8 +1196,10 @@ subroutine write_pif_data_gather(ievent, acqui_simu, inversion_param, array_to_w if (myrank == irank .and. acqui_simu(ievent)%nsta_slice > 0) then NSTA_LOC=acqui_simu(ievent)%nsta_slice Nt=acqui_simu(ievent)%Nt_data - allocate(Gather_loc(NSTA_LOC,Nt,NDIM)) - allocate(irec_global(NSTA_LOC)) + allocate(Gather_loc(NSTA_LOC,Nt,NDIM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 428') + allocate(irec_global(NSTA_LOC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 429') do irec_local = 1, NSTA_LOC irec_global(irec_local) = acqui_simu(ievent)%number_receiver_global(irec_local) @@ -1331,9 +1369,11 @@ subroutine read_acqui_file(acqui_file, acqui_simu, myrank) !! 2/ allocate and store type(acqui) acqui_simu if (NEVENT > 0) then - allocate(acqui_simu(NEVENT)) + allocate(acqui_simu(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 430') else - allocate(acqui_simu(1)) + allocate(acqui_simu(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 431') write(*,*) 'ERROR NO EVENTS FOUND IN ACQUISITION FILE ',myrank, mygroup, trim(acqui_file) stop endif @@ -1437,7 +1477,8 @@ subroutine read_acqui_file(acqui_file, acqui_simu, myrank) ! master broadcasts read values call MPI_BCAST(NEVENT,1,MPI_INTEGER,0,my_local_mpi_comm_world,ier) if (myrank > 0) then - allocate(acqui_simu(NEVENT)) + allocate(acqui_simu(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 432') endif do ievent = 1, NEVENT acqui_simu(ievent)%nevent_tot = NEVENT @@ -1519,8 +1560,10 @@ subroutine read_inver_file(inver_file, acqui_simu, inversion_param, myrank) case('use_frequency_band_pass_filter') inversion_param%use_band_pass_filter=.true. read(line(ipos0:ipos1),*) inversion_param%Nifrq - allocate(fl(inversion_param%Nifrq)) - allocate(fh(inversion_param%Nifrq)) + allocate(fl(inversion_param%Nifrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 433') + allocate(fh(inversion_param%Nifrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 434') case('fl') read(line(ipos0:ipos1),*) fl(:) @@ -1583,14 +1626,16 @@ subroutine read_inver_file(inver_file, acqui_simu, inversion_param, myrank) inversion_param%use_regularization_FD_Tikonov=.true. case('use_tk_sem_regularization') - allocate(inversion_param%smooth_weight(inversion_param%NinvPar)) + allocate(inversion_param%smooth_weight(inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 435') read(line(ipos0:ipos1),*) inversion_param%smooth_weight(1), & inversion_param%smooth_weight(2), & inversion_param%smooth_weight(3) inversion_param%use_regularization_SEM_Tikonov=.true. case('use_tk_sem_damping') - allocate(inversion_param%damp_weight(inversion_param%NinvPar)) + allocate(inversion_param%damp_weight(inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 436') read(line(ipos0:ipos1),*) inversion_param%damp_weight(1:inversion_param%NinvPar) inversion_param%use_damping_SEM_Tikonov=.true. !! we have read standard deviation for model @@ -1651,7 +1696,8 @@ subroutine read_inver_file(inver_file, acqui_simu, inversion_param, myrank) if (inversion_param%use_band_pass_filter) then call MPI_BCAST(inversion_param%Nifrq, 1,MPI_INTEGER,0,my_local_mpi_comm_world,ier) if (myrank > 0) then - allocate(fl(inversion_param%Nifrq), fh(inversion_param%Nifrq)) + allocate(fl(inversion_param%Nifrq), fh(inversion_param%Nifrq),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 437') endif call MPI_BCAST(fl,inversion_param%Nifrq,CUSTOM_MPI_TYPE,0,my_local_mpi_comm_world,ier) call MPI_BCAST(fh,inversion_param%Nifrq,CUSTOM_MPI_TYPE,0,my_local_mpi_comm_world,ier) @@ -1683,12 +1729,14 @@ subroutine read_inver_file(inver_file, acqui_simu, inversion_param, myrank) call MPI_BCAST(inversion_param%distance_from_source,1,CUSTOM_MPI_TYPE,0,my_local_mpi_comm_world,ier) call MPI_BCAST(inversion_param%NinvPar,1,MPI_INTEGER,0,my_local_mpi_comm_world,ier) if (myrank > 0 .and. inversion_param%use_regularization_SEM_Tikonov ) then - allocate(inversion_param%smooth_weight(inversion_param%NinvPar)) + allocate(inversion_param%smooth_weight(inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 438') endif if (inversion_param%use_regularization_SEM_Tikonov) & call MPI_BCAST(inversion_param%smooth_weight(1),inversion_param%NinvPar,CUSTOM_MPI_TYPE,0,my_local_mpi_comm_world,ier) if (myrank > 0 .and. inversion_param%use_damping_SEM_Tikonov ) then - allocate(inversion_param%damp_weight(inversion_param%NinvPar)) + allocate(inversion_param%damp_weight(inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 439') endif if (inversion_param%use_damping_SEM_Tikonov) & call MPI_BCAST(inversion_param%damp_weight(1),inversion_param%NinvPar,CUSTOM_MPI_TYPE,0,my_local_mpi_comm_world,ier) @@ -1770,7 +1818,7 @@ subroutine get_stations(acqui_simu) type(acqui), allocatable, dimension(:), intent(inout) :: acqui_simu - integer :: ievent, irec, nsta, nrec_loc + integer :: ievent, irec, nsta, nrec_loc, ier character(len=MAX_LEN_STRING) :: rec_filename,filtered_rec_filename if (myrank == 0) then write(INVERSE_LOG_FILE,*) @@ -1792,15 +1840,24 @@ subroutine get_stations(acqui_simu) call station_filter(rec_filename,filtered_rec_filename,nsta) acqui_simu(ievent)%nsta_tot=nsta - allocate(acqui_simu(ievent)%station_name(nsta),acqui_simu(ievent)%network_name(nsta)) - allocate(acqui_simu(ievent)%position_station(3,nsta)) - allocate(acqui_simu(ievent)%xi_rec(nsta)) - allocate(acqui_simu(ievent)%eta_rec(nsta)) - allocate(acqui_simu(ievent)%gamma_rec(nsta)) - allocate(acqui_simu(ievent)%islice_selected_rec(nsta)) - allocate(acqui_simu(ievent)%ispec_selected_rec(nsta)) - allocate(acqui_simu(ievent)%number_receiver_global(nsta)) - allocate(acqui_simu(ievent)%nu(NDIM,NDIM,nsta)) + allocate(acqui_simu(ievent)%station_name(nsta),acqui_simu(ievent)%network_name(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 440') + allocate(acqui_simu(ievent)%position_station(3,nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 441') + allocate(acqui_simu(ievent)%xi_rec(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 442') + allocate(acqui_simu(ievent)%eta_rec(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 443') + allocate(acqui_simu(ievent)%gamma_rec(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 444') + allocate(acqui_simu(ievent)%islice_selected_rec(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 445') + allocate(acqui_simu(ievent)%ispec_selected_rec(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 446') + allocate(acqui_simu(ievent)%number_receiver_global(nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 447') + allocate(acqui_simu(ievent)%nu(NDIM,NDIM,nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 448') ! reads STATIONS_FILTERED file, locates receivers in the mesh and compute Lagrange interpolators call locate_receivers(filtered_rec_filename,nsta,acqui_simu(ievent)%islice_selected_rec, & @@ -1817,21 +1874,35 @@ subroutine get_stations(acqui_simu) acqui_simu(ievent)%nsta_slice=nrec_loc if (acqui_simu(ievent)%nsta_slice > 0) then - allocate(acqui_simu(ievent)%hxi (NGLLX,nrec_loc)) - allocate(acqui_simu(ievent)%heta (NGLLY,nrec_loc)) - allocate(acqui_simu(ievent)%hgamma (NGLLZ,nrec_loc)) - allocate(acqui_simu(ievent)%hpxi (NGLLX,nrec_loc)) - allocate(acqui_simu(ievent)%hpeta (NGLLY,nrec_loc)) - allocate(acqui_simu(ievent)%hpgamma(NGLLZ,nrec_loc)) - allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,nrec_loc)) + allocate(acqui_simu(ievent)%hxi (NGLLX,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 449') + allocate(acqui_simu(ievent)%heta (NGLLY,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 450') + allocate(acqui_simu(ievent)%hgamma (NGLLZ,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 451') + allocate(acqui_simu(ievent)%hpxi (NGLLX,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 452') + allocate(acqui_simu(ievent)%hpeta (NGLLY,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 453') + allocate(acqui_simu(ievent)%hpgamma(NGLLZ,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 454') + allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,nrec_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 455') else - allocate(acqui_simu(ievent)%hxi (1,1)) - allocate(acqui_simu(ievent)%heta (1,1)) - allocate(acqui_simu(ievent)%hgamma (1,1)) - allocate(acqui_simu(ievent)%hpxi (1,1)) - allocate(acqui_simu(ievent)%hpeta (1,1)) - allocate(acqui_simu(ievent)%hpgamma(1,1)) - allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,1)) + allocate(acqui_simu(ievent)%hxi (1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 456') + allocate(acqui_simu(ievent)%heta (1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 457') + allocate(acqui_simu(ievent)%hgamma (1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 458') + allocate(acqui_simu(ievent)%hpxi (1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 459') + allocate(acqui_simu(ievent)%hpeta (1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 460') + allocate(acqui_simu(ievent)%hpgamma(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 461') + allocate(acqui_simu(ievent)%freqcy_to_invert(NDIM,2,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 462') endif nrec_loc = 0 @@ -1937,35 +2008,59 @@ subroutine get_point_source(acqui_simu) ! 2/ Allocate the acqui_simu structure acqui_simu(ievent)%nsources_tot=NSOURCES - allocate(acqui_simu(ievent)%islice_selected_source(NSOURCES)) - allocate(acqui_simu(ievent)%ispec_selected_source(NSOURCES)) - allocate(acqui_simu(ievent)%tshift(NSOURCES)) - allocate(acqui_simu(ievent)%hdur(NSOURCES)) - allocate(acqui_simu(ievent)%hdur_Gaussian(NSOURCES)) - allocate(acqui_simu(ievent)%sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ)) - allocate(acqui_simu(ievent)%Xs(NSOURCES)) - allocate(acqui_simu(ievent)%Ys(NSOURCES)) + allocate(acqui_simu(ievent)%islice_selected_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 463') + allocate(acqui_simu(ievent)%ispec_selected_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 464') + allocate(acqui_simu(ievent)%tshift(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 465') + allocate(acqui_simu(ievent)%hdur(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 466') + allocate(acqui_simu(ievent)%hdur_Gaussian(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 467') + allocate(acqui_simu(ievent)%sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 468') + allocate(acqui_simu(ievent)%Xs(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 469') + allocate(acqui_simu(ievent)%Ys(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 470') allocate(acqui_simu(ievent)%Zs(NSOURCES), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 471') if (ier /= 0) stop 'error allocating arrays for sources' - allocate(Mxx(NSOURCES)) - allocate(Myy(NSOURCES)) - allocate(Mzz(NSOURCES)) - allocate(Mxy(NSOURCES)) - allocate(Mxz(NSOURCES)) - allocate(Myz(NSOURCES)) - allocate(x_target_source(NSOURCES)) - allocate(y_target_source(NSOURCES)) - allocate(z_target_source(NSOURCES)) - allocate(xi_source(NSOURCES)) - allocate(eta_source(NSOURCES)) - allocate(gamma_source(NSOURCES)) + allocate(Mxx(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 472') + allocate(Myy(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 473') + allocate(Mzz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 474') + allocate(Mxy(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 475') + allocate(Mxz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 476') + allocate(Myz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 477') + allocate(x_target_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 478') + allocate(y_target_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 479') + allocate(z_target_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 480') + allocate(xi_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 481') + allocate(eta_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 482') + allocate(gamma_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 483') allocate(nu_source(NDIM,NDIM,NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 484') if (ier /= 0) stop 'error allocating utm source arrays' if (USE_FORCE_POINT_SOURCE) then allocate(factor_force_source(NSOURCES),Fx(NSOURCES),Fy(NSOURCES),Fz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 485') else allocate(factor_force_source(1),Fx(1),Fy(1),Fz(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 486') endif if (ier /= 0) stop 'error allocating arrays for force point sources' @@ -1980,6 +2075,7 @@ subroutine get_point_source(acqui_simu) !! allocate the array contains the user defined source time function allocate(acqui_simu(ievent)%user_source_time_function(NSTEP_STF, NSOURCES_STF),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 487') if (ier /= 0) stop 'error allocating arrays for user sources time function' @@ -1989,7 +2085,8 @@ subroutine get_point_source(acqui_simu) case('moment','force') - allocate(lat(NSOURCES),long(NSOURCES),depth(NSOURCES),moment_tensor(6,NSOURCES)) + allocate(lat(NSOURCES),long(NSOURCES),depth(NSOURCES),moment_tensor(6,NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 488') ! read all the sources if (USE_FORCE_POINT_SOURCE) then ! point forces diff --git a/src/inverse_problem_for_model/input_output/interpolation_mod.f90 b/src/inverse_problem_for_model/input_output/interpolation_mod.f90 index 890cfdc20..372ae0f71 100644 --- a/src/inverse_problem_for_model/input_output/interpolation_mod.f90 +++ b/src/inverse_problem_for_model/input_output/interpolation_mod.f90 @@ -242,25 +242,32 @@ subroutine time_deconv(dobs,dcal,dt,nt,nit,src_sum) real(kind=cp), dimension(:), allocatable :: dobs2, autocorr, crosscorr, new_obs, src_one + integer :: ier !* 0. Allocate if (.not. allocated(autocorr)) then - allocate(autocorr(nt)) + allocate(autocorr(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 377') endif if (.not. allocated(crosscorr)) then - allocate(crosscorr(nt)) + allocate(crosscorr(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 378') endif if (.not. allocated(src_sum)) then - allocate(src_sum(nt)) + allocate(src_sum(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 379') endif if (.not. allocated(src_one)) then - allocate(src_one(nt)) + allocate(src_one(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 380') endif if (.not. allocated(dobs2)) then - allocate(dobs2(nt)) + allocate(dobs2(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 381') endif if (.not. allocated(new_obs)) then - allocate(new_obs(nt)) + allocate(new_obs(nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 382') endif src_sum = 0._cp @@ -307,13 +314,14 @@ subroutine myconvolution(sig1,sig2,n1,n2,conv,part) real(kind=cp), dimension(n1), intent(in) :: sig1 real(kind=cp), dimension(n2), intent(in) :: sig2 -! real(kind=cp), dimension(n1), intent(out) ::conv - real(kind=cp), dimension(:), allocatable, intent(inout) ::conv + real(kind=cp), dimension(:), allocatable, intent(inout) ::conv - real(kind=cp), dimension(n1+n2-1) :: convtmp !, intent(out) :: conv + real(kind=cp), dimension(n1+n2-1) :: convtmp integer(kind=si) :: i1, i2, ind + integer :: ier + !*** Put to zero convtmp = zero @@ -332,20 +340,23 @@ subroutine myconvolution(sig1,sig2,n1,n2,conv,part) ind = ceiling(real(n2/2,kind=cp)) endif if (.not. allocated(conv)) then - allocate(conv(n2)) + allocate(conv(n2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 383') endif conv(1:n2) = convtmp(ind:ind+n2-1) else if (part == 1) then ! full convolution if (.not. allocated(conv)) then - allocate(conv(n1+n2-1)) + allocate(conv(n1+n2-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 384') endif conv(:) = convtmp(:) else if (part == 2) then !(middle irregular) if (.not. allocated(conv)) then - allocate(conv(n2)) + allocate(conv(n2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 385') endif conv(1:n2) = convtmp(n2:n2+n2-1) endif @@ -362,20 +373,23 @@ subroutine mycorrelation(sig1,sig2,n1,n2,corr,part) real(kind=cp), dimension(n1), intent(in) :: sig1 real(kind=cp), dimension(n2), intent(in) :: sig2 -! real(kind=cp), dimension(n1), intent(out) :: corr real(kind=cp), dimension(:), allocatable, intent(inout) :: corr real(kind=cp), dimension(n2) :: flipsig2 integer(kind=si) :: i + integer :: ier + !*** Choose size of corr if (part == 0) then ! (middle) if (.not. allocated(corr)) then - allocate(corr(n2)) + allocate(corr(n2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 386') endif else if (part == 1) then ! (full) if (.not. allocated(corr)) then - allocate(corr(n1+n2-1)) + allocate(corr(n1+n2-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 387') endif endif @@ -408,9 +422,12 @@ subroutine determine_lag(sig1,sig2,n1,n2,lag) integer(kind=si) :: it, ind real(kind=cp) :: maxcorr - !*** Take good parts define middle + integer :: ier + + !*** Take good parts, define middle if (.not. allocated(corr)) then - allocate(corr(n1)) + allocate(corr(n1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 388') endif if (modulo(n2,2) == 0) then @@ -714,14 +731,19 @@ subroutine taper_3D(ndom,taper,isr,sizetapx,sizetapy,sizetapz) real(kind=cp) :: alpha real(kind=cp),intent(in) :: sizetapx, sizetapy, sizetapz + integer :: ier + if (.not. allocated(tapx)) then - allocate(tapx(ndom(1))) + allocate(tapx(ndom(1)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 389') endif if (.not. allocated(tapy)) then - allocate(tapy(ndom(2))) + allocate(tapy(ndom(2)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 390') endif if (.not. allocated(tapz)) then - allocate(tapz(ndom(3))) + allocate(tapz(ndom(3)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 391') endif alpha = sizetapx*2./ndom(1) diff --git a/src/inverse_problem_for_model/input_output/mesh_tools_mod.f90 b/src/inverse_problem_for_model/input_output/mesh_tools_mod.f90 index ee4c5fc56..0c1922683 100644 --- a/src/inverse_problem_for_model/input_output/mesh_tools_mod.f90 +++ b/src/inverse_problem_for_model/input_output/mesh_tools_mod.f90 @@ -124,7 +124,7 @@ subroutine get_MPI_slice_and_bcast_to_all(x_to_locate, y_to_locate, z_to_locate, double precision, dimension(:,:), allocatable :: xi_all, eta_all, gamma_all double precision, dimension(:,:), allocatable :: x_found_all, y_found_all, z_found_all integer, dimension(:,:), allocatable :: ispec_selected_all - integer :: iproc + integer :: iproc, ier !! to avoid compler error when calling gather_all* double precision, dimension(1) :: distance_from_target_dummy @@ -132,15 +132,23 @@ subroutine get_MPI_slice_and_bcast_to_all(x_to_locate, y_to_locate, z_to_locate, double precision, dimension(1) :: x_found_dummy, y_found_dummy, z_found_dummy integer, dimension(1) :: ispec_selected_dummy, islice_selected_dummy - allocate(distance_from_target_all(1,0:NPROC-1)) - allocate(xi_all(1,0:NPROC-1)) - allocate(eta_all(1,0:NPROC-1)) - allocate(gamma_all(1,0:NPROC-1)) - allocate(x_found_all(1,0:NPROC-1)) - allocate(y_found_all(1,0:NPROC-1)) - allocate(z_found_all(1,0:NPROC-1)) - - allocate(ispec_selected_all(1,0:NPROC-1)) + allocate(distance_from_target_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 322') + allocate(xi_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 323') + allocate(eta_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 324') + allocate(gamma_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 325') + allocate(x_found_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 326') + allocate(y_found_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 327') + allocate(z_found_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 328') + + allocate(ispec_selected_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 329') distance_from_target = sqrt( (x_to_locate - x_found)**2 + (y_to_locate - y_found)**2 + (z_to_locate - z_found)**2) @@ -510,6 +518,7 @@ subroutine create_mass_matrices_Stacey_duplication_routine() ! allocates memory if (.not. allocated(rmass_acoustic)) then allocate(rmass_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 330') if (ier /= 0) stop 'error allocating array rmass_acoustic' endif rmass_acoustic(:) = 0._CUSTOM_REAL @@ -544,7 +553,8 @@ subroutine create_mass_matrices_Stacey_duplication_routine() if (ELASTIC_SIMULATION) then ! returns elastic mass matrix if (.not. allocated(rmass)) then - allocate(rmass(NGLOB_AB)) + allocate(rmass(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 331') endif rmass(:) = 0._CUSTOM_REAL if (PML_CONDITIONS) then @@ -587,6 +597,7 @@ subroutine create_mass_matrices_Stacey_duplication_routine() if (ACOUSTIC_SIMULATION) then if (.not. allocated(rmassz_acoustic)) then allocate(rmassz_acoustic(nglob_ab), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 332') endif rmassz_acoustic(:) = 0._CUSTOM_REAL endif diff --git a/src/inverse_problem_for_model/input_output/passive_imaging_format_mod.f90 b/src/inverse_problem_for_model/input_output/passive_imaging_format_mod.f90 index 924ffd6fe..1f7c09c52 100644 --- a/src/inverse_problem_for_model/input_output/passive_imaging_format_mod.f90 +++ b/src/inverse_problem_for_model/input_output/passive_imaging_format_mod.f90 @@ -122,11 +122,13 @@ subroutine read_pif_header_file(filename,mygather) type(gather), intent(out) :: mygather integer(kind=si) :: k - write(6,*)'Read PIF-file header from ',trim(adjustl(filename)),' ...' + integer :: ier + + write(*,*)'Read PIF-file header from ',trim(adjustl(filename)),' ...' open(iunit, file=trim(adjustl(filename)), status='old',action='read', iostat=io_err) if (io_err /= 0) then - write(6,*)'PIF file: ',trim(adjustl(filename)),' does not exist!' + write(*,*)'PIF file: ',trim(adjustl(filename)),' does not exist!' stop 'PIF file does not exist!' endif @@ -201,7 +203,8 @@ subroutine read_pif_header_file(filename,mygather) !*** Now read stations k = 0 if (.not. allocated(mygather%stations)) then - allocate(mygather%stations(mygather%hdr%nsta)) + allocate(mygather%stations(mygather%hdr%nsta),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 489') endif do read(iunit,fmt='(a256)',iostat=io_err) line @@ -269,13 +272,13 @@ subroutine read_pif_header_file(filename,mygather) end select - if (debug_level > 1) write(6,*)trim(adjustl(line)) + if (debug_level > 1) write(*,*)trim(adjustl(line)) enddo if (k < mygather%hdr%nsta) stop 'Not enough stations in PIF binary file..., check number_of_station' close(iunit) - write(6,*)'Done!' + write(*,*)'Done!' ! Read CMT file if needed select case (mygather%hdr%source_type) @@ -298,7 +301,7 @@ subroutine read_pif_header_file(filename,mygather) mygather%source%y, & mygather%source%z) case default - write(6,*)'WARNING : source_type undefined !' + write(*,*) 'WARNING : source_type undefined !' end select !!!! Not here.... since only header diff --git a/src/inverse_problem_for_model/inversion_scheme/family_parameter_mod.f90 b/src/inverse_problem_for_model/inversion_scheme/family_parameter_mod.f90 index 82031fe70..db385ac70 100644 --- a/src/inverse_problem_for_model/inversion_scheme/family_parameter_mod.f90 +++ b/src/inverse_problem_for_model/inversion_scheme/family_parameter_mod.f90 @@ -49,9 +49,11 @@ subroutine PrepareArraysfamilyParam(inversion_param) !! temporary array useful for MPI comm allocate(wks(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 564') if (ier /= 0) call exit_MPI(myrank,"error allocation wks in PrepareArraysfamilyParam subroutine, family_parameter_mod") if (ANISOTROPIC_KL) then allocate(wks1(21, NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 565') if (ier /= 0) call exit_MPI(myrank,"error allocation wks1 in PrepareArraysfamilyParam subroutine, family_parameter_mod") endif @@ -59,9 +61,12 @@ subroutine PrepareArraysfamilyParam(inversion_param) call choose_inversion_parameters(inversion_param) !! temporay arrays used for translation : inversion parmeters <-> modeling parameters - allocate(gradient_wks(NGLLX, NGLLY, NGLLZ, inversion_param%NinvPar)) - allocate(model_wks(NGLLX, NGLLY, NGLLZ, inversion_param%NinvPar)) - allocate(model_ref_wks(NGLLX, NGLLY, NGLLZ, inversion_param%NinvPar)) + allocate(gradient_wks(NGLLX, NGLLY, NGLLZ, inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 566') + allocate(model_wks(NGLLX, NGLLY, NGLLZ, inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 567') + allocate(model_ref_wks(NGLLX, NGLLY, NGLLZ, inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 568') if (myrank == 0) then diff --git a/src/inverse_problem_for_model/inversion_scheme/fwi_iteration_mod.f90 b/src/inverse_problem_for_model/inversion_scheme/fwi_iteration_mod.f90 index c3c9455fc..1bc35daf1 100644 --- a/src/inverse_problem_for_model/inversion_scheme/fwi_iteration_mod.f90 +++ b/src/inverse_problem_for_model/inversion_scheme/fwi_iteration_mod.f90 @@ -587,45 +587,58 @@ subroutine AllocatememoryForFWI(inversion_param, nevent) !! allocate arrays for fwi_iteration allocate(initial_model(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 544') if (ier /= 0) call exit_MPI(myrank,"error allocation initial_model in AllocatememoryForFWI subroutine") allocate(prior_model(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 545') if (ier /= 0) call exit_MPI(myrank,"error allocation prior_model in AllocatememoryForFWI subroutine") allocate(ref_model(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 546') if (ier /= 0) call exit_MPI(myrank,"error allocation ref_model in AllocatememoryForFWI subroutine") allocate(current_model(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 547') if (ier /= 0) call exit_MPI(myrank,"error allocation current_model in AllocatememoryForFWI subroutine") allocate(initial_gradient(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 548') if (ier /= 0) call exit_MPI(myrank,"error allocation initial_gradient in AllocatememoryForFWI subroutine") allocate(current_gradient(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 549') if (ier /= 0) call exit_MPI(myrank,"error allocation current_gradient in AllocatememoryForFWI subroutine") allocate(descent_direction(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 550') if (ier /= 0) call exit_MPI(myrank,"error allocation descent_direction in AllocatememoryForFWI subroutine") allocate(fwi_precond(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 551') if (ier /= 0) call exit_MPI(myrank,"error allocation fwi_precond in AllocatememoryForFWI subroutine") fwi_precond(:,:,:,:,:) = 1._CUSTOM_REAL allocate(hess_approxim(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 552') if (ier /= 0) call exit_MPI(myrank,"error allocation hess_approxim in AllocatememoryForFWI subroutine") hess_approxim(:,:,:,:,:) = 1._CUSTOM_REAL allocate(regularization_penalty(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 553') if (ier /= 0) call exit_MPI(myrank,"error allocation regularization_penalty in AllocatememoryForFWI subroutine") regularization_penalty(:,:,:,:,:) = 0._CUSTOM_REAL allocate(gradient_regularization_penalty(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 554') if (ier /= 0) call exit_MPI(myrank,"error allocation gradient_regularization_penalty in AllocatememoryForFWI subroutine") gradient_regularization_penalty(:,:,:,:,:) = 0._CUSTOM_REAL - allocate(inversion_param%current_cost_prime(NEVENT), inversion_param%previous_cost_prime(NEVENT)) - allocate(inversion_param%current_cost(NEVENT), inversion_param%previous_cost(NEVENT)) + allocate(inversion_param%current_cost_prime(NEVENT), inversion_param%previous_cost_prime(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 555') + allocate(inversion_param%current_cost(NEVENT), inversion_param%previous_cost(NEVENT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 556') end subroutine AllocatememoryForFWI diff --git a/src/inverse_problem_for_model/inversion_scheme/inversion_scheme_mod.f90 b/src/inverse_problem_for_model/inversion_scheme/inversion_scheme_mod.f90 index 8b86a7152..2e006ed0b 100644 --- a/src/inverse_problem_for_model/inversion_scheme/inversion_scheme_mod.f90 +++ b/src/inverse_problem_for_model/inversion_scheme/inversion_scheme_mod.f90 @@ -40,21 +40,27 @@ subroutine AllocateArraysForInversion(inversion_param) Mbfgs=inversion_param%max_history_bfgs allocate(bfgs_stored_gradient(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar, 0:Mbfgs),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 557') if (ier /= 0) call exit_MPI(myrank,"error allocation bfgs_stored_gradient in AllocateArraysForInversion subroutine") allocate(bfgs_stored_model(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar, 0:Mbfgs),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 558') if (ier /= 0) call exit_MPI(myrank,"error allocation bfgs_stored_model in AllocateArraysForInversion subroutine") allocate(wks_1(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 559') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_1 in AllocateArraysForInversion subroutine") allocate(wks_2(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 560') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_2 in AllocateArraysForInversion subroutine") allocate(wks_1n(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 561') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_1n in AllocateArraysForInversion subroutine") allocate(wks_2n(NGLLX, NGLLY, NGLLZ, NSPEC_ADJOINT, Ninvpar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 562') if (ier /= 0) call exit_MPI(myrank,"error allocation wks_2n in AllocateArraysForInversion subroutine") bfgs_stored_gradient(:,:,:,:,:,:) = 0._CUSTOM_REAL diff --git a/src/inverse_problem_for_model/inversion_scheme/iso_parameters.f90 b/src/inverse_problem_for_model/inversion_scheme/iso_parameters.f90 index ac69e90f3..2915ab03d 100644 --- a/src/inverse_problem_for_model/inversion_scheme/iso_parameters.f90 +++ b/src/inverse_problem_for_model/inversion_scheme/iso_parameters.f90 @@ -27,7 +27,7 @@ module iso_parameter_mod subroutine selector_iso_family(inversion_param) type(inver), intent(inout) :: inversion_param integer :: ipar - integer :: ipar_inv + integer :: ipar_inv, ier logical, dimension(3) :: is_selected character(len=MAX_LEN_STRING), dimension(3) :: vti_family_name @@ -72,7 +72,8 @@ subroutine selector_iso_family(inversion_param) !! set wanted parameters in inversion structure inversion_param%NinvPar=ipar_inv - allocate(inversion_param%Index_Invert(inversion_param%NinvPar)) + allocate(inversion_param%Index_Invert(inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 569') ipar_inv=0 do ipar=1, inversion_param%NfamilyPar !! loop on all parameters : rho, vp, vs if (is_selected(ipar)) then diff --git a/src/inverse_problem_for_model/inversion_scheme/vti_parameters.f90 b/src/inverse_problem_for_model/inversion_scheme/vti_parameters.f90 index 4774f6164..32b905283 100644 --- a/src/inverse_problem_for_model/inversion_scheme/vti_parameters.f90 +++ b/src/inverse_problem_for_model/inversion_scheme/vti_parameters.f90 @@ -33,7 +33,7 @@ module vti_parameters_mod subroutine selector_vti_family(inversion_param) type(inver), intent(inout) :: inversion_param integer :: ipar - integer :: ipar_inv + integer :: ipar_inv, ier logical, dimension(6) :: is_selected character(len=MAX_LEN_STRING), dimension(6) :: vti_family_name @@ -51,7 +51,6 @@ subroutine selector_vti_family(inversion_param) inversion_param%param_ref_name(5)="delta--(de)" inversion_param%param_ref_name(6)="gamma--(gm)" - is_selected(:)=.false. ipar_inv=0 inversion_param%NfamilyPar=6 @@ -103,7 +102,8 @@ subroutine selector_vti_family(inversion_param) !! set wanted parameters in inversion structure inversion_param%NinvPar=ipar_inv - allocate(inversion_param%Index_Invert(inversion_param%NinvPar)) + allocate(inversion_param%Index_Invert(inversion_param%NinvPar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 563') ipar_inv=0 do ipar=1, inversion_param%NfamilyPar !! loop on all parameters : rho, vp, vs, ep, gm, de if (is_selected(ipar)) then diff --git a/src/inverse_problem_for_model/projection_on_FD_grid/projection_on_FD_grid_mod.f90 b/src/inverse_problem_for_model/projection_on_FD_grid/projection_on_FD_grid_mod.f90 index 584d0bc37..9a7b4bb80 100644 --- a/src/inverse_problem_for_model/projection_on_FD_grid/projection_on_FD_grid_mod.f90 +++ b/src/inverse_problem_for_model/projection_on_FD_grid/projection_on_FD_grid_mod.f90 @@ -154,7 +154,7 @@ subroutine compute_interpolation_coeff_FD_SEM(projection_fd, myrank) double precision, dimension(NGLLX) :: hxis, hpxis double precision, dimension(NGLLY) :: hetas, hpetas double precision, dimension(NGLLZ) :: hgammas, hpgammas - integer :: nb_fd_point_loc + integer :: nb_fd_point_loc, ier integer, dimension(:,:,:), allocatable :: point_already_found double precision, dimension(:,:,:), allocatable :: xi_in_fd, eta_in_fd, gamma_in_fd @@ -170,10 +170,14 @@ subroutine compute_interpolation_coeff_FD_SEM(projection_fd, myrank) nb_fd_point_loc=0 - allocate(point_already_found(nx_fd_proj, ny_fd_proj, nz_fd_proj)) - allocate(xi_in_fd(nx_fd_proj, ny_fd_proj, nz_fd_proj)) - allocate(eta_in_fd(nx_fd_proj, ny_fd_proj, nz_fd_proj)) - allocate(gamma_in_fd(nx_fd_proj, ny_fd_proj, nz_fd_proj)) + allocate(point_already_found(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 144') + allocate(xi_in_fd(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 145') + allocate(eta_in_fd(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 146') + allocate(gamma_in_fd(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 147') point_already_found(:,:,:)=0 @@ -285,11 +289,16 @@ subroutine compute_interpolation_coeff_FD_SEM(projection_fd, myrank) projection_fd%nb_fd_point=nb_fd_point_loc - allocate(projection_fd%ispec_selected(nb_fd_point_loc)) - allocate(projection_fd%index_on_fd_grid(3,nb_fd_point_loc)) - allocate(projection_fd%hxi(NGLLX,nb_fd_point_loc)) - allocate(projection_fd%heta(NGLLX,nb_fd_point_loc)) - allocate(projection_fd%hgamma(NGLLX,nb_fd_point_loc)) + allocate(projection_fd%ispec_selected(nb_fd_point_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 148') + allocate(projection_fd%index_on_fd_grid(3,nb_fd_point_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 149') + allocate(projection_fd%hxi(NGLLX,nb_fd_point_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 150') + allocate(projection_fd%heta(NGLLX,nb_fd_point_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 151') + allocate(projection_fd%hgamma(NGLLX,nb_fd_point_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 152') nb_fd_point_loc=0 do kfd = 1, nz_fd_proj @@ -453,15 +462,18 @@ subroutine Project_model_SEM2FD_grid(model_on_SEM_mesh, model_on_FD_grid, projec real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable, intent(in) :: model_on_SEM_mesh real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable, intent(inout) :: model_on_FD_grid - integer :: igrid, ispec, iglob + integer :: igrid, ispec, iglob, ier double precision, dimension(NGLLX) :: hxis double precision, dimension(NGLLY) :: hetas double precision, dimension(NGLLZ) :: hgammas double precision :: val - allocate(valence( projection_fd%nx,projection_fd%ny, projection_fd%nz )) - allocate(valence_tmp( projection_fd%nx,projection_fd%ny, projection_fd%nz )) - allocate(model_on_FD_grid_tmp( projection_fd%nx, projection_fd%ny, projection_fd%nz )) + allocate(valence( projection_fd%nx,projection_fd%ny, projection_fd%nz ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 153') + allocate(valence_tmp( projection_fd%nx,projection_fd%ny, projection_fd%nz ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 154') + allocate(model_on_FD_grid_tmp( projection_fd%nx, projection_fd%ny, projection_fd%nz ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 155') valence_tmp(:,:,:) = 0._CUSTOM_REAL model_on_FD_grid_tmp(:,:,:) = 0._CUSTOM_REAL @@ -543,7 +555,7 @@ subroutine locate_MPI_slice_and_bcast_to_all_1(x_to_locate, y_to_locate, z_to_lo double precision, dimension(:), allocatable :: y_array_found double precision, dimension(:), allocatable :: z_array_found integer, dimension(:,:), allocatable :: ispec_selected_all - integer :: iproc + integer :: iproc, ier !! to avoid compler error when calling gather_all* double precision, dimension(1) :: distance_from_target_dummy @@ -551,15 +563,23 @@ subroutine locate_MPI_slice_and_bcast_to_all_1(x_to_locate, y_to_locate, z_to_lo double precision, dimension(1) :: x_dummy, y_dummy, z_dummy integer, dimension(1) :: ispec_selected_dummy, islice_selected_dummy - allocate(distance_from_target_all(1,0:NPROC-1)) - allocate(xi_all(1,0:NPROC-1)) - allocate(eta_all(1,0:NPROC-1)) - allocate(gamma_all(1,0:NPROC-1)) - allocate(x_array_found(0:NPROC-1)) - allocate(y_array_found(0:NPROC-1)) - allocate(z_array_found(0:NPROC-1)) - - allocate(ispec_selected_all(1,0:NPROC-1)) + allocate(distance_from_target_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 156') + allocate(xi_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 157') + allocate(eta_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 158') + allocate(gamma_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 159') + allocate(x_array_found(0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 160') + allocate(y_array_found(0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 161') + allocate(z_array_found(0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 162') + + allocate(ispec_selected_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 163') distance_from_target = sqrt( (x_to_locate - x_found)**2& +(y_to_locate - y_found)**2& diff --git a/src/inverse_problem_for_model/regularization/regularization_FD_mod.f90 b/src/inverse_problem_for_model/regularization/regularization_FD_mod.f90 index 51b96027a..4e2a75def 100644 --- a/src/inverse_problem_for_model/regularization/regularization_FD_mod.f90 +++ b/src/inverse_problem_for_model/regularization/regularization_FD_mod.f90 @@ -27,10 +27,15 @@ subroutine setup_FD_regularization(projection_fd, myrank) type(profd), intent(inout) :: projection_fd integer, intent(in) :: myrank + integer :: ier + call compute_interpolation_coeff_FD_SEM(projection_fd, myrank) - allocate(model_on_FD_grid(nx_fd_proj, ny_fd_proj, nz_fd_proj)) - allocate(diff_model_on_FD_grid(nx_fd_proj, ny_fd_proj, nz_fd_proj)) - allocate(diff2_model_on_FD_grid(nx_fd_proj, ny_fd_proj, nz_fd_proj)) + allocate(model_on_FD_grid(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 218') + allocate(diff_model_on_FD_grid(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 219') + allocate(diff2_model_on_FD_grid(nx_fd_proj, ny_fd_proj, nz_fd_proj),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 220') end subroutine setup_FD_regularization !!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/src/inverse_problem_for_model/regularization/regularization_SEM_mod.f90 b/src/inverse_problem_for_model/regularization/regularization_SEM_mod.f90 index 71ae2da29..b658b6497 100644 --- a/src/inverse_problem_for_model/regularization/regularization_SEM_mod.f90 +++ b/src/inverse_problem_for_model/regularization/regularization_SEM_mod.f90 @@ -1375,6 +1375,7 @@ subroutine read_partition_files read(IIN) nnodes_ext_mesh allocate(nodes_coords_ext_mesh(NDIM,nnodes_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 164') if (ier /= 0) stop 'Error allocating array nodes_coords_ext_mesh' do inode = 1, nnodes_ext_mesh @@ -1393,6 +1394,7 @@ subroutine read_partition_files read(IIN) nmat_ext_mesh, nundefMat_ext_mesh allocate(materials_ext_mesh(16,nmat_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 165') if (ier /= 0) stop 'Error allocating array materials_ext_mesh' materials_ext_mesh(:,:) = 0.d0 @@ -1417,6 +1419,7 @@ subroutine read_partition_files call synchronize_all() allocate(undef_mat_prop(6,nundefMat_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 166') if (ier /= 0) stop 'Error allocating array undef_mat_prop' do imat = 1, nundefMat_ext_mesh ! format example tomography: @@ -1436,8 +1439,10 @@ subroutine read_partition_files ! element indexing read(IIN) nelmnts_ext_mesh allocate(elmnts_ext_mesh(NGNOD,nelmnts_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 167') if (ier /= 0) stop 'Error allocating array elmnts_ext_mesh' allocate(mat_ext_mesh(2,nelmnts_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 168') if (ier /= 0) stop 'Error allocating array mat_ext_mesh' ! reads in material association for each spectral element and corner node indices @@ -1483,36 +1488,42 @@ subroutine read_partition_files NSPEC2D_TOP = nspec2D_top_ext allocate(ibelm_xmin(nspec2D_xmin),nodes_ibelm_xmin(NGNOD2D,nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 169') if (ier /= 0) stop 'Error allocating array ibelm_xmin etc.' do ispec2D = 1,nspec2D_xmin read(IIN) ibelm_xmin(ispec2D),(nodes_ibelm_xmin(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_xmax(nspec2D_xmax),nodes_ibelm_xmax(NGNOD2D,nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 170') if (ier /= 0) stop 'Error allocating array ibelm_xmax etc.' do ispec2D = 1,nspec2D_xmax read(IIN) ibelm_xmax(ispec2D),(nodes_ibelm_xmax(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_ymin(nspec2D_ymin),nodes_ibelm_ymin(NGNOD2D,nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 171') if (ier /= 0) stop 'Error allocating array ibelm_ymin' do ispec2D = 1,nspec2D_ymin read(IIN) ibelm_ymin(ispec2D),(nodes_ibelm_ymin(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_ymax(nspec2D_ymax),nodes_ibelm_ymax(NGNOD2D,nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 172') if (ier /= 0) stop 'Error allocating array ibelm_ymax etc.' do ispec2D = 1,nspec2D_ymax read(IIN) ibelm_ymax(ispec2D),(nodes_ibelm_ymax(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_bottom(nspec2D_bottom_ext),nodes_ibelm_bottom(NGNOD2D,nspec2D_bottom_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 173') if (ier /= 0) stop 'Error allocating array ibelm_bottom etc.' do ispec2D = 1,nspec2D_bottom_ext read(IIN) ibelm_bottom(ispec2D),(nodes_ibelm_bottom(j,ispec2D),j=1,NGNOD2D) enddo allocate(ibelm_top(nspec2D_top_ext),nodes_ibelm_top(NGNOD2D,nspec2D_top_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 174') if (ier /= 0) stop 'Error allocating array ibelm_top etc.' do ispec2D = 1,nspec2D_top_ext read(IIN) ibelm_top(ispec2D),(nodes_ibelm_top(j,ispec2D),j=1,NGNOD2D) @@ -1559,8 +1570,10 @@ subroutine read_partition_files ! reads C-PML regions and C-PML spectral elements global indexing allocate(CPML_to_spec(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 175') if (ier /= 0) stop 'Error allocating array CPML_to_spec' allocate(CPML_regions(nspec_cpml),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 176') if (ier /= 0) stop 'Error allocating array CPML_regions' do i=1,nspec_cpml @@ -1578,6 +1591,7 @@ subroutine read_partition_files ! reads mask of C-PML elements for all elements in this partition allocate(is_CPML(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 177') if (ier /= 0) stop 'Error allocating array is_CPML' do i=1,NSPEC_AB @@ -1596,14 +1610,19 @@ subroutine read_partition_files ! allocates interfaces allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 178') if (ier /= 0) stop 'Error allocating array my_neighbors_ext_mesh' allocate(my_nelmnts_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 179') if (ier /= 0) stop 'Error allocating array my_nelmnts_neighbors_ext_mesh' allocate(my_interfaces_ext_mesh(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 180') if (ier /= 0) stop 'Error allocating array my_interfaces_ext_mesh' allocate(ibool_interfaces_ext_mesh(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 181') if (ier /= 0) stop 'Error allocating array ibool_interfaces_ext_mesh' allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 182') if (ier /= 0) stop 'Error allocating array nibool_interfaces_ext_mesh' ! loops over MPI interfaces with other partitions @@ -1651,6 +1670,7 @@ subroutine read_partition_files ! reads in element informations allocate(ibelm_moho(nspec2D_moho_ext),nodes_ibelm_moho(NGNOD2D,nspec2D_moho_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 183') if (ier /= 0) stop 'Error allocating array ibelm_moho etc.' do ispec2D = 1,nspec2D_moho_ext ! format: #element_id #node_id1 #node_id2 #node_id3 #node_id4 @@ -1666,6 +1686,7 @@ subroutine read_partition_files ! allocate dummy array nspec2D_moho_ext = 0 allocate(ibelm_moho(nspec2D_moho_ext),nodes_ibelm_moho(NGNOD2D,nspec2D_moho_ext),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 184') if (ier /= 0) stop 'Error allocating dumy array ibelm_moho etc.' endif @@ -1712,6 +1733,8 @@ subroutine check_regularization_on_mesh() real(kind=CUSTOM_REAL) :: length integer :: itest, Nb_test + integer :: ier + value_to_test(1)=2. value_to_test(2)=4. value_to_test(3)=8. @@ -1725,8 +1748,10 @@ subroutine check_regularization_on_mesh() elemsize_min_glob,elemsize_max_glob, & distance_min_glob,distance_max_glob) - allocate(field(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(laplacian_of_field(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) + allocate(field(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 185') + allocate(laplacian_of_field(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 186') if (myrank == 0) then write(INVERSE_LOG_FILE,*) @@ -1919,8 +1944,11 @@ subroutine compute_laplacian(field, numerical_laplacian_of_field, regularization real(kind=CUSTOM_REAL), dimension(:), allocatable :: field_to_derivate real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: Laplac_boundary, LapF + integer :: ier + !! the order below is important do not change it. - allocate(Laplac_boundary(NDIM, Nb_iglob_on_faces), field_to_derivate(NGLOB_AB), LapF(NDIM,NGLOB_AB)) + allocate(Laplac_boundary(NDIM, Nb_iglob_on_faces), field_to_derivate(NGLOB_AB), LapF(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 187') !! 1/ compute FD derivatives call compute_laplacian_FD(Laplac_boundary, field, regularization_fd) @@ -1959,8 +1987,12 @@ subroutine compute_grad_laplacian(field, laplacian_of_field, norm_grad_of_field) real(kind=CUSTOM_REAL), dimension(:), allocatable :: Laplac_boundary, nGrad_boundary real(kind=CUSTOM_REAL), dimension(:), allocatable :: nGrad, LapF - allocate(Laplac_boundary(Nb_iglob_on_faces), nGrad_boundary(Nb_iglob_on_faces)) - allocate(field_to_derivate(NGLOB_AB), LapF(NGLOB_AB), nGrad(NGLOB_AB)) + integer :: ier + + allocate(Laplac_boundary(Nb_iglob_on_faces), nGrad_boundary(Nb_iglob_on_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 188') + allocate(field_to_derivate(NGLOB_AB), LapF(NGLOB_AB), nGrad(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 189') !! the order below is important, do not change it. @@ -2005,9 +2037,14 @@ subroutine compute_grad_laplacian_vp_vs_rho(nGrad_vp, nGrad_vs, nGrad_rh, Lap1_v real(kind=CUSTOM_REAL) :: penalty integer :: i,j,k,ispec,iglob - allocate(field(NDIM,NGLOB_AB), field_to_derivate(NGLOB_AB)) - allocate(laplacian_of_field(NGLOB_AB), norm_grad_of_field(NGLOB_AB)) - allocate(valence(NGLOB_AB)) + integer :: ier + + allocate(field(NDIM,NGLOB_AB), field_to_derivate(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 190') + allocate(laplacian_of_field(NGLOB_AB), norm_grad_of_field(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 191') + allocate(valence(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 192') field(:,:)=0._CUSTOM_REAL @@ -2099,10 +2136,16 @@ subroutine compute_laplacian2_vp_vs_rho(Lap1_vp, Lap1_vs, Lap1_rh, Lap2_vp, Lap2 real(kind=CUSTOM_REAL) :: penalty integer :: i,j,k,ispec,iglob - allocate(field(NDIM,NGLOB_AB)) - allocate(numerical_laplacian_of_field(NGLOB_AB)) - allocate(valence(NGLOB_AB)) - allocate(field_to_derivate(NGLLX,NGLLX,NGLLX,NSPEC_AB)) + integer :: ier + + allocate(field(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 193') + allocate(numerical_laplacian_of_field(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 194') + allocate(valence(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 195') + allocate(field_to_derivate(NGLLX,NGLLX,NGLLX,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 196') field(:,:)=0._CUSTOM_REAL valence(:)=0._CUSTOM_REAL @@ -2272,7 +2315,10 @@ subroutine compute_mean_values_on_edge(field) real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: field_wksp, valence integer :: ispec, iglob, i, j, k - allocate(field_wksp(NDIM,NGLOB_AB), valence(NDIM,NGLOB_AB)) + integer :: ier + + allocate(field_wksp(NDIM,NGLOB_AB), valence(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 197') field_wksp(:,:) = 0. valence(:,:)=0. @@ -3571,8 +3617,12 @@ subroutine compute_grad_laplac_lagrange(nGrad, Lapf, field_to_derivate) real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: Derivatives_of_field real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: field_to_derivate_wks, Fwks - allocate(Derivatives_of_field(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(field_to_derivate_wks(NDIM,NGLOB_AB), Fwks(NDIM,NGLOB_AB)) + integer :: ier + + allocate(Derivatives_of_field(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 198') + allocate(field_to_derivate_wks(NDIM,NGLOB_AB), Fwks(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 199') call compute_first_derivatives_lagrange(Derivatives_of_field, field_to_derivate) call compute_mean_values_on_edge(Derivatives_of_field) @@ -3940,11 +3990,14 @@ subroutine compute_laplacian_FD(Dfb, field_input, regularization_fd) integer :: iglob, iglob_index, igll, idim, ip integer :: nline, ncolu + integer :: ier nline=10 - allocate(valence(NDIM,NGLOB_AB), field_to_derivate(NDIM,NGLOB_AB)) - allocate(field_to_send(NGLOB_AB), field_overlap(indx_recv(NPROC)), result_df(nline)) + allocate(valence(NDIM,NGLOB_AB), field_to_derivate(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 200') + allocate(field_to_send(NGLOB_AB), field_overlap(indx_recv(NPROC)), result_df(nline),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 201') valence(:,:)=1. field_to_derivate(:,:) = field_input(:,:) @@ -3971,7 +4024,8 @@ subroutine compute_laplacian_FD(Dfb, field_input, regularization_fd) !! 3/ process derivatives in edges by FD do iglob_index=1, Nb_iglob_on_faces ncolu=regularization_fd(iglob_index)%nReg+regularization_fd(iglob_index)%nNei - allocate(Values(ncolu)) + allocate(Values(ncolu),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 202') ip=0 do igll=1, regularization_fd(iglob_index)%nReg ip = ip + 1 @@ -4020,9 +4074,13 @@ subroutine compute_gradient_laplacian_FD(nGrad, Laplac, field_input, regularizat integer :: iglob, iglob_index, igll, ip integer :: nline, ncolu + integer :: ier + nline=10 - allocate(valence(NDIM,NGLOB_AB), field_to_derivate(NDIM,NGLOB_AB)) - allocate(field_to_send(NGLOB_AB), field_overlap(indx_recv(NPROC)), result_df(nline)) + allocate(valence(NDIM,NGLOB_AB), field_to_derivate(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 203') + allocate(field_to_send(NGLOB_AB), field_overlap(indx_recv(NPROC)), result_df(nline),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 204') valence(:,:)=1. !! need to duplicate in order to use the already build subroutine from sepcfem package : assembel_MPI.. @@ -4052,7 +4110,8 @@ subroutine compute_gradient_laplacian_FD(nGrad, Laplac, field_input, regularizat !! 3/ process derivatives in edges by FD do iglob_index=1, Nb_iglob_on_faces ncolu=regularization_fd(iglob_index)%nReg+regularization_fd(iglob_index)%nNei - allocate(Values(ncolu)) + allocate(Values(ncolu),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 205') ip=0 do igll=1, regularization_fd(iglob_index)%nReg ip = ip + 1 @@ -4320,13 +4379,16 @@ end subroutine matrix_times_vector !!!!!!!!!!!!!!!! DEBUG subroutine !!!!!!!!!!!!!!!!!! subroutine write_in_disk_this(f) + integer :: ier + real(kind=CUSTOM_REAL), dimension(:), allocatable :: f integer i,j,k,ispec, iglob real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: dd character(len=256) :: path_file, name_file integer itest itest=1 - allocate(dd(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(dd(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 206') do ispec=1,nspec_ab do k=1,ngllz do j=1,nglly @@ -4362,9 +4424,14 @@ subroutine compute_lapalacian_of_field(field, laplacian_of_field) real(kind=CUSTOM_REAL),dimension(:,:,:,:,:), allocatable :: derivative_of_field real(kind=CUSTOM_REAL),dimension(:,:,:,:,:), allocatable :: second_derivative_of_field - allocate(field_wkstmp(3,NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(derivative_of_field(3,NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(second_derivative_of_field(3,NGLLX, NGLLY, NGLLZ, NSPEC_AB)) + integer :: ier + + allocate(field_wkstmp(3,NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 207') + allocate(derivative_of_field(3,NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 208') + allocate(second_derivative_of_field(3,NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 209') field_wkstmp(1,:,:,:,:) = field(:,:,:,:) field_wkstmp(2,:,:,:,:) = field(:,:,:,:) @@ -4629,6 +4696,8 @@ subroutine compute_spatial_damping_for_source_singularities(acqui_simu, inversio real(kind=CUSTOM_REAL) :: xgll, ygll, zgll real(kind=CUSTOM_REAL) :: distance_from_source, value_of_damping + integer :: ier + do ispec = 1, NSPEC_AB do k = 1, NGLLZ @@ -4666,7 +4735,8 @@ subroutine compute_spatial_damping_for_source_singularities(acqui_simu, inversio enddo if (NUMBER_OF_SIMULTANEOUS_RUNS > 1) then - allocate(spatial_damping_tmp(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(spatial_damping_tmp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 210') spatial_damping_tmp(:,:,:,:)=spatial_damping(:,:,:,:) call max_all_all_cr_for_simulatenous_runs(spatial_damping_tmp(1,1,1,1), spatial_damping(1,1,1,1), NGLLX*NGLLY*NGLLZ*NSPEC_AB) deallocate(spatial_damping_tmp) diff --git a/src/inverse_problem_for_model/regularization/regularization_interface.f90 b/src/inverse_problem_for_model/regularization/regularization_interface.f90 index 217fc8323..94bbb3db9 100644 --- a/src/inverse_problem_for_model/regularization/regularization_interface.f90 +++ b/src/inverse_problem_for_model/regularization/regularization_interface.f90 @@ -19,7 +19,7 @@ subroutine SetUpRegularization(inversion_param, acqui_simu, myrank) type(inver), intent(inout) :: inversion_param type(acqui), dimension(:), allocatable, intent(inout) :: acqui_simu - + integer :: ier if (myrank == 0) then write(INVERSE_LOG_FILE,*) @@ -36,10 +36,10 @@ subroutine SetUpRegularization(inversion_param, acqui_simu, myrank) endif endif - if ( inversion_param%use_damping_SEM_Tikonov .or. inversion_param%use_variable_SEM_damping) then if (.not. allocated(spatial_damping)) then - allocate(spatial_damping(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) + allocate(spatial_damping(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 211') endif spatial_damping(:,:,:,:)=min(1._CUSTOM_REAL, inversion_param%min_damp) endif @@ -90,14 +90,12 @@ subroutine AddRegularization(inversion_param, model, ref_model, prior_model, reg real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable, intent(inout) :: regul_penalty, gradient_regul_penalty real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: model_on_sem, regul_on_sem, gradient_regul_on_sem real(kind=CUSTOM_REAL) :: cost_penalty - integer :: ipar + integer :: ipar, ier inversion_param%cost_penalty= 0._CUSTOM_REAL regul_penalty(:,:,:,:,:)= 0._CUSTOM_REAL gradient_regul_penalty(:,:,:,:,:)= 0._CUSTOM_REAL - - !! ----------------- SEM BASED REGULARIZATION -------- if (inversion_param%use_regularization_SEM_Tikonov) then if (myrank == 0) then @@ -109,9 +107,12 @@ subroutine AddRegularization(inversion_param, model, ref_model, prior_model, reg write(INVERSE_LOG_FILE,*) endif - allocate(model_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(gradient_regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) + allocate(model_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 212') + allocate(regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 213') + allocate(gradient_regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 214') do ipar = 1, inversion_param%NinvPar @@ -225,9 +226,12 @@ subroutine AddRegularization(inversion_param, model, ref_model, prior_model, reg write(INVERSE_LOG_FILE,*) endif - allocate(model_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) - allocate(gradient_regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB)) + allocate(model_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 215') + allocate(regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 216') + allocate(gradient_regul_on_sem(NGLLX, NGLLY, NGLLZ, NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 217') do ipar = 1, inversion_param%NinvPar model_on_sem(:,:,:,:) = model(:,:,:,:,ipar) diff --git a/src/inverse_problem_for_model/specfem_interface/specfem_interface_mod.F90 b/src/inverse_problem_for_model/specfem_interface/specfem_interface_mod.F90 index 7962c8676..4b1b871c6 100644 --- a/src/inverse_problem_for_model/specfem_interface/specfem_interface_mod.F90 +++ b/src/inverse_problem_for_model/specfem_interface/specfem_interface_mod.F90 @@ -223,12 +223,18 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers if (allocated(hdur_Gaussian)) deallocate(hdur_Gaussian) if (allocated(tshift_src)) deallocate(tshift_src) - allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ)) - allocate(islice_selected_source(NSOURCES)) - allocate(ispec_selected_source(NSOURCES)) - allocate(hdur(NSOURCES)) - allocate(hdur_Gaussian(NSOURCES)) - allocate(tshift_src(NSOURCES)) + allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 490') + allocate(islice_selected_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 491') + allocate(ispec_selected_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 492') + allocate(hdur(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 493') + allocate(hdur_Gaussian(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 494') + allocate(tshift_src(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 495') sourcearrays(:,:,:,:,:)=acqui_simu(ievent)%sourcearrays(:,:,:,:,:) @@ -243,6 +249,7 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers if (USE_EXTERNAL_SOURCE_FILE) then if (allocated(user_source_time_function)) deallocate(user_source_time_function) allocate(user_source_time_function(NSTEP_STF, NSOURCES_STF),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 496') if (ier /= 0) stop ' error in allocating user_source_time_function' if (inversion_param%only_forward) then user_source_time_function(:,:)=acqui_simu(ievent)%user_source_time_function(:,:) @@ -250,7 +257,8 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers !! filter the user stf !! EB EB Warning, filtering may be done each time we are switching events if (inversion_param%use_band_pass_filter) then - allocate(raw_stf(NSTEP), filt_stf(NSTEP)) + allocate(raw_stf(NSTEP), filt_stf(NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 497') do isrc=1,NSOURCES raw_stf(:)=acqui_simu(ievent)%user_source_time_function(:,isrc) call bwfilt (raw_stf, filt_stf, & @@ -320,10 +328,14 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers if (allocated(nu)) deallocate(nu) !! re-allocation - allocate(islice_selected_rec(nrec),ispec_selected_rec(nrec)) - allocate(xi_receiver(nrec),eta_receiver(nrec),gamma_receiver(nrec)) - allocate(station_name(nrec),network_name(nrec)) - allocate(nu(NDIM,NDIM,nrec)) + allocate(islice_selected_rec(nrec),ispec_selected_rec(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 498') + allocate(xi_receiver(nrec),eta_receiver(nrec),gamma_receiver(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 499') + allocate(station_name(nrec),network_name(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 500') + allocate(nu(NDIM,NDIM,nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 501') !! store current arrays islice_selected_rec(:)=acqui_simu(ievent)%islice_selected_rec(:) @@ -354,14 +366,21 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers nadj_rec_local = nrec_local - allocate(hxir_store(nrec_local,NGLLX)) - allocate(hetar_store(nrec_local,NGLLY)) - allocate(hgammar_store(nrec_local,NGLLZ)) - allocate(hpxir_store(nrec_local,NGLLX)) - allocate(hpetar_store(nrec_local,NGLLY)) - allocate(hpgammar_store(nrec_local,NGLLZ)) - - allocate(number_receiver_global(nrec_local)) + allocate(hxir_store(nrec_local,NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 502') + allocate(hetar_store(nrec_local,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 503') + allocate(hgammar_store(nrec_local,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 504') + allocate(hpxir_store(nrec_local,NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 505') + allocate(hpetar_store(nrec_local,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 506') + allocate(hpgammar_store(nrec_local,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 507') + + allocate(number_receiver_global(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 508') number_receiver_global(:)=acqui_simu(ievent)%number_receiver_global(1:nrec_local) do irec=1, nrec_local @@ -380,12 +399,16 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers ! allocate seismogram array allocate(seismograms_d(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 509') if (ier /= 0) stop 'error allocating array seismograms_d' allocate(seismograms_v(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 510') if (ier /= 0) stop 'error allocating array seismograms_v' allocate(seismograms_a(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 511') if (ier /= 0) stop 'error allocating array seismograms_a' allocate(seismograms_p(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 512') if (ier /= 0) stop 'error allocating array seismograms_p' ! initialize seismograms @@ -406,14 +429,21 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers if (allocated(number_receiver_global)) deallocate(number_receiver_global) ! in Fortran it is legal to allocate dummy arrays with a size of zero - allocate(hxir_store(0,0)) - allocate(hetar_store(0,0)) - allocate(hgammar_store(0,0)) - allocate(hpxir_store(0,0)) - allocate(hpetar_store(0,0)) - allocate(hpgammar_store(0,0)) - - allocate(number_receiver_global(0)) + allocate(hxir_store(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 513') + allocate(hetar_store(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 514') + allocate(hgammar_store(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 515') + allocate(hpxir_store(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 516') + allocate(hpetar_store(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 517') + allocate(hpgammar_store(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 518') + + allocate(number_receiver_global(0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 519') if (allocated(seismograms_d)) deallocate(seismograms_d) if (allocated(seismograms_v)) deallocate(seismograms_v) @@ -422,12 +452,16 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers ! allocate seismogram array allocate(seismograms_d(NDIM,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 520') if (ier /= 0) stop 'error allocating array seismograms_d' allocate(seismograms_v(NDIM,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 521') if (ier /= 0) stop 'error allocating array seismograms_v' allocate(seismograms_a(NDIM,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 522') if (ier /= 0) stop 'error allocating array seismograms_a' allocate(seismograms_p(NDIM,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 523') if (ier /= 0) stop 'error allocating array seismograms_p' endif @@ -441,6 +475,7 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers ! initializes adjoint sources -------------------------------------------------------------------------------------------------- if (allocated(source_adjoint)) deallocate(source_adjoint) allocate(source_adjoint(NDIM,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 524') if (ier /= 0) stop 'error allocating array adj_sourcearrays' source_adjoint(:,:,:) = 0._CUSTOM_REAL if (SIMULATION_TYPE == 3) then @@ -695,8 +730,10 @@ subroutine InitSpecfemForOneRun(acqui_simu, ievent, inversion_param, iter_invers LOCAL_PATH,SAVE_MESH_FILES) else if (ACOUSTIC_SIMULATION) then allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 525') if (ier /= 0) stop 'error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 526') if (ier /= 0) stop 'error allocating array rho_vs' rho_vp = sqrt( kappastore / rhostore ) * rhostore rho_vs = 0.0_CUSTOM_REAL @@ -989,14 +1026,20 @@ subroutine PrepareTimerunInverseProblem() ! from prepare_timerun_lddrk() ------------------------------------------------- if (ELASTIC_SIMULATION) then - allocate(b_R_xx_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS)) - allocate(b_R_yy_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS)) - allocate(b_R_xy_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS)) - allocate(b_R_xz_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS)) + allocate(b_R_xx_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 527') + allocate(b_R_yy_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 528') + allocate(b_R_xy_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 529') + allocate(b_R_xz_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 530') allocate(b_R_yz_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK ,N_SLS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 531') if (ier /= 0) stop 'Error allocating array R_**_lddrk etc.' - allocate(b_R_trace_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK,N_SLS)) + allocate(b_R_trace_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK,N_SLS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 532') if (ier /= 0) stop 'Error allocating array R_**_lddrk etc.' if (SIMULATION_TYPE == 3) then @@ -1131,30 +1174,39 @@ subroutine PrepareTimerunInverseProblem() !! allocate arrays for saving the kernel computed by GPU in CPU memory in order to perform summation over events. if (GPU_MODE) then if (ACOUSTIC_SIMULATION) then - allocate(rho_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB), kappa_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rho_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB), kappa_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 533') rho_ac_kl_GPU(:,:,:,:)=0._CUSTOM_REAL kappa_ac_kl_GPU(:,:,:,:)=0._CUSTOM_REAL if (APPROXIMATE_HESS_KL) then - allocate(hess_rho_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),hess_kappa_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(hess_rho_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),hess_kappa_ac_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 534') endif endif if (ELASTIC_SIMULATION) then - allocate(rho_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(kappa_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(mu_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rho_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 535') + allocate(kappa_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 536') + allocate(mu_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 537') rho_kl_GPU(:,:,:,:)=0._CUSTOM_REAL kappa_kl_GPU(:,:,:,:)=0._CUSTOM_REAL mu_kl_GPU(:,:,:,:)=0._CUSTOM_REAL if (APPROXIMATE_HESS_KL) then - allocate(hess_rho_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(hess_kappa_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(hess_mu_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(hess_rho_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 538') + allocate(hess_kappa_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 539') + allocate(hess_mu_kl_GPU(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 540') endif endif if (ANISOTROPIC_KL) then - allocate(cijkl_kl_GPU(21,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(cijkl_kl_GPU(21,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 541') cijkl_kl_GPU(:,:,:,:,:)=0._CUSTOM_REAL endif endif @@ -1237,8 +1289,10 @@ subroutine CheckModelSuitabilityForModeling(ModelIsSuitable) ! nothing to do else if (ACOUSTIC_SIMULATION) then allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 542') if (ier /= 0) stop 'error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 543') if (ier /= 0) stop 'error allocating array rho_vs' rho_vp = sqrt( kappastore / rhostore ) * rhostore rho_vs = 0.0_CUSTOM_REAL diff --git a/src/inverse_problem_for_source/CMT3D/cmt3d/cmt3d_flexwin.f90 b/src/inverse_problem_for_source/CMT3D/cmt3d/cmt3d_flexwin.f90 index 89293eea8..f2b017630 100644 --- a/src/inverse_problem_for_source/CMT3D/cmt3d/cmt3d_flexwin.f90 +++ b/src/inverse_problem_for_source/CMT3D/cmt3d/cmt3d_flexwin.f90 @@ -50,6 +50,7 @@ program cmt3d_flexwin ! allocate arrays allocate(A(npar,npar),b(npar),dm(npar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1093') if (ier /= 0) stop 'Error allocating ' print *, 'Set up inversion matrix ...' call setup_matrix(A,b,npar) diff --git a/src/meshfem3D/check_mesh_quality.f90 b/src/meshfem3D/check_mesh_quality.f90 index 761625037..190c353ab 100644 --- a/src/meshfem3D/check_mesh_quality.f90 +++ b/src/meshfem3D/check_mesh_quality.f90 @@ -126,6 +126,7 @@ subroutine check_mesh_quality(myrank,VP_MAX,NGLOB,NSPEC,x,y,z,ibool, & ! debug: for vtk output if (CREATE_VTK_FILES) then allocate(tmp1(NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1345') if (ier /= 0) stop 'error allocating array tmp' tmp1(:) = 0.0 endif diff --git a/src/meshfem3D/chunk_earth_mesh_mod.f90 b/src/meshfem3D/chunk_earth_mesh_mod.f90 index ba7603194..0bc7ee781 100644 --- a/src/meshfem3D/chunk_earth_mesh_mod.f90 +++ b/src/meshfem3D/chunk_earth_mesh_mod.f90 @@ -116,7 +116,7 @@ subroutine read_metric_params() character(len=MAX_STRING_LEN) :: keyw integer :: ilayer, nx, ny, k, ntmp double precision :: dz - integer :: i, iflag, imat + integer :: i, iflag, imat, ier double precision :: vp, vs, rho, Q, Aniso double precision :: x0, x1, y0, y1, z0, z1 @@ -154,13 +154,16 @@ subroutine read_metric_params() case('nb_doubling') use_doubling=.true. read(line(ipos0:ipos1),*) nb_doubling - allocate(layer_doubling(nb_doubling)) + allocate(layer_doubling(nb_doubling),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1240') case('layer_doubling') read(line(ipos0:ipos1),*) layer_doubling(:) case ('nb_material') read(line(ipos0:ipos1),*) nb_mat - allocate(material_prop(nb_mat, 5)) - allocate(flag_acoustic_elastic(nb_mat)) + allocate(material_prop(nb_mat, 5),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1241') + allocate(flag_acoustic_elastic(nb_mat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1242') flag_acoustic_elastic(:)=-1 case('material') read(line(ipos0:ipos1),*) i, rho, vp, vs, Q, Aniso, iflag @@ -176,8 +179,10 @@ subroutine read_metric_params() endif case('nb_region') read(line(ipos0:ipos1),*) nb_dom - allocate(domain_boundary(nb_dom,6)) - allocate(Imaterial_domain(nb_dom)) + allocate(domain_boundary(nb_dom,6),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1243') + allocate(Imaterial_domain(nb_dom),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1244') domain_boundary(:,:)=0. case('region') read(line(ipos0:ipos1),*) i, x0, x1, y0, y1, z0, z1, imat @@ -217,8 +222,10 @@ subroutine read_metric_params() ny_ref = floor(( ymax_chunk - ymin_chunk ) / dy_max ) + 1 !! store the subdomain boundary - allocate(zlayer(nb_doubling+2)) - allocate(nzlayer(nb_doubling+1)) + allocate(zlayer(nb_doubling+2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1245') + allocate(nzlayer(nb_doubling+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1246') k=0 do ilayer=2, nb_doubling+1 k=k+1 @@ -270,8 +277,10 @@ subroutine read_metric_params() write(*,*) 'zlayer ', zlayer(:) write(*,*) 'nzlayer ', nzlayer(:) !! allocate mesh arrays - allocate(x_mesh_point(npoint_tot), y_mesh_point(npoint_tot), z_mesh_point(npoint_tot)) - allocate(EtoV(8,nspec_tot), iboun(6,nspec_tot)) + allocate(x_mesh_point(npoint_tot), y_mesh_point(npoint_tot), z_mesh_point(npoint_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1247') + allocate(EtoV(8,nspec_tot), iboun(6,nspec_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1248') iboun(:,:)=.false. EtoV(:,:)=0 @@ -282,7 +291,7 @@ end subroutine read_metric_params !!################################################################################################################################## subroutine mesh_metric_chunk() - integer :: nx, ny, nz, ispec, ipoint, ilayer + integer :: nx, ny, nz, ispec, ipoint, ilayer, ier double precision :: dx, dy, dz, z double precision, dimension(:,:), allocatable :: top_surface, bottom_surface @@ -308,7 +317,8 @@ subroutine mesh_metric_chunk() dy = ( ymax_chunk - ymin_chunk ) / real(ny,8) dz = ( zlayer(ilayer+1) - zlayer(ilayer) ) / real(nz,8) - allocate(top_surface(nx+1,ny+1), bottom_surface(nx+1,ny+1)) + allocate(top_surface(nx+1,ny+1), bottom_surface(nx+1,ny+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1249') top_surface(:,:) = zlayer(ilayer+1) - dz bottom_surface(:,:) = zlayer(ilayer) @@ -317,7 +327,8 @@ subroutine mesh_metric_chunk() deallocate(top_surface) - allocate(top_surface(2*nx+1,2*ny+1)) + allocate(top_surface(2*nx+1,2*ny+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1250') top_surface(:,:) = zlayer(ilayer+1) bottom_surface(:,:) = zlayer(ilayer+1) - dz call mesh_doubling_domain_Hex8(xmin_chunk, ymin_chunk, z, dx, dy, dz, nx, ny, & @@ -335,7 +346,8 @@ subroutine mesh_metric_chunk() dx = ( xmax_chunk - xmin_chunk ) / real(nx,8) dy = ( ymax_chunk - ymin_chunk ) / real(ny,8) dz = ( zlayer(ilayer+1) - zlayer(ilayer) ) / real(nz,8) - allocate(top_surface(nx+1,ny+1), bottom_surface(nx+1,ny+1)) + allocate(top_surface(nx+1,ny+1), bottom_surface(nx+1,ny+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1251') top_surface(:,:) = zlayer(ilayer+1) - dz bottom_surface(:,:) = zlayer(ilayer) call mesh_regular_domain_Hex8(xmin_chunk, ymin_chunk, z, dx, dy, dz, nx, ny, nz, & @@ -357,13 +369,15 @@ subroutine create_mesh_metric_chunk() integer, dimension(:), allocatable :: iglob, locval logical, dimension(:), allocatable :: ifseg integer :: nglob - integer :: i, k, idom, IOVTK + integer :: i, k, idom, IOVTK, ier character(len=10) :: MESH - MESH='./MESH/' !! VM VM harcoded directory (todo fix it) + MESH='./MESH/' !! VM VM harcoded directory (todo fix it) - allocate(iglob(npoint_tot), locval(npoint_tot)) - allocate(ifseg(npoint_tot)) + allocate(iglob(npoint_tot), locval(npoint_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1252') + allocate(ifseg(npoint_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1253') call get_global(npoint_tot, x_mesh_point, y_mesh_point, z_mesh_point, iglob, locval, ifseg, nglob, xmin_chunk, xmax_chunk) @@ -384,7 +398,8 @@ subroutine create_mesh_metric_chunk() npoint_tot=k write(*,*) " number of point found ", npoint_tot, nglob deallocate(x_mesh_point, y_mesh_point, z_mesh_point) - allocate(x_mesh_point(npoint_tot), y_mesh_point(npoint_tot), z_mesh_point(npoint_tot)) + allocate(x_mesh_point(npoint_tot), y_mesh_point(npoint_tot), z_mesh_point(npoint_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1254') open(27,file=trim(MESH)//'nodes_coords_file') read(27,*) k do i = 1, npoint_tot @@ -439,7 +454,8 @@ subroutine create_mesh_metric_chunk() enddo close(27) - allocate(Imatetrial_ispec(nspec_tot)) + allocate(Imatetrial_ispec(nspec_tot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1255') open(28,file=trim(MESH)//'/materials_file') do i=1, nspec_tot call Find_Domain(idom, i, iglob) @@ -499,7 +515,7 @@ subroutine mesh_regular_domain_Hex8(ox, oy, oz, dx, dy, dz, nx, ny, nz, top_su !! locals double precision, dimension(:), allocatable :: xgrid, ygrid, zgrid double precision :: ztop, zbottom - integer :: i, j, k, ip + integer :: i, j, k, ip, ier !!------------------------------------------------------------------------------------------------------- !! in regular layer domain we have : @@ -510,7 +526,8 @@ subroutine mesh_regular_domain_Hex8(ox, oy, oz, dx, dy, dz, nx, ny, nz, top_su !!------------------------------------------------------------------------------------------------------ !! creating regular Cartesian grid --------------------------------------------------------------------- - allocate(xgrid(nx+1), ygrid(ny+1), zgrid(nz+1)) + allocate(xgrid(nx+1), ygrid(ny+1), zgrid(nz+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1256') !! define the reference grid do i = 1, nx + 1 diff --git a/src/meshfem3D/create_CPML_regions.f90 b/src/meshfem3D/create_CPML_regions.f90 index d5233ab28..ee8a7eb28 100644 --- a/src/meshfem3D/create_CPML_regions.f90 +++ b/src/meshfem3D/create_CPML_regions.f90 @@ -56,6 +56,7 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! CPML allocation allocate(is_CPML(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1310') if (ier /= 0) stop 'Error allocating is_CPML array' ! initializes CPML elements @@ -65,8 +66,10 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! checks if anything to do if (.not. PML_CONDITIONS) then ! dummy allocation - allocate(CPML_to_spec(1)) + allocate(CPML_to_spec(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1311') allocate(CPML_regions(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1312') if (ier /= 0) stop 'Error allocating dummy CPML arrays' ! nothing to do anymore @@ -98,9 +101,12 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) call max_all_all_cr(ymax,ymax_all) call max_all_all_cr(zmax,zmax_all) - allocate(is_X_CPML(nspec)) - allocate(is_Y_CPML(nspec)) - allocate(is_Z_CPML(nspec)) + allocate(is_X_CPML(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1313') + allocate(is_Y_CPML(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1314') + allocate(is_Z_CPML(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1315') is_X_CPML(:) = .false. is_Y_CPML(:) = .false. @@ -191,8 +197,10 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) endif ! allocates arrays - allocate(CPML_to_spec(nspec_CPML)) + allocate(CPML_to_spec(nspec_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1316') allocate(CPML_regions(nspec_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1317') if (ier /= 0) stop 'Error allocating CPML arrays' ispec_CPML=0 diff --git a/src/meshfem3D/create_interfaces_mesh.f90 b/src/meshfem3D/create_interfaces_mesh.f90 index 95584aeee..5897687cb 100644 --- a/src/meshfem3D/create_interfaces_mesh.f90 +++ b/src/meshfem3D/create_interfaces_mesh.f90 @@ -105,8 +105,10 @@ subroutine create_interfaces_mesh() ! allocates interface arrays allocate(interface_bottom(max_npx_interface,max_npy_interface),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1281') if (ier /= 0) stop 'Error allocating array interface_bottom' allocate(interface_top(max_npx_interface,max_npy_interface),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1282') if (ier /= 0) stop 'Error allocating array interface_top' ! read number of interfaces @@ -526,6 +528,7 @@ subroutine get_interfaces_mesh_count() number_of_layers = number_of_interfaces allocate(ner_layer(number_of_layers),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1283') if (ier /= 0) stop 'Error allocating array ner_layer' ! loop on all the layers diff --git a/src/meshfem3D/create_meshfem_mesh.f90 b/src/meshfem3D/create_meshfem_mesh.f90 index 538c0b227..96eda3847 100644 --- a/src/meshfem3D/create_meshfem_mesh.f90 +++ b/src/meshfem3D/create_meshfem_mesh.f90 @@ -247,65 +247,88 @@ subroutine cmm_allocate_arrays() ! use dynamic allocation to allocate memory for arrays allocate(ibool(NGLLX_M,NGLLY_M,NGLLZ_M,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1257') if (ier /= 0) stop 'Error allocating array ibool' allocate(xstore(NGLLX_M,NGLLY_M,NGLLZ_M,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1258') if (ier /= 0) stop 'Error allocating array xstore' allocate(ystore(NGLLX_M,NGLLY_M,NGLLZ_M,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1259') if (ier /= 0) stop 'Error allocating array ystore' allocate(zstore(NGLLX_M,NGLLY_M,NGLLZ_M,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1260') ! exit if there is not enough memory to allocate all the arrays if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! flag indicating whether point is in the sediments allocate(flag_sediments(NGLLX_M,NGLLY_M,NGLLZ_M,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1261') if (ier /= 0) stop 'Error allocating array flag_sediments' allocate(not_fully_in_bedrock(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1262') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! boundary locator allocate(iboun(6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1263') if (ier /= 0) stop 'Error allocating array iboun' ! boundary parameters locator allocate(ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1264') if (ier /= 0) stop 'Error allocating array ibelm_xmin' allocate(ibelm_xmax(NSPEC2DMAX_XMIN_XMAX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1265') if (ier /= 0) stop 'Error allocating array ibelm_xmax' allocate(ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1266') if (ier /= 0) stop 'Error allocating array ibelm_ymin' allocate(ibelm_ymax(NSPEC2DMAX_YMIN_YMAX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1267') if (ier /= 0) stop 'Error allocating array ibelm_ymax' allocate(ibelm_bottom(NSPEC2D_BOTTOM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1268') if (ier /= 0) stop 'Error allocating array ibelm_bottom' allocate(ibelm_top(NSPEC2D_TOP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1269') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! MPI cut-planes parameters along xi and along eta allocate(iMPIcut_xi(2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1270') if (ier /= 0) stop 'Error allocating array iMPIcut_xi' allocate(iMPIcut_eta(2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1271') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! allocate memory for arrays allocate(iglob(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1272') if (ier /= 0) stop 'Error allocating array iglob' allocate(locval(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1273') if (ier /= 0) stop 'Error allocating array locval' allocate(ifseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1274') if (ier /= 0) stop 'Error allocating array ifseg' allocate(xp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1275') if (ier /= 0) stop 'Error allocating array xp' allocate(yp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1276') if (ier /= 0) stop 'Error allocating array yp' allocate(zp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1277') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') ! allocate material ids array allocate(material_num(0:2*NER,0:2*NEX_PER_PROC_XI,0:2*NEX_PER_PROC_ETA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1278') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') allocate(ispec_material_id(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1279') if (ier /= 0) stop 'Error allocating array ispec_material_id' ! synchronize @@ -661,6 +684,7 @@ subroutine cmm_create_addressing() ! put in classical format allocate(nodes_coords(nglob,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1280') if (ier /= 0) stop 'Error allocating array nodes_coords' nodes_coords(:,:) = 0.0d0 diff --git a/src/meshfem3D/determine_cavity.f90 b/src/meshfem3D/determine_cavity.f90 index 02d555b98..47c4de959 100644 --- a/src/meshfem3D/determine_cavity.f90 +++ b/src/meshfem3D/determine_cavity.f90 @@ -120,12 +120,18 @@ subroutine cmm_determine_cavity(nglob) ! reads in cavity dimensions if (ncavity > 0) then - allocate(cavity_x0(ncavity)) - allocate(cavity_x1(ncavity)) - allocate(cavity_y0(ncavity)) - allocate(cavity_y1(ncavity)) - allocate(cavity_z0(ncavity)) - allocate(cavity_z1(ncavity)) + allocate(cavity_x0(ncavity),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1321') + allocate(cavity_x1(ncavity),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1322') + allocate(cavity_y0(ncavity),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1323') + allocate(cavity_y1(ncavity),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1324') + allocate(cavity_z0(ncavity),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1325') + allocate(cavity_z1(ncavity),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1326') cavity_x0=HUGEVAL; cavity_x1=HUGEVAL cavity_y0=HUGEVAL; cavity_y1=HUGEVAL cavity_z0=HUGEVAL; cavity_z1=HUGEVAL @@ -160,6 +166,7 @@ subroutine cmm_determine_cavity(nglob) endif allocate(is_elmt(nspec),is_node(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1327') if (ier /= 0) stop 'Error allocating is_elmt, is_node arrays' is_elmt(:) = .true. @@ -237,6 +244,7 @@ subroutine cmm_determine_cavity(nglob) ! note: index (0,*) == 1 indicates a boundary point ! and there can be 4 boundaries maximum for each element: xi-min, xi-max, eta-min, eta-max side allocate(cavity_boundary(0:3,4*num_cav_total),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1328') if (ier /= 0) stop 'Error allocating cavity_boundary arrays' cavity_boundary(:,:) = 0.0 @@ -344,9 +352,11 @@ subroutine cmm_determine_cavity(nglob) ! collects on master processes if (myrank == 0) then - allocate(tmp_all(4,num_cav_total*4)) + allocate(tmp_all(4,num_cav_total*4),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1329') else - allocate(tmp_all(1,1)) + allocate(tmp_all(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1330') endif call sum_all_1Darray_dp(cavity_boundary,tmp_all,size(cavity_boundary)) if (myrank == 0) then @@ -462,6 +472,7 @@ subroutine cmm_determine_cavity(nglob) ! allocates new mesh arrays allocate(ispec_new(nspec_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1331') if (ier /= 0) stop 'Error allocating ispec_new array' ispec_new(:) = -1 @@ -475,7 +486,8 @@ subroutine cmm_determine_cavity(nglob) enddo if (ispec_new_mesh /= nspec) call exit_MPI(myrank,'ERROR: new number of spectral elements mismatch!') - allocate(inode_new(nglob_old)) + allocate(inode_new(nglob_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1332') inode_new(:) = -1 inode_new_mesh = 0 @@ -488,12 +500,18 @@ subroutine cmm_determine_cavity(nglob) if (inode_new_mesh /= nglob) call exit_MPI(myrank,'ERROR: new number of spectral elements mismatch!') ! old mesh arrays - allocate(nodes_coords_old(nglob_old,3)) - allocate(ispec_material_id_old(nspec_old)) - allocate(ibool_old(NGLLX_M,NGLLY_M,NGLLZ_M,nspec_old)) - allocate(iboun_old(6,nspec_old)) - allocate(iMPIcut_xi_old(2,nspec_old)) + allocate(nodes_coords_old(nglob_old,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1333') + allocate(ispec_material_id_old(nspec_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1334') + allocate(ibool_old(NGLLX_M,NGLLY_M,NGLLZ_M,nspec_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1335') + allocate(iboun_old(6,nspec_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1336') + allocate(iMPIcut_xi_old(2,nspec_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1337') allocate(iMPIcut_eta_old(2,nspec_old),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1338') if (ier /= 0 ) stop 'Error allocating old mesh arrays for cavity' nodes_coords_old(:,:) = nodes_coords(:,:) @@ -510,12 +528,18 @@ subroutine cmm_determine_cavity(nglob) deallocate(iMPIcut_xi,iMPIcut_eta) ! re-allocates new mesh arrays - allocate(nodes_coords(nglob,3)) - allocate(ispec_material_id(nspec)) - allocate(ibool(NGLLX_M,NGLLY_M,NGLLZ_M,nspec)) - allocate(iboun(6,nspec)) - allocate(iMPIcut_xi(2,nspec)) + allocate(nodes_coords(nglob,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1339') + allocate(ispec_material_id(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1340') + allocate(ibool(NGLLX_M,NGLLY_M,NGLLZ_M,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1341') + allocate(iboun(6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1342') + allocate(iMPIcut_xi(2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1343') allocate(iMPIcut_eta(2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1344') if (ier /= 0 ) stop 'Error allocating updated mesh arrays for cavity' ! new specs diff --git a/src/meshfem3D/earth_chunk.f90 b/src/meshfem3D/earth_chunk.f90 index 9757df813..08267ea48 100644 --- a/src/meshfem3D/earth_chunk.f90 +++ b/src/meshfem3D/earth_chunk.f90 @@ -72,7 +72,7 @@ subroutine earth_chunk_HEX8_Mesher(NGNOD) integer ilat, ilon, ispec, iz, i, j, k, nspec, ia, izshift, index_mat integer ispec2Dxmin, ispec2Dxmax, ispec2Dymin, ispec2Dymax, ispec2Dzmin, ispec2Dzmax integer ilayer_current, ilayer - integer nlat_dsm, nlon_dsm + integer nlat_dsm, nlon_dsm, ier integer iaddx(NGNOD), iaddy(NGNOD), iaddz(NGNOD) @@ -194,16 +194,25 @@ subroutine earth_chunk_HEX8_Mesher(NGNOD) nspec = nel_lat * nel_lon * nel_depth npointot = 8 * nspec - allocate(xp(npointot), yp(npointot), zp(npointot)) - allocate(iglob(npointot), loc(npointot)) - allocate(ifseg(npointot)) - allocate(ProfForGemini(0:NZ-1,3)) - allocate(current_layer(0:NZ-1)) - allocate(inum_loc(2,2,2,nspec)) - allocate(xgrid(2,2,2,nspec), ygrid(2,2,2,nspec), zgrid(2,2,2,nspec)) - allocate(lon_zmin(nlon_dsm,nlat_dsm), lat_zmin(nlon_dsm,nlat_dsm)) + allocate(xp(npointot), yp(npointot), zp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1284') + allocate(iglob(npointot), loc(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1285') + allocate(ifseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1286') + allocate(ProfForGemini(0:NZ-1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1287') + allocate(current_layer(0:NZ-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1288') + allocate(inum_loc(2,2,2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1289') + allocate(xgrid(2,2,2,nspec), ygrid(2,2,2,nspec), zgrid(2,2,2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1290') + allocate(lon_zmin(nlon_dsm,nlat_dsm), lat_zmin(nlon_dsm,nlat_dsm),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1291') ! boundary locator - allocate(iboun(6,nspec)) + allocate(iboun(6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1292') iboun(:,:) = .false. @@ -621,7 +630,8 @@ subroutine earth_chunk_HEX8_Mesher(NGNOD) call getglob_for_chunk(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,NGNOD,UTM_X_MIN,UTM_X_MAX) deallocate(xp,yp,zp) - allocate(xp(nglob),yp(nglob),zp(nglob)) + allocate(xp(nglob),yp(nglob),zp(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1293') ! on ne stocke que les points de la grille et leur numeros do ispec=1,nspec @@ -813,7 +823,7 @@ subroutine earth_chunk_HEX27_Mesher(NGNOD) double precision, allocatable :: lon_zmin(:,:), lat_zmin(:,:) double precision, dimension(:,:), allocatable :: ProfForGemini - integer :: istore_for_new_outputs + integer :: istore_for_new_outputs, ier integer :: updown(NGLLZ) double precision , dimension(NGLLX,NGLLY,NGLLZ) :: longitud, latitud, radius @@ -900,16 +910,25 @@ subroutine earth_chunk_HEX27_Mesher(NGNOD) nspec = nel_lat * nel_lon * nel_depth npointot = 27 * nspec - allocate(xp(npointot), yp(npointot), zp(npointot)) - allocate(iglob(npointot), loc(npointot)) - allocate(ifseg(npointot)) - allocate(ProfForGemini(0:NZ-1,3)) - allocate(current_layer(0:NZ-1)) - allocate(inum_loc(3,3,3,nspec)) - allocate(xgrid(3,3,3,nspec), ygrid(3,3,3,nspec), zgrid(3,3,3,nspec)) - allocate(lon_zmin(nlon_dsm,nlat_dsm), lat_zmin(nlon_dsm,nlat_dsm)) + allocate(xp(npointot), yp(npointot), zp(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1294') + allocate(iglob(npointot), loc(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1295') + allocate(ifseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1296') + allocate(ProfForGemini(0:NZ-1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1297') + allocate(current_layer(0:NZ-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1298') + allocate(inum_loc(3,3,3,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1299') + allocate(xgrid(3,3,3,nspec), ygrid(3,3,3,nspec), zgrid(3,3,3,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1300') + allocate(lon_zmin(nlon_dsm,nlat_dsm), lat_zmin(nlon_dsm,nlat_dsm),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1301') ! boundary locator - allocate(iboun(6,nspec)) + allocate(iboun(6,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1302') iboun(:,:) = .false. @@ -1425,7 +1444,8 @@ subroutine earth_chunk_HEX27_Mesher(NGNOD) call getglob_for_chunk(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,NGNOD,UTM_X_MIN,UTM_X_MAX) deallocate(xp,yp,zp) - allocate(xp(nglob),yp(nglob),zp(nglob)) + allocate(xp(nglob),yp(nglob),zp(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1303') !! MODIF HEX27 LA ----------------------------- @@ -2189,12 +2209,14 @@ subroutine write_recdepth_dsm(Ndepth,R_EARTH,MESH) double precision R_EARTH,prof double precision, allocatable :: z(:) integer, allocatable :: zindex(:),ziflag(:) - integer ilayer,flag + integer ilayer,flag,ier character(len=10) MESH open(27,file=trim(MESH)//'.recdepth') - allocate(zindex(Ndepth),ziflag(Ndepth)) - allocate(z(Ndepth)) + allocate(zindex(Ndepth),ziflag(Ndepth),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1304') + allocate(z(Ndepth),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1305') do i=1,Ndepth read(27,*) prof,ilayer,flag @@ -2879,7 +2901,7 @@ subroutine getglob_for_chunk(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,NGNOD double precision UTM_X_MIN,UTM_X_MAX integer ispec,i,j - integer ieoff,ilocnum,nseg,ioff,iseg,ig + integer ieoff,ilocnum,nseg,ioff,iseg,ig,ier integer, dimension(:), allocatable :: ind,ninseg,iwork double precision, dimension(:), allocatable :: work @@ -2893,10 +2915,14 @@ subroutine getglob_for_chunk(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,NGNOD write(*,*) dabs(UTM_X_MAX - UTM_X_MIN) write(*,*) ' SMALLVALTOL ',SMALLVALTOL ! dynamically allocate arrays - allocate(ind(npointot)) - allocate(ninseg(npointot)) - allocate(iwork(npointot)) - allocate(work(npointot)) + allocate(ind(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1306') + allocate(ninseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1307') + allocate(iwork(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1308') + allocate(work(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1309') ! establish initial pointers (!! VM changed NGLLCUBE (as in Specfem3D Basin Version 1.1) to NGNOD !!) do ispec=1,nspec diff --git a/src/meshfem3D/meshfem3D.F90 b/src/meshfem3D/meshfem3D.F90 index 2b84b7501..e7e62fd05 100644 --- a/src/meshfem3D/meshfem3D.F90 +++ b/src/meshfem3D/meshfem3D.F90 @@ -386,20 +386,27 @@ program xmeshfem3D ! dynamic allocation of mesh arrays allocate(rns(0:2*NER),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1352') if (ier /= 0) stop 'Error allocating array rns' allocate(xgrid(0:2*NER,0:2*NEX_PER_PROC_XI,0:2*NEX_PER_PROC_ETA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1353') if (ier /= 0) stop 'Error allocating array xgrid' allocate(ygrid(0:2*NER,0:2*NEX_PER_PROC_XI,0:2*NEX_PER_PROC_ETA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1354') if (ier /= 0) stop 'Error allocating array ygrid' allocate(zgrid(0:2*NER,0:2*NEX_PER_PROC_XI,0:2*NEX_PER_PROC_ETA),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1355') if (ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays') allocate(addressing(0:NPROC_XI-1,0:NPROC_ETA-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1356') if (ier /= 0) stop 'Error allocating array addressing' allocate(iproc_xi_slice(0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1357') if (ier /= 0) stop 'Error allocating array iproc_xi_slice' allocate(iproc_eta_slice(0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1358') if (ier /= 0) stop 'Error allocating array iproc_eta_slice' ! clear arrays diff --git a/src/meshfem3D/read_mesh_parameter_file.f90 b/src/meshfem3D/read_mesh_parameter_file.f90 index 40a9f4ab2..dd8676fdc 100644 --- a/src/meshfem3D/read_mesh_parameter_file.f90 +++ b/src/meshfem3D/read_mesh_parameter_file.f90 @@ -119,6 +119,7 @@ subroutine read_mesh_parameter_file() ! allocate doubling array allocate(ner_doublings(NDOUBLINGS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1318') if (ier /= 0) stop 'Error allocating ner_doublings array' ner_doublings(:) = 0 @@ -167,6 +168,7 @@ subroutine read_mesh_parameter_file() ! read materials properties allocate(material_properties(NMATERIALS,7),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1319') if (ier /= 0) stop 'Error allocation of material_properties' material_properties(:,:) = 0.d0 do imat = 1,NMATERIALS @@ -188,6 +190,7 @@ subroutine read_mesh_parameter_file() ! read subregions properties allocate(subregions(NSUBREGIONS,7),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1320') if (ier /= 0) stop 'Error allocation of subregions' subregions(:,:) = 0 do ireg = 1,NSUBREGIONS diff --git a/src/meshfem3D/save_databases.F90 b/src/meshfem3D/save_databases.F90 index 3a9242073..7e228c00e 100644 --- a/src/meshfem3D/save_databases.F90 +++ b/src/meshfem3D/save_databases.F90 @@ -108,6 +108,7 @@ subroutine save_databases(prname,nspec,nglob,iproc_xi,iproc_eta, & ! assignes material index ! format: (1,ispec) = #material_id , (2,ispec) = #material_definition allocate(material_index(2,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1346') if (ier /= 0) stop 'Error allocating array material_index' material_index (:,:) = 0 do ispec = 1, nspec @@ -636,7 +637,7 @@ subroutine save_output_mesh_files_for_coupled_model(nspec, & double precision :: lat_center_chunk, lon_center_chunk, chunk_depth, chunk_azi double precision :: radius_of_box_top - integer :: ielm, j,k, imin,imax,jmin,jmax,kmin,kmax + integer :: ielm, j,k, imin,imax,jmin,jmax,kmin,kmax,ier integer :: nel_lat, nel_lon, nel_depth logical :: buried_box @@ -653,10 +654,14 @@ subroutine save_output_mesh_files_for_coupled_model(nspec, & z_bottom = 0. ! will shift coordinates in z-direction - allocate(longitud(NGLLX,NGLLY,NGLLZ), latitud(NGLLX,NGLLY,NGLLZ), radius(NGLLX,NGLLY,NGLLZ)) - allocate(xstore(NGLLX,NGLLY,NGLLZ), ystore(NGLLX,NGLLY,NGLLZ), zstore(NGLLX,NGLLY,NGLLZ)) - allocate(xelm(NGNOD), yelm(NGNOD), zelm(NGNOD)) - allocate(xigll(NGLLX), yigll(NGLLY), zigll(NGLLZ), wxgll(NGLLX),wygll(NGLLY), wzgll(NGLLZ)) + allocate(longitud(NGLLX,NGLLY,NGLLZ), latitud(NGLLX,NGLLY,NGLLZ), radius(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1347') + allocate(xstore(NGLLX,NGLLY,NGLLZ), ystore(NGLLX,NGLLY,NGLLZ), zstore(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1348') + allocate(xelm(NGNOD), yelm(NGNOD), zelm(NGNOD),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1349') + allocate(xigll(NGLLX), yigll(NGLLY), zigll(NGLLZ), wxgll(NGLLX),wygll(NGLLY), wzgll(NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1350') deg2rad = 3.141592653589793d0/180.d0 @@ -678,7 +683,8 @@ subroutine save_output_mesh_files_for_coupled_model(nspec, & ! !--- get the 3-D shape functions ! - allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)) + allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1351') call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll,NGNOD) ! diff --git a/src/shared/assemble_MPI_scalar.f90 b/src/shared/assemble_MPI_scalar.f90 index f045b5738..e5808d01f 100644 --- a/src/shared/assemble_MPI_scalar.f90 +++ b/src/shared/assemble_MPI_scalar.f90 @@ -64,12 +64,16 @@ subroutine assemble_MPI_scalar_blocking(NPROC,NGLOB_AB,array_val, & if (NPROC > 1) then allocate(buffer_send_scalar(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1190') if (ier /= 0) stop 'error allocating array buffer_send_scalar' allocate(buffer_recv_scalar(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1191') if (ier /= 0) stop 'error allocating array buffer_recv_scalar' allocate(request_send_scalar(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1192') if (ier /= 0) stop 'error allocating array request_send_scalar' allocate(request_recv_scalar(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1193') if (ier /= 0) stop 'error allocating array request_recv_scalar' ! partition border copy into the buffer @@ -158,12 +162,16 @@ subroutine assemble_MPI_scalar_i_blocking(NPROC,NGLOB_AB,array_val, & if (NPROC > 1) then allocate(buffer_send_scalar(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1194') if (ier /= 0) stop 'error allocating array buffer_send_scalar' allocate(buffer_recv_scalar(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1195') if (ier /= 0) stop 'error allocating array buffer_recv_scalar' allocate(request_send_scalar(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1196') if (ier /= 0) stop 'error allocating array request_send_scalar' allocate(request_recv_scalar(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1197') if (ier /= 0) stop 'error allocating array request_recv_scalar' ! partition border copy into the buffer diff --git a/src/shared/check_mesh_resolution.f90 b/src/shared/check_mesh_resolution.f90 index eb1f6525e..f3c8cd639 100644 --- a/src/shared/check_mesh_resolution.f90 +++ b/src/shared/check_mesh_resolution.f90 @@ -133,7 +133,9 @@ subroutine check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zs ! debug: for vtk output if (SAVE_MESH_FILES) then allocate(tmp1(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1229') allocate(tmp2(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1230') if (ier /= 0) stop 'error allocating array tmp' tmp1(:) = 0.0 tmp2(:) = 0.0 @@ -568,7 +570,9 @@ subroutine check_mesh_resolution_poro(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ysto ! debug: for vtk output if (SAVE_MESH_FILES) then allocate(tmp1(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1231') allocate(tmp2(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1232') if (ier /= 0) stop 'error allocating array tmp' tmp1(:) = 0.0 tmp2(:) = 0.0 diff --git a/src/shared/detect_surface.f90 b/src/shared/detect_surface.f90 index 147a85796..c18184ff8 100644 --- a/src/shared/detect_surface.f90 +++ b/src/shared/detect_surface.f90 @@ -65,6 +65,7 @@ subroutine detect_surface(NPROC,nglob,nspec,ibool, & ! detecting surface points/elements (based on valence check on NGLL points) for external mesh allocate(valence(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1223') if (ier /= 0) stop 'error allocate valence array' ! initialize surface indices @@ -293,6 +294,7 @@ subroutine detect_surface_cross_section(NPROC,nglob,nspec,ibool, & ! detecting surface points/elements (based on valence check on NGLL points) for external mesh allocate(valence(nglob),ispec_has_points(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1224') if (ier /= 0) stop 'error allocate valence array' ! an estimation of the minimum distance between global points (for an element width) @@ -706,6 +708,7 @@ subroutine detect_surface_PNM_image(NPROC,nglob,nspec,ibool, & ! detecting surface points/elements (based on valence check on NGLL points) for external mesh allocate(valence(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1225') if (ier /= 0) stop 'error allocate valence array' ! initialize surface indices diff --git a/src/shared/get_attenuation_model.f90 b/src/shared/get_attenuation_model.f90 index 2b3bd3465..a8b0809d5 100644 --- a/src/shared/get_attenuation_model.f90 +++ b/src/shared/get_attenuation_model.f90 @@ -179,12 +179,16 @@ subroutine get_attenuation_model(myrank,nspec,USE_OLSEN_ATTENUATION,OLSEN_ATTENU !----------------------------------------------------- ! initializes arrays - allocate(factor_common(N_SLS,NGLLX,NGLLY,NGLLZ,nspec)) + allocate(factor_common(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1182') allocate(scale_factor(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1183') if (ier /= 0) call exit_mpi(myrank,'error allocation attenuation arrays') - allocate(factor_common_kappa(N_SLS,NGLLX,NGLLY,NGLLZ,nspec)) + allocate(factor_common_kappa(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1184') allocate(scale_factor_kappa(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1185') if (ier /= 0) call exit_mpi(myrank,'error allocation attenuation arrays') factor_common(:,:,:,:,:) = 1._CUSTOM_REAL @@ -843,8 +847,10 @@ subroutine model_attenuation_storage(Qmu, tau_eps, rw) AM_S%Q_max = ATTENUATION_COMP_MAXIMUM Qtmp = AM_S%Q_resolution * AM_S%Q_max - allocate(AM_S%tau_eps_storage(N_SLS, Qtmp)) + allocate(AM_S%tau_eps_storage(N_SLS, Qtmp),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1186') allocate(AM_S%Qmu_storage(Qtmp),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1187') if (ier /= 0) stop 'error allocating arrays for attenuation storage' AM_S%Qmu_storage(:) = -1 endif @@ -1011,8 +1017,10 @@ subroutine attenuation_simplex_setup(nf_in,nsls_in,f_in,Q_in,tau_s_in) double precision, dimension(nsls_in) :: tau_s_in integer ier - allocate(AS_V%f(nf_in)) + allocate(AS_V%f(nf_in),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1188') allocate(AS_V%tau_s(nsls_in),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1189') if (ier /= 0) stop 'error allocating arrays for attenuation simplex' AS_V%nf = nf_in diff --git a/src/shared/get_global.f90 b/src/shared/get_global.f90 index a5081a023..c32e290c1 100644 --- a/src/shared/get_global.f90 +++ b/src/shared/get_global.f90 @@ -58,8 +58,10 @@ subroutine get_global(npointot,xp,yp,zp,iglob,locval,ifseg,nglob,UTM_X_MIN,UTM_X ! dynamically allocate arrays allocate(ninseg(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1236') if (ier /= 0) stop 'error allocating array ninseg' allocate(idummy(npointot),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1237') if (ier /= 0) stop 'error allocating array idummy' call sort_array_coordinates(npointot,xp,yp,zp,idummy,iglob,locval,ifseg, & @@ -100,8 +102,10 @@ subroutine get_global_indirect_addressing(nspec,nglob,ibool) ! copies original array allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1238') if (ier /= 0) call exit_MPI_without_rank('error in allocate') allocate(mask_ibool(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1239') if (ier /= 0) call exit_MPI_without_rank('error in allocate') mask_ibool(:) = -1 diff --git a/src/shared/prepare_assemble_MPI.f90 b/src/shared/prepare_assemble_MPI.f90 index 122afac0f..c83bfd093 100644 --- a/src/shared/prepare_assemble_MPI.f90 +++ b/src/shared/prepare_assemble_MPI.f90 @@ -77,6 +77,7 @@ subroutine prepare_assemble_MPI (nelmnts,knods, & ! initializes allocate(mask_ibool_ext_mesh(npoin), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1233') if (ier /= 0) call exit_MPI_without_rank('error allocating array') ibool_interfaces_ext_mesh(:,:) = 0 diff --git a/src/shared/safe_alloc_mod.f90 b/src/shared/safe_alloc_mod.f90 index 0ad18dc38..56d74c25b 100644 --- a/src/shared/safe_alloc_mod.f90 +++ b/src/shared/safe_alloc_mod.f90 @@ -191,6 +191,7 @@ subroutine safe_alloc_float_1d(array, dim1, usr_msg) integer :: ier allocate(array(dim1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1198') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_float_1d @@ -209,6 +210,7 @@ subroutine safe_alloc_float_2d(array, dim1, dim2, usr_msg) integer :: ier allocate(array(dim1, dim2), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1199') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_float_2d @@ -228,6 +230,7 @@ subroutine safe_alloc_float_3d(array, dim1, dim2, dim3, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1200') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_float_3d @@ -248,6 +251,7 @@ subroutine safe_alloc_float_4d(array, dim1, dim2, dim3, dim4, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1201') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_float_4d @@ -269,6 +273,7 @@ subroutine safe_alloc_float_5d(array, dim1, dim2, dim3, dim4, dim5, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4, dim5), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1202') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_float_5d @@ -286,6 +291,7 @@ subroutine safe_alloc_double_1d(array, dim1, usr_msg) integer :: ier allocate(array(dim1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1203') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_double_1d @@ -304,6 +310,7 @@ subroutine safe_alloc_double_2d(array, dim1, dim2, usr_msg) integer :: ier allocate(array(dim1, dim2), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1204') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_double_2d @@ -323,6 +330,7 @@ subroutine safe_alloc_double_3d(array, dim1, dim2, dim3, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1205') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_double_3d @@ -343,6 +351,7 @@ subroutine safe_alloc_double_4d(array, dim1, dim2, dim3, dim4, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1206') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_double_4d @@ -364,6 +373,7 @@ subroutine safe_alloc_double_5d(array, dim1, dim2, dim3, dim4, dim5, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4, dim5), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1207') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_double_5d @@ -381,6 +391,7 @@ subroutine safe_alloc_int_1d(array, dim1, usr_msg) integer :: ier allocate(array(dim1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1208') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_int_1d @@ -399,6 +410,7 @@ subroutine safe_alloc_int_2d(array, dim1, dim2, usr_msg) integer :: ier allocate(array(dim1, dim2), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1209') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_int_2d @@ -418,6 +430,7 @@ subroutine safe_alloc_int_3d(array, dim1, dim2, dim3, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1210') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_int_3d @@ -438,6 +451,7 @@ subroutine safe_alloc_int_4d(array, dim1, dim2, dim3, dim4, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1211') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_int_4d @@ -459,6 +473,7 @@ subroutine safe_alloc_int_5d(array, dim1, dim2, dim3, dim4, dim5, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4, dim5), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1212') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_int_5d @@ -476,6 +491,7 @@ subroutine safe_alloc_long_1d(array, dim1, usr_msg) integer :: ier allocate(array(dim1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1213') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_long_1d @@ -494,6 +510,7 @@ subroutine safe_alloc_long_2d(array, dim1, dim2, usr_msg) integer :: ier allocate(array(dim1, dim2), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1214') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_long_2d @@ -513,6 +530,7 @@ subroutine safe_alloc_long_3d(array, dim1, dim2, dim3, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1215') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_long_3d @@ -533,6 +551,7 @@ subroutine safe_alloc_long_4d(array, dim1, dim2, dim3, dim4, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1216') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_long_4d @@ -554,6 +573,7 @@ subroutine safe_alloc_long_5d(array, dim1, dim2, dim3, dim4, dim5, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4, dim5), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1217') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_long_5d @@ -666,6 +686,7 @@ subroutine safe_alloc_logical_1d(array, dim1, usr_msg) integer :: ier allocate(array(dim1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1218') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_logical_1d @@ -684,6 +705,7 @@ subroutine safe_alloc_logical_2d(array, dim1, dim2, usr_msg) integer :: ier allocate(array(dim1, dim2), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1219') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_logical_2d @@ -703,6 +725,7 @@ subroutine safe_alloc_logical_3d(array, dim1, dim2, dim3, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1220') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_logical_3d @@ -723,6 +746,7 @@ subroutine safe_alloc_logical_4d(array, dim1, dim2, dim3, dim4, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1221') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_logical_4d @@ -744,6 +768,7 @@ subroutine safe_alloc_logical_5d(array, dim1, dim2, dim3, dim4, dim5, usr_msg) integer :: ier allocate(array(dim1, dim2, dim3, dim4, dim5), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1222') call check_alloc_err(ier, usr_msg) end subroutine safe_alloc_logical_5d diff --git a/src/shared/search_kdtree.f90 b/src/shared/search_kdtree.f90 index cda42063a..5e63c8598 100644 --- a/src/shared/search_kdtree.f90 +++ b/src/shared/search_kdtree.f90 @@ -197,6 +197,7 @@ subroutine kdtree_setup() ! local ordering allocate(points_index(kdtree_num_nodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1226') if (ier /= 0) stop 'Error allocating array points_index' ! initial point ordering @@ -658,6 +659,7 @@ recursive subroutine create_kdtree(npoints,points_data,points_index,node, & ! creates new node allocate(node,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1227') if (ier /= 0) then print *,'Error creating node: ',numnodes stop 'Error allocating kd-tree node' @@ -733,6 +735,7 @@ recursive subroutine create_kdtree(npoints,points_data,points_index,node, & ! temporary index array for sorting allocate(workindex(ibound_upper - ibound_lower + 1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1228') if (ier /= 0) stop 'Error allocating workindex array' ! sorts point indices diff --git a/src/shared/write_VTK_data.f90 b/src/shared/write_VTK_data.f90 index 25c53677e..c692b7440 100644 --- a/src/shared/write_VTK_data.f90 +++ b/src/shared/write_VTK_data.f90 @@ -223,6 +223,7 @@ subroutine write_VTK_data_gll_cr(nspec,nglob, & ! iflag field on global nodeset if (.not. allocated(mask_ibool)) then allocate(mask_ibool(nglob),flag_val(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1234') if (ier /= 0) stop 'error allocating mask' endif @@ -313,6 +314,7 @@ subroutine write_VTK_data_gll_i(nspec,nglob, & ! iflag field on global nodeset allocate(mask_ibool(nglob),flag_val(nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1235') if (ier /= 0) stop 'error allocating mask' mask_ibool = .false. diff --git a/src/specfem3D/assemble_MPI_vector.f90 b/src/specfem3D/assemble_MPI_vector.f90 index a08e7a694..e01532b42 100644 --- a/src/specfem3D/assemble_MPI_vector.f90 +++ b/src/specfem3D/assemble_MPI_vector.f90 @@ -69,12 +69,16 @@ subroutine assemble_MPI_vector_blocking(NPROC,NGLOB_AB,array_val, & if (NPROC > 1) then allocate(buffer_send_vector(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1985') if (ier /= 0) stop 'error allocating array buffer_send_vector' allocate(buffer_recv_vector(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1986') if (ier /= 0) stop 'error allocating array buffer_recv_vector' allocate(request_send_vector(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1987') if (ier /= 0) stop 'error allocating array request_send_vector' allocate(request_recv_vector(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1988') if (ier /= 0) stop 'error allocating array request_recv_vector' ! partition border copy into the buffer @@ -170,12 +174,16 @@ subroutine synchronize_MPI_vector_blocking_ord(NPROC,NGLOB_AB,array_val, & if (NPROC > 1) then allocate(buffer_send_vector(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1989') if (ier /= 0) stop 'error allocating array buffer_send_vector' allocate(buffer_recv_vector(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1990') if (ier /= 0) stop 'error allocating array buffer_recv_vector' allocate(request_send_vector(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1991') if (ier /= 0) stop 'error allocating array request_send_vector' allocate(request_recv_vector(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1992') if (ier /= 0) stop 'error allocating array request_recv_vector' ! partition border copy into the buffer diff --git a/src/specfem3D/couple_with_injection.f90 b/src/specfem3D/couple_with_injection.f90 index dca1f8f10..d34fe7080 100644 --- a/src/specfem3D/couple_with_injection.f90 +++ b/src/specfem3D/couple_with_injection.f90 @@ -97,8 +97,10 @@ subroutine couple_with_injection_setup() if (INJECTION_TECHNIQUE_TYPE == INJECTION_TECHNIQUE_IS_DSM) then - allocate(Veloc_dsm_boundary(3,Ntime_step_dsm,NGLLSQUARE,num_abs_boundary_faces)) - allocate(Tract_dsm_boundary(3,Ntime_step_dsm,NGLLSQUARE,num_abs_boundary_faces)) + allocate(Veloc_dsm_boundary(3,Ntime_step_dsm,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2190') + allocate(Tract_dsm_boundary(3,Ntime_step_dsm,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2191') if (old_DSM_coupling_from_Vadim) then open(unit=IIN_veloc_dsm,file=dsmname(1:len_trim(dsmname))//'vel.bin',status='old', & @@ -111,8 +113,10 @@ subroutine couple_with_injection_setup() else if (INJECTION_TECHNIQUE_TYPE == INJECTION_TECHNIQUE_IS_AXISEM) then - allocate(Veloc_axisem(3,NGLLSQUARE*num_abs_boundary_faces)) - allocate(Tract_axisem(3,NGLLSQUARE*num_abs_boundary_faces)) + allocate(Veloc_axisem(3,NGLLSQUARE*num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2192') + allocate(Tract_axisem(3,NGLLSQUARE*num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2193') open(unit=IIN_veloc_dsm,file=dsmname(1:len_trim(dsmname))//'sol_axisem',status='old', & action='read',form='unformatted',iostat=ier) @@ -121,10 +125,14 @@ subroutine couple_with_injection_setup() !! CD CD added this if (RECIPROCITY_AND_KH_INTEGRAL) then - allocate(Displ_axisem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP)) - allocate(Tract_axisem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP)) - allocate(Tract_specfem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP)) - allocate(Displ_specfem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP)) + allocate(Displ_axisem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2194') + allocate(Tract_axisem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2195') + allocate(Tract_specfem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2196') + allocate(Displ_specfem_time(3,NGLLSQUARE*num_abs_boundary_faces,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2197') if (.not. SAVE_RUN_BOUN_FOR_KH_INTEGRAL) then !! We only read Specfem Tract and Displ, and Axisem Displ (Axisem Tract is read in compute_stacey_visco...) @@ -148,10 +156,14 @@ subroutine couple_with_injection_setup() else ! dummy arrays - allocate(Veloc_dsm_boundary(1,1,1,1)) - allocate(Tract_dsm_boundary(1,1,1,1)) - allocate(Veloc_axisem(1,1)) - allocate(Tract_axisem(1,1)) + allocate(Veloc_dsm_boundary(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2198') + allocate(Tract_dsm_boundary(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2199') + allocate(Veloc_axisem(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2200') + allocate(Tract_axisem(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2201') endif !! CD CD add this : @@ -215,11 +227,15 @@ subroutine couple_with_injection_prepare_boundary() !! allocate memory for FK solution if (npt > 0) then - allocate(nbdglb(npt)) - allocate(vx_FK(npt),vy_FK(npt),vz_FK(npt),tx_FK(npt),ty_FK(npt),tz_FK(npt)) + allocate(nbdglb(npt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2202') + allocate(vx_FK(npt),vy_FK(npt),vz_FK(npt),tx_FK(npt),ty_FK(npt),tz_FK(npt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2203') else - allocate(nbdglb(1)) - allocate(vx_FK(1),vy_FK(1),vz_FK(1),tx_FK(1),ty_FK(1),tz_FK(1)) + allocate(nbdglb(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2204') + allocate(vx_FK(1),vy_FK(1),vz_FK(1),tx_FK(1),ty_FK(1),tz_FK(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2205') endif call FindBoundaryBox(Xmin_box, Xmax_box, Ymin_box, Ymax_box, Zmin_box, Zmax_box) @@ -231,10 +247,14 @@ subroutine couple_with_injection_prepare_boundary() call bcast_all_singlei(nlayer) if (myrank > 0) then - allocate(al_FK(nlayer)) - allocate(be_FK(nlayer)) - allocate(mu_FK(nlayer)) - allocate(h_FK(nlayer)) + allocate(al_FK(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2206') + allocate(be_FK(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2207') + allocate(mu_FK(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2208') + allocate(h_FK(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2209') endif call bcast_all_cr(al_FK, nlayer) @@ -299,26 +319,32 @@ subroutine couple_with_injection_prepare_boundary() !! arrays for storing FK solution -------------------------------------------- allocate(VX_t(npt, -NP_RESAMP:NF_FOR_STORING+NP_RESAMP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2210') if (ier /= 0) stop 'error while allocating VX_t' VX_t(:,:)=0._CUSTOM_REAL allocate(VY_t(npt, -NP_RESAMP:NF_FOR_STORING+NP_RESAMP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2211') if (ier /= 0) stop 'error while allocating VY_t' VY_t(:,:)=0._CUSTOM_REAL allocate(VZ_t(npt, -NP_RESAMP:NF_FOR_STORING+NP_RESAMP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2212') if (ier /= 0) stop 'error while allocating VZ_t' VZ_t(:,:)=0._CUSTOM_REAL allocate(TX_t(npt, -NP_RESAMP:NF_FOR_STORING+NP_RESAMP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2213') if (ier /= 0) stop 'error while allocating TX_t' TX_t(:,:)=0._CUSTOM_REAL allocate(TY_t(npt, -NP_RESAMP:NF_FOR_STORING+NP_RESAMP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2214') if (ier /= 0) stop 'error while allocating TY_t' TY_t(:,:)=0._CUSTOM_REAL allocate(TZ_t(npt, -NP_RESAMP:NF_FOR_STORING+NP_RESAMP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2215') if (ier /= 0) stop 'error while allocating TZ_t' TZ_t(:,:)=0._CUSTOM_REAL @@ -423,13 +449,15 @@ subroutine FK3D(NSPEC_AB, ibool, abs_boundary_ijk, abs_boundary_normal, & real(kind=CUSTOM_REAL),dimension(3,NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_normal ! local parameters - integer :: ispec,iglob,i,j,k,iface,igll + integer :: ispec,iglob,i,j,k,iface,igll,ier ! absorbs absorbing-boundary surface using Stacey condition (Clayton and Enquist) if (npt > 0) then - allocate(xx(npt),yy(npt),zz(npt),xi1(npt),xim(npt),bdlambdamu(npt),nmx(npt),nmy(npt),nmz(npt)) + allocate(xx(npt),yy(npt),zz(npt),xi1(npt),xim(npt),bdlambdamu(npt),nmx(npt),nmy(npt),nmz(npt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2216') else - allocate(xx(1),yy(1),zz(1),xi1(1),xim(1),bdlambdamu(1),nmx(1),nmy(1),nmz(1)) + allocate(xx(1),yy(1),zz(1),xi1(1),xim(1),bdlambdamu(1),nmx(1),nmy(1),nmz(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2217') endif nbdglb(:) = 0 @@ -569,28 +597,35 @@ subroutine FK(al, be, mu, h, nlayer, Tg, p, phi, x0, y0, z0, t0, dt, npts, np, & !! allocate(fvec(nf2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2218') fvec = 0. do ii = 1, nf2 fvec(ii)=(ii-1)*df enddo allocate(coeff(2,nf2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2219') if (ier /= 0) stop 'error while allocating' allocate(field_f(nf,nvar),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2220') if (ier /= 0) stop 'error while allocating' allocate(field(npts2,nvar),dtmp(npts),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2221') if (ier /= 0) stop 'error while allocating' !! allocate debug vectors allocate(tmp_f1(npts2), tmp_f2(npts2), tmp_f3(npts2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2222') if (ier /= 0) stop 'error while allocating' allocate(tmp_t1(npts2), tmp_t2(npts2), tmp_t3(npts2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2223') if (ier /= 0) stop 'error while allocating' - allocate(tmp_it1(npoints2)) + allocate(tmp_it1(npoints2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2224') NPTS_STORED = npts2 NPTS_INTERP = npoints2 @@ -1258,9 +1293,10 @@ subroutine compute_spline_coef_to_store(Sig, npts, spline_coeff) double precision :: error=1.d-24 double precision :: z1, zn, sumc double precision, dimension(:), allocatable :: c - integer :: i, n_init + integer :: i, n_init, ier - allocate(c(npts)) + allocate(c(npts),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2225') ! Compute pole value z1 = dsqrt(3.d0)-2.d0 @@ -1317,7 +1353,7 @@ subroutine ReadFKModelInput(Xmin_box, Xmax_box, Ymin_box, Ymax_box, Zmin_box) real(kind=CUSTOM_REAL) :: Radius_box, wave_length_at_bottom real(kind=CUSTOM_REAL), dimension(:), allocatable :: rho_fk_input, vp_fk_input, vs_fk_input, ztop_fk_input integer, dimension(:), allocatable :: ilayer_fk_input - integer :: ilayer + integer :: ilayer,ier logical :: position_of_wavefront_not_read !!-------------------------------------------------------------- @@ -1361,12 +1397,18 @@ subroutine ReadFKModelInput(Xmin_box, Xmax_box, Ymin_box, Ymax_box, Zmin_box) case('NLAYER') read(line, *) keyword_tmp, nlayer - allocate(al_FK(nlayer), be_FK(nlayer), mu_FK(nlayer), h_FK(nlayer)) - allocate(rho_fk_input(nlayer)) - allocate(vp_fk_input(nlayer)) - allocate(vs_fk_input(nlayer)) - allocate(ztop_fk_input(nlayer+1)) - allocate(ilayer_fk_input(nlayer+1)) + allocate(al_FK(nlayer), be_FK(nlayer), mu_FK(nlayer), h_FK(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2226') + allocate(rho_fk_input(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2227') + allocate(vp_fk_input(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2228') + allocate(vs_fk_input(nlayer),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2229') + allocate(ztop_fk_input(nlayer+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2230') + allocate(ilayer_fk_input(nlayer+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2231') ilayer_fk_input(:)=-1 case('LAYER') diff --git a/src/specfem3D/create_color_image.f90 b/src/specfem3D/create_color_image.f90 index 06ad02b4a..b9c45b008 100644 --- a/src/specfem3D/create_color_image.f90 +++ b/src/specfem3D/create_color_image.f90 @@ -153,6 +153,7 @@ subroutine write_PNM_initialize() ! finds global points on image surface allocate(ispec_is_image_surface(NSPEC_AB),iglob_is_image_surface(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1766') if (ier /= 0) call exit_mpi(myrank,'error allocating image ispec and iglob') call detect_surface_PNM_image(NPROC,NGLOB_AB,NSPEC_AB,ibool, & @@ -167,10 +168,14 @@ subroutine write_PNM_initialize() xstore,ystore,zstore,myrank) ! extracts points on surface - allocate(xcoord(num_iglob_image_surface)) - allocate(zcoord(num_iglob_image_surface)) - allocate(iglob_coord(num_iglob_image_surface)) + allocate(xcoord(num_iglob_image_surface),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1767') + allocate(zcoord(num_iglob_image_surface),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1768') + allocate(iglob_coord(num_iglob_image_surface),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1769') allocate(ispec_coord(num_iglob_image_surface),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1770') if (ier /= 0) call exit_mpi(myrank,'error allocating xyz image coordinates') countval=0 @@ -281,11 +286,14 @@ subroutine write_PNM_initialize() endif ! allocate an array for the grid point that corresponds to a given image data point - allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color)) + allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1771') allocate(ispec_image_color(NX_IMAGE_color,NZ_IMAGE_color),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1772') if (ier /= 0) call exit_mpi(myrank,'error allocating iglob_image_color') allocate(dist_pixel_image(NX_IMAGE_color,NZ_IMAGE_color),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1773') if (ier /= 0) call exit_mpi(myrank,'error allocating dist pixel image') iglob_image_color(:,:) = -1 @@ -346,6 +354,7 @@ subroutine write_PNM_initialize() ! gather info from other processes as well allocate(dist_pixel_recv(NX_IMAGE_color,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1774') if (ier /= 0) call exit_mpi(myrank,'error allocating dist pixel recv') dist_pixel_recv(:,:) = HUGEVAL nb_pixel_loc = 0 @@ -375,6 +384,7 @@ subroutine write_PNM_initialize() ! pixel owned by the local process (useful for parallel jobs) if (nb_pixel_loc > 0) then allocate(num_pixel_loc(nb_pixel_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1775') if (ier /= 0) stop 'error allocating array num_pixel_loc' endif nb_pixel_loc = 0 @@ -393,6 +403,7 @@ subroutine write_PNM_initialize() ! filling array iglob_image_color, containing info on which process owns which pixels. allocate(nb_pixel_per_proc(0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1776') if (ier /= 0) stop 'error allocating array nb_pixel_per_proc' call gather_all_singlei(nb_pixel_loc,tmp_pixel_per_proc,NPROC) @@ -401,6 +412,7 @@ subroutine write_PNM_initialize() ! allocates receiving array if (myrank == 0) then allocate( num_pixel_recv(maxval(nb_pixel_per_proc(:)),0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1777') if (ier /= 0) stop 'error allocating array num_pixel_recv' endif ! fills iglob_image_color index array @@ -425,8 +437,10 @@ subroutine write_PNM_initialize() endif ! allocate an array for image data - allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color)) + allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1778') allocate(image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1779') if (ier /= 0) call exit_mpi(myrank,'error allocating image data') image_color_data(:,:) = 0._CUSTOM_REAL @@ -434,11 +448,13 @@ subroutine write_PNM_initialize() if (myrank == 0) then allocate( data_pixel_recv(maxval(nb_pixel_per_proc(:))),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1780') if (ier /= 0) stop 'error allocating array data_pixel_recv' data_pixel_recv(:) = 0._CUSTOM_REAL endif if (nb_pixel_loc > 0) then allocate(data_pixel_send(nb_pixel_loc),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1781') if (ier /= 0) call exit_mpi(myrank,'error allocating image send data') data_pixel_send(:) = 0._CUSTOM_REAL endif diff --git a/src/specfem3D/detect_mesh_surfaces.f90 b/src/specfem3D/detect_mesh_surfaces.f90 index d2659257a..42faed7c3 100644 --- a/src/specfem3D/detect_mesh_surfaces.f90 +++ b/src/specfem3D/detect_mesh_surfaces.f90 @@ -73,17 +73,24 @@ subroutine detect_mesh_surfaces() if (MOVIE_VOLUME) then ! acoustic if (ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION) then - allocate(velocity_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(velocity_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(velocity_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1731') + allocate(velocity_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1732') allocate(velocity_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1733') if (ier /= 0) stop 'error allocating array movie velocity_x etc.' endif ! elastic only if (ELASTIC_SIMULATION) then - allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1734') + allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1735') + allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1736') allocate(curl_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1737') if (ier /= 0) stop 'error allocating array movie div and curl' div(:,:,:,:) = 0._CUSTOM_REAL curl_x(:,:,:,:) = 0._CUSTOM_REAL diff --git a/src/specfem3D/fault_solver_common.f90 b/src/specfem3D/fault_solver_common.f90 index 6b914ae2b..9085dff3b 100644 --- a/src/specfem3D/fault_solver_common.f90 +++ b/src/specfem3D/fault_solver_common.f90 @@ -126,24 +126,35 @@ subroutine initialize_fault (bc,IIN_BIN) real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: normal real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: nxyz integer, dimension(:,:), allocatable :: ibool1 - integer :: ij,k,e + integer :: ij,k,e,ier read(IIN_BIN) bc%nspec,bc%nglob if (.not. PARALLEL_FAULT .and. bc%nspec == 0) return if (bc%nspec > 0) then - allocate(bc%ibulk1(bc%nglob)) - allocate(bc%ibulk2(bc%nglob)) - allocate(bc%R(3,3,bc%nglob)) - allocate(bc%coord(3,(bc%nglob))) - allocate(bc%invM1(bc%nglob)) - allocate(bc%invM2(bc%nglob)) - allocate(bc%B(bc%nglob)) - allocate(bc%Z(bc%nglob)) - - allocate(ibool1(NGLLSQUARE,bc%nspec)) - allocate(normal(NDIM,NGLLSQUARE,bc%nspec)) - allocate(jacobian2Dw(NGLLSQUARE,bc%nspec)) + allocate(bc%ibulk1(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2159') + allocate(bc%ibulk2(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2160') + allocate(bc%R(3,3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2161') + allocate(bc%coord(3,(bc%nglob)),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2162') + allocate(bc%invM1(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2163') + allocate(bc%invM2(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2164') + allocate(bc%B(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2165') + allocate(bc%Z(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2166') + + allocate(ibool1(NGLLSQUARE,bc%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2167') + allocate(normal(NDIM,NGLLSQUARE,bc%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2168') + allocate(jacobian2Dw(NGLLSQUARE,bc%nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2169') read(IIN_BIN) ibool1 read(IIN_BIN) jacobian2Dw @@ -157,7 +168,8 @@ subroutine initialize_fault (bc,IIN_BIN) bc%dt = dt bc%B = 0e0_CUSTOM_REAL - allocate(nxyz(3,bc%nglob)) + allocate(nxyz(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2170') nxyz = 0e0_CUSTOM_REAL do e=1,bc%nspec do ij = 1,NGLLSQUARE @@ -393,10 +405,13 @@ subroutine init_dataT(dataT,coord,nglob,NT,DT,ndat,iflt) if (dataT%npoin == 0) return - allocate(dataT%iglob(dataT%npoin)) - allocate(dataT%name(dataT%npoin)) + allocate(dataT%iglob(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2171') + allocate(dataT%name(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2172') ! Surendra: for parallel fault - allocate(dist_loc(dataT%npoin)) + allocate(dist_loc(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2173') open(IIN,file=IN_DATA_FILES(1:len_trim(IN_DATA_FILES))//'FAULT_STATIONS',status='old',action='read') read(IIN,*) np @@ -426,9 +441,12 @@ subroutine init_dataT(dataT,coord,nglob,NT,DT,ndat,iflt) if (PARALLEL_FAULT) then ! For each output point, find the processor that contains the nearest node - allocate(iproc(dataT%npoin)) - allocate(iglob_all(dataT%npoin,0:NPROC-1)) - allocate(dist_all(dataT%npoin,0:NPROC-1)) + allocate(iproc(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2174') + allocate(iglob_all(dataT%npoin,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2175') + allocate(dist_all(dataT%npoin,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2176') call gather_all_i(dataT%iglob,dataT%npoin,iglob_all,dataT%npoin,NPROC) call gather_all_cr(dist_loc,dataT%npoin,dist_all,dataT%npoin,NPROC) if (myrank == 0) then @@ -446,7 +464,8 @@ subroutine init_dataT(dataT,coord,nglob,NT,DT,ndat,iflt) if (npoin_local > 0) then ! Make a list of output points contained in the current processor - allocate(glob_indx(npoin_local)) + allocate(glob_indx(npoin_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2177') ipoin_local = 0 do ipoin = 1,dataT%npoin if (myrank == iproc(ipoin)) then @@ -455,15 +474,19 @@ subroutine init_dataT(dataT,coord,nglob,NT,DT,ndat,iflt) endif enddo ! Consolidate the output information (remove output points outside current proc) - allocate(iglob_tmp(dataT%npoin)) - allocate(name_tmp(dataT%npoin)) + allocate(iglob_tmp(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2178') + allocate(name_tmp(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2179') iglob_tmp = dataT%iglob name_tmp = dataT%name deallocate(dataT%iglob) deallocate(dataT%name) dataT%npoin = npoin_local - allocate(dataT%iglob(dataT%npoin)) - allocate(dataT%name(dataT%npoin)) + allocate(dataT%iglob(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2180') + allocate(dataT%name(dataT%npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2181') dataT%iglob = iglob_tmp(glob_indx) dataT%name = name_tmp(glob_indx) deallocate(glob_indx,iglob_tmp,name_tmp) @@ -482,9 +505,11 @@ subroutine init_dataT(dataT,coord,nglob,NT,DT,ndat,iflt) dataT%ndat = ndat dataT%nt = NT dataT%dt = DT - allocate(dataT%dat(dataT%ndat,dataT%npoin,dataT%nt)) + allocate(dataT%dat(dataT%ndat,dataT%npoin,dataT%nt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2182') dataT%dat = 0e0_CUSTOM_REAL - allocate(dataT%longFieldNames(dataT%ndat)) + allocate(dataT%longFieldNames(dataT%ndat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2183') dataT%longFieldNames(1) = "horizontal right-lateral slip (m)" dataT%longFieldNames(2) = "horizontal right-lateral slip rate (m/s)" dataT%longFieldNames(3) = "horizontal right-lateral shear stress (MPa)" diff --git a/src/specfem3D/fault_solver_dynamic.f90 b/src/specfem3D/fault_solver_dynamic.f90 index 29fa5590d..c39c31fd5 100644 --- a/src/specfem3D/fault_solver_dynamic.f90 +++ b/src/specfem3D/fault_solver_dynamic.f90 @@ -164,7 +164,8 @@ subroutine BC_DYNFLT_init(prname,DTglobal,myrank) read(IIN_BIN) nbfaults ! should be the same as in IIN_PAR Nfaults = nbfaults - allocate( faults(nbfaults) ) + allocate( faults(nbfaults) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1361') dt = real(DTglobal) read(IIN_PAR,nml=RUPTURE_SWITCHES,end=110,iostat=ier) if (ier /= 0) write(*,*) 'RUPTURE_SWITCHES not found in Par_file_faults' @@ -183,7 +184,8 @@ subroutine BC_DYNFLT_init(prname,DTglobal,myrank) endif read(IIN_BIN) size_Kelvin_Voigt if (size_Kelvin_Voigt > 0) then - allocate(Kelvin_Voigt_eta(size_Kelvin_Voigt)) + allocate(Kelvin_Voigt_eta(size_Kelvin_Voigt),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1362') read(IIN_BIN) Kelvin_Voigt_eta endif close(IIN_BIN) @@ -237,7 +239,7 @@ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,dt,NT,iflt,myrank) integer, intent(in) :: myrank real(kind=CUSTOM_REAL) :: S1,S2,S3,Sigma(6) - integer :: n1,n2,n3 + integer :: n1,n2,n3,ier logical :: LOAD_STRESSDROP = .false. NAMELIST / INIT_STRESS / S1,S2,S3,n1,n2,n3 @@ -247,15 +249,19 @@ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,dt,NT,iflt,myrank) if (bc%nspec > 0) then - allocate(bc%T(3,bc%nglob)) - allocate(bc%D(3,bc%nglob)) - allocate(bc%V(3,bc%nglob)) + allocate(bc%T(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1363') + allocate(bc%D(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1364') + allocate(bc%V(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1365') bc%T = 0e0_CUSTOM_REAL bc%D = 0e0_CUSTOM_REAL bc%V = 0e0_CUSTOM_REAL ! Set initial fault stresses - allocate(bc%T0(3,bc%nglob)) + allocate(bc%T0(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1366') S1 = 0e0_CUSTOM_REAL S2 = 0e0_CUSTOM_REAL S3 = 0e0_CUSTOM_REAL @@ -286,12 +292,15 @@ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,dt,NT,iflt,myrank) ! enddo ! Set friction parameters and initialize friction variables - allocate(bc%MU(bc%nglob)) + allocate(bc%MU(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1367') if (RATE_AND_STATE) then - allocate(bc%rsf) + allocate(bc%rsf,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1368') call rsf_init(bc%rsf,bc%T0,bc%V,bc%Fload,bc%coord,IIN_PAR) else - allocate(bc%swf) + allocate(bc%swf,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1369') call swf_init(bc%swf,bc%MU,bc%coord,IIN_PAR) if (TPV16) call TPV16_init() !WARNING: ad hoc, initializes T0 and swf endif @@ -834,19 +843,25 @@ subroutine swf_init(f,mu,coord,IIN_PAR) real(kind=CUSTOM_REAL), intent(in) :: coord(:,:) integer, intent(in) :: IIN_PAR - integer :: nglob + integer :: nglob,ier real(kind=CUSTOM_REAL) :: mus,mud,dc,C,T integer :: nmus,nmud,ndc,nC,nForcedRup NAMELIST / SWF / mus,mud,dc,nmus,nmud,ndc,C,T,nC,nForcedRup nglob = size(mu) - allocate( f%mus(nglob) ) - allocate( f%mud(nglob) ) - allocate( f%Dc(nglob) ) - allocate( f%theta(nglob) ) - allocate( f%C(nglob) ) - allocate( f%T(nglob) ) + allocate( f%mus(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1370') + allocate( f%mud(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1371') + allocate( f%Dc(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1372') + allocate( f%theta(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1373') + allocate( f%C(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1374') + allocate( f%T(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1375') ! WARNING: if V_HEALING is negative we turn off healing f%healing = (V_HEALING > 0e0_CUSTOM_REAL) @@ -968,7 +983,7 @@ subroutine rsf_init(f,T0,V,nucFload,coord,IIN_PAR) real(kind=CUSTOM_REAL) :: Fload integer :: nFload ! real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: init_vel - integer :: nglob + integer :: nglob,ier integer :: InputStateLaw = 1 ! By default using aging law NAMELIST / RSF / V0,f0,a,b,L,V_init,theta_init,nV0,nf0,na,nb,nL,nV_init,ntheta_init,C,T,nC,nForcedRup,Vw,fw,nVw,nfw,InputStateLaw @@ -978,17 +993,28 @@ subroutine rsf_init(f,T0,V,nucFload,coord,IIN_PAR) f%StateLaw = InputStateLaw - allocate( f%V0(nglob) ) - allocate( f%f0(nglob) ) - allocate( f%a(nglob) ) - allocate( f%b(nglob) ) - allocate( f%L(nglob) ) - allocate( f%V_init(nglob) ) - allocate( f%theta(nglob) ) - allocate( f%C(nglob) ) - allocate( f%T(nglob) ) - allocate( f%fw(nglob) ) - allocate( f%Vw(nglob) ) + allocate( f%V0(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1376') + allocate( f%f0(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1377') + allocate( f%a(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1378') + allocate( f%b(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1379') + allocate( f%L(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1380') + allocate( f%V_init(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1381') + allocate( f%theta(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1382') + allocate( f%C(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1383') + allocate( f%T(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1384') + allocate( f%fw(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1385') + allocate( f%Vw(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1386') V0 =1.e-6_CUSTOM_REAL f0 =0.6_CUSTOM_REAL @@ -1065,7 +1091,8 @@ subroutine rsf_init(f,T0,V,nucFload,coord,IIN_PAR) endif endif ! WARNING : ad hoc for SCEC benchmark TPV10x - allocate( nucFload(nglob) ) + allocate( nucFload(nglob) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1387') Fload = 0.e0_CUSTOM_REAL nFload = 0 read(IIN_PAR, nml=ASP) @@ -1103,19 +1130,32 @@ subroutine RSF_HETE_init() snum_cell_all=snum_cell_str*snum_cell_dip write(6,*) snum_cell_str,snum_cell_dip,ssiz_str,ssiz_dip - allocate( sloc_str(snum_cell_all) ) - allocate( sloc_dip(snum_cell_all) ) - allocate( ssigma0(snum_cell_all) ) - allocate( stau0_str(snum_cell_all) ) - allocate( stau0_dip(snum_cell_all) ) - allocate( sV0(snum_cell_all) ) - allocate( sf0(snum_cell_all) ) - allocate( sa(snum_cell_all) ) - allocate( sb(snum_cell_all) ) - allocate( sL(snum_cell_all) ) - allocate( sV_init(snum_cell_all) ) - allocate( stheta(snum_cell_all) ) - allocate( sC(snum_cell_all) ) + allocate( sloc_str(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1388') + allocate( sloc_dip(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1389') + allocate( ssigma0(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1390') + allocate( stau0_str(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1391') + allocate( stau0_dip(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1392') + allocate( sV0(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1393') + allocate( sf0(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1394') + allocate( sa(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1395') + allocate( sb(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1396') + allocate( sL(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1397') + allocate( sV_init(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1398') + allocate( stheta(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1399') + allocate( sC(snum_cell_all) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1400') do ipar=1,snum_cell_all read(sIIN_NUC,*) sloc_str(ipar),sloc_dip(ipar),ssigma0(ipar),stau0_str(ipar),stau0_dip(ipar), & @@ -1323,13 +1363,14 @@ subroutine init_dataXZ(dataXZ,bc) type(dataXZ_type), intent(inout) :: dataXZ type(bc_dynandkinflt_type) :: bc - integer :: npoin_all,iproc + integer :: npoin_all,iproc,ier dataXZ%npoin = bc%nglob if (bc%nglob > 0) then - allocate(dataXZ%stg(bc%nglob)) + allocate(dataXZ%stg(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1401') if (.not. RATE_AND_STATE) then dataXZ%sta => bc%swf%theta else @@ -1345,8 +1386,10 @@ subroutine init_dataXZ(dataXZ,bc) dataXZ%xcoord => bc%coord(1,:) dataXZ%ycoord => bc%coord(2,:) dataXZ%zcoord => bc%coord(3,:) - allocate(dataXZ%tRUP(bc%nglob)) - allocate(dataXZ%tPZ(bc%nglob)) + allocate(dataXZ%tRUP(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1402') + allocate(dataXZ%tPZ(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1403') !Percy, setting up initial rupture time null dataXZ%tRUP = 0e0_CUSTOM_REAL @@ -1360,31 +1403,47 @@ subroutine init_dataXZ(dataXZ,bc) call sum_all_i(bc%nglob,npoin_all) if (myrank == 0 .and. npoin_all > 0) then bc%dataXZ_all%npoin = npoin_all - allocate(bc%dataXZ_all%xcoord(npoin_all)) - allocate(bc%dataXZ_all%ycoord(npoin_all)) - allocate(bc%dataXZ_all%zcoord(npoin_all)) - allocate(bc%dataXZ_all%t1(npoin_all)) - allocate(bc%dataXZ_all%t2(npoin_all)) - allocate(bc%dataXZ_all%t3(npoin_all)) - allocate(bc%dataXZ_all%d1(npoin_all)) - allocate(bc%dataXZ_all%d2(npoin_all)) - allocate(bc%dataXZ_all%v1(npoin_all)) - allocate(bc%dataXZ_all%v2(npoin_all)) - allocate(bc%dataXZ_all%tRUP(npoin_all)) - allocate(bc%dataXZ_all%tPZ(npoin_all)) - allocate(bc%dataXZ_all%stg(npoin_all)) - allocate(bc%dataXZ_all%sta(npoin_all)) + allocate(bc%dataXZ_all%xcoord(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1404') + allocate(bc%dataXZ_all%ycoord(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1405') + allocate(bc%dataXZ_all%zcoord(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1406') + allocate(bc%dataXZ_all%t1(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1407') + allocate(bc%dataXZ_all%t2(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1408') + allocate(bc%dataXZ_all%t3(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1409') + allocate(bc%dataXZ_all%d1(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1410') + allocate(bc%dataXZ_all%d2(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1411') + allocate(bc%dataXZ_all%v1(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1412') + allocate(bc%dataXZ_all%v2(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1413') + allocate(bc%dataXZ_all%tRUP(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1414') + allocate(bc%dataXZ_all%tPZ(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1415') + allocate(bc%dataXZ_all%stg(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1416') + allocate(bc%dataXZ_all%sta(npoin_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1417') endif !note: crayftn compiler warns about possible copy which may slow down the code for dataXZ%npoin,dataXZ%xcoord,.. !ftn-1438 crayftn: CAUTION INIT_DATAXZ, File = src/specfem3D/fault_solver_dynamic.f90, Line = 1036, Column = 45 ! This argument produces a possible copy in and out to a temporary variable. - allocate(bc%npoin_perproc(NPROC)) + allocate(bc%npoin_perproc(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1418') bc%npoin_perproc=0 call gather_all_singlei(dataXZ%npoin,bc%npoin_perproc,NPROC) - allocate(bc%poin_offset(NPROC)) + allocate(bc%poin_offset(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1419') bc%poin_offset(1)=0 do iproc=2,NPROC bc%poin_offset(iproc) = sum(bc%npoin_perproc(1:iproc-1)) diff --git a/src/specfem3D/fault_solver_kinematic.f90 b/src/specfem3D/fault_solver_kinematic.f90 index 524baca8a..72dde4850 100644 --- a/src/specfem3D/fault_solver_kinematic.f90 +++ b/src/specfem3D/fault_solver_kinematic.f90 @@ -125,7 +125,8 @@ subroutine BC_KINFLT_init(prname,DTglobal,myrank) read(IIN_PAR,*) DUMMY read(IIN_BIN) nbfaults ! should be the same as in IIN_PAR - allocate( faults(nbfaults) ) + allocate( faults(nbfaults) ,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1993') dt = real(DTglobal) do iflt=1,nbfaults read(IIN_PAR,nml=BEGIN_FAULT,end=100) @@ -156,15 +157,20 @@ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,dt,NT,iflt) real(kind=CUSTOM_REAL) :: kindt + integer :: ier + NAMELIST / KINPAR / kindt call initialize_fault(bc,IIN_BIN) if (bc%nspec > 0) then - allocate(bc%T(3,bc%nglob)) - allocate(bc%D(3,bc%nglob)) - allocate(bc%V(3,bc%nglob)) + allocate(bc%T(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1994') + allocate(bc%D(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1995') + allocate(bc%V(3,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1996') bc%T = 0e0_CUSTOM_REAL bc%D = 0e0_CUSTOM_REAL bc%V = 0e0_CUSTOM_REAL @@ -176,8 +182,10 @@ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,dt,NT,iflt) bc%kin_it=0 ! Always have in memory the slip-rate model at two times, t1 and t2, ! spatially interpolated in the spectral element grid - allocate(bc%v_kin_t1(2,bc%nglob)) - allocate(bc%v_kin_t2(2,bc%nglob)) + allocate(bc%v_kin_t1(2,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1997') + allocate(bc%v_kin_t2(2,bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1998') bc%v_kin_t1 = 0e0_CUSTOM_REAL bc%v_kin_t2 = 0e0_CUSTOM_REAL @@ -330,6 +338,8 @@ subroutine init_dataXZ(dataXZ,bc) type(dataXZ_type), intent(inout) :: dataXZ type(bc_dynandkinflt_type) :: bc + integer :: ier + if (bc%nglob > 0) then dataXZ%d1 => bc%d(1,:) dataXZ%d2 => bc%d(2,:) @@ -338,9 +348,12 @@ subroutine init_dataXZ(dataXZ,bc) dataXZ%t1 => bc%t(1,:) dataXZ%t2 => bc%t(2,:) dataXZ%t3 => bc%t(3,:) - allocate(dataXZ%xcoord(bc%nglob)) - allocate(dataXZ%ycoord(bc%nglob)) - allocate(dataXZ%zcoord(bc%nglob)) + allocate(dataXZ%xcoord(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1999') + allocate(dataXZ%ycoord(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2000') + allocate(dataXZ%zcoord(bc%nglob),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2001') endif end subroutine init_dataXZ diff --git a/src/specfem3D/get_elevation.f90 b/src/specfem3D/get_elevation.f90 index f38948942..220001172 100644 --- a/src/specfem3D/get_elevation.f90 +++ b/src/specfem3D/get_elevation.f90 @@ -78,16 +78,21 @@ subroutine get_elevation_and_z_coordinate_all(npoints,plon,plat,pbur,utm_x,utm_y ! ! allocates temporary arrays allocate(elevation_distmin(npoints),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2184') if (ier /= 0) stop 'Error allocating elevation arrays' if (myrank == 0) then ! only master gathers all - allocate(elevation_all(npoints,0:NPROC-1)) + allocate(elevation_all(npoints,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2185') allocate(elevation_distmin_all(npoints,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2186') if (ier /= 0) stop 'Error allocating elevation gather arrays' else - allocate(elevation_all(1,1)) + allocate(elevation_all(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2187') allocate(elevation_distmin_all(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2188') if (ier /= 0) stop 'Error allocating elevation gather arrays' endif diff --git a/src/specfem3D/gravity_perturbation.f90 b/src/specfem3D/gravity_perturbation.f90 index 30a7bb4ca..28636934a 100644 --- a/src/specfem3D/gravity_perturbation.f90 +++ b/src/specfem3D/gravity_perturbation.f90 @@ -99,24 +99,31 @@ subroutine gravity_init() write(IMAIN,*) endif - allocate(xstat(nstat)) - allocate(ystat(nstat)) - allocate(zstat(nstat)) + allocate(xstat(nstat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2234') + allocate(ystat(nstat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2235') + allocate(zstat(nstat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2236') do istat=1,nstat read(IIN_G,*) xstat(istat),ystat(istat),zstat(istat) enddo close(IIN_G) nstep_grav = floor(dble(NSTEP)/dble(ntimgap)) - allocate(accE(nstep_grav,nstat)) - allocate(accN(nstep_grav,nstat)) - allocate(accZ(nstep_grav,nstat)) + allocate(accE(nstep_grav,nstat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2237') + allocate(accN(nstep_grav,nstat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2238') + allocate(accZ(nstep_grav,nstat),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2239') accE = 0._CUSTOM_REAL accN = 0._CUSTOM_REAL accZ = 0._CUSTOM_REAL - allocate(rho0_wm(NGLOB_AB)) + allocate(rho0_wm(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2240') rho0_wm = 0._CUSTOM_REAL call usual_hex_nodes(NGNOD,iaddx,iaddy,iaddz) @@ -320,12 +327,14 @@ subroutine gravity_timeseries() real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: accEdV,accNdV,accZdV real(kind=CUSTOM_REAL) :: E_local,N_local,Z_local,E_all,N_all,Z_all real(kind=CUSTOM_REAL), dimension(:), allocatable :: Rg,dotP - integer :: istat, it_grav + integer :: istat, it_grav, ier if (mod(it,ntimgap) == 0) then it_grav = nint(dble(it)/dble(ntimgap)) - allocate(Rg(NGLOB_AB)) - allocate(dotP(NGLOB_AB)) + allocate(Rg(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2241') + allocate(dotP(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2242') do istat=1,nstat Rg = sqrt((xstore-xstat(istat))**2+(ystore-ystat(istat))**2+(zstore-zstat(istat))**2) diff --git a/src/specfem3D/initialize_simulation.F90 b/src/specfem3D/initialize_simulation.F90 index 51cc00f50..355e60a83 100644 --- a/src/specfem3D/initialize_simulation.F90 +++ b/src/specfem3D/initialize_simulation.F90 @@ -170,52 +170,82 @@ subroutine initialize_simulation() endif allocate(irregular_element_number(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2388') if (ier /= 0) stop 'error allocating arrays for irregular element numbering' ! allocate arrays for storing the databases allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2389') if (ier /= 0) stop 'error allocating ibool' if (NSPEC_IRREGULAR > 0) then - allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) + allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2390') + allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2391') + allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2392') + allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2393') + allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2394') + allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2395') + allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2396') + allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2397') + allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2398') allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2399') else - allocate(xix(1,1,1,1)) - allocate(xiy(1,1,1,1)) - allocate(xiz(1,1,1,1)) - allocate(etax(1,1,1,1)) - allocate(etay(1,1,1,1)) - allocate(etaz(1,1,1,1)) - allocate(gammax(1,1,1,1)) - allocate(gammay(1,1,1,1)) - allocate(gammaz(1,1,1,1)) + allocate(xix(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2400') + allocate(xiy(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2401') + allocate(xiz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2402') + allocate(etax(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2403') + allocate(etay(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2404') + allocate(etaz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2405') + allocate(gammax(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2406') + allocate(gammay(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2407') + allocate(gammaz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2408') allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2409') endif if (ier /= 0) stop 'error allocating arrays for databases' ! mesh node locations - allocate(xstore(NGLOB_AB)) - allocate(ystore(NGLOB_AB)) + allocate(xstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2410') + allocate(ystore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2411') allocate(zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2412') if (ier /= 0) stop 'error allocating arrays for mesh nodes' ! material properties - allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2413') allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2414') if (ier /= 0) stop 'error allocating arrays for material properties' ! material flags - allocate(ispec_is_acoustic(NSPEC_AB)) - allocate(ispec_is_elastic(NSPEC_AB)) + allocate(ispec_is_acoustic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2415') + allocate(ispec_is_elastic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2416') allocate(ispec_is_poroelastic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2417') if (ier /= 0) stop 'error allocating arrays for material flags' ispec_is_acoustic(:) = .false. ispec_is_elastic(:) = .false. diff --git a/src/specfem3D/iterate_time.F90 b/src/specfem3D/iterate_time.F90 index 16f70d358..8938a86af 100644 --- a/src/specfem3D/iterate_time.F90 +++ b/src/specfem3D/iterate_time.F90 @@ -39,7 +39,7 @@ subroutine iterate_time() implicit none ! for EXACT_UNDOING_TO_DISK - integer :: ispec,iglob,i,j,k,counter,record_length + integer :: ispec,iglob,i,j,k,counter,record_length,ier integer, dimension(:), allocatable :: integer_mask_ibool_exact_undo real(kind=CUSTOM_REAL), dimension(:), allocatable :: buffer_for_disk character(len=MAX_STRING_LEN) outputname @@ -129,7 +129,8 @@ subroutine iterate_time() !! DK DK determine the largest value of iglob that we need to save to disk, !! DK DK since we save the upper part of the mesh only in the case of surface-wave kernels ! crust_mantle - allocate(integer_mask_ibool_exact_undo(NGLOB_AB)) + allocate(integer_mask_ibool_exact_undo(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1359') integer_mask_ibool_exact_undo(:) = -1 counter = 0 @@ -155,7 +156,8 @@ subroutine iterate_time() enddo ! allocate the buffer used to dump a single time step - allocate(buffer_for_disk(counter)) + allocate(buffer_for_disk(counter),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1360') ! open the file in which we will dump all the time steps (in a single file) write(outputname,"('huge_dumps/proc',i6.6,'_huge_dump_of_all_time_steps.bin')") myrank diff --git a/src/specfem3D/locate_MPI_slice.f90 b/src/specfem3D/locate_MPI_slice.f90 index 0d9302e9e..98a71288a 100644 --- a/src/specfem3D/locate_MPI_slice.f90 +++ b/src/specfem3D/locate_MPI_slice.f90 @@ -145,7 +145,7 @@ subroutine locate_MPI_slice_and_bcast_to_all_single(x_to_locate, y_to_locate, z_ double precision, dimension(:,:,:), allocatable :: nu_all double precision, dimension(:,:), allocatable :: x_found_all, y_found_all, z_found_all integer, dimension(:,:), allocatable :: ispec_selected_all, domain_all - integer :: iproc + integer :: iproc, ier !! to avoid compler error when calling gather_all* double precision, dimension(1) :: distance_from_target_dummy @@ -153,16 +153,25 @@ subroutine locate_MPI_slice_and_bcast_to_all_single(x_to_locate, y_to_locate, z_ double precision, dimension(1) :: x_found_dummy, y_found_dummy, z_found_dummy integer, dimension(1) :: ispec_selected_dummy, islice_selected_dummy, domain_dummy - allocate(distance_from_target_all(1,0:NPROC-1)) - allocate(xi_all(1,0:NPROC-1)) - allocate(eta_all(1,0:NPROC-1)) - allocate(gamma_all(1,0:NPROC-1)) - allocate(x_found_all(1,0:NPROC-1)) - allocate(y_found_all(1,0:NPROC-1)) - allocate(z_found_all(1,0:NPROC-1)) - allocate(nu_all(3,3,0:NPROC-1)) - - allocate(ispec_selected_all(1,0:NPROC-1),domain_all(1,0:NPROC-1)) + allocate(distance_from_target_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1782') + allocate(xi_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1783') + allocate(eta_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1784') + allocate(gamma_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1785') + allocate(x_found_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1786') + allocate(y_found_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1787') + allocate(z_found_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1788') + allocate(nu_all(3,3,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1789') + + allocate(ispec_selected_all(1,0:NPROC-1),domain_all(1,0:NPROC-1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1790') distance_from_target = dsqrt( (x_to_locate - x_found)**2& +(y_to_locate - y_found)**2& diff --git a/src/specfem3D/locate_point.f90 b/src/specfem3D/locate_point.f90 index 4919b4dd8..5e27fcbe2 100644 --- a/src/specfem3D/locate_point.f90 +++ b/src/specfem3D/locate_point.f90 @@ -270,6 +270,7 @@ subroutine locate_point_in_mesh(x_target, y_target, z_target, & ! allocates search array if (kdtree_search_num_nodes > 0) then allocate(kdtree_search_index(kdtree_search_num_nodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2418') if (ier /= 0) stop 'Error allocating array kdtree_search_index' ! finds closest n points in mesh @@ -284,6 +285,7 @@ subroutine locate_point_in_mesh(x_target, y_target, z_target, & ! starts with dummy element allocate(kdtree_search_index(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2419') if (ier /= 0) stop 'Error allocating array kdtree_search_index' kdtree_search_index(1) = 1 ! first element diff --git a/src/specfem3D/locate_receivers.f90 b/src/specfem3D/locate_receivers.f90 index b151c2668..0cc4bb15a 100644 --- a/src/specfem3D/locate_receivers.f90 +++ b/src/specfem3D/locate_receivers.f90 @@ -135,21 +135,36 @@ subroutine locate_receivers(rec_filename,nrec,islice_selected_rec,ispec_selected endif ! allocate memory for arrays using number of stations - allocate(stlat(nrec)) - allocate(stlon(nrec)) - allocate(stele(nrec)) - allocate(stbur(nrec)) - allocate(stutm_x(nrec)) - allocate(stutm_y(nrec)) - allocate(elevation(nrec)) - allocate(x_target(nrec)) - allocate(y_target(nrec)) - allocate(z_target(nrec)) - allocate(x_found(nrec)) - allocate(y_found(nrec)) - allocate(z_found(nrec)) - allocate(final_distance(nrec)) + allocate(stlat(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1955') + allocate(stlon(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1956') + allocate(stele(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1957') + allocate(stbur(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1958') + allocate(stutm_x(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1959') + allocate(stutm_y(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1960') + allocate(elevation(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1961') + allocate(x_target(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1962') + allocate(y_target(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1963') + allocate(z_target(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1964') + allocate(x_found(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1965') + allocate(y_found(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1966') + allocate(z_found(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1967') + allocate(final_distance(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1968') allocate(idomain(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1969') if (ier /= 0) stop 'Error allocating arrays for locating receivers' ! loop on all the stations to read the file @@ -170,6 +185,7 @@ subroutine locate_receivers(rec_filename,nrec,islice_selected_rec,ispec_selected ! "append") to a file with same name. The philosophy here is to accept multiple ! appearances and to just add a count to the station name in this case. allocate(station_duplet(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1970') if (ier /= 0 ) call exit_MPI(myrank,'Error allocating station_duplet array') station_duplet(:) = 0 do irec = 1,nrec @@ -490,7 +506,8 @@ subroutine read_stations_from_previous_run(is_done_stations) write(IMAIN,*) 'station details from SU_stations_info.bin' call flush_IMAIN() - allocate(x_found(nrec),y_found(nrec),z_found(nrec)) + allocate(x_found(nrec),y_found(nrec),z_found(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1971') ! reads in station infos read(IOUT_SU) islice_selected_rec,ispec_selected_rec read(IOUT_SU) xi_receiver,eta_receiver,gamma_receiver diff --git a/src/specfem3D/make_gravity.f90 b/src/specfem3D/make_gravity.f90 index 4c4534975..6beb00bf4 100644 --- a/src/specfem3D/make_gravity.f90 +++ b/src/specfem3D/make_gravity.f90 @@ -589,11 +589,12 @@ subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_ ! spline coefficients output by the routine double precision, dimension(npoint), intent(out) :: spline_coefficients - integer :: i + integer :: i, ier double precision, dimension(:), allocatable :: temporary_array - allocate(temporary_array(npoint)) + allocate(temporary_array(npoint),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2431') spline_coefficients(1) = - 1.d0 / 2.d0 diff --git a/src/specfem3D/pml_allocate_arrays.f90 b/src/specfem3D/pml_allocate_arrays.f90 index 3e25e7014..42177962c 100644 --- a/src/specfem3D/pml_allocate_arrays.f90 +++ b/src/specfem3D/pml_allocate_arrays.f90 @@ -54,139 +54,195 @@ subroutine pml_allocate_arrays() ! C-PML spectral elements local indexing allocate(spec_to_CPML(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2254') if (ier /= 0) stop 'error allocating array spec_to_CPML' ! C-PML element type array: 1 = face, 2 = edge, 3 = corner allocate(CPML_type(NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2255') if (ier /= 0) stop 'error allocating array CPML_type' if (ELASTIC_SIMULATION) then ! store the displ field at n-1 time step allocate(PML_displ_old(3,NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2256') if (ier /= 0) stop 'error allocating PML_displ_old array' ! store the displ field at n time step allocate(PML_displ_new(3,NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2257') if (ier /= 0) stop 'error allocating PML_displ_new array' if (ier /= 0) stop 'error allocating displ_new array' ! stores derivatives of ux, uy and uz with respect to x, y and z allocate(PML_dux_dxl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2258') if (ier /= 0) stop 'error allocating PML_dux_dxl array' allocate(PML_dux_dyl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2259') if (ier /= 0) stop 'error allocating PML_dux_dyl array' allocate(PML_dux_dzl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2260') if (ier /= 0) stop 'error allocating PML_dux_dzl array' allocate(PML_duy_dxl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2261') if (ier /= 0) stop 'error allocating PML_duy_dxl array' allocate(PML_duy_dyl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2262') if (ier /= 0) stop 'error allocating PML_duy_dyl array' allocate(PML_duy_dzl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2263') if (ier /= 0) stop 'error allocating PML_duy_dzl array' allocate(PML_duz_dxl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2264') if (ier /= 0) stop 'error allocating PML_duz_dxl array' allocate(PML_duz_dyl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2265') if (ier /= 0) stop 'error allocating PML_duz_dyl array' allocate(PML_duz_dzl(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2266') if (ier /= 0) stop 'error allocating PML_duz_dzl array' allocate(PML_dux_dxl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2267') if (ier /= 0) stop 'error allocating PML_dux_dxl_old array' allocate(PML_dux_dyl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2268') if (ier /= 0) stop 'error allocating PML_dux_dyl_old array' allocate(PML_dux_dzl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2269') if (ier /= 0) stop 'error allocating PML_dux_dzl_old array' allocate(PML_duy_dxl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2270') if (ier /= 0) stop 'error allocating PML_duy_dxl_old array' allocate(PML_duy_dyl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2271') if (ier /= 0) stop 'error allocating PML_duy_dyl_old array' allocate(PML_duy_dzl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2272') if (ier /= 0) stop 'error allocating PML_duy_dzl_old array' allocate(PML_duz_dxl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2273') if (ier /= 0) stop 'error allocating PML_duz_dxl_old array' allocate(PML_duz_dyl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2274') if (ier /= 0) stop 'error allocating PML_duz_dyl_old array' allocate(PML_duz_dzl_old(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2275') if (ier /= 0) stop 'error allocating PML_duz_dzl_old array' allocate(PML_dux_dxl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2276') if (ier /= 0) stop 'error allocating PML_dux_dxl_new array' allocate(PML_dux_dyl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2277') if (ier /= 0) stop 'error allocating PML_dux_dyl_new array' allocate(PML_dux_dzl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2278') if (ier /= 0) stop 'error allocating PML_dux_dzl_new array' allocate(PML_duy_dxl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2279') if (ier /= 0) stop 'error allocating PML_duy_dxl_new array' allocate(PML_duy_dyl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2280') if (ier /= 0) stop 'error allocating PML_duy_dyl_new array' allocate(PML_duy_dzl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2281') if (ier /= 0) stop 'error allocating PML_duy_dzl_new array' allocate(PML_duz_dxl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2282') if (ier /= 0) stop 'error allocating PML_duz_dxl_new array' allocate(PML_duz_dyl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2283') if (ier /= 0) stop 'error allocating PML_duz_dyl_new array' allocate(PML_duz_dzl_new(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2284') if (ier /= 0) stop 'error allocating PML_duz_dzl_new array' ! stores C-PML memory variables allocate(rmemory_dux_dxl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2285') if (ier /= 0) stop 'error allocating rmemory_dux_dxl_x array' allocate(rmemory_dux_dyl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2286') if (ier /= 0) stop 'error allocating rmemory_dux_dyl_x array' allocate(rmemory_dux_dzl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2287') if (ier /= 0) stop 'error allocating rmemory_dux_dzl_x array' allocate(rmemory_duy_dxl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2288') if (ier /= 0) stop 'error allocating rmemory_duy_dxl_x array' allocate(rmemory_duy_dyl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2289') if (ier /= 0) stop 'error allocating rmemory_duy_dyl_x array' allocate(rmemory_duz_dxl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2290') if (ier /= 0) stop 'error allocating rmemory_duz_dxl_x array' allocate(rmemory_duz_dzl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2291') if (ier /= 0) stop 'error allocating rmemory_duz_dzl_x array' allocate(rmemory_dux_dxl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2292') if (ier /= 0) stop 'error allocating rmemory_dux_dxl_y array' allocate(rmemory_dux_dyl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2293') if (ier /= 0) stop 'error allocating rmemory_dux_dyl_y array' allocate(rmemory_duy_dxl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2294') if (ier /= 0) stop 'error allocating rmemory_duy_dxl_y array' allocate(rmemory_duy_dyl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2295') if (ier /= 0) stop 'error allocating rmemory_duy_dyl_y array' allocate(rmemory_duy_dzl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2296') if (ier /= 0) stop 'error allocating rmemory_duy_dzl_y array' allocate(rmemory_duz_dyl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2297') if (ier /= 0) stop 'error allocating rmemory_duz_dyl_y array' allocate(rmemory_duz_dzl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2298') if (ier /= 0) stop 'error allocating rmemory_duz_dzl_y array' allocate(rmemory_dux_dxl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2299') if (ier /= 0) stop 'error allocating rmemory_dux_dxl_z array' allocate(rmemory_dux_dzl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2300') if (ier /= 0) stop 'error allocating rmemory_dux_dzl_z array' allocate(rmemory_duy_dyl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2301') if (ier /= 0) stop 'error allocating rmemory_duy_dyl_z array' allocate(rmemory_duy_dzl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2302') if (ier /= 0) stop 'error allocating rmemory_duy_dzl_z array' allocate(rmemory_duz_dxl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2303') if (ier /= 0) stop 'error allocating rmemory_duz_dxl_z array' allocate(rmemory_duz_dyl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2304') if (ier /= 0) stop 'error allocating rmemory_duz_dyl_z array' allocate(rmemory_duz_dzl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2305') if (ier /= 0) stop 'error allocating rmemory_duz_dzl_z array' ! stores C-PML memory variables needed for displacement allocate(rmemory_displ_elastic(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2306') if (ier /= 0) stop 'error allocating rmemory_displ_elastic array' ! stores C-PML contribution to update acceleration to the global mesh allocate(accel_elastic_CPML(NDIM,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2307') if (ier /= 0) stop 'error allocating accel_elastic_CPML array' endif if (ACOUSTIC_SIMULATION) then ! store the potential acoustic field at n-1 time step for CMPL allocate(PML_potential_acoustic_old(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2308') if (ier /= 0) stop 'error allocating PML_potential_acoustic_old array' ! store the potential acoustic field at n time step for CMPL allocate(PML_potential_acoustic_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2309') if (ier /= 0) stop 'error allocating PML_potential_acoustic_new array' ! store the potential acoustic field at n-1 time step @@ -195,29 +251,37 @@ subroutine pml_allocate_arrays() ! stores C-PML memory variables allocate(rmemory_dpotential_dxl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2310') if (ier /= 0) stop 'error allocating rmemory_dpotential_dxl array' allocate(rmemory_dpotential_dyl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2311') if (ier /= 0) stop 'error allocating rmemory_dpotential_dyl array' allocate(rmemory_dpotential_dzl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2312') if (ier /= 0) stop 'error allocating rmemory_dpotential_dzl array' ! stores C-PML memory variables needed for potential allocate(rmemory_potential_acoustic(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2313') if (ier /= 0) stop 'error allocating rmemory_potential_acoustic array' ! stores C-PML contribution to update the second derivative of the potential to the global mesh allocate(potential_dot_dot_acoustic_CPML(NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2314') if (ier /= 0) stop 'error allocating potential_dot_dot_acoustic_CPML array' endif ! stores C-PML contribution on elastic/acoustic interface if (ACOUSTIC_SIMULATION .and. ELASTIC_SIMULATION) then allocate(rmemory_coupling_ac_el_displ(3,NGLLX,NGLLY,NGLLZ,num_coupling_ac_el_faces,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2315') if (ier /= 0) stop 'error allocating rmemory_coupling_ac_el_displ array' allocate(rmemory_coupling_el_ac_potential_dot_dot(3,NGLLX,NGLLY,NGLLZ,num_coupling_ac_el_faces,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2316') if (ier /= 0) stop 'error allocating rmemory_coupling_el_ac_potential_dot_dot array' if (SIMULATION_TYPE == 3) then allocate(rmemory_coupling_el_ac_potential(3,NGLLX,NGLLY,NGLLZ,num_coupling_ac_el_faces,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2317') if (ier /= 0) stop 'error allocating rmemory_coupling_el_ac_potential array' endif endif @@ -326,6 +390,7 @@ subroutine pml_allocate_arrays() ! allocates wavefield allocate(b_PML_field(9,b_nglob_interface_PML_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2318') if (ier /= 0) stop 'error allocating array b_PML_field' ! size of single record @@ -356,6 +421,7 @@ subroutine pml_allocate_arrays() else ! needs dummy array allocate(b_PML_field(9,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2319') if (ier /= 0) stop 'error allocating array b_PML_field' endif endif @@ -370,6 +436,7 @@ subroutine pml_allocate_arrays() ! allocates wavefield allocate(b_PML_potential(3,b_nglob_interface_PML_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2320') if (ier /= 0) stop 'error allocating array b_PML_potential' ! size of single record @@ -400,6 +467,7 @@ subroutine pml_allocate_arrays() else ! needs dummy array allocate(b_PML_potential(3,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2321') if (ier /= 0) stop 'error allocating array b_PML_potential' endif endif @@ -421,218 +489,286 @@ subroutine pml_allocate_arrays_dummy() implicit none + integer :: ier + if (.not. allocated(spec_to_CPML)) then - allocate(spec_to_CPML(1)) + allocate(spec_to_CPML(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2322') endif if (.not. allocated(CPML_type)) then - allocate(CPML_type(1)) + allocate(CPML_type(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2323') endif if (ELASTIC_SIMULATION) then if (.not. allocated(PML_displ_old)) then - allocate(PML_displ_old(3,1,1,1,1)) + allocate(PML_displ_old(3,1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2324') endif if (.not. allocated(PML_displ_new)) then - allocate(PML_displ_new(3,1,1,1,1)) + allocate(PML_displ_new(3,1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2325') endif if (.not. allocated(PML_dux_dxl)) then - allocate(PML_dux_dxl(1,1,1)) + allocate(PML_dux_dxl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2326') endif if (.not. allocated(PML_dux_dyl)) then - allocate(PML_dux_dyl(1,1,1)) + allocate(PML_dux_dyl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2327') endif if (.not. allocated(PML_dux_dzl)) then - allocate(PML_dux_dzl(1,1,1)) + allocate(PML_dux_dzl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2328') endif if (.not. allocated(PML_duy_dxl)) then - allocate(PML_duy_dxl(1,1,1)) + allocate(PML_duy_dxl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2329') endif if (.not. allocated(PML_duy_dyl)) then - allocate(PML_duy_dyl(1,1,1)) + allocate(PML_duy_dyl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2330') endif if (.not. allocated(PML_duy_dzl)) then - allocate(PML_duy_dzl(1,1,1)) + allocate(PML_duy_dzl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2331') endif if (.not. allocated(PML_duz_dxl)) then - allocate(PML_duz_dxl(1,1,1)) + allocate(PML_duz_dxl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2332') endif if (.not. allocated(PML_duz_dyl)) then - allocate(PML_duz_dyl(1,1,1)) + allocate(PML_duz_dyl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2333') endif if (.not. allocated(PML_duz_dzl)) then - allocate(PML_duz_dzl(1,1,1)) + allocate(PML_duz_dzl(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2334') endif if (.not. allocated(PML_dux_dxl_old)) then - allocate(PML_dux_dxl_old(1,1,1)) + allocate(PML_dux_dxl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2335') endif if (.not. allocated(PML_dux_dyl_old)) then - allocate(PML_dux_dyl_old(1,1,1)) + allocate(PML_dux_dyl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2336') endif if (.not. allocated(PML_dux_dzl_old)) then - allocate(PML_dux_dzl_old(1,1,1)) + allocate(PML_dux_dzl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2337') endif if (.not. allocated(PML_duy_dxl_old)) then - allocate(PML_duy_dxl_old(1,1,1)) + allocate(PML_duy_dxl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2338') endif if (.not. allocated(PML_duy_dyl_old)) then - allocate(PML_duy_dyl_old(1,1,1)) + allocate(PML_duy_dyl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2339') endif if (.not. allocated(PML_duy_dzl_old)) then - allocate(PML_duy_dzl_old(1,1,1)) + allocate(PML_duy_dzl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2340') endif if (.not. allocated(PML_duz_dxl_old)) then - allocate(PML_duz_dxl_old(1,1,1)) + allocate(PML_duz_dxl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2341') endif if (.not. allocated(PML_duz_dyl_old)) then - allocate(PML_duz_dyl_old(1,1,1)) + allocate(PML_duz_dyl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2342') endif if (.not. allocated(PML_duz_dzl_old)) then - allocate(PML_duz_dzl_old(1,1,1)) + allocate(PML_duz_dzl_old(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2343') endif if (.not. allocated(PML_dux_dxl_new)) then - allocate(PML_dux_dxl_new(1,1,1)) + allocate(PML_dux_dxl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2344') endif if (.not. allocated(PML_dux_dyl_new)) then - allocate(PML_dux_dyl_new(1,1,1)) + allocate(PML_dux_dyl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2345') endif if (.not. allocated(PML_dux_dzl_new)) then - allocate(PML_dux_dzl_new(1,1,1)) + allocate(PML_dux_dzl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2346') endif if (.not. allocated(PML_duy_dxl_new)) then - allocate(PML_duy_dxl_new(1,1,1)) + allocate(PML_duy_dxl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2347') endif if (.not. allocated(PML_duy_dyl_new)) then - allocate(PML_duy_dyl_new(1,1,1)) + allocate(PML_duy_dyl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2348') endif if (.not. allocated(PML_duy_dzl_new)) then - allocate(PML_duy_dzl_new(1,1,1)) + allocate(PML_duy_dzl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2349') endif if (.not. allocated(PML_duz_dxl_new)) then - allocate(PML_duz_dxl_new(1,1,1)) + allocate(PML_duz_dxl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2350') endif if (.not. allocated(PML_duz_dyl_new)) then - allocate(PML_duz_dyl_new(1,1,1)) + allocate(PML_duz_dyl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2351') endif if (.not. allocated(PML_duz_dzl_new)) then - allocate(PML_duz_dzl_new(1,1,1)) + allocate(PML_duz_dzl_new(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2352') endif if (.not. allocated(rmemory_dux_dxl_x)) then - allocate(rmemory_dux_dxl_x(1,1,1,1,3)) + allocate(rmemory_dux_dxl_x(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2353') endif if (.not. allocated(rmemory_dux_dyl_x)) then - allocate(rmemory_dux_dyl_x(1,1,1,1,3)) + allocate(rmemory_dux_dyl_x(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2354') endif if (.not. allocated(rmemory_dux_dzl_x)) then - allocate(rmemory_dux_dzl_x(1,1,1,1,3)) + allocate(rmemory_dux_dzl_x(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2355') endif if (.not. allocated(rmemory_duy_dxl_x)) then - allocate(rmemory_duy_dxl_x(1,1,1,1)) + allocate(rmemory_duy_dxl_x(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2356') endif if (.not. allocated(rmemory_duy_dyl_x)) then - allocate(rmemory_duy_dyl_x(1,1,1,1)) + allocate(rmemory_duy_dyl_x(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2357') endif if (.not. allocated(rmemory_duz_dxl_x)) then - allocate(rmemory_duz_dxl_x(1,1,1,1)) + allocate(rmemory_duz_dxl_x(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2358') endif if (.not. allocated(rmemory_duz_dzl_x)) then - allocate(rmemory_duz_dzl_x(1,1,1,1)) + allocate(rmemory_duz_dzl_x(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2359') endif if (.not. allocated(rmemory_dux_dxl_y)) then - allocate(rmemory_dux_dxl_y(1,1,1,1)) + allocate(rmemory_dux_dxl_y(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2360') endif if (.not. allocated(rmemory_dux_dyl_y)) then - allocate(rmemory_dux_dyl_y(1,1,1,1)) + allocate(rmemory_dux_dyl_y(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2361') endif if (.not. allocated(rmemory_duy_dxl_y)) then - allocate(rmemory_duy_dxl_y(1,1,1,1,3)) + allocate(rmemory_duy_dxl_y(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2362') endif if (.not. allocated(rmemory_duy_dyl_y)) then - allocate(rmemory_duy_dyl_y(1,1,1,1,3)) + allocate(rmemory_duy_dyl_y(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2363') endif if (.not. allocated(rmemory_duy_dzl_y)) then - allocate(rmemory_duy_dzl_y(1,1,1,1,3)) + allocate(rmemory_duy_dzl_y(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2364') endif if (.not. allocated(rmemory_duz_dyl_y)) then - allocate(rmemory_duz_dyl_y(1,1,1,1)) + allocate(rmemory_duz_dyl_y(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2365') endif if (.not. allocated(rmemory_duz_dzl_y)) then - allocate(rmemory_duz_dzl_y(1,1,1,1)) + allocate(rmemory_duz_dzl_y(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2366') endif if (.not. allocated(rmemory_dux_dxl_z)) then - allocate(rmemory_dux_dxl_z(1,1,1,1)) + allocate(rmemory_dux_dxl_z(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2367') endif if (.not. allocated(rmemory_dux_dzl_z)) then - allocate(rmemory_dux_dzl_z(1,1,1,1)) + allocate(rmemory_dux_dzl_z(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2368') endif if (.not. allocated(rmemory_duy_dyl_z)) then - allocate(rmemory_duy_dyl_z(1,1,1,1)) + allocate(rmemory_duy_dyl_z(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2369') endif if (.not. allocated(rmemory_duy_dzl_z)) then - allocate(rmemory_duy_dzl_z(1,1,1,1)) + allocate(rmemory_duy_dzl_z(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2370') endif if (.not. allocated(rmemory_duz_dxl_z)) then - allocate(rmemory_duz_dxl_z(1,1,1,1,3)) + allocate(rmemory_duz_dxl_z(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2371') endif if (.not. allocated(rmemory_duz_dyl_z)) then - allocate(rmemory_duz_dyl_z(1,1,1,1,3)) + allocate(rmemory_duz_dyl_z(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2372') endif if (.not. allocated(rmemory_duz_dzl_z)) then - allocate(rmemory_duz_dzl_z(1,1,1,1,3)) + allocate(rmemory_duz_dzl_z(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2373') endif if (.not. allocated(rmemory_displ_elastic)) then - allocate(rmemory_displ_elastic(1,1,1,1,1,3)) + allocate(rmemory_displ_elastic(1,1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2374') endif if (.not. allocated(accel_elastic_CPML)) then - allocate(accel_elastic_CPML(1,1,1,1)) + allocate(accel_elastic_CPML(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2375') endif ! allocates wavefield if (.not. allocated(b_PML_field)) then - allocate(b_PML_field(9,1)) + allocate(b_PML_field(9,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2376') endif endif if (ACOUSTIC_SIMULATION) then if (.not. allocated(PML_potential_acoustic_old)) then - allocate(PML_potential_acoustic_old(1,1,1,1)) + allocate(PML_potential_acoustic_old(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2377') endif if (.not. allocated(PML_potential_acoustic_new)) then - allocate(PML_potential_acoustic_new(1,1,1,1)) + allocate(PML_potential_acoustic_new(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2378') endif if (.not. allocated(rmemory_dpotential_dxl)) then - allocate(rmemory_dpotential_dxl(1,1,1,1,3)) + allocate(rmemory_dpotential_dxl(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2379') endif if (.not. allocated(rmemory_dpotential_dyl)) then - allocate(rmemory_dpotential_dyl(1,1,1,1,3)) + allocate(rmemory_dpotential_dyl(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2380') endif if (.not. allocated(rmemory_dpotential_dzl)) then - allocate(rmemory_dpotential_dzl(1,1,1,1,3)) + allocate(rmemory_dpotential_dzl(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2381') endif if (.not. allocated(rmemory_potential_acoustic)) then - allocate(rmemory_potential_acoustic(1,1,1,1,3)) + allocate(rmemory_potential_acoustic(1,1,1,1,3),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2382') endif if (.not. allocated(potential_dot_dot_acoustic_CPML)) then - allocate(potential_dot_dot_acoustic_CPML(1,1,1)) + allocate(potential_dot_dot_acoustic_CPML(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2383') endif ! allocates wavefield if (.not. allocated(b_PML_potential)) then - allocate(b_PML_potential(3,1)) + allocate(b_PML_potential(3,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2384') endif endif if (ACOUSTIC_SIMULATION .and. ELASTIC_SIMULATION) then if (.not. allocated(rmemory_coupling_ac_el_displ)) then - allocate(rmemory_coupling_ac_el_displ(3,1,1,1,1,2)) + allocate(rmemory_coupling_ac_el_displ(3,1,1,1,1,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2385') endif if (.not. allocated(rmemory_coupling_el_ac_potential_dot_dot)) then - allocate(rmemory_coupling_el_ac_potential_dot_dot(3,1,1,1,1,2)) + allocate(rmemory_coupling_el_ac_potential_dot_dot(3,1,1,1,1,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2386') endif if (SIMULATION_TYPE == 3) then if (.not. allocated(rmemory_coupling_el_ac_potential)) then - allocate(rmemory_coupling_el_ac_potential(3,1,1,1,1,2)) + allocate(rmemory_coupling_el_ac_potential(3,1,1,1,1,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2387') endif endif endif diff --git a/src/specfem3D/pml_output_VTKs.f90 b/src/specfem3D/pml_output_VTKs.f90 index e0049a8e0..87381120d 100644 --- a/src/specfem3D/pml_output_VTKs.f90 +++ b/src/specfem3D/pml_output_VTKs.f90 @@ -50,6 +50,7 @@ subroutine pml_output_VTKs() ! C-PML regions allocate(temp_CPML_regions(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1981') if (ier /= 0) stop 'error allocating array temp_CPML_regions' temp_CPML_regions(:) = 0 @@ -69,10 +70,13 @@ subroutine pml_output_VTKs() ! C-PML damping profile arrays allocate(temp_d_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1982') if (ier /= 0) stop 'error allocating array temp_d_store_x' allocate(temp_d_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1983') if (ier /= 0) stop 'error allocating array temp_d_store_y' allocate(temp_d_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1984') if (ier /= 0) stop 'error allocating array temp_d_store_z' temp_d_store_x(:,:,:,:) = 0._CUSTOM_REAL diff --git a/src/specfem3D/prepare_attenuation.f90 b/src/specfem3D/prepare_attenuation.f90 index 0f9446229..28330a944 100644 --- a/src/specfem3D/prepare_attenuation.f90 +++ b/src/specfem3D/prepare_attenuation.f90 @@ -56,11 +56,13 @@ subroutine prepare_attenuation() factor_common(:,:,:,:,:) = 1._CUSTOM_REAL allocate( scale_factor(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2232') if (ier /= 0) call exit_mpi(myrank,'error allocation scale_factor') scale_factor(:,:,:,:) = 1._CUSTOM_REAL factor_common_kappa(:,:,:,:,:) = 1._CUSTOM_REAL allocate( scale_factor_kappa(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2233') if (ier /= 0) call exit_mpi(myrank,'error allocation scale_factor_kappa') scale_factor_kappa(:,:,:,:) = 1._CUSTOM_REAL diff --git a/src/specfem3D/prepare_gravity.f90 b/src/specfem3D/prepare_gravity.f90 index d6bf1c627..bb4445ec5 100644 --- a/src/specfem3D/prepare_gravity.f90 +++ b/src/specfem3D/prepare_gravity.f90 @@ -71,8 +71,10 @@ subroutine prepare_gravity() if (GRAVITY) then ! allocates gravity arrays - allocate(minus_deriv_gravity(NGLOB_AB)) + allocate(minus_deriv_gravity(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2156') allocate(minus_g(NGLOB_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2157') if (ier /= 0) stop 'error allocating gravity arrays' ! sets up spline table @@ -117,6 +119,7 @@ subroutine prepare_gravity() ! allocates dummy gravity arrays allocate( minus_deriv_gravity(0), minus_g(0), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2158') if (ier /= 0) stop 'error allocating gravity arrays' endif diff --git a/src/specfem3D/prepare_noise.f90 b/src/specfem3D/prepare_noise.f90 index 205b27c7a..5d5fe1889 100644 --- a/src/specfem3D/prepare_noise.f90 +++ b/src/specfem3D/prepare_noise.f90 @@ -52,17 +52,23 @@ subroutine prepare_noise() ! allocates arrays allocate(noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1975') if (ier /= 0) call exit_mpi(myrank,'error allocating noise source array') allocate(normal_x_noise(NGLLSQUARE*num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1976') if (ier /= 0) stop 'error allocating array normal_x_noise' allocate(normal_y_noise(NGLLSQUARE*num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1977') if (ier /= 0) stop 'error allocating array normal_y_noise' allocate(normal_z_noise(NGLLSQUARE*num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1978') if (ier /= 0) stop 'error allocating array normal_z_noise' allocate(mask_noise(NGLLSQUARE*num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1979') if (ier /= 0) stop 'error allocating array mask_noise' allocate(noise_surface_movie(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1980') if (ier /= 0) stop 'error allocating array noise_surface_movie' ! initializes diff --git a/src/specfem3D/prepare_timerun.F90 b/src/specfem3D/prepare_timerun.F90 index bc8ea43c3..d4e958347 100644 --- a/src/specfem3D/prepare_timerun.F90 +++ b/src/specfem3D/prepare_timerun.F90 @@ -408,8 +408,10 @@ subroutine prepare_timerun_lddrk() if (ACOUSTIC_SIMULATION) then allocate(potential_acoustic_lddrk(NGLOB_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2120') if (ier /= 0) stop 'Error allocating array potential_acoustic_lddrk' allocate(potential_dot_acoustic_lddrk(NGLOB_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2121') if (ier /= 0) stop 'Error allocating array potential_dot_acoustic_lddrk' potential_acoustic_lddrk(:) = 0._CUSTOM_REAL @@ -422,8 +424,10 @@ subroutine prepare_timerun_lddrk() if (ELASTIC_SIMULATION) then allocate(displ_lddrk(NDIM,NGLOB_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2122') if (ier /= 0) stop 'Error allocating array displ_lddrk' allocate(veloc_lddrk(NDIM,NGLOB_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2123') if (ier /= 0) stop 'Error allocating array veloc_lddrk' displ_lddrk(:,:) = 0._CUSTOM_REAL @@ -434,25 +438,37 @@ subroutine prepare_timerun_lddrk() endif ! note: currently, they need to be defined, as they are used in some subroutine arguments - allocate(R_xx_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) - allocate(R_yy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) - allocate(R_xy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) - allocate(R_xz_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) + allocate(R_xx_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2124') + allocate(R_yy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2125') + allocate(R_xy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2126') + allocate(R_xz_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2127') allocate(R_yz_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2128') if (ier /= 0) stop 'Error allocating array R_**_lddrk etc.' - allocate(R_trace_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) + allocate(R_trace_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2129') if (ier /= 0) stop 'Error allocating array R_trace_lddrk etc.' if (SIMULATION_TYPE == 3) then - allocate(b_R_xx_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) - allocate(b_R_yy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) - allocate(b_R_xy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) - allocate(b_R_xz_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) + allocate(b_R_xx_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2130') + allocate(b_R_yy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2131') + allocate(b_R_xy_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2132') + allocate(b_R_xz_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2133') allocate(b_R_yz_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2134') if (ier /= 0) stop 'Error allocating array R_**_lddrk etc.' - allocate(b_R_trace_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK)) + allocate(b_R_trace_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB_LDDRK),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2135') if (ier /= 0) stop 'Error allocating array R_**_lddrk etc.' endif @@ -611,13 +627,20 @@ subroutine prepare_timerun_adjoint() ! moment tensor derivatives if (nrec_local > 0 .and. SIMULATION_TYPE == 2) then ! allocate Frechet derivatives array - allocate(Mxx_der(nrec_local)) - allocate(Myy_der(nrec_local)) - allocate(Mzz_der(nrec_local)) - allocate(Mxy_der(nrec_local)) - allocate(Mxz_der(nrec_local)) - allocate(Myz_der(nrec_local)) + allocate(Mxx_der(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2136') + allocate(Myy_der(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2137') + allocate(Mzz_der(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2138') + allocate(Mxy_der(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2139') + allocate(Mxz_der(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2140') + allocate(Myz_der(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2141') allocate(sloc_der(NDIM,nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2142') if (ier /= 0) stop 'error allocating array Mxx_der and following arrays' Mxx_der = 0._CUSTOM_REAL Myy_der = 0._CUSTOM_REAL @@ -746,6 +769,7 @@ subroutine prepare_timerun_adjoint() if (ELASTIC_SIMULATION) then ! allocates wavefield allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2143') if (ier /= 0) stop 'error allocating array b_absorb_field' ! size of single record @@ -780,6 +804,7 @@ subroutine prepare_timerun_adjoint() if (ACOUSTIC_SIMULATION) then ! allocates wavefield allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2144') if (ier /= 0) stop 'error allocating array b_absorb_potential' ! size of single record @@ -823,7 +848,9 @@ subroutine prepare_timerun_adjoint() if (POROELASTIC_SIMULATION) then ! allocates wavefields for solid and fluid phases allocate(b_absorb_fields(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2145') allocate(b_absorb_fieldw(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2146') if (ier /= 0) stop 'error allocating array b_absorb_fields and b_absorb_fieldw' ! size of single record @@ -866,17 +893,21 @@ subroutine prepare_timerun_adjoint() b_num_abs_boundary_faces = 0 if (ELASTIC_SIMULATION) then allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2147') if (ier /= 0) stop 'error allocating array b_absorb_field' endif if (ACOUSTIC_SIMULATION) then allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2148') if (ier /= 0) stop 'error allocating array b_absorb_potential' endif if (POROELASTIC_SIMULATION) then allocate(b_absorb_fields(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2149') allocate(b_absorb_fieldw(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2150') if (ier /= 0) stop 'error allocating array b_absorb_fields and b_absorb_fieldw' endif endif @@ -885,17 +916,21 @@ subroutine prepare_timerun_adjoint() b_num_abs_boundary_faces = 0 if (ELASTIC_SIMULATION) then allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2151') if (ier /= 0) stop 'error allocating array b_absorb_field' endif if (ACOUSTIC_SIMULATION) then allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2152') if (ier /= 0) stop 'error allocating array b_absorb_potential' endif if (POROELASTIC_SIMULATION) then allocate(b_absorb_fields(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2153') allocate(b_absorb_fieldw(NDIM,NGLLSQUARE,b_num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2154') if (ier /= 0) stop 'error allocating array b_absorb_fields and b_absorb_fieldw' endif endif @@ -997,6 +1032,7 @@ subroutine prepare_timerun_OpenMP() num_colors_outer_elastic = 1 num_colors_inner_elastic = 1 allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2155') if (ier /= 0) stop 'error allocating num_elem_colors_elastic array' ! sets to all elements in inner/outer phase diff --git a/src/specfem3D/read_mesh_databases.F90 b/src/specfem3D/read_mesh_databases.F90 index 48d33236c..3a68a3ccf 100644 --- a/src/specfem3D/read_mesh_databases.F90 +++ b/src/specfem3D/read_mesh_databases.F90 @@ -130,23 +130,29 @@ subroutine read_mesh_databases() ! potentials ! NB_RUNS_ACOUSTIC_GPU is set to 1 by default in constants.h allocate(potential_acoustic(NGLOB_AB*NB_RUNS_ACOUSTIC_GPU),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1420') if (ier /= 0) stop 'Error allocating array potential_acoustic' allocate(potential_dot_acoustic(NGLOB_AB*NB_RUNS_ACOUSTIC_GPU),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1421') if (ier /= 0) stop 'Error allocating array potential_dot_acoustic' allocate(potential_dot_dot_acoustic(NGLOB_AB*NB_RUNS_ACOUSTIC_GPU),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1422') if (ier /= 0) stop 'Error allocating array potential_dot_dot_acoustic' if (SIMULATION_TYPE /= 1) then allocate(potential_acoustic_adj_coupling(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1423') if (ier /= 0) stop 'Error allocating array potential_acoustic_adj_coupling' endif ! mass matrix, density allocate(rmass_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1424') if (ier /= 0) stop 'Error allocating array rmass_acoustic' if (I_should_read_the_database) read(27) rmass_acoustic if (size(rmass_acoustic) > 0) call bcast_all_cr_for_database(rmass_acoustic(1), size(rmass_acoustic)) ! initializes mass matrix contribution allocate(rmassz_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1425') if (ier /= 0) stop 'Error allocating array rmassz_acoustic' rmassz_acoustic(:) = 0._CUSTOM_REAL endif @@ -154,6 +160,7 @@ subroutine read_mesh_databases() ! this array is needed for acoustic simulations but also for elastic simulations with CPML, ! thus we now allocate it and read it in all cases (whether the simulation is acoustic, elastic, or acoustic/elastic) allocate(rhostore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1426') if (ier /= 0) stop 'Error allocating array rhostore' if (I_should_read_the_database) read(27) rhostore call bcast_all_cr_for_database(rhostore(1,1,1,1), size(rhostore)) @@ -170,85 +177,131 @@ subroutine read_mesh_databases() ! displacement,velocity,acceleration allocate(displ(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1427') if (ier /= 0) stop 'Error allocating array displ' allocate(veloc(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1428') if (ier /= 0) stop 'Error allocating array veloc' allocate(accel(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1429') if (ier /= 0) stop 'Error allocating array accel' if (SIMULATION_TYPE /= 1) then allocate(accel_adj_coupling(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1430') if (ier /= 0) stop 'Error allocating array accel_adj_coupling' endif ! allocates mass matrix allocate(rmass(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1431') if (ier /= 0) stop 'Error allocating array rmass' ! initializes mass matrix contributions - allocate(rmassx(NGLOB_AB)) - allocate(rmassy(NGLOB_AB)) + allocate(rmassx(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1432') + allocate(rmassy(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1433') allocate(rmassz(NGLOB_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1434') if (ier /= 0) stop 'Error allocating array rmassx,rmassy,rmassz' rmassx(:) = 0._CUSTOM_REAL rmassy(:) = 0._CUSTOM_REAL rmassz(:) = 0._CUSTOM_REAL allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1435') if (ier /= 0) stop 'Error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1436') if (ier /= 0) stop 'Error allocating array rho_vs' - allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) + allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1437') + allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1438') + allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1439') + allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1440') + allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1441') + allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1442') + allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1443') + allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1444') + allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1445') + allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1446') + allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1447') + allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1448') + allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1449') + allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1450') + allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1451') + allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1452') + allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1453') + allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1454') + allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1455') + allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1456') allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1457') if (ier /= 0) stop 'Error allocating array c11store etc.' ! note: currently, they need to be defined, as they are used in some subroutine arguments - allocate(R_xx(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(R_yy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(R_xy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(R_xz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) + allocate(R_xx(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1458') + allocate(R_yy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1459') + allocate(R_xy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1460') + allocate(R_xz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1461') allocate(R_yz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1462') if (ier /= 0) stop 'Error allocating array R_xx etc.' ! needed for attenuation and/or kernel computations - allocate(epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) + allocate(epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1463') + allocate(epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1464') + allocate(epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1465') + allocate(epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1466') + allocate(epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1467') allocate(epsilondev_trace(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1468') if (ier /= 0) stop 'Error allocating array epsilondev_xx etc.' allocate(R_trace(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1469') if (ier /= 0) stop 'Error allocating array R_trace etc.' ! note: needed for some subroutine arguments allocate(epsilon_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1470') if (ier /= 0) stop 'Error allocating array epsilon_trace_over_3' ! needed for attenuation allocate(factor_common(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1471') if (ier /= 0) stop 'Error allocating array factor_common etc.' allocate(factor_common_kappa(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1472') if (ier /= 0) stop 'Error allocating array factor_common_kappa etc.' ! reads mass matrices @@ -259,12 +312,14 @@ subroutine read_mesh_databases() if (APPROXIMATE_OCEAN_LOAD) then ! ocean mass matrix allocate(rmass_ocean_load(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1473') if (ier /= 0) stop 'Error allocating array rmass_ocean_load' if (I_should_read_the_database) read(27) rmass_ocean_load if (size(rmass_ocean_load) > 0) call bcast_all_cr_for_database(rmass_ocean_load(1), size(rmass_ocean_load)) else ! dummy allocation allocate(rmass_ocean_load(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1474') if (ier /= 0) stop 'Error allocating dummy array rmass_ocean_load' endif @@ -290,49 +345,78 @@ subroutine read_mesh_databases() ! displacement,velocity,acceleration for the solid (s) & fluid (w) phases allocate(displs_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1475') if (ier /= 0) stop 'Error allocating array displs_poroelastic' allocate(velocs_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1476') if (ier /= 0) stop 'Error allocating array velocs_poroelastic' allocate(accels_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1477') if (ier /= 0) stop 'Error allocating array accels_poroelastic' allocate(displw_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1478') if (ier /= 0) stop 'Error allocating array displw_poroelastic' allocate(velocw_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1479') if (ier /= 0) stop 'Error allocating array velocw_poroelastic' allocate(accelw_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1480') if (ier /= 0) stop 'Error allocating array accelw_poroelastic' allocate(rmass_solid_poroelastic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1481') if (ier /= 0) stop 'Error allocating array rmass_solid_poroelastic' allocate(rmass_fluid_poroelastic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1482') if (ier /= 0) stop 'Error allocating array rmass_fluid_poroelastic' - allocate(rhoarraystore(2,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(kappaarraystore(3,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(etastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(tortstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(phistore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(permstore(6,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vpI(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vpII(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rhoarraystore(2,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1483') + allocate(kappaarraystore(3,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1484') + allocate(etastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1485') + allocate(tortstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1486') + allocate(phistore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1487') + allocate(permstore(6,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1488') + allocate(rho_vpI(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1489') + allocate(rho_vpII(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1490') allocate(rho_vsI(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1491') if (ier /= 0) stop 'Error allocating array poroelastic properties' ! needed for kernel computations - allocate(epsilonsdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(epsilonsdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1492') + allocate(epsilonsdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1493') + allocate(epsilonsdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1494') + allocate(epsilonsdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1495') + allocate(epsilonsdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1496') + allocate(epsilonwdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1497') + allocate(epsilonwdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1498') + allocate(epsilonwdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1499') + allocate(epsilonwdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1500') allocate(epsilonwdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1501') if (ier /= 0) stop 'Error allocating array epsilonsdev_xx etc.' - allocate(epsilons_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(epsilons_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1502') allocate(epsilonw_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1503') if (ier /= 0) stop 'Error allocating array epsilons_trace_over_3 etc.' if (I_should_read_the_database) then @@ -383,6 +467,7 @@ subroutine read_mesh_databases() ! C-PML absorbing boundary conditions ! we allocate this array even when PMLs are absent because we need it in logical tests in "if" statements allocate(is_CPML(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1504') if (ier /= 0) stop 'Error allocating array is_CPML' ! make sure there are no PMLs by default, @@ -406,27 +491,38 @@ subroutine read_mesh_databases() if (NSPEC_CPML > 0) then allocate(CPML_regions(NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1505') if (ier /= 0) stop 'Error allocating array CPML_regions' allocate(CPML_to_spec(NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1506') if (ier /= 0) stop 'Error allocating array CPML_to_spec' allocate(d_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1507') if (ier /= 0) stop 'Error allocating array d_store_x' allocate(d_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1508') if (ier /= 0) stop 'Error allocating array d_store_y' allocate(d_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1509') if (ier /= 0) stop 'Error allocating array d_store_z' allocate(K_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1510') if (ier /= 0) stop 'Error allocating array K_store_x' allocate(K_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1511') if (ier /= 0) stop 'Error allocating array K_store_y' allocate(K_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1512') if (ier /= 0) stop 'Error allocating array K_store_z' allocate(alpha_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1513') if (ier /= 0) stop 'Error allocating array alpha_store' allocate(alpha_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1514') if (ier /= 0) stop 'Error allocating array alpha_store' allocate(alpha_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1515') if (ier /= 0) stop 'Error allocating array alpha_store' if (I_should_read_the_database) then @@ -463,6 +559,7 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(nglob_interface_PML_elastic, 1) if (nglob_interface_PML_acoustic > 0) then allocate(points_interface_PML_acoustic(nglob_interface_PML_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1516') if (ier /= 0) stop 'Error allocating array points_interface_PML_acoustic' if (I_should_read_the_database) read(27) points_interface_PML_acoustic if (size(points_interface_PML_acoustic) > 0) & @@ -470,6 +567,7 @@ subroutine read_mesh_databases() endif if (nglob_interface_PML_elastic > 0) then allocate(points_interface_PML_elastic(nglob_interface_PML_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1517') if (ier /= 0) stop 'Error allocating array points_interface_PML_elastic' if (I_should_read_the_database) read(27) points_interface_PML_elastic if (size(points_interface_PML_elastic) > 0) & @@ -488,10 +586,14 @@ subroutine read_mesh_databases() print *,'read_mesh_databases: reading in negative num_abs_boundary_faces ',num_abs_boundary_faces,'...resetting to zero' num_abs_boundary_faces = 0 endif - allocate(abs_boundary_ispec(num_abs_boundary_faces)) - allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)) - allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)) + allocate(abs_boundary_ispec(num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1518') + allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1519') + allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1520') allocate(abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1521') if (ier /= 0) stop 'Error allocating array abs_boundary_ispec etc.' if (num_abs_boundary_faces > 0) then @@ -544,12 +646,18 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(NSPEC2D_BOTTOM, 1) call bcast_all_i_for_database(NSPEC2D_TOP, 1) - allocate(ibelm_xmin(nspec2D_xmin)) - allocate(ibelm_xmax(nspec2D_xmax)) - allocate(ibelm_ymin(nspec2D_ymin)) - allocate(ibelm_ymax(nspec2D_ymax)) - allocate(ibelm_bottom(NSPEC2D_BOTTOM)) + allocate(ibelm_xmin(nspec2D_xmin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1522') + allocate(ibelm_xmax(nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1523') + allocate(ibelm_ymin(nspec2D_ymin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1524') + allocate(ibelm_ymax(nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1525') + allocate(ibelm_bottom(NSPEC2D_BOTTOM),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1526') allocate(ibelm_top(NSPEC2D_TOP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1527') if (ier /= 0) stop 'Error allocating arrays ibelm_xmin,ibelm_xmax etc.' if (I_should_read_the_database) then read(27) ibelm_xmin @@ -569,10 +677,14 @@ subroutine read_mesh_databases() ! free surface if (I_should_read_the_database) read(27) num_free_surface_faces call bcast_all_i_for_database(num_free_surface_faces, 1) - allocate(free_surface_ispec(num_free_surface_faces)) - allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)) - allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces)) + allocate(free_surface_ispec(num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1528') + allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1529') + allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1530') allocate(free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1531') if (ier /= 0) stop 'Error allocating arrays free_surface_ispec etc.' if (num_free_surface_faces > 0) then if (I_should_read_the_database) then @@ -594,10 +706,14 @@ subroutine read_mesh_databases() ! acoustic-elastic coupling surface if (I_should_read_the_database) read(27) num_coupling_ac_el_faces call bcast_all_i_for_database(num_coupling_ac_el_faces, 1) - allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)) - allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)) - allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)) + allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1532') + allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1533') + allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1534') allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1535') if (ier /= 0) stop 'Error allocating array coupling_ac_el_normal etc.' if (num_coupling_ac_el_faces > 0) then if (I_should_read_the_database) then @@ -619,10 +735,14 @@ subroutine read_mesh_databases() ! acoustic-poroelastic coupling surface if (I_should_read_the_database) read(27) num_coupling_ac_po_faces call bcast_all_i_for_database(num_coupling_ac_po_faces, 1) - allocate(coupling_ac_po_normal(NDIM,NGLLSQUARE,num_coupling_ac_po_faces)) - allocate(coupling_ac_po_jacobian2Dw(NGLLSQUARE,num_coupling_ac_po_faces)) - allocate(coupling_ac_po_ijk(3,NGLLSQUARE,num_coupling_ac_po_faces)) + allocate(coupling_ac_po_normal(NDIM,NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1536') + allocate(coupling_ac_po_jacobian2Dw(NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1537') + allocate(coupling_ac_po_ijk(3,NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1538') allocate(coupling_ac_po_ispec(num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1539') if (ier /= 0) stop 'Error allocating array coupling_ac_po_normal etc.' if (num_coupling_ac_po_faces > 0) then if (I_should_read_the_database) then @@ -644,12 +764,18 @@ subroutine read_mesh_databases() ! elastic-poroelastic coupling surface if (I_should_read_the_database) read(27) num_coupling_el_po_faces call bcast_all_i_for_database(num_coupling_el_po_faces, 1) - allocate(coupling_el_po_normal(NDIM,NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_el_po_jacobian2Dw(NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_el_po_ijk(3,NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_po_el_ijk(3,NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_el_po_ispec(num_coupling_el_po_faces)) + allocate(coupling_el_po_normal(NDIM,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1540') + allocate(coupling_el_po_jacobian2Dw(NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1541') + allocate(coupling_el_po_ijk(3,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1542') + allocate(coupling_po_el_ijk(3,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1543') + allocate(coupling_el_po_ispec(num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1544') allocate(coupling_po_el_ispec(num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1545') if (ier /= 0) stop 'Error allocating array coupling_el_po_normal etc.' if (num_coupling_el_po_faces > 0) then if (I_should_read_the_database) then @@ -677,13 +803,16 @@ subroutine read_mesh_databases() ! MPI interfaces if (I_should_read_the_database) read(27) num_interfaces_ext_mesh call bcast_all_i_for_database(num_interfaces_ext_mesh, 1) - allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh)) + allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1546') allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1547') if (ier /= 0) stop 'Error allocating array my_neighbors_ext_mesh etc.' if (num_interfaces_ext_mesh > 0) then if (I_should_read_the_database) read(27) max_nibool_interfaces_ext_mesh call bcast_all_i_for_database(max_nibool_interfaces_ext_mesh, 1) allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1548') if (ier /= 0) stop 'Error allocating array ibool_interfaces_ext_mesh' if (I_should_read_the_database) then read(27) my_neighbors_ext_mesh @@ -699,6 +828,7 @@ subroutine read_mesh_databases() else max_nibool_interfaces_ext_mesh = 0 allocate(ibool_interfaces_ext_mesh(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1549') endif if (ELASTIC_SIMULATION .and. ANISOTROPY) then @@ -750,6 +880,7 @@ subroutine read_mesh_databases() ! inner / outer elements allocate(ispec_is_inner(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1550') if (ier /= 0) stop 'Error allocating array ispec_is_inner' if (I_should_read_the_database) read(27) ispec_is_inner if (size(ispec_is_inner) > 0) call bcast_all_l_for_database(ispec_is_inner(1), size(ispec_is_inner)) @@ -764,6 +895,7 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(num_phase_ispec_acoustic, 1) if (num_phase_ispec_acoustic < 0) stop 'Error acoustic simulation: num_phase_ispec_acoustic is < zero' allocate( phase_ispec_inner_acoustic(num_phase_ispec_acoustic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1551') if (ier /= 0) stop 'Error allocating array phase_ispec_inner_acoustic' if (num_phase_ispec_acoustic > 0) then if (I_should_read_the_database) read(27) phase_ispec_inner_acoustic @@ -782,6 +914,7 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(num_phase_ispec_elastic, 1) if (num_phase_ispec_elastic < 0) stop 'Error elastic simulation: num_phase_ispec_elastic is < zero' allocate( phase_ispec_inner_elastic(num_phase_ispec_elastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1552') if (ier /= 0) stop 'Error allocating array phase_ispec_inner_elastic' if (num_phase_ispec_elastic > 0) then if (I_should_read_the_database) read(27) phase_ispec_inner_elastic @@ -800,6 +933,7 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(num_phase_ispec_poroelastic, 1) if (num_phase_ispec_poroelastic < 0) stop 'Error poroelastic simulation: num_phase_ispec_poroelastic is < zero' allocate( phase_ispec_inner_poroelastic(num_phase_ispec_poroelastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1553') if (ier /= 0) stop 'Error allocating array phase_ispec_inner_poroelastic' if (num_phase_ispec_poroelastic > 0) then if (I_should_read_the_database) read(27) phase_ispec_inner_poroelastic @@ -817,6 +951,7 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(num_colors_inner_acoustic, 1) allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1554') if (ier /= 0) stop 'Error allocating num_elem_colors_acoustic array' if (I_should_read_the_database) read(27) num_elem_colors_acoustic @@ -830,6 +965,7 @@ subroutine read_mesh_databases() call bcast_all_i_for_database(num_colors_inner_elastic, 1) allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1555') if (ier /= 0) stop 'Error allocating num_elem_colors_elastic array' if (I_should_read_the_database) read(27) num_elem_colors_elastic @@ -842,19 +978,23 @@ subroutine read_mesh_databases() num_colors_outer_acoustic = 0 num_colors_inner_acoustic = 0 allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1556') if (ier /= 0) stop 'Error allocating num_elem_colors_acoustic array' endif if (ELASTIC_SIMULATION) then num_colors_outer_elastic = 0 num_colors_inner_elastic = 0 allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1557') if (ier /= 0) stop 'Error allocating num_elem_colors_elastic array' endif endif ! for mesh surface - allocate(ispec_is_surface_external_mesh(NSPEC_AB)) + allocate(ispec_is_surface_external_mesh(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1558') allocate(iglob_is_surface_external_mesh(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1559') if (ier /= 0) stop 'error allocating array for mesh surface' ! determines model surface ! returns surface points/elements in ispec_is_surface_external_mesh / iglob_is_surface_external_mesh @@ -874,28 +1014,44 @@ subroutine read_mesh_databases() ! MPI communications if (ACOUSTIC_SIMULATION) then - allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh)) + allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1560') + allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1561') + allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1562') allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1563') if (ier /= 0) stop 'Error allocating array buffer_send_scalar_ext_mesh,.. for acoustic simulations' endif if (ELASTIC_SIMULATION) then - allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh)) + allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1564') + allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1565') + allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1566') allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1567') if (ier /= 0) stop 'Error allocating array buffer_send_vector_ext_mesh,.. for elastic simulations' endif if (POROELASTIC_SIMULATION) then - allocate(buffer_send_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_send_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(request_send_vector_ext_mesh_s(num_interfaces_ext_mesh)) - allocate(request_recv_vector_ext_mesh_s(num_interfaces_ext_mesh)) - allocate(request_send_vector_ext_mesh_w(num_interfaces_ext_mesh)) + allocate(buffer_send_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1568') + allocate(buffer_recv_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1569') + allocate(buffer_send_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1570') + allocate(buffer_recv_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1571') + allocate(request_send_vector_ext_mesh_s(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1572') + allocate(request_recv_vector_ext_mesh_s(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1573') + allocate(request_send_vector_ext_mesh_w(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1574') allocate(request_recv_vector_ext_mesh_w(num_interfaces_ext_mesh), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1575') if (ier /= 0) stop 'Error allocating array buffer_send_vector_ext_mesh_s,.. for poroelastic simulations' endif @@ -918,6 +1074,7 @@ subroutine read_mesh_databases_moho() ! always needed to be allocated for routine arguments allocate( is_moho_top(NSPEC_BOUN),is_moho_bot(NSPEC_BOUN),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1576') if (ier /= 0) stop 'Error allocating array is_moho_top etc.' ! checks if anything to do @@ -936,12 +1093,18 @@ subroutine read_mesh_databases_moho() call bcast_all_i_for_database(NSPEC2D_MOHO, 1) ! allocates arrays for moho mesh - allocate(ibelm_moho_bot(NSPEC2D_MOHO)) - allocate(ibelm_moho_top(NSPEC2D_MOHO)) - allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO)) - allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO)) - allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO)) + allocate(ibelm_moho_bot(NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1577') + allocate(ibelm_moho_top(NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1578') + allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1579') + allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1580') + allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1581') allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1582') if (ier /= 0) stop 'Error allocating array ibelm_moho_bot etc.' if (I_should_read_the_database) then @@ -1002,10 +1165,14 @@ subroutine read_mesh_databases_moho() ! moho boundary if (ELASTIC_SIMULATION) then ! always needed to be allocated for routine arguments - allocate(dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO)) - allocate(dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO)) - allocate(b_dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO)) + allocate(dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1583') + allocate(dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1584') + allocate(b_dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1585') allocate(b_dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1586') if (ier /= 0) stop 'Error allocating array dsdx_top etc.' endif @@ -1033,10 +1200,13 @@ subroutine read_mesh_databases_adjoint() if (ELASTIC_SIMULATION .and. SIMULATION_TYPE == 3) then ! backward displacement,velocity,acceleration fields allocate(b_displ(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1587') if (ier /= 0) stop 'Error allocating array b_displ' allocate(b_veloc(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1588') if (ier /= 0) stop 'Error allocating array b_veloc' allocate(b_accel(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1589') if (ier /= 0) stop 'Error allocating array b_accel' ! adjoint kernels @@ -1044,92 +1214,129 @@ subroutine read_mesh_databases_adjoint() ! primary, isotropic kernels ! density kernel allocate(rho_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1590') if (ier /= 0) stop 'Error allocating array rho_kl' if (ANISOTROPIC_KL) then ! anisotropic kernels allocate(cijkl_kl(21,NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1591') if (ier /= 0) stop 'Error allocating array cijkl_kl' !dummy - allocate(mu_kl(1,1,1,1)) - allocate(kappa_kl(1,1,1,1)) + allocate(mu_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1592') + allocate(kappa_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1593') else ! shear modulus kernel allocate(mu_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1594') if (ier /= 0) stop 'Error allocating array mu_kl' ! compressional modulus kernel allocate(kappa_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1595') if (ier /= 0) stop 'Error allocating array kappa_kl' !dummy - allocate(cijkl_kl(1,1,1,1,1)) + allocate(cijkl_kl(1,1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1596') endif ! noise source strength kernel if (NOISE_TOMOGRAPHY == 3) then allocate(sigma_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1597') if (ier /= 0) stop 'Error allocating array sigma_kl' endif ! preconditioner if (APPROXIMATE_HESS_KL) then allocate(hess_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1598') allocate(hess_rho_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1599') allocate(hess_kappa_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1600') allocate(hess_mu_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1601') if (ier /= 0) stop 'Error allocating array hess_kl' else ! dummy allocation allocate(hess_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1602') allocate(hess_rho_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1603') allocate(hess_mu_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1604') allocate(hess_kappa_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1605') if (ier /= 0) stop 'Error allocating dummy array hess_kl' endif ! MPI handling - allocate(b_request_send_vector_ext_mesh(num_interfaces_ext_mesh)) - allocate(b_request_recv_vector_ext_mesh(num_interfaces_ext_mesh)) - allocate(b_buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) + allocate(b_request_send_vector_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1606') + allocate(b_request_recv_vector_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1607') + allocate(b_buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1608') allocate(b_buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1609') if (ier /= 0) stop 'Error allocating array b_request_send_vector_ext_mesh etc.' ! allocates attenuation solids - allocate(b_R_xx(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(b_R_yy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(b_R_xy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(b_R_xz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) + allocate(b_R_xx(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1610') + allocate(b_R_yy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1611') + allocate(b_R_xy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1612') + allocate(b_R_xz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1613') allocate(b_R_yz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1614') if (ier /= 0) stop 'Error allocating array b_R_xx etc.' ! note: these arrays are needed for attenuation and/or kernel computations - allocate(b_epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(b_epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(b_epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(b_epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(b_epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) + allocate(b_epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1615') + allocate(b_epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1616') + allocate(b_epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1617') + allocate(b_epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1618') + allocate(b_epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1619') allocate(b_epsilondev_trace(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1620') if (ier /= 0) stop 'Error allocating array b_epsilondev_xx etc.' ! needed for kernel computations allocate(b_epsilon_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1621') if (ier /= 0) stop 'Error allocating array b_epsilon_trace_over_3' ! allocates attenuation solids for considering kappa allocate(b_R_trace(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1622') if (ier /= 0) stop 'Error allocating array b_R_trace etc.' ! Moho kernel if (SAVE_MOHO_MESH) then allocate( moho_kl(NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1623') if (ier /= 0) stop 'Error allocating array moho_kl' endif else ! dummy allocation allocate(b_displ(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1624') if (ier /= 0) stop 'Error allocating dummy array b_displ' allocate(b_veloc(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1625') if (ier /= 0) stop 'Error allocating dummy array b_veloc' allocate(b_accel(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1626') if (ier /= 0) stop 'Error allocating dummy array b_accel' endif @@ -1138,59 +1345,87 @@ subroutine read_mesh_databases_adjoint() ! backward potentials ! NB_RUNS_ACOUSTIC_GPU is set to 1 by default in constants.h - allocate(b_potential_acoustic(NGLOB_ADJOINT*NB_RUNS_ACOUSTIC_GPU)) - allocate(b_potential_dot_acoustic(NGLOB_ADJOINT*NB_RUNS_ACOUSTIC_GPU)) + allocate(b_potential_acoustic(NGLOB_ADJOINT*NB_RUNS_ACOUSTIC_GPU),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1627') + allocate(b_potential_dot_acoustic(NGLOB_ADJOINT*NB_RUNS_ACOUSTIC_GPU),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1628') allocate(b_potential_dot_dot_acoustic(NGLOB_ADJOINT*NB_RUNS_ACOUSTIC_GPU),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1629') if (ier /= 0) stop 'Error allocating array b_potential_acoustic etc.' ! kernels - allocate(rho_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(rhop_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(kappa_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(rho_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1630') + allocate(rhop_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1631') + allocate(kappa_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1632') allocate(alpha_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1633') if (ier /= 0) stop 'Error allocating array rho_ac_kl etc.' ! preconditioner if (APPROXIMATE_HESS_KL) then allocate(hess_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1634') allocate(hess_rho_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1635') allocate(hess_kappa_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1636') if (ier /= 0) stop 'Error allocating array hess_ac_kl' else ! dummy allocation allocate(hess_ac_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1637') allocate(hess_rho_ac_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1638') allocate(hess_kappa_ac_kl(0,0,0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1639') if (ier /= 0) stop 'Error allocating dummy array hess_ac_kl' endif ! MPI handling - allocate(b_request_send_scalar_ext_mesh(num_interfaces_ext_mesh)) - allocate(b_request_recv_scalar_ext_mesh(num_interfaces_ext_mesh)) - allocate(b_buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) + allocate(b_request_send_scalar_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1640') + allocate(b_request_recv_scalar_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1641') + allocate(b_buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1642') allocate(b_buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1643') if (ier /= 0) stop 'Error allocating array b_request_send_scalar_ext_mesh' else ! backward potentials - allocate(b_potential_acoustic(1)) - allocate(b_potential_dot_acoustic(1)) + allocate(b_potential_acoustic(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1644') + allocate(b_potential_dot_acoustic(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1645') allocate(b_potential_dot_dot_acoustic(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1646') if (ier /= 0) stop 'Error allocating dummy array b_potential_acoustic etc.' ! kernels - allocate(rho_ac_kl(1,1,1,1)) - allocate(rhop_ac_kl(1,1,1,1)) - allocate(kappa_ac_kl(1,1,1,1)) + allocate(rho_ac_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1647') + allocate(rhop_ac_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1648') + allocate(kappa_ac_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1649') allocate(alpha_ac_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1650') if (ier /= 0) stop 'Error allocating dummy array rho_ac_kl etc.' ! MPI handling - allocate(b_request_send_scalar_ext_mesh(1)) - allocate(b_request_recv_scalar_ext_mesh(1)) - allocate(b_buffer_send_scalar_ext_mesh(1,1)) + allocate(b_request_send_scalar_ext_mesh(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1651') + allocate(b_request_recv_scalar_ext_mesh(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1652') + allocate(b_buffer_send_scalar_ext_mesh(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1653') allocate(b_buffer_recv_scalar_ext_mesh(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1654') if (ier /= 0) stop 'Error allocating dummy array b_request_send_scalar_ext_mesh etc.' endif @@ -1199,85 +1434,133 @@ subroutine read_mesh_databases_adjoint() if (POROELASTIC_SIMULATION .and. SIMULATION_TYPE == 3) then ! backward displacement,velocity,acceleration for the solid (s) & fluid (w) phases allocate(b_displs_poroelastic(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1655') if (ier /= 0) stop 'Error allocating array b_displs_poroelastic' allocate(b_velocs_poroelastic(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1656') if (ier /= 0) stop 'Error allocating array b_velocs_poroelastic' allocate(b_accels_poroelastic(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1657') if (ier /= 0) stop 'Error allocating array b_accels_poroelastic' allocate(b_displw_poroelastic(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1658') if (ier /= 0) stop 'Error allocating array b_displw_poroelastic' allocate(b_velocw_poroelastic(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1659') if (ier /= 0) stop 'Error allocating array b_velocw_poroelastic' allocate(b_accelw_poroelastic(NDIM,NGLOB_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1660') if (ier /= 0) stop 'Error allocating array b_accelw_poroelastic' ! adjoint kernels ! primary, isotropic kernels - allocate(rhot_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(rhof_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(sm_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(rhot_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1661') + allocate(rhof_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1662') + allocate(sm_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1663') allocate(eta_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1664') if (ier /= 0) stop 'Error allocating array rhot_kl etc.' allocate(mufr_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1665') if (ier /= 0) stop 'Error allocating array mufr_kl' - allocate(B_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(C_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(B_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1666') + allocate(C_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1667') allocate(M_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1668') if (ier /= 0) stop 'Error allocating array B_kl etc.' ! density, isotropic kernels - allocate(rhob_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(rhofb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(rhob_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1669') + allocate(rhofb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1670') allocate(phi_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1671') if (ier /= 0) stop 'Error allocating array rhob_kl etc.' allocate(mufrb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1672') if (ier /= 0) stop 'Error allocating array mufrb_kl' - allocate(Bb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(Cb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(Bb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1673') + allocate(Cb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1674') allocate(Mb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1675') if (ier /= 0) stop 'Error allocating array Bb_kl etc.' ! wavespeed, isotropic kernels - allocate(rhobb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(rhofbb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(phib_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(rhobb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1676') + allocate(rhofbb_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1677') + allocate(phib_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1678') allocate(ratio_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1679') if (ier /= 0) stop 'Error allocating array rhobb_kl etc.' allocate(cs_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1680') if (ier /= 0) stop 'Error allocating array cs_kl' - allocate(cpI_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(cpI_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1681') allocate(cpII_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1682') if (ier /= 0) stop 'Error allocating array cpI_kl etc.' ! MPI handling - allocate(b_request_send_vector_ext_meshs(num_interfaces_ext_mesh)) - allocate(b_request_recv_vector_ext_meshs(num_interfaces_ext_mesh)) - allocate(b_buffer_send_vector_ext_meshs(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) + allocate(b_request_send_vector_ext_meshs(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1683') + allocate(b_request_recv_vector_ext_meshs(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1684') + allocate(b_buffer_send_vector_ext_meshs(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1685') allocate(b_buffer_recv_vector_ext_meshs(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1686') if (ier /= 0) stop 'Error allocating array b_request_send_vector_ext_meshs etc.' - allocate(b_request_send_vector_ext_meshw(num_interfaces_ext_mesh)) - allocate(b_request_recv_vector_ext_meshw(num_interfaces_ext_mesh)) - allocate(b_buffer_send_vector_ext_meshw(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) + allocate(b_request_send_vector_ext_meshw(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1687') + allocate(b_request_recv_vector_ext_meshw(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1688') + allocate(b_buffer_send_vector_ext_meshw(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1689') allocate(b_buffer_recv_vector_ext_meshw(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1690') if (ier /= 0) stop 'Error allocating array b_request_send_vector_ext_meshw etc.' ! arrays needed for kernel computations - allocate(b_epsilonsdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonsdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonsdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonsdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonsdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonwdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonwdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonwdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(b_epsilonwdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(b_epsilonsdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1691') + allocate(b_epsilonsdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1692') + allocate(b_epsilonsdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1693') + allocate(b_epsilonsdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1694') + allocate(b_epsilonsdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1695') + allocate(b_epsilonwdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1696') + allocate(b_epsilonwdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1697') + allocate(b_epsilonwdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1698') + allocate(b_epsilonwdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1699') allocate(b_epsilonwdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1700') if (ier /= 0) stop 'Error allocating array b_epsilonsdev_xx etc.' - allocate(b_epsilons_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(b_epsilons_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1701') allocate(b_epsilonw_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1702') if (ier /= 0) stop 'Error allocating array b_epsilons_trace_over_3 etc.' else ! dummy arrays @@ -1285,55 +1568,83 @@ subroutine read_mesh_databases_adjoint() ! backward displacement,velocity,acceleration for the solid (s) & fluid (w) ! phases allocate(b_displs_poroelastic(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1703') if (ier /= 0) stop 'Error allocating dummy array b_displs_poroelastic' allocate(b_velocs_poroelastic(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1704') if (ier /= 0) stop 'Error allocating dummy array b_velocs_poroelastic' allocate(b_accels_poroelastic(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1705') if (ier /= 0) stop 'Error allocating dummy array b_accels_poroelastic' allocate(b_displw_poroelastic(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1706') if (ier /= 0) stop 'Error allocating dummy array b_displw_poroelastic' allocate(b_velocw_poroelastic(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1707') if (ier /= 0) stop 'Error allocating dummy array b_velocw_poroelastic' allocate(b_accelw_poroelastic(1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1708') if (ier /= 0) stop 'Error allocating dummy array b_accelw_poroelastic' ! adjoint kernels ! primary, isotropic kernels - allocate(rhot_kl(1,1,1,1)) - allocate(rhof_kl(1,1,1,1)) - allocate(sm_kl(1,1,1,1)) + allocate(rhot_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1709') + allocate(rhof_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1710') + allocate(sm_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1711') allocate(eta_kl(1,1,1,1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1712') if (ier /= 0) stop 'Error allocating dummy array rhot_kl etc.' allocate(mufr_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1713') if (ier /= 0) stop 'Error allocating dummy array mufr_kl' - allocate(B_kl(1,1,1,1)) - allocate(C_kl(1,1,1,1)) + allocate(B_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1714') + allocate(C_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1715') allocate(M_kl(1,1,1,1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1716') if (ier /= 0) stop 'Error allocating dummy array B_kl etc.' ! density, isotropic kernels - allocate(rhob_kl(1,1,1,1)) - allocate(rhofb_kl(1,1,1,1)) + allocate(rhob_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1717') + allocate(rhofb_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1718') allocate(phi_kl(1,1,1,1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1719') if (ier /= 0) stop 'Error allocating dummy array rhob_kl etc.' allocate(mufrb_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1720') if (ier /= 0) stop 'Error allocating dummy array mufrb_kl' - allocate(Bb_kl(1,1,1,1)) - allocate(Cb_kl(1,1,1,1)) + allocate(Bb_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1721') + allocate(Cb_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1722') allocate(Mb_kl(1,1,1,1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1723') if (ier /= 0) stop 'Error allocating dummy array Bb_kl etc.' ! wavespeed, isotropic kernels - allocate(rhobb_kl(1,1,1,1)) - allocate(rhofbb_kl(1,1,1,1)) - allocate(phib_kl(1,1,1,1)) + allocate(rhobb_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1724') + allocate(rhofbb_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1725') + allocate(phib_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1726') allocate(ratio_kl(1,1,1,1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1727') if (ier /= 0) stop 'Error allocating dummy array rhobb_kl etc.' allocate(cs_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1728') if (ier /= 0) stop 'Error allocating dummy array cs_kl' - allocate(cpI_kl(1,1,1,1)) + allocate(cpI_kl(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1729') allocate(cpII_kl(1,1,1,1), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1730') if (ier /= 0) stop 'Error allocating dummy array cpI_kl etc.' endif diff --git a/src/specfem3D/read_mesh_databases_adios.F90 b/src/specfem3D/read_mesh_databases_adios.F90 index 84d0e1f2c..d7de5b6e5 100644 --- a/src/specfem3D/read_mesh_databases_adios.F90 +++ b/src/specfem3D/read_mesh_databases_adios.F90 @@ -612,21 +612,27 @@ subroutine read_mesh_databases_adios() if (ACOUSTIC_SIMULATION) then ! potentials allocate(potential_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1791') if (ier /= 0) stop 'error allocating array potential_acoustic' allocate(potential_dot_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1792') if (ier /= 0) stop 'error allocating array potential_dot_acoustic' allocate(potential_dot_dot_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1793') if (ier /= 0) stop 'error allocating array potential_dot_dot_acoustic' if (SIMULATION_TYPE /= 1) then allocate(potential_acoustic_adj_coupling(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1794') if (ier /= 0) stop 'error allocating array potential_acoustic_adj_coupling' endif ! mass matrix, density allocate(rmass_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1795') if (ier /= 0) stop 'error allocating array rmass_acoustic' ! initializes mass matrix contribution allocate(rmassz_acoustic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1796') if (ier /= 0) stop 'error allocating array rmassz_acoustic' rmassz_acoustic(:) = 0._CUSTOM_REAL endif @@ -635,6 +641,7 @@ subroutine read_mesh_databases_adios() ! simulations with CPML, thus we now allocate it and read it in all ! cases (whether the simulation is acoustic, elastic, or acoustic/elastic) allocate(rhostore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1797') if (ier /= 0) stop 'error allocating array rhostore' !TODO @@ -645,96 +652,144 @@ subroutine read_mesh_databases_adios() #if 1 ! displacement,velocity,acceleration allocate(displ(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1798') if (ier /= 0) stop 'error allocating array displ' allocate(veloc(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1799') if (ier /= 0) stop 'error allocating array veloc' allocate(accel(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1800') if (ier /= 0) stop 'error allocating array accel' if (SIMULATION_TYPE /= 1) then allocate(accel_adj_coupling(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1801') if (ier /= 0) stop 'error allocating array accel_adj_coupling' endif ! allocates mass matrix allocate(rmass(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1802') if (ier /= 0) stop 'error allocating array rmass' ! initializes mass matrix contributions - allocate(rmassx(NGLOB_AB)) - allocate(rmassy(NGLOB_AB)) + allocate(rmassx(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1803') + allocate(rmassy(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1804') allocate(rmassz(NGLOB_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1805') if (ier /= 0) stop 'error allocating array rmassx,rmassy,rmassz' rmassx(:) = 0._CUSTOM_REAL rmassy(:) = 0._CUSTOM_REAL rmassz(:) = 0._CUSTOM_REAL allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1806') if (ier /= 0) stop 'error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1807') if (ier /= 0) stop 'error allocating array rho_vs' rho_vp = 0.0_CUSTOM_REAL rho_vs = 0.0_CUSTOM_REAL - allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) - allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO)) + allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1808') + allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1809') + allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1810') + allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1811') + allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1812') + allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1813') + allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1814') + allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1815') + allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1816') + allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1817') + allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1818') + allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1819') + allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1820') + allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1821') + allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1822') + allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1823') + allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1824') + allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1825') + allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1826') + allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1827') allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1828') if (ier /= 0) stop 'error allocating array c11store etc.' ! note: currently, they need to be defined, as they are used in some subroutine arguments - allocate(R_xx(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(R_yy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(R_xy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) - allocate(R_xz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB)) + allocate(R_xx(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1829') + allocate(R_yy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1830') + allocate(R_xy(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1831') + allocate(R_xz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1832') allocate(R_yz(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1833') if (ier /= 0) stop 'error allocating array R_xx etc.' ! needed for attenuation and/or kernel computations - allocate(epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) - allocate(epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY)) + allocate(epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1834') + allocate(epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1835') + allocate(epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1836') + allocate(epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1837') + allocate(epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1838') allocate(epsilondev_trace(NGLLX,NGLLY,NGLLZ,NSPEC_STRAIN_ONLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1839') if (ier /= 0) stop 'error allocating array epsilondev_xx etc.' allocate(R_trace(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1840') if (ier /= 0) stop 'error allocating array R_trace etc.' ! note: needed for some subroutine arguments allocate(epsilon_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1841') if (ier /= 0) stop 'error allocating array epsilon_trace_over_3' ! needed for attenuation allocate(factor_common(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1842') if (ier /= 0) stop 'error allocating array factor_common' allocate(factor_common_kappa(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1843') if (ier /= 0) stop 'error allocating array factor_common_kappa' if (APPROXIMATE_OCEAN_LOAD) then ! ocean mass matrix allocate(rmass_ocean_load(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1844') if (ier /= 0) stop 'error allocating array rmass_ocean_load' else ! dummy allocation allocate(rmass_ocean_load(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1845') if (ier /= 0) stop 'error allocating dummy array rmass_ocean_load' endif ! TODO @@ -752,55 +807,85 @@ subroutine read_mesh_databases_adios() ! displacement,velocity,acceleration for the solid (s) & fluid (w) phases allocate(displs_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1846') if (ier /= 0) stop 'error allocating array displs_poroelastic' allocate(velocs_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1847') if (ier /= 0) stop 'error allocating array velocs_poroelastic' allocate(accels_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1848') if (ier /= 0) stop 'error allocating array accels_poroelastic' allocate(displw_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1849') if (ier /= 0) stop 'error allocating array displw_poroelastic' allocate(velocw_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1850') if (ier /= 0) stop 'error allocating array velocw_poroelastic' allocate(accelw_poroelastic(NDIM,NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1851') if (ier /= 0) stop 'error allocating array accelw_poroelastic' allocate(rmass_solid_poroelastic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1852') if (ier /= 0) stop 'error allocating array rmass_solid_poroelastic' allocate(rmass_fluid_poroelastic(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1853') if (ier /= 0) stop 'error allocating array rmass_fluid_poroelastic' - allocate(rhoarraystore(2,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(kappaarraystore(3,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(etastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(tortstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(phistore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(permstore(6,NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vpI(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vpII(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rhoarraystore(2,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1854') + allocate(kappaarraystore(3,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1855') + allocate(etastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1856') + allocate(tortstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1857') + allocate(phistore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1858') + allocate(permstore(6,NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1859') + allocate(rho_vpI(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1860') + allocate(rho_vpII(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1861') allocate(rho_vsI(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1862') if (ier /= 0) stop 'error allocating array poroelastic properties' ! needed for kernel computations - allocate(epsilonsdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonsdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(epsilonwdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(epsilonsdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1863') + allocate(epsilonsdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1864') + allocate(epsilonsdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1865') + allocate(epsilonsdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1866') + allocate(epsilonsdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1867') + allocate(epsilonwdev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1868') + allocate(epsilonwdev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1869') + allocate(epsilonwdev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1870') + allocate(epsilonwdev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1871') allocate(epsilonwdev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1872') if (ier /= 0) stop 'error allocating array epsilonsdev_xx etc.' - allocate(epsilons_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(epsilons_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1873') allocate(epsilonw_trace_over_3(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1874') if (ier /= 0) stop 'error allocating array epsilons_trace_over_3 etc.' endif ! C-PML absorbing boundary conditions ! we allocate this array even when PMLs are absent because we need it in logical tests in "if" statements allocate(is_CPML(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1875') if (ier /= 0) stop 'error allocating array is_CPML' ! make sure there are no PMLs by default, @@ -810,35 +895,48 @@ subroutine read_mesh_databases_adios() if (PML_CONDITIONS) then if (NSPEC_CPML > 0) then allocate(CPML_regions(NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1876') if (ier /= 0) stop 'error allocating array CPML_regions' allocate(CPML_to_spec(NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1877') if (ier /= 0) stop 'error allocating array CPML_to_spec' allocate(d_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1878') if (ier /= 0) stop 'error allocating array d_store_x' allocate(d_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1879') if (ier /= 0) stop 'error allocating array d_store_y' allocate(d_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1880') if (ier /= 0) stop 'error allocating array d_store_z' allocate(K_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1881') if (ier /= 0) stop 'error allocating array K_store_x' allocate(K_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1882') if (ier /= 0) stop 'error allocating array K_store_y' allocate(K_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1883') if (ier /= 0) stop 'error allocating array K_store_z' allocate(alpha_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1884') if (ier /= 0) stop 'error allocating array alpha_store_x' allocate(alpha_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1885') if (ier /= 0) stop 'error allocating array alpha_store_y' allocate(alpha_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1886') if (ier /= 0) stop 'error allocating array alpha_store_z' if ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then if (nglob_interface_PML_acoustic > 0) then allocate(points_interface_PML_acoustic(nglob_interface_PML_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1887') if (ier /= 0) stop 'error allocating array points_interface_PML_acoustic' endif if (nglob_interface_PML_elastic > 0) then allocate(points_interface_PML_elastic(nglob_interface_PML_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1888') if (ier /= 0) stop 'error allocating array points_interface_PML_elastic' endif endif @@ -846,67 +944,98 @@ subroutine read_mesh_databases_adios() endif ! absorbing boundary surface - allocate(abs_boundary_ispec(num_abs_boundary_faces)) - allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)) - allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)) + allocate(abs_boundary_ispec(num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1889') + allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1890') + allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1891') allocate(abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1892') if (ier /= 0) stop 'error allocating array abs_boundary_ispec etc.' - allocate(ibelm_xmin(nspec2D_xmin),ibelm_xmax(nspec2D_xmax)) - allocate(ibelm_ymin(nspec2D_ymin),ibelm_ymax(nspec2D_ymax)) + allocate(ibelm_xmin(nspec2D_xmin),ibelm_xmax(nspec2D_xmax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1893') + allocate(ibelm_ymin(nspec2D_ymin),ibelm_ymax(nspec2D_ymax),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1894') allocate(ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1895') if (ier /= 0) stop 'error allocating arrays ibelm_xmin,ibelm_xmax etc.' ! free surface - allocate(free_surface_ispec(num_free_surface_faces)) - allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)) - allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces)) + allocate(free_surface_ispec(num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1896') + allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1897') + allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1898') allocate(free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1899') if (ier /= 0) stop 'error allocating arrays free_surface_ispec etc.' ! acoustic-elastic coupling surface - allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)) - allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)) - allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)) + allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1900') + allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1901') + allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1902') allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1903') if (ier /= 0) stop 'error allocating array coupling_ac_el_normal etc.' ! acoustic-poroelastic coupling surface - allocate(coupling_ac_po_normal(NDIM,NGLLSQUARE,num_coupling_ac_po_faces)) - allocate(coupling_ac_po_jacobian2Dw(NGLLSQUARE,num_coupling_ac_po_faces)) - allocate(coupling_ac_po_ijk(3,NGLLSQUARE,num_coupling_ac_po_faces)) + allocate(coupling_ac_po_normal(NDIM,NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1904') + allocate(coupling_ac_po_jacobian2Dw(NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1905') + allocate(coupling_ac_po_ijk(3,NGLLSQUARE,num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1906') allocate(coupling_ac_po_ispec(num_coupling_ac_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1907') if (ier /= 0) stop 'error allocating array coupling_ac_po_normal etc.' ! elastic-poroelastic coupling surface - allocate(coupling_el_po_normal(NDIM,NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_el_po_jacobian2Dw(NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_el_po_ijk(3,NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_po_el_ijk(3,NGLLSQUARE,num_coupling_el_po_faces)) - allocate(coupling_el_po_ispec(num_coupling_el_po_faces)) + allocate(coupling_el_po_normal(NDIM,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1908') + allocate(coupling_el_po_jacobian2Dw(NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1909') + allocate(coupling_el_po_ijk(3,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1910') + allocate(coupling_po_el_ijk(3,NGLLSQUARE,num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1911') + allocate(coupling_el_po_ispec(num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1912') allocate(coupling_po_el_ispec(num_coupling_el_po_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1913') if (ier /= 0) stop 'error allocating array coupling_el_po_normal etc.' ! MPI interfaces - allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh)) + allocate(my_neighbors_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1914') allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1915') if (ier /= 0) stop 'error allocating array my_neighbors_ext_mesh etc.' if (num_interfaces_ext_mesh > 0) then allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1916') if (ier /= 0) stop 'error allocating array ibool_interfaces_ext_mesh' else max_nibool_interfaces_ext_mesh = 0 allocate(ibool_interfaces_ext_mesh(0,0),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1917') endif ! inner / outer elements allocate(ispec_is_inner(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1918') if (ier /= 0) stop 'error allocating array ispec_is_inner' if (ACOUSTIC_SIMULATION) then if (num_phase_ispec_acoustic < 0) stop 'error acoustic simulation:' // & 'num_phase_ispec_acoustic is < zero' allocate(phase_ispec_inner_acoustic(num_phase_ispec_acoustic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1919') if (ier /= 0) stop 'error allocating array phase_ispec_inner_acoustic' endif @@ -914,6 +1043,7 @@ subroutine read_mesh_databases_adios() if (num_phase_ispec_elastic < 0) stop 'error elastic simulation:' // & 'num_phase_ispec_elastic is < zero' allocate(phase_ispec_inner_elastic(num_phase_ispec_elastic,2),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1920') if (ier /= 0) stop 'error allocating array phase_ispec_inner_elastic' endif @@ -921,6 +1051,7 @@ subroutine read_mesh_databases_adios() if (num_phase_ispec_poroelastic < 0) & stop 'error poroelastic simulation:num_phase_ispec_poroelastic is < zero' allocate(phase_ispec_inner_poroelastic(num_phase_ispec_poroelastic,2), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1921') if (ier /= 0) stop 'error allocating array phase_ispec_inner_poroelastic' endif @@ -929,28 +1060,34 @@ subroutine read_mesh_databases_adios() ! acoustic domain colors if (ACOUSTIC_SIMULATION) then allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1922') if (ier /= 0) stop 'error allocating num_elem_colors_acoustic array' endif ! elastic domain colors if (ELASTIC_SIMULATION) then allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1923') if (ier /= 0) stop 'error allocating num_elem_colors_elastic array' endif else ! allocates dummy arrays if (ACOUSTIC_SIMULATION) then allocate(num_elem_colors_acoustic(num_colors_outer_acoustic + num_colors_inner_acoustic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1924') if (ier /= 0) stop 'error allocating num_elem_colors_acoustic array' endif if (ELASTIC_SIMULATION) then allocate(num_elem_colors_elastic(num_colors_outer_elastic + num_colors_inner_elastic),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1925') if (ier /= 0) stop 'error allocating num_elem_colors_elastic array' endif endif ! for mesh surface - allocate(ispec_is_surface_external_mesh(NSPEC_AB)) + allocate(ispec_is_surface_external_mesh(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1926') allocate(iglob_is_surface_external_mesh(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1927') if (ier /= 0) stop 'error allocating array for mesh surface' !-----------------------------------. @@ -1616,22 +1753,38 @@ subroutine read_mesh_databases_adios() !endif ! MPI communications - allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh)) - allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh)) - allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh)) - allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh)) - allocate(buffer_send_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_send_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(buffer_recv_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh)) - allocate(request_send_vector_ext_mesh_s(num_interfaces_ext_mesh)) - allocate(request_recv_vector_ext_mesh_s(num_interfaces_ext_mesh)) - allocate(request_send_vector_ext_mesh_w(num_interfaces_ext_mesh)) + allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1928') + allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1929') + allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1930') + allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1931') + allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1932') + allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1933') + allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1934') + allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1935') + allocate(buffer_send_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1936') + allocate(buffer_recv_vector_ext_mesh_s(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1937') + allocate(buffer_send_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1938') + allocate(buffer_recv_vector_ext_mesh_w(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1939') + allocate(request_send_vector_ext_mesh_s(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1940') + allocate(request_recv_vector_ext_mesh_s(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1941') + allocate(request_send_vector_ext_mesh_w(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1942') allocate(request_recv_vector_ext_mesh_w(num_interfaces_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1943') if (ier /= 0) stop 'error allocating array buffer_send_vector_ext_mesh etc.' end subroutine read_mesh_databases_adios @@ -1667,6 +1820,7 @@ subroutine read_mesh_databases_moho_adios() ! always needed to be allocated for routine arguments allocate( is_moho_top(NSPEC_BOUN),is_moho_bot(NSPEC_BOUN),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1944') if (ier /= 0) stop 'Error allocating array is_moho_top etc.' ! checks if anything to do @@ -1726,12 +1880,18 @@ subroutine read_mesh_databases_moho_adios() !---------------------------------------------. ! Allocate arrays with previously read values | !---------------------------------------------' - allocate(ibelm_moho_bot(NSPEC2D_MOHO)) - allocate(ibelm_moho_top(NSPEC2D_MOHO)) - allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO)) - allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO)) - allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO)) + allocate(ibelm_moho_bot(NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1945') + allocate(ibelm_moho_top(NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1946') + allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1947') + allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1948') + allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1949') allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1950') if (ier /= 0) stop 'error allocating array ibelm_moho_bot etc.' !-----------------------------------. @@ -1813,10 +1973,14 @@ subroutine read_mesh_databases_moho_adios() ! moho boundary if (ELASTIC_SIMULATION) then ! always needed to be allocated for routine arguments - allocate(dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO)) - allocate(dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO)) - allocate(b_dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO)) + allocate(dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1951') + allocate(dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1952') + allocate(b_dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1953') allocate(b_dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1954') if (ier /= 0) stop 'Error allocating array dsdx_top etc.' endif diff --git a/src/specfem3D/save_adjoint_kernels.f90 b/src/specfem3D/save_adjoint_kernels.f90 index 722791b9d..0c239e9b7 100644 --- a/src/specfem3D/save_adjoint_kernels.f90 +++ b/src/specfem3D/save_adjoint_kernels.f90 @@ -102,31 +102,41 @@ end subroutine save_kernels_elastic ! allocates temporary transversely isotropic kernels if (ANISOTROPIC_KL) then if (SAVE_TRANSVERSE_KL) then - allocate(alphav_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(alphah_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(betav_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) - allocate(betah_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT)) + allocate(alphav_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2243') + allocate(alphah_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2244') + allocate(betav_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2245') + allocate(betah_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2246') allocate(eta_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2247') if (ier /= 0) stop 'error allocating arrays alphav_kl,...' ! derived kernels ! vp kernel allocate(alpha_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2248') if (ier /= 0) stop 'error allocating array alpha_kl' ! vs kernel allocate(beta_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2249') if (ier /= 0) stop 'error allocating array beta_kl' endif else ! derived kernels ! vp kernel allocate(alpha_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2250') if (ier /= 0) stop 'error allocating array alpha_kl' ! vs kernel allocate(beta_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2251') if (ier /= 0) stop 'error allocating array beta_kl' ! density prime kernel allocate(rhop_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2252') if (ier /= 0) stop 'error allocating array rhop_kl' endif @@ -195,6 +205,7 @@ subroutine save_weights_kernel() real(kind=CUSTOM_REAL) :: jacobianl allocate(weights_kernel(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2253') if (ier /= 0) stop 'error allocating array weights_kernel' do ispec = 1, NSPEC_AB ispec_irreg = irregular_element_number(ispec) diff --git a/src/specfem3D/setup_GLL_points.f90 b/src/specfem3D/setup_GLL_points.f90 index 13321948c..1c103b62a 100644 --- a/src/specfem3D/setup_GLL_points.f90 +++ b/src/specfem3D/setup_GLL_points.f90 @@ -61,8 +61,10 @@ subroutine setup_GLL_points() LOCAL_PATH,SAVE_MESH_FILES) else if (POROELASTIC_SIMULATION) then - allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2421') + allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2422') rho_vp = 0.0_CUSTOM_REAL rho_vs = 0.0_CUSTOM_REAL call check_mesh_resolution_poro(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & @@ -72,8 +74,10 @@ subroutine setup_GLL_points() deallocate(rho_vp,rho_vs) else if (ACOUSTIC_SIMULATION) then allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2423') if (ier /= 0) stop 'error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2424') if (ier /= 0) stop 'error allocating array rho_vs' rho_vp = sqrt( kappastore / rhostore ) * rhostore rho_vs = 0.0_CUSTOM_REAL @@ -122,12 +126,18 @@ subroutine setup_GLL_points() enddo ! allocate 1-D Lagrange interpolators and derivatives - allocate(hxir(NGLLX)) - allocate(hpxir(NGLLX)) - allocate(hetar(NGLLY)) - allocate(hpetar(NGLLY)) - allocate(hgammar(NGLLZ)) + allocate(hxir(NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2425') + allocate(hpxir(NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2426') + allocate(hetar(NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2427') + allocate(hpetar(NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2428') + allocate(hgammar(NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2429') allocate(hpgammar(NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2430') if (ier /= 0) stop 'error allocating arrays for interpolators' ! create name of database diff --git a/src/specfem3D/setup_movie_meshes.f90 b/src/specfem3D/setup_movie_meshes.f90 index 26af2b0e6..acac96cd5 100644 --- a/src/specfem3D/setup_movie_meshes.f90 +++ b/src/specfem3D/setup_movie_meshes.f90 @@ -67,31 +67,42 @@ subroutine setup_movie_meshes() npoin = npoin_elem * nfaces_m ! surface elements - allocate(faces_surface_ispec(nfaces_m)) + allocate(faces_surface_ispec(nfaces_m),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2098') allocate(faces_surface_ibool(npoin_elem,nfaces_m),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2099') if (ier /= 0) stop 'error allocating array faces_surface_ispec' faces_surface_ispec(:) = 0 faces_surface_ibool(:,:) = 0 ! point locations - allocate(store_val_x(npoin)) - allocate(store_val_y(npoin)) + allocate(store_val_x(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2100') + allocate(store_val_y(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2101') allocate(store_val_z(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2102') if (ier /= 0) stop 'error allocating location arrays for highres movie' ! surface movie data if (MOVIE_SURFACE) then - allocate(store_val_ux(npoin)) - allocate(store_val_uy(npoin)) + allocate(store_val_ux(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2103') + allocate(store_val_uy(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2104') allocate(store_val_uz(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2105') if (ier /= 0) stop 'error allocating arrays for highres movie' endif ! shakemap data if (CREATE_SHAKEMAP) then - allocate(shakemap_ux(npoin)) - allocate(shakemap_uy(npoin)) + allocate(shakemap_ux(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2106') + allocate(shakemap_uy(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2107') allocate(shakemap_uz(npoin),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2108') if (ier /= 0) stop 'error allocating arrays for highres shakemap' ! initializes shakemap values shakemap_ux(:) = 0._CUSTOM_REAL @@ -105,31 +116,42 @@ subroutine setup_movie_meshes() ! arrays used for collected/gathered fields if (myrank == 0) then ! all point locations - allocate(store_val_x_all(npoin_elem*nfaces_surface_glob_ext_mesh)) - allocate(store_val_y_all(npoin_elem*nfaces_surface_glob_ext_mesh)) + allocate(store_val_x_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2109') + allocate(store_val_y_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2110') allocate(store_val_z_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2111') if (ier /= 0) stop 'error allocating arrays for highres movie' ! surface movie if (MOVIE_SURFACE) then - allocate(store_val_ux_all(npoin_elem*nfaces_surface_glob_ext_mesh)) - allocate(store_val_uy_all(npoin_elem*nfaces_surface_glob_ext_mesh)) + allocate(store_val_ux_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2112') + allocate(store_val_uy_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2113') allocate(store_val_uz_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2114') if (ier /= 0) stop 'error allocating arrays for highres movie' endif ! shakemap if (CREATE_SHAKEMAP) then - allocate(shakemap_ux_all(npoin_elem*nfaces_surface_glob_ext_mesh)) - allocate(shakemap_uy_all(npoin_elem*nfaces_surface_glob_ext_mesh)) + allocate(shakemap_ux_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2115') + allocate(shakemap_uy_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2116') allocate(shakemap_uz_all(npoin_elem*nfaces_surface_glob_ext_mesh),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2117') if (ier /= 0) stop 'error allocating arrays for highres movie' endif endif ! arrays for collecting movies and shakemaps - allocate(nfaces_perproc_surface(NPROC)) + allocate(nfaces_perproc_surface(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2118') allocate(faces_surface_offset(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2119') if (ier /= 0) stop 'error allocating array for movie faces' ! number of faces per slice diff --git a/src/specfem3D/setup_sources_receivers.f90 b/src/specfem3D/setup_sources_receivers.f90 index 2abe281ef..07c3627af 100644 --- a/src/specfem3D/setup_sources_receivers.f90 +++ b/src/specfem3D/setup_sources_receivers.f90 @@ -154,40 +154,66 @@ subroutine setup_sources() endif ! allocate arrays for source - allocate(islice_selected_source(NSOURCES)) - allocate(ispec_selected_source(NSOURCES)) - allocate(Mxx(NSOURCES)) - allocate(Myy(NSOURCES)) - allocate(Mzz(NSOURCES)) - allocate(Mxy(NSOURCES)) - allocate(Mxz(NSOURCES)) - allocate(Myz(NSOURCES)) - allocate(xi_source(NSOURCES)) - allocate(eta_source(NSOURCES)) - allocate(gamma_source(NSOURCES)) - allocate(tshift_src(NSOURCES)) - allocate(hdur(NSOURCES)) - allocate(hdur_Gaussian(NSOURCES)) - allocate(utm_x_source(NSOURCES)) - allocate(utm_y_source(NSOURCES)) + allocate(islice_selected_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2033') + allocate(ispec_selected_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2034') + allocate(Mxx(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2035') + allocate(Myy(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2036') + allocate(Mzz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2037') + allocate(Mxy(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2038') + allocate(Mxz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2039') + allocate(Myz(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2040') + allocate(xi_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2041') + allocate(eta_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2042') + allocate(gamma_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2043') + allocate(tshift_src(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2044') + allocate(hdur(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2045') + allocate(hdur_Gaussian(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2046') + allocate(utm_x_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2047') + allocate(utm_y_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2048') allocate(nu_source(NDIM,NDIM,NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2049') if (ier /= 0) stop 'error allocating arrays for sources' if (USE_FORCE_POINT_SOURCE) then - allocate(factor_force_source(NSOURCES)) - allocate(comp_dir_vect_source_E(NSOURCES)) - allocate(comp_dir_vect_source_N(NSOURCES)) + allocate(factor_force_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2050') + allocate(comp_dir_vect_source_E(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2051') + allocate(comp_dir_vect_source_N(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2052') allocate(comp_dir_vect_source_Z_UP(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2053') else - allocate(factor_force_source(1)) - allocate(comp_dir_vect_source_E(1)) - allocate(comp_dir_vect_source_N(1)) + allocate(factor_force_source(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2054') + allocate(comp_dir_vect_source_E(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2055') + allocate(comp_dir_vect_source_N(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2056') allocate(comp_dir_vect_source_Z_UP(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2057') endif if (ier /= 0) stop 'error allocating arrays for force point sources' !! allocate the array contains the user defined source time function allocate(user_source_time_function(NSTEP_STF, NSOURCES_STF),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2058') if (ier /= 0) stop 'error allocating arrays for user sources time function' if (USE_FORCE_POINT_SOURCE) then @@ -244,7 +270,8 @@ subroutine get_run_number_of_the_source() character(len=MAX_STRING_LEN) :: filename,string integer :: ier,isource,icounter - allocate(run_number_of_the_source(NSOURCES)) + allocate(run_number_of_the_source(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2059') if (NB_RUNS_ACOUSTIC_GPU == 1) then run_number_of_the_source(:) = 0 @@ -568,14 +595,22 @@ subroutine setup_receivers() endif ! allocate memory for receiver arrays, i.e. stations given in STATIONS file - allocate(islice_selected_rec(nrec)) - allocate(ispec_selected_rec(nrec)) - allocate(xi_receiver(nrec)) - allocate(eta_receiver(nrec)) - allocate(gamma_receiver(nrec)) - allocate(station_name(nrec)) - allocate(network_name(nrec)) + allocate(islice_selected_rec(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2060') + allocate(ispec_selected_rec(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2061') + allocate(xi_receiver(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2062') + allocate(eta_receiver(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2063') + allocate(gamma_receiver(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2064') + allocate(station_name(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2065') + allocate(network_name(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2066') allocate(nu(NDIM,NDIM,nrec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2067') if (ier /= 0) stop 'error allocating arrays for receivers' ! locate receivers in the mesh @@ -756,8 +791,10 @@ subroutine setup_sources_precompute_arrays() ! for source encoding (acoustic sources only so far) if (USE_SOURCE_ENCODING) then allocate(pm1_source_encoding(NSOURCES),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2068') else allocate(pm1_source_encoding(1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2069') endif if (ier /= 0) stop 'error allocating arrays for sources' pm1_source_encoding(:) = 1._CUSTOM_REAL @@ -765,8 +802,10 @@ subroutine setup_sources_precompute_arrays() ! forward simulations if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then - allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ)) + allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2070') allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2071') if (ier /= 0) stop 'error allocating array sourcearray' ! compute source arrays @@ -895,6 +934,7 @@ subroutine setup_sources_precompute_arrays() ! SIMULATION_TYPE == 2 ! allocate dummy array (needed for subroutine calls) allocate(sourcearrays(1,1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2072') if (ier /= 0) stop 'error allocating dummy sourcearrays' endif @@ -993,6 +1033,7 @@ subroutine setup_sources_precompute_arrays() ! initializes adjoint sources allocate(source_adjoint(NDIM,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2073') if (ier /= 0) stop 'error allocating array source_adjoint' ! note: @@ -1100,21 +1141,28 @@ subroutine setup_receivers_precompute_intp() ! needs to be allocate for subroutine calls (even if nrec_local == 0) allocate(number_receiver_global(nrec_local),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2074') if (ier /= 0) stop 'error allocating array number_receiver_global' ! stores local receivers interpolation factors if (nrec_local > 0) then ! allocate Lagrange interpolators for receivers - allocate(hxir_store(nrec_local,NGLLX)) - allocate(hetar_store(nrec_local,NGLLY)) + allocate(hxir_store(nrec_local,NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2075') + allocate(hetar_store(nrec_local,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2076') allocate(hgammar_store(nrec_local,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2077') if (ier /= 0) stop 'error allocating array hxir_store etc.' ! allocates derivatives if (SIMULATION_TYPE == 2) then - allocate(hpxir_store(nrec_local,NGLLX)) - allocate(hpetar_store(nrec_local,NGLLY)) + allocate(hpxir_store(nrec_local,NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2078') + allocate(hpetar_store(nrec_local,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2079') allocate(hpgammar_store(nrec_local,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2080') if (ier /= 0) stop 'error allocating array hpxir_store' endif @@ -1171,15 +1219,21 @@ subroutine setup_receivers_precompute_intp() else ! VM VM need to allocate Lagrange interpolators for receivers with 0 because it is used ! in calling subroutines parmeters. (otherwise it can be crash at runtime). - allocate(hxir_store(nrec_local,NGLLX)) - allocate(hetar_store(nrec_local,NGLLY)) + allocate(hxir_store(nrec_local,NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2081') + allocate(hetar_store(nrec_local,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2082') allocate(hgammar_store(nrec_local,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2083') if (ier /= 0) stop 'error allocating array hxir_store etc.' ! allocates derivatives if (SIMULATION_TYPE == 2) then - allocate(hpxir_store(nrec_local,NGLLX)) - allocate(hpetar_store(nrec_local,NGLLY)) + allocate(hpxir_store(nrec_local,NGLLX),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2084') + allocate(hpetar_store(nrec_local,NGLLY),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2085') allocate(hpgammar_store(nrec_local,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2086') if (ier /= 0) stop 'error allocating array hpxir_store' endif endif ! nrec_local > 0 @@ -1189,30 +1243,38 @@ subroutine setup_receivers_precompute_intp() ! allocate seismogram array if (SAVE_SEISMOGRAMS_DISPLACEMENT) then allocate(seismograms_d(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2087') else allocate(seismograms_d(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2088') endif if (ier /= 0) stop 'error allocating array seismograms_d' if (SAVE_SEISMOGRAMS_VELOCITY) then allocate(seismograms_v(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2089') else allocate(seismograms_v(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2090') endif if (ier /= 0) stop 'error allocating array seismograms_v' if (SAVE_SEISMOGRAMS_ACCELERATION) then allocate(seismograms_a(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2091') else allocate(seismograms_a(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2092') endif if (ier /= 0) stop 'error allocating array seismograms_a' if (SAVE_SEISMOGRAMS_PRESSURE) then !NB_RUNS_ACOUSTIC_GPU is set to 1 by default in constants.h allocate(seismograms_p(NDIM,nrec_local*NB_RUNS_ACOUSTIC_GPU,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2093') else allocate(seismograms_p(1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2094') endif if (ier /= 0) stop 'error allocating array seismograms_p' @@ -1227,6 +1289,7 @@ subroutine setup_receivers_precompute_intp() if (SIMULATION_TYPE == 2) then if (nrec_local > 0) then allocate(seismograms_eps(NDIM,NDIM,nrec_local,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2095') if (ier /= 0) stop 'error allocating array seismograms_eps' seismograms_eps(:,:,:,:) = 0._CUSTOM_REAL endif @@ -1423,8 +1486,10 @@ subroutine setup_search_kdtree() ! allocates tree arrays allocate(kdtree_nodes_location(NDIM,kdtree_num_nodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2096') if (ier /= 0) stop 'Error allocating kdtree_nodes_location arrays' allocate(kdtree_nodes_index(kdtree_num_nodes),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2097') if (ier /= 0) stop 'Error allocating kdtree_nodes_index arrays' ! tree verbosity diff --git a/src/specfem3D/surface_or_volume_integral.f90 b/src/specfem3D/surface_or_volume_integral.f90 index d24241682..f0dc7493f 100644 --- a/src/specfem3D/surface_or_volume_integral.f90 +++ b/src/specfem3D/surface_or_volume_integral.f90 @@ -51,6 +51,7 @@ subroutine surface_or_volume_integral_on_whole_domain() if (RECIPROCITY_AND_KH_INTEGRAL) then allocate(f_integrand_KH(3,NGLLSQUARE*num_abs_boundary_faces), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1972') call integrand_for_computing_Kirchoff_Helmholtz_integral() @@ -68,6 +69,7 @@ subroutine surface_or_volume_integral_on_whole_domain() if ( (Surf_or_vol_integral == 2) .or. (Surf_or_vol_integral == 3) ) then allocate(integral_vol(3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1973') ! calculates volume of all elements in mesh do ispec = 1, NSPEC_AB @@ -125,6 +127,7 @@ subroutine surface_or_volume_integral_on_whole_domain() if ( (Surf_or_vol_integral == 1) .or. (Surf_or_vol_integral == 3) ) then allocate(integral_boun(3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1974') ! calculates integral on all the surface of the whole domain diff --git a/src/specfem3D/vtk_window.F90 b/src/specfem3D/vtk_window.F90 index db85e7d01..80ece9ac4 100644 --- a/src/specfem3D/vtk_window.F90 +++ b/src/specfem3D/vtk_window.F90 @@ -97,6 +97,7 @@ subroutine vtk_window_prepare() ! mask allocate(vtkmask(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1738') if (ier /= 0) stop 'Error allocating arrays' vtkmask(:) = .false. @@ -246,6 +247,7 @@ subroutine vtk_window_prepare_receivers() ! array to hold receiver locations allocate(vtkdata_recv_x(nrec),vtkdata_recv_y(nrec),vtkdata_recv_z(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1739') if (ier /= 0) stop 'Error allocating receiver arrays' vtkdata_recv_x(:) = 0.0 vtkdata_recv_y(:) = 0.0 @@ -393,10 +395,12 @@ subroutine vtk_window_prepare_freesurface() if (myrank == 0) write(IMAIN,*) " loading surface points: ",free_np allocate(free_x(free_np),free_y(free_np),free_z(free_np),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1740') if (ier /= 0) stop 'Error allocating arrays' ! permutation array allocate(free_perm(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1741') if (ier /= 0) stop 'Error allocating arrays' free_perm(:) = 0 @@ -419,6 +423,7 @@ subroutine vtk_window_prepare_freesurface() free_nspec = num_free_surface_faces*(NGLLX-1)*(NGLLY-1) allocate(free_conn(4,free_nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1742') if (ier /= 0) stop 'Error allocating arrays' inum = 0 @@ -465,6 +470,7 @@ subroutine vtk_window_prepare_freesurface() free_nspec = num_free_surface_faces allocate(free_conn(4,free_nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1743') if (ier /= 0) stop 'Error allocating arrays' inum = 0 @@ -527,6 +533,7 @@ subroutine vtk_window_prepare_freesurface() ! gathers point infos allocate(free_points_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1744') if (ier /= 0) stop 'Error allocating arrays' free_points_all(:) = 0 @@ -534,6 +541,7 @@ subroutine vtk_window_prepare_freesurface() ! array offsets allocate(free_offset_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1745') if (ier /= 0) stop 'Error allocating arrays' free_offset_all(1) = 0 @@ -547,6 +555,7 @@ subroutine vtk_window_prepare_freesurface() ! freesurface elements allocate(free_conn_nspec_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1746') if (ier /= 0) stop 'Error allocating arrays' free_conn_nspec_all(:) = 0 @@ -554,6 +563,7 @@ subroutine vtk_window_prepare_freesurface() ! array offsets allocate(free_conn_offset_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1747') if (ier /= 0) stop 'Error allocating arrays' free_conn_offset_all(1) = 0 @@ -564,9 +574,12 @@ subroutine vtk_window_prepare_freesurface() ! global data arrays (only needed on master process) if (myrank == 0) then ! gather locations - allocate(free_x_all(free_np_all)) - allocate(free_y_all(free_np_all)) + allocate(free_x_all(free_np_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1748') + allocate(free_y_all(free_np_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1749') allocate(free_z_all(free_np_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1750') if (ier /= 0) stop 'Error allocating free_x_all,... arrays' free_x_all(:) = 0.0 @@ -575,6 +588,7 @@ subroutine vtk_window_prepare_freesurface() ! connectivity allocate(free_conn_all(4,free_nspec_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1751') if (ier /= 0) stop 'Error allocating free_conn_all array' free_conn_all(:,:) = 0 endif @@ -719,10 +733,12 @@ subroutine vtk_window_prepare_volume() if (myrank == 0) write(IMAIN,*) " loading volume points: ",vol_np allocate(vol_x(vol_np),vol_y(vol_np),vol_z(vol_np),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1752') if (ier /= 0) stop 'Error allocating arrays' ! permutation array allocate(vol_perm(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1753') if (ier /= 0) stop 'Error allocating arrays' vol_perm(:) = 0 @@ -744,6 +760,7 @@ subroutine vtk_window_prepare_volume() vol_nspec = NSPEC_AB*(NGLLX-1)*(NGLLY-1)*(NGLLZ-1) allocate(vol_conn(8,vol_nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1754') if (ier /= 0) stop 'Error allocating arrays' inum = 0 @@ -782,6 +799,7 @@ subroutine vtk_window_prepare_volume() vol_nspec = NSPEC_AB allocate(vol_conn(8,vol_nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1755') if (ier /= 0) stop 'Error allocating arrays' vol_conn(:,:) = -1 @@ -812,6 +830,7 @@ subroutine vtk_window_prepare_volume() ! allocates local data array allocate(vtkdata(vol_np),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1756') if (ier /= 0) stop 'Error allocating arrays' vtkdata(:) = 0.0 @@ -827,6 +846,7 @@ subroutine vtk_window_prepare_volume() ! gathers point infos allocate(vtkdata_points_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1757') if (ier /= 0) stop 'Error allocating arrays' vtkdata_points_all(:) = 0 @@ -834,6 +854,7 @@ subroutine vtk_window_prepare_volume() ! array offsets allocate(vtkdata_offset_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1758') if (ier /= 0) stop 'Error allocating arrays' vtkdata_offset_all(1) = 0 @@ -847,6 +868,7 @@ subroutine vtk_window_prepare_volume() ! volume elements allocate(vol_conn_nspec_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1759') if (ier /= 0) stop 'Error allocating arrays' vol_conn_nspec_all(:) = 0 @@ -854,6 +876,7 @@ subroutine vtk_window_prepare_volume() ! array offsets allocate(vol_conn_offset_all(NPROC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1760') if (ier /= 0) stop 'Error allocating arrays' vol_conn_offset_all(1) = 0 @@ -865,14 +888,18 @@ subroutine vtk_window_prepare_volume() if (myrank == 0) then ! point data allocate(vtkdata_all(vtkdata_numpoints_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1761') if (ier /= 0) stop 'Error allocating vtkdata_all array' vtkdata_all(:) = 0.0 ! gather locations - allocate(vol_x_all(vtkdata_numpoints_all)) - allocate(vol_y_all(vtkdata_numpoints_all)) + allocate(vol_x_all(vtkdata_numpoints_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1762') + allocate(vol_y_all(vtkdata_numpoints_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1763') allocate(vol_z_all(vtkdata_numpoints_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1764') if (ier /= 0) stop 'Error allocating vol_x_all,... arrays' vol_x_all(:) = 0.0 @@ -881,6 +908,7 @@ subroutine vtk_window_prepare_volume() ! connectivity allocate(vol_conn_all(8,vol_nspec_all),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1765') if (ier /= 0) stop 'Error allocating vol_conn_all array' vol_conn_all(:,:) = 0 diff --git a/src/specfem3D/write_movie_output.F90 b/src/specfem3D/write_movie_output.F90 index 375e6ca99..8bc8e098e 100644 --- a/src/specfem3D/write_movie_output.F90 +++ b/src/specfem3D/write_movie_output.F90 @@ -514,6 +514,7 @@ subroutine wmo_movie_volume_output() ! allocate array for single elements allocate(veloc_element(NDIM,NGLLX,NGLLY,NGLLZ),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2002') if (ier /= 0) stop 'error allocating arrays for movie elements' ! uses div as temporary array to store velocity on all GLL points @@ -527,7 +528,8 @@ subroutine wmo_movie_volume_output() enddo if (.not. ELASTIC_SIMULATION .and. .not. POROELASTIC_SIMULATION) then - allocate(pressure_loc(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(pressure_loc(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2003') do ispec=1,NSPEC_AB @@ -554,8 +556,10 @@ subroutine wmo_movie_volume_output() if (ELASTIC_SIMULATION) then ! allocate array for single elements - allocate(div_glob(NGLOB_AB)) + allocate(div_glob(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2004') allocate(valence(NGLOB_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2005') if (ier /= 0) stop 'error allocating arrays for movie div and curl' ! calculates divergence and curl of velocity field @@ -579,8 +583,10 @@ subroutine wmo_movie_volume_output() ! saves full snapshot data to local disk if (POROELASTIC_SIMULATION) then ! allocate array for single elements - allocate(div_glob(NGLOB_AB)) + allocate(div_glob(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2006') allocate(valence(NGLOB_AB), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2007') if (ier /= 0) stop 'error allocating arrays for movie div and curl' ! calculates divergence and curl of velocity field diff --git a/src/specfem3D/write_output_ASDF.f90 b/src/specfem3D/write_output_ASDF.f90 index 4f4cb4a6a..cf4e81847 100644 --- a/src/specfem3D/write_output_ASDF.f90 +++ b/src/specfem3D/write_output_ASDF.f90 @@ -44,21 +44,29 @@ subroutine init_asdf_data(nrec_local) asdf_container%nrec_local = nrec_local - allocate(asdf_container%receiver_name_array(nrec_local), STAT=ier) + allocate(asdf_container%receiver_name_array(nrec_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2008') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%network_array(nrec_local), STAT=ier) + allocate(asdf_container%network_array(nrec_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2009') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%component_array(total_seismos_local), STAT=ier) + allocate(asdf_container%component_array(total_seismos_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2010') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%receiver_lat(nrec_local), STAT=ier) + allocate(asdf_container%receiver_lat(nrec_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2011') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%receiver_lo(nrec_local), STAT=ier) + allocate(asdf_container%receiver_lo(nrec_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2012') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%receiver_el(nrec_local), STAT=ier) + allocate(asdf_container%receiver_el(nrec_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2013') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%receiver_dpt(nrec_local), STAT=ier) + allocate(asdf_container%receiver_dpt(nrec_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2014') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') - allocate(asdf_container%records(total_seismos_local), STAT=ier) + allocate(asdf_container%records(total_seismos_local), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2015') if (ier /= 0) call exit_MPI (myrank, 'Allocate failed.') end subroutine init_asdf_data @@ -94,6 +102,7 @@ subroutine store_asdf_data(seismogram_tmp, irec_local, irec, chn, iorientation) integer :: ier, i, index_increment allocate(x_found(nrec),y_found(nrec),z_found(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2016') if (ier /= 0) stop 'error allocating arrays x_found y_found z_found' ! reads in station locations from output_list file @@ -121,7 +130,8 @@ subroutine store_asdf_data(seismogram_tmp, irec_local, irec, chn, iorientation) i = (irec_local-1)*(3) + (index_increment) asdf_container%component_array(i) = chn(1:3) - allocate(asdf_container%records(i)%record(NSTEP), STAT=ier) + allocate(asdf_container%records(i)%record(NSTEP), STAT=ier,stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2017') if (ier /= 0) call exit_MPI (myrank, 'Allocating ASDF container failed.') asdf_container%records(i)%record(1:NSTEP) = seismogram_tmp(iorientation,1:NSTEP) @@ -274,36 +284,50 @@ subroutine write_asdf() call ASDF_generate_sf_provenance_f(trim(start_time_string)//C_NULL_CHAR, & trim(end_time_string)//C_NULL_CHAR, cptr, len_prov) call c_f_pointer(cptr, fptr, [len_prov]) - allocate(provenance(len_prov+1)) + allocate(provenance(len_prov+1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2018') provenance(1:len_prov) = fptr(1:len_prov) provenance(len_prov+1) = C_NULL_CHAR endif allocate(networks_names(num_stations(1)), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2019') allocate(stations_names(num_stations(1)), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2020') allocate(component_names(num_stations(1)*3), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2021') !-------------------------------------------------------- ! ASDF variables !-------------------------------------------------------- ! Find how many stations are managed by each allgatheress - allocate(num_stations_gather(mysize)) + allocate(num_stations_gather(mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2022') call gather_all_all_i(num_stations(1), 1, num_stations_gather, 1, mysize) ! find the largest number of stations per allgatheress max_num_stations_gather = maxval(num_stations_gather) - allocate(displs(mysize)) - allocate(rcounts(mysize)) + allocate(displs(mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2023') + allocate(rcounts(mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2024') ! Everyone should know about each and every station name and its coordinates - allocate(station_names_gather(max_num_stations_gather, mysize)) - allocate(network_names_gather(max_num_stations_gather, mysize)) - allocate(station_lats_gather(max_num_stations_gather,mysize)) - allocate(station_longs_gather(max_num_stations_gather,mysize)) - allocate(station_elevs_gather(max_num_stations_gather,mysize)) - allocate(station_depths_gather(max_num_stations_gather,mysize)) - allocate(component_names_gather(max_num_stations_gather*3, mysize)) + allocate(station_names_gather(max_num_stations_gather, mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2025') + allocate(network_names_gather(max_num_stations_gather, mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2026') + allocate(station_lats_gather(max_num_stations_gather,mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2027') + allocate(station_longs_gather(max_num_stations_gather,mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2028') + allocate(station_elevs_gather(max_num_stations_gather,mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2029') + allocate(station_depths_gather(max_num_stations_gather,mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2030') + allocate(component_names_gather(max_num_stations_gather*3, mysize),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2031') ! This needs to be done because asdf_data is a pointer @@ -402,6 +426,7 @@ subroutine write_asdf() deallocate(rcounts) allocate(one_seismogram(NDIM,NSTEP),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2032') !-------------------------------------------------------- ! write ASDF diff --git a/src/specfem3D/write_output_SU.f90 b/src/specfem3D/write_output_SU.f90 index 7eb021133..6659b5c39 100644 --- a/src/specfem3D/write_output_SU.f90 +++ b/src/specfem3D/write_output_SU.f90 @@ -56,6 +56,7 @@ subroutine write_output_SU(seismograms,istore) character(len=1),parameter :: comp(4) = (/ 'd', 'v', 'a', 'p' /) allocate(x_found(nrec),y_found(nrec),z_found(nrec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2189') if (ier /= 0) stop 'error allocating arrays x_found y_found z_found' ! reads in station locations from output_list file diff --git a/src/specfem3D/write_seismograms.f90 b/src/specfem3D/write_seismograms.f90 index 1bb800d7e..aab9f7cdc 100644 --- a/src/specfem3D/write_seismograms.f90 +++ b/src/specfem3D/write_seismograms.f90 @@ -226,6 +226,7 @@ subroutine write_seismograms_to_file(seismograms,istore) endif allocate(one_seismogram(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 2420') if (ier /= 0) stop 'error while allocating one temporary seismogram' ! write out seismograms: all processes write their local seismograms themselves diff --git a/src/tomography/add_model_iso.f90 b/src/tomography/add_model_iso.f90 index 14aab81ef..c35fe8edf 100644 --- a/src/tomography/add_model_iso.f90 +++ b/src/tomography/add_model_iso.f90 @@ -123,9 +123,12 @@ program add_model ! computes new model values for alpha, beta and rho ! and stores new model files ! allocate new model arrays - allocate(model_vp_new(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vs_new(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_vp_new(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1083') + allocate(model_vs_new(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1084') allocate(model_rho_new(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1085') if (ier /= 0) stop 'Error allocating model arrays' ! initializes arrays diff --git a/src/tomography/compute_kernel_integral.f90 b/src/tomography/compute_kernel_integral.f90 index b5736363d..baa3ea548 100644 --- a/src/tomography/compute_kernel_integral.f90 +++ b/src/tomography/compute_kernel_integral.f90 @@ -93,12 +93,14 @@ subroutine compute_kernel_integral_iso() !allocations if (NSPEC_IRREGULAR > 0) then allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1064') s1_jac = NGLLX s2_jac = NGLLY s3_jac = NGLLZ s4_jac = NSPEC_IRREGULAR else allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1065') s1_jac = 1 s2_jac = 1 s3_jac = 1 @@ -109,7 +111,8 @@ subroutine compute_kernel_integral_iso() call exit_mpi(myrank,'error allocation jacobian') endif - allocate(irregular_element_number(NSPEC)) + allocate(irregular_element_number(NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1066') ! GLL points @@ -337,12 +340,14 @@ subroutine compute_kernel_integral_tiso() !allocations if (NSPEC_IRREGULAR > 0) then allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1067') s1_jac = NGLLX s2_jac = NGLLY s3_jac = NGLLZ s4_jac = NSPEC_IRREGULAR else allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1068') s1_jac = 1 s2_jac = 1 s3_jac = 1 @@ -353,7 +358,8 @@ subroutine compute_kernel_integral_tiso() call exit_mpi(myrank,'error allocation jacobian') endif - allocate(irregular_element_number(NSPEC)) + allocate(irregular_element_number(NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1069') @@ -609,12 +615,14 @@ subroutine compute_kernel_integral_tiso_iso() !allocations if (NSPEC_IRREGULAR > 0) then allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1070') s1_jac = NGLLX s2_jac = NGLLY s3_jac = NGLLZ s4_jac = NSPEC_IRREGULAR else allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1071') s1_jac = 1 s2_jac = 1 s3_jac = 1 @@ -625,7 +633,8 @@ subroutine compute_kernel_integral_tiso_iso() call exit_mpi(myrank,'error allocation jacobian') endif - allocate(irregular_element_number(NSPEC)) + allocate(irregular_element_number(NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1072') ! GLL points @@ -838,8 +847,10 @@ subroutine compute_jacobian(jacobian,irregular_element_number,jacobian_regular,s !allocations if (NSPEC_IRREGULAR > 0) then allocate(dummy_sem(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1073') else allocate(dummy_sem(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1074') endif if (ier /= 0) then print *,'Error allocating array dummy_sem' diff --git a/src/tomography/get_cg_direction.f90 b/src/tomography/get_cg_direction.f90 index 5f572d9c4..4ea4b03c8 100644 --- a/src/tomography/get_cg_direction.f90 +++ b/src/tomography/get_cg_direction.f90 @@ -60,10 +60,14 @@ subroutine get_cg_direction_tiso() ! allocate arrays for storing gradient ! transversely isotropic arrays - allocate(model_dbulk(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbetav(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbetah(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_dbulk(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1089') + allocate(model_dbetav(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1090') + allocate(model_dbetah(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1091') allocate(model_deta(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1092') if (ier /= 0) stop 'error allocating gradient arrays' ! initializes arrays diff --git a/src/tomography/get_sd_direction.f90 b/src/tomography/get_sd_direction.f90 index 0e1ddc1d0..fb8d46cb7 100644 --- a/src/tomography/get_sd_direction.f90 +++ b/src/tomography/get_sd_direction.f90 @@ -45,9 +45,12 @@ subroutine get_sd_direction_iso() ! allocate arrays for storing gradient ! isotropic arrays - allocate(model_dbulk(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbeta(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_dbulk(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1046') + allocate(model_dbeta(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1047') allocate(model_drho(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1048') if (ier /= 0) stop 'error allocating gradient arrays' ! initializes arrays @@ -254,10 +257,14 @@ subroutine get_sd_direction_tiso() ! allocate arrays for storing gradient ! transversely isotropic arrays - allocate(model_dbulk(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbetav(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbetah(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_dbulk(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1049') + allocate(model_dbetav(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1050') + allocate(model_dbetah(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1051') allocate(model_deta(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1052') if (ier /= 0) stop 'error allocating gradient arrays' ! initializes arrays diff --git a/src/tomography/model_update.f90 b/src/tomography/model_update.f90 index 548053b05..ccec6fdce 100644 --- a/src/tomography/model_update.f90 +++ b/src/tomography/model_update.f90 @@ -157,11 +157,15 @@ program model_update ! MODEL UPDATE ! allocation ! model and kernel variables - allocate(model_vp(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vs(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_rho(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_vp(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 911') + allocate(model_vs(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 912') + allocate(model_rho(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 913') - allocate(total_model(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(total_model(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 914') ! initialize variables ! old model @@ -330,9 +334,12 @@ program model_update ! computes new model values for alpha, beta and rho ! allocate new model arrays - allocate(model_vp_new(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vs_new(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_vp_new(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 915') + allocate(model_vs_new(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 916') allocate(model_rho_new(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 917') if (ier /= 0) stop 'Error allocating model arrays' ! initializes arrays @@ -639,48 +646,77 @@ subroutine get_external_mesh() real(kind=CUSTOM_REAL) :: z_min_glob,z_max_glob ! allocate arrays for storing the databases - allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 918') if (NSPEC_IRREGULAR > 0) then - allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) + allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 919') + allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 920') + allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 921') + allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 922') + allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 923') + allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 924') + allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 925') + allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 926') + allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 927') allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 928') else - allocate(xix(1,1,1,1)) - allocate(xiy(1,1,1,1)) - allocate(xiz(1,1,1,1)) - allocate(etax(1,1,1,1)) - allocate(etay(1,1,1,1)) - allocate(etaz(1,1,1,1)) - allocate(gammax(1,1,1,1)) - allocate(gammay(1,1,1,1)) - allocate(gammaz(1,1,1,1)) + allocate(xix(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 929') + allocate(xiy(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 930') + allocate(xiz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 931') + allocate(etax(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 932') + allocate(etay(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 933') + allocate(etaz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 934') + allocate(gammax(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 935') + allocate(gammay(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 936') + allocate(gammaz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 937') allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 938') endif if (ier /= 0) stop 'Error allocating arrays for databases' ! mesh node locations - allocate(xstore(NGLOB_AB)) - allocate(ystore(NGLOB_AB)) + allocate(xstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 939') + allocate(ystore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 940') allocate(zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 941') if (ier /= 0) stop 'Error allocating arrays for mesh nodes' ! material properties - allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 942') allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 943') if (ier /= 0) stop 'Error allocating arrays for material properties' ! material flags - allocate(ispec_is_acoustic(NSPEC_AB)) - allocate(ispec_is_elastic(NSPEC_AB)) + allocate(ispec_is_acoustic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 944') + allocate(ispec_is_elastic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 945') allocate(ispec_is_poroelastic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 946') if (ier /= 0) stop 'Error allocating arrays for material flags' ispec_is_acoustic(:) = .false. ispec_is_elastic(:) = .false. @@ -726,8 +762,10 @@ subroutine get_external_mesh() LOCAL_PATH,SAVE_MESH_FILES) else if (POROELASTIC_SIMULATION) then - allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 947') + allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 948') rho_vp = 0.0_CUSTOM_REAL rho_vs = 0.0_CUSTOM_REAL call check_mesh_resolution_poro(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & @@ -737,8 +775,10 @@ subroutine get_external_mesh() deallocate(rho_vp,rho_vs) else if (ACOUSTIC_SIMULATION) then allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 949') if (ier /= 0) stop 'Error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 950') if (ier /= 0) stop 'Error allocating array rho_vs' rho_vp = sqrt( kappastore / rhostore ) * rhostore rho_vs = 0.0_CUSTOM_REAL @@ -814,11 +854,16 @@ subroutine save_new_databases() call create_name_database(prname_new,myrank,OUTPUT_MODEL_DIR) ! new variables for save_external_bin_m_up - allocate(kappastore_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(mustore_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rhostore_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vp_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vs_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(kappastore_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 951') + allocate(mustore_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 952') + allocate(rhostore_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 953') + allocate(rho_vp_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 954') + allocate(rho_vs_new(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 955') ! calculate NEW variables to calculate rmass and then for save_external_bin_m_up rhostore_new = 0._CUSTOM_REAL @@ -834,7 +879,8 @@ subroutine save_new_databases() rho_vs_new = model_rho_new * model_vs_new ! jacobian from read_mesh_databases - allocate(jacobianstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(jacobianstore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 956') jacobianstore = 0._CUSTOM_REAL jacobianstore = jacobian @@ -845,12 +891,14 @@ subroutine save_new_databases() call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA) ! rmass for the OLD model from read_mesh_databases - allocate(rmass_old(NGLOB_AB)) + allocate(rmass_old(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 957') rmass_old = 0._CUSTOM_REAL rmass_old = rmass ! create mass matrix ONLY for the elastic case - allocate(rmass_new(NGLOB_AB)) + allocate(rmass_new(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 958') rmass_new(:) = 0._CUSTOM_REAL ! user output @@ -887,9 +935,12 @@ subroutine save_new_databases() call synchronize_all() ! dummy allocations, arrays are not needed since the update here only works for elastic models - allocate(rmass_acoustic_new(NGLOB_AB)) - allocate(rmass_solid_poroelastic_new(NGLOB_AB)) - allocate(rmass_fluid_poroelastic_new(NGLOB_AB)) + allocate(rmass_acoustic_new(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 959') + allocate(rmass_solid_poroelastic_new(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 960') + allocate(rmass_fluid_poroelastic_new(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 961') rmass_acoustic_new = 0._CUSTOM_REAL rmass_solid_poroelastic_new = 0._CUSTOM_REAL rmass_fluid_poroelastic_new = 0._CUSTOM_REAL @@ -918,8 +969,10 @@ subroutine save_new_databases() !-------- attenuation ------- ! store the attenuation flag in qmu_attenuation_store - allocate(qmu_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(qkappa_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(qmu_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 962') + allocate(qkappa_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 963') qmu_attenuation_store=0._CUSTOM_REAL qkappa_attenuation_store=0._CUSTOM_REAL @@ -938,6 +991,7 @@ subroutine save_new_databases() read(12,'(a,i12,a)') string5, idummy1, string6 !text allocate(dummy_g_1(NGLOB_AB),dummy_g_2(NGLOB_AB),dummy_g_3(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 964') if (ier /= 0) stop 'Error allocating array dummy etc.' read(12,'(3e18.6)') dummy_g_1,dummy_g_2,dummy_g_3 !xstore,ystore,zstore for i=1,nglob @@ -946,15 +1000,24 @@ subroutine save_new_databases() read(12,'(a,i12,i12)') string7, idummy2, idummy3 !text - allocate(dummy_num(NSPEC_AB)) - allocate(dummy_l_1(NSPEC_AB)) - allocate(dummy_l_2(NSPEC_AB)) - allocate(dummy_l_3(NSPEC_AB)) - allocate(dummy_l_4(NSPEC_AB)) - allocate(dummy_l_5(NSPEC_AB)) - allocate(dummy_l_6(NSPEC_AB)) - allocate(dummy_l_7(NSPEC_AB)) + allocate(dummy_num(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 965') + allocate(dummy_l_1(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 966') + allocate(dummy_l_2(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 967') + allocate(dummy_l_3(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 968') + allocate(dummy_l_4(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 969') + allocate(dummy_l_5(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 970') + allocate(dummy_l_6(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 971') + allocate(dummy_l_7(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 972') allocate(dummy_l_8(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 973') if (ier /= 0) stop 'Error allocating array dummy etc.' read(12,'(9i12)') dummy_num,dummy_l_1,dummy_l_2,dummy_l_3,dummy_l_4, & @@ -966,6 +1029,7 @@ subroutine save_new_databases() read(12,'(a,i12)') string8, idummy4 !text allocate(dummy_num(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 974') if (ier /= 0) stop 'Error allocating array dummy etc.' read(12,*) dummy_num !12 for ispec=1,nspec @@ -978,6 +1042,7 @@ subroutine save_new_databases() read(12,'(a)') string11 !text allocate(flag_val(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 975') if (ier /= 0) stop 'Error allocating flag_val' read(12,*) flag_val @@ -985,6 +1050,7 @@ subroutine save_new_databases() close(12) allocate(mask_ibool(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 976') if (ier /= 0) stop 'Error allocating mask' mask_ibool = .false. diff --git a/src/tomography/postprocess_sensitivity_kernels/clip_sem.f90 b/src/tomography/postprocess_sensitivity_kernels/clip_sem.f90 index 3dac6fbaf..3bae0b394 100644 --- a/src/tomography/postprocess_sensitivity_kernels/clip_sem.f90 +++ b/src/tomography/postprocess_sensitivity_kernels/clip_sem.f90 @@ -147,7 +147,8 @@ program clip_sem close(27) call synchronize_all() - allocate(sem_array(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(sem_array(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 977') ! clip kernels do iker=1,nker @@ -202,3 +203,23 @@ program clip_sem end program clip_sem +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/src/tomography/postprocess_sensitivity_kernels/combine_sem.f90 b/src/tomography/postprocess_sensitivity_kernels/combine_sem.f90 index 6b2793970..3c937ba45 100644 --- a/src/tomography/postprocess_sensitivity_kernels/combine_sem.f90 +++ b/src/tomography/postprocess_sensitivity_kernels/combine_sem.f90 @@ -190,8 +190,10 @@ subroutine combine_sem_array(kernel_name,kernel_paths,output_dir,npath) double precision :: norm,norm_sum integer :: iker,ier - allocate(array(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(array(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 978') allocate(sum_arrays(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 979') if (ier /= 0) stop 'Error allocating array' ! loop over kernel paths @@ -242,4 +244,23 @@ subroutine combine_sem_array(kernel_name,kernel_paths,output_dir,npath) end subroutine combine_sem_array +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank diff --git a/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 b/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 index c90b92622..5d236e65a 100644 --- a/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 +++ b/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 @@ -249,49 +249,78 @@ program smooth_sem call read_mesh_for_init() allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),irregular_element_number(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 980') if (NSPEC_IRREGULAR > 0) then ! allocate arrays for storing the databases - allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) - allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR)) + allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 981') + allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 982') + allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 983') + allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 984') + allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 985') + allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 986') + allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 987') + allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 988') + allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 989') allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 990') else ! allocate arrays for storing the databases - allocate(xix(1,1,1,1)) - allocate(xiy(1,1,1,1)) - allocate(xiz(1,1,1,1)) - allocate(etax(1,1,1,1)) - allocate(etay(1,1,1,1)) - allocate(etaz(1,1,1,1)) - allocate(gammax(1,1,1,1)) - allocate(gammay(1,1,1,1)) - allocate(gammaz(1,1,1,1)) + allocate(xix(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 991') + allocate(xiy(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 992') + allocate(xiz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 993') + allocate(etax(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 994') + allocate(etay(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 995') + allocate(etaz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 996') + allocate(gammax(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 997') + allocate(gammay(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 998') + allocate(gammaz(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 999') allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1000') endif if (ier /= 0) stop 'Error allocating arrays for databases' ! mesh node locations - allocate(xstore(NGLOB_AB)) - allocate(ystore(NGLOB_AB)) + allocate(xstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1001') + allocate(ystore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1002') allocate(zstore(NGLOB_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1003') if (ier /= 0) stop 'Error allocating arrays for mesh nodes' ! material properties - allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1004') allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1005') if (ier /= 0) stop 'Error allocating arrays for material properties' ! material flags - allocate(ispec_is_acoustic(NSPEC_AB)) - allocate(ispec_is_elastic(NSPEC_AB)) + allocate(ispec_is_acoustic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1006') + allocate(ispec_is_elastic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1007') allocate(ispec_is_poroelastic(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1008') if (ier /= 0) stop 'Error allocating arrays for material flags' ispec_is_acoustic(:) = .false. ispec_is_elastic(:) = .false. @@ -331,8 +360,10 @@ program smooth_sem LOCAL_PATH,SAVE_MESH_FILES) else if (POROELASTIC_SIMULATION) then - allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1009') + allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1010') rho_vp = 0.0_CUSTOM_REAL rho_vs = 0.0_CUSTOM_REAL call check_mesh_resolution_poro(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & @@ -342,8 +373,10 @@ program smooth_sem deallocate(rho_vp,rho_vs) else if (ACOUSTIC_SIMULATION) then allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1011') if (ier /= 0) stop 'Error allocating array rho_vp' allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1012') if (ier /= 0) stop 'Error allocating array rho_vs' rho_vp = sqrt( kappastore / rhostore ) * rhostore rho_vs = 0.0_CUSTOM_REAL @@ -358,12 +391,18 @@ program smooth_sem ! for smoothing, we use cell centers to find and locate nearby elements ! ! sets the location of the center of the elements and local points - allocate(xl(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(yl(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(zl(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) - allocate(cx0(NSPEC_AB)) - allocate(cy0(NSPEC_AB)) + allocate(xl(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1013') + allocate(yl(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1014') + allocate(zl(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1015') + allocate(cx0(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1016') + allocate(cy0(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1017') allocate(cz0(NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1018') if (ier /= 0) stop 'Error allocating array xl etc.' ! sets element center location @@ -465,8 +504,10 @@ program smooth_sem ! allocates mesh arrays allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1019') if (ier /= 0) stop 'Error allocating array ibool' allocate(xstore(NGLOB_N),ystore(NGLOB_N),zstore(NGLOB_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1020') if (ier /= 0) stop 'Error allocating array xstore etc.' ! ibool file @@ -557,8 +598,10 @@ program smooth_sem ! loops over slices ! each process reads in his own neighbor slices and Gaussian filters the values - allocate(tk(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) + allocate(tk(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1021') allocate(bk(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1022') if (ier /= 0) stop 'Error allocating array tk and bk' tk = 0.0_CUSTOM_REAL @@ -595,23 +638,30 @@ program smooth_sem ! allocates arrays allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1023') if (ier /= 0) stop 'Error allocating array ibool' allocate(xstore(NGLOB_N),ystore(NGLOB_N),zstore(NGLOB_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1024') if (ier /= 0) stop 'Error allocating array xstore etc.' if (USE_QUADRATURE_RULE_FOR_SMOOTHING) then if (NSPEC_IRREGULAR_N > 0) then allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_IRREGULAR_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1025') if (ier /= 0) stop 'Error allocating array jacobian' allocate(dummy(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1026') if (ier /= 0) stop 'Error allocating array dummy' else allocate(jacobian(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1027') if (ier /= 0) stop 'Error allocating array jacobian' allocate(dummy(1,1,1,1),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1028') if (ier /= 0) stop 'Error allocating array dummy' endif allocate(irregular_element_number(NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1029') if (ier /= 0) stop 'Error allocating array irregular_element_number' endif @@ -643,12 +693,18 @@ program smooth_sem close(IIN) ! get the location of the center of the elements and local points - allocate(xx(NGLLX,NGLLY,NGLLZ,NSPEC_N)) - allocate(yy(NGLLX,NGLLY,NGLLZ,NSPEC_N)) - allocate(zz(NGLLX,NGLLY,NGLLZ,NSPEC_N)) - allocate(cx(NSPEC_N)) - allocate(cy(NSPEC_N)) + allocate(xx(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1030') + allocate(yy(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1031') + allocate(zz(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1032') + allocate(cx(NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1033') + allocate(cy(NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1034') allocate(cz(NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1035') if (ier /= 0) stop 'Error allocating array xx etc.' ! sets element center location @@ -683,6 +739,7 @@ program smooth_sem endif allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_N),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1036') if (ier /= 0) stop 'Error allocating dat array' read(IIN) dat @@ -787,6 +844,7 @@ program smooth_sem endif allocate(dat_smooth(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1037') if (ier /= 0) stop 'Error allocating array dat_smooth' dat_smooth(:,:,:,:) = 0.0_CUSTOM_REAL diff --git a/src/tomography/read_kernels.f90 b/src/tomography/read_kernels.f90 index a3f0ce056..656204350 100644 --- a/src/tomography/read_kernels.f90 +++ b/src/tomography/read_kernels.f90 @@ -43,9 +43,12 @@ subroutine read_kernels_iso() ! allocate arrays for storing kernels and perturbations ! isotropic arrays - allocate(kernel_bulk(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(kernel_beta(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(kernel_bulk(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 904') + allocate(kernel_beta(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 905') allocate(kernel_rho(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 906') if (ier /= 0) stop 'error allocating kernel arrays' ! initializes arrays @@ -168,10 +171,14 @@ subroutine read_kernels_tiso() ! allocate arrays for storing kernels and perturbations ! transversely isotropic arrays - allocate(kernel_bulk(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(kernel_betav(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(kernel_betah(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(kernel_bulk(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 907') + allocate(kernel_betav(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 908') + allocate(kernel_betah(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 909') allocate(kernel_eta(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 910') if (ier /= 0) stop 'error allocating kernel arrays' ! initializes arrays diff --git a/src/tomography/read_kernels_cg.f90 b/src/tomography/read_kernels_cg.f90 index 42be50b3b..d8a2133fa 100644 --- a/src/tomography/read_kernels_cg.f90 +++ b/src/tomography/read_kernels_cg.f90 @@ -43,10 +43,14 @@ subroutine read_kernels_cg_tiso_old() ! allocate arrays for storing kernels and perturbations ! transversely isotropic arrays - allocate(kernel_bulk_old(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(kernel_betav_old(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(kernel_betah_old(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(kernel_bulk_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1075') + allocate(kernel_betav_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1076') + allocate(kernel_betah_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1077') allocate(kernel_eta_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1078') if (ier /= 0) stop 'error allocating kernel arrays' ! initializes arrays @@ -189,10 +193,14 @@ subroutine read_kernels_cg_tiso_old() ! allocate arrays for storing old gradient ! transversely isotropic arrays - allocate(model_dbulk_old(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbetav_old(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_dbetah_old(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_dbulk_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1079') + allocate(model_dbetav_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1080') + allocate(model_dbetah_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1081') allocate(model_deta_old(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1082') if (ier /= 0) stop 'error allocating gradient arrays' ! initializes arrays diff --git a/src/tomography/read_model.f90 b/src/tomography/read_model.f90 index 4a0c71e7f..ebdb3ced4 100644 --- a/src/tomography/read_model.f90 +++ b/src/tomography/read_model.f90 @@ -40,9 +40,12 @@ subroutine read_model_iso() if (myrank == 0) print *,'reading model...' ! allocate arrays for storing the databases - allocate(model_vp(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vs(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_vp(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1053') + allocate(model_vs(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1054') allocate(model_rho(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1055') if (ier /= 0) stop 'Error allocating model arrays' ! initializes arrays @@ -142,12 +145,18 @@ subroutine read_model_tiso() if (myrank == 0) print *,'reading model...' ! allocate arrays for storing the databases - allocate(model_vpv(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vph(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vsv(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_vsh(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(model_eta(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(model_vpv(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1056') + allocate(model_vph(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1057') + allocate(model_vsv(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1058') + allocate(model_vsh(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1059') + allocate(model_eta(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1060') allocate(model_rho(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1061') if (ier /= 0) stop 'Error allocating model arrays' ! initializes arrays @@ -313,10 +322,12 @@ subroutine read_model_database() ! allocate arrays for storing the databases allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1062') if (ier /= 0) stop 'Error allocating ibool array for databases' ! mesh node locations allocate(x(NGLOB),y(NGLOB),z(NGLOB),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1063') if (ier /= 0) stop 'Error allocating x/y/z arrays for mesh nodes' read(IIN) ibool(:,:,:,1:nspec) diff --git a/src/tomography/save_external_bin_m_up.f90 b/src/tomography/save_external_bin_m_up.f90 index 5a8d6a973..cbdd9b892 100644 --- a/src/tomography/save_external_bin_m_up.f90 +++ b/src/tomography/save_external_bin_m_up.f90 @@ -348,6 +348,7 @@ subroutine save_external_bin_m_up(nspec,nglob, & close(27) allocate(v_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1043') if (ier /= 0) call exit_MPI_without_rank('error allocating array') ! vp (for checking the mesh and model) @@ -419,7 +420,8 @@ subroutine save_external_bin_m_up(nspec,nglob, & ! acoustic-elastic domains if (ACOUSTIC_SIMULATION .and. ELASTIC_SIMULATION) then ! saves points on acoustic-elastic coupling interface - allocate( iglob_tmp(NGLLSQUARE*num_coupling_ac_el_faces)) + allocate( iglob_tmp(NGLLSQUARE*num_coupling_ac_el_faces),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1044') inum = 0 iglob_tmp(:) = 0 do i=1,num_coupling_ac_el_faces @@ -438,7 +440,8 @@ subroutine save_external_bin_m_up(nspec,nglob, & filename) ! saves acoustic/elastic flag - allocate(v_tmp_i(nspec)) + allocate(v_tmp_i(nspec),stat=ier) + if (ier /= 0) call exit_MPI_without_rank('error allocating array 1045') do i=1,nspec if (ispec_is_acoustic(i)) then v_tmp_i(i) = 1 diff --git a/src/tomography/sum_kernels.f90 b/src/tomography/sum_kernels.f90 index 43e421b35..c52a95696 100644 --- a/src/tomography/sum_kernels.f90 +++ b/src/tomography/sum_kernels.f90 @@ -224,12 +224,15 @@ subroutine sum_kernel(kernel_name,kernel_list,nker) real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: mask_source ! initializes arrays - allocate(kernel(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(kernel(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1086') allocate(total_kernel(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1087') if (ier /= 0) stop 'Error allocating kernel arrays' if (USE_SOURCE_MASK) then - allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) ) + allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) ,stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1088') mask_source(:,:,:,:) = 1.0_CUSTOM_REAL endif @@ -305,4 +308,23 @@ subroutine sum_kernel(kernel_name,kernel_list,nker) end subroutine sum_kernel +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank diff --git a/src/tomography/sum_preconditioned_kernels.f90 b/src/tomography/sum_preconditioned_kernels.f90 index 43e84ecad..bb9cf7ee2 100644 --- a/src/tomography/sum_preconditioned_kernels.f90 +++ b/src/tomography/sum_preconditioned_kernels.f90 @@ -223,18 +223,23 @@ subroutine sum_kernel_pre(kernel_name,kernel_list,nker) real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: total_hess,mask_source ! initializes arrays - allocate(kernel(NGLLX,NGLLY,NGLLZ,NSPEC)) - allocate(hess(NGLLX,NGLLY,NGLLZ,NSPEC)) + allocate(kernel(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1038') + allocate(hess(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1039') allocate(total_kernel(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1040') if (ier /= 0) stop 'Error allocating kernel arrays' if (USE_HESS_SUM) then - allocate( total_hess(NGLLX,NGLLY,NGLLZ,NSPEC) ) + allocate( total_hess(NGLLX,NGLLY,NGLLZ,NSPEC) ,stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1041') total_hess(:,:,:,:) = 0.0_CUSTOM_REAL endif if (USE_SOURCE_MASK) then - allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) ) + allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) ,stat=ier) + if (ier /= 0) call my_local_exit_MPI_without_rank('error allocating array 1042') mask_source(:,:,:,:) = 1.0_CUSTOM_REAL endif @@ -433,3 +438,24 @@ subroutine invert_hess( hess_matrix ) !hess_matrix = hess_matrix * maxh_all end subroutine invert_hess + +! +!------------------------------------------------------------------------------------------------- +! + +! version without rank number printed in the error message + + subroutine my_local_exit_MPI_without_rank(error_msg) + + implicit none + + character(len=*) error_msg + +! write error message to screen + write(*,*) error_msg(1:len(error_msg)) + write(*,*) 'Error detected, aborting MPI...' + + stop 'Fatal error' + + end subroutine my_local_exit_MPI_without_rank + diff --git a/utils/clean_listings_specfem.pl b/utils/clean_listings_specfem.pl index b48c7c75c..4cb4e029f 100755 --- a/utils/clean_listings_specfem.pl +++ b/utils/clean_listings_specfem.pl @@ -270,6 +270,8 @@ $line =~ s#write\s*\(\s*IMAIN\s*,\s*\*\s*\)\s*""#write\(IMAIN,\*\)#ogi; $line =~ s#write\s*\(\s*IOUT\s*,\s*\*\s*\)\s*""#write\(IOUT,\*\)#ogi; + $line =~ s#write\s*\(\s*6\s*,\s*\*\s*\)\s*""#write\(IMAIN,\*\)#ogi; + # force space in , & at end of line $line =~ s#\s*,\s*&\s*$#, &#ogi; diff --git a/utils/instructions_on_how_to_add_checks_of_all_allocate_statements_automatically_here_is_also_how_to_prepare_the_source_code.txt b/utils/instructions_on_how_to_add_checks_of_all_allocate_statements_automatically_here_is_also_how_to_prepare_the_source_code.txt new file mode 100644 index 000000000..6f180b423 --- /dev/null +++ b/utils/instructions_on_how_to_add_checks_of_all_allocate_statements_automatically_here_is_also_how_to_prepare_the_source_code.txt @@ -0,0 +1,50 @@ + +pour trouver ceux qui ont un espace avant la parenthese : + +grep -i "allocate[[:space:]](" src/*/*90 src/*/*/*90 src/*/*/*/*90 + +----------- + +pour trouver ceux qui sont sur plusieurs lignes, et pouvoir les mettre manuellement en plusieurs lignes separees : + +/bin/grep -i "allocate\s*(" src/*/*90 src/*/*/*90 src/*/*/*/*90 | /bin/grep -i -v "deallocate\s*(" | /bin/grep "&" + +----------- + +pour verifier que tous ceux qui ont deja stat= utilisent bien ier comme variable, et sans espace avant la parenthese finale, pour futur remplacement automatique par Perl : + +/bin/grep -i "allocate\s*(" src/*/*90 src/*/*/*90 src/*/*/*/*90 | /bin/grep -i -v "deallocate\s*(" | /bin/grep ",\s*stat\s*=" | /bin/grep -v -i "stat=ier)" + +----------- + +Pour voir si certains de ceux-la appellent call stop_the_code sur la meme ligne (dans ce cas, les passer a la main sur la ligne suivante) : + +/bin/grep -i "allocate\s*(" src/*/*90 src/*/*/*90 src/*/*/*/*90 | /bin/grep -i -v "deallocate\s*(" | /bin/grep ",\s*stat\s*=" | /bin/grep -i call + +----------- + +Pour voir si certains de ceux-la appellent "stop" sur la meme ligne (dans ce cas, les passer a la main sur la ligne suivante) : + +/bin/grep -i "allocate\s*(" src/*/*90 src/*/*/*90 src/*/*/*/*90 | /bin/grep -i -v "deallocate\s*(" | /bin/grep ",\s*stat\s*=" | /bin/grep -i stop + +----------- + +Pour trouver ceux qui sont dans un "if" sur une seule ligne sans "then" et donc pour lesquels on ne pourrait pas ajouter une ligne automatiquement par notre script car elle se retrouverait a l'exterieur du "if" : + +/bin/grep -i "allocate\s*(" src/*/*90 src/*/*/*90 src/*/*/*/*90 | /bin/grep -i -v "deallocate\s*(" | /bin/grep -i "if\s*(" + +----------- + +Pour trouver ceux qui ont un commentaire a la fin de la ligne, qu'il faut deplacer manuellement sur la ligne precedente + +/bin/grep -i "allocate\s*(" src/*/*90 src/*/*/*90 src/*/*/*/*90 | /bin/grep -i -v "deallocate\s*(" | /bin/grep -i ")\s*!" + +----------- + +ceci sera le call a mettre au lieu de mettre des stops : + + if (ier /= 0) call exit_MPI_without_rank('error allocating array') + +----------- + + diff --git a/utils/script_to_add_a_line_to_check_the_error_code_to_all_allocate_statements.pl b/utils/script_to_add_a_line_to_check_the_error_code_to_all_allocate_statements.pl new file mode 100755 index 000000000..6ef42656b --- /dev/null +++ b/utils/script_to_add_a_line_to_check_the_error_code_to_all_allocate_statements.pl @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +# +# read and clean all Fortran files in the current directory and subdirectories +# + +## DK DK June 2018: add checking of all allocate() statements in the code, calling exit_MPI_without_rank() in case of an error + +## DK DK June 2018: three known minor issues for this script: +## - it makes replacements in all strings, even in print statements; thus if you have a print statement that contains the word "allocate()" (with parentheses) it will be changed :-( +## - since it works line by line, it will add a check even if there is an existing one already in the lines below the allocate() statement; this does not hurt, but can lead to duplicated lines or similar line +## - since it works line by line, it also has issues with allocate() statements that may extend over several lines; if so, it will likely generate something slightly incorrect, +#" which you will have to fix manually when compiling the code for the first time (that should be easy to do) +## Because of these three known issues, I do not put this script in the automatic cleaning script of Buildbot (specfem3d/utils/clean_listings_specfem.pl) + +# DK DK only do this in the "src" directory, otherwise independent programs in other directories such as "utils" will not have access to the "exit_MPI_without_rank()" subroutine + +# when using this "find" command from Perl we need to use \\ instead of \ below otherwise Perl tries to interpret it + @objects = `find 'src' -name '.git' -prune -o -name 'm4' -prune -o -type f -regextype posix-extended -regex '.*\\.(fh|f90|F90|h\\.in|fh\\.in)' -print`; + +# create a counter to put in the error message printed if the allocate() fails, so that users can see which allocate() statement had a problem + $counter_for_error_message = 0; + + foreach $name (@objects) { + chop $name; +# change tabs to white spaces + system("expand -2 < $name > _____temp08_____"); + $f90name = $name; + print STDOUT "Cleaning $f90name ...\n"; + + open(FILE_INPUT,"<_____temp08_____"); + open(FILEF90,">$f90name"); + +# open the input f90 file + while($line = ) { + +# suppress trailing white spaces and carriage return + $line =~ s/\s*$//; + +# clear the flag that says if we need to add an allocate statement check or not + $need_to_add_an_allocate_statement_check = 0; + + $linewithnospaceatall = $line; + $linewithnospaceatall =~ s# ##ogi; + $first_letter = substr(($linewithnospaceatall),0,1); +# do not make replacements in comments + if($first_letter ne '!') { + +# test if the line contains an "allocate()" statement + if (index($line, "allocate(") != -1) { +# and test that it is not a "deallocate()" statement + if (index($line, "deallocate(") == -1) { + + $need_to_add_an_allocate_statement_check = 1; + $counter_for_error_message = $counter_for_error_message + 1; + +# count the number of white spaces until the beginning of the allocate() statement +# we will add the same number of white spaces in front of the if() test, to align it with it + $number_of_white_spaces_before_allocate = index($line, "allocate("); + if ($number_of_white_spaces_before_allocate < 0) {die "error when counting number of white spaces before allocate() statement";} + +# if the stat=ier) exit code is not present at the end of the allocate() statement, add it by replacing the final parenthesis with ,stat=ier) + if (index($line, "stat=ier") == -1) { + $line =~ s/\)\s*$/\,stat=ier\)/; + } + +# suppress trailing white spaces, just in case we have added any in the above processing + $line =~ s/\s*$//; + + } + } + } + + print FILEF90 "$line\n"; + if ($need_to_add_an_allocate_statement_check != 0) { +# put the right number of white spaces before the if() test in order to align it with the allocate() statement + print FILEF90 ' ' x $number_of_white_spaces_before_allocate . "if (ier /= 0) call exit_MPI_without_rank('error allocating array $counter_for_error_message')\n"; + } + + } + + close(FILE_INPUT); + close(FILEF90); + + } + + print "\n"; + print "A total of $counter_for_error_message error messages have been added to check all the allocate() statements of the code\n"; + print "\n"; + + system("rm -f _____temp08_____"); + diff --git a/utils/script_to_visualize_all_the_allocate_statements_that_will_be_changed_automatically_with_our_script.pl b/utils/script_to_visualize_all_the_allocate_statements_that_will_be_changed_automatically_with_our_script.pl new file mode 100755 index 000000000..73568c64c --- /dev/null +++ b/utils/script_to_visualize_all_the_allocate_statements_that_will_be_changed_automatically_with_our_script.pl @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +# +# read and clean all Fortran files in the current directory and subdirectories +# + +## DK DK June 2018: visualize (dry run) all the lines to which the other script will add checking of all allocate() statements in the code, calling exit_MPI_without_rank() in case of an error + +## DK DK June 2018: three known minor issues for this script: +## - it makes replacements in all strings, even in print statements; thus if you have a print statement that contains the word "allocate()" (with parentheses) it will be changed :-( +## - since it works line by line, it will add a check even if there is an existing one already in the lines below the allocate() statement; this does not hurt, but can lead to duplicated lines or similar line +## - since it works line by line, it also has issues with allocate() statements that may extend over several lines; if so, it will likely generate something slightly incorrect, +#" which you will have to fix manually when compiling the code for the first time (that should be easy to do) + +# DK DK only do this in the "src" directory, otherwise independent programs in other directories such as "utils" will not have access to the "exit_MPI_without_rank()" subroutine + +# when using this "find" command from Perl we need to use \\ instead of \ below otherwise Perl tries to interpret it + @objects = `find 'src' -name '.git' -prune -o -name 'm4' -prune -o -type f -regextype posix-extended -regex '.*\\.(fh|f90|F90|h\\.in|fh\\.in)' -print`; + + foreach $name (@objects) { + chop $name; +# change tabs to white spaces + system("expand -2 < $name > _____temp08_____"); + $f90name = $name; +##################### print STDOUT "Cleaning $f90name ...\n"; + + open(FILE_INPUT,"<_____temp08_____"); +################### open(FILEF90,">$f90name"); + +# open the input f90 file + while($line = ) { + +# suppress trailing white spaces and carriage return + $line =~ s/\s*$//; + +# clear the flag that says if we need to add an allocate statement check or not + $need_to_add_an_allocate_statement_check = 0; + + $linewithnospaceatall = $line; + $linewithnospaceatall =~ s# ##ogi; + $first_letter = substr(($linewithnospaceatall),0,1); +# do not make replacements in comments + if($first_letter ne '!') { + +# test if the line contains an "allocate()" statement + if (index($line, "allocate(") != -1) { +# and test that it is not a "deallocate()" statement + if (index($line, "deallocate(") == -1) { + +# suppress trailing white spaces, just in case we have added any in the above processing + $line =~ s/\s*$//; + + print "$line\n"; + + } + } + } + +################### print FILEF90 "$line\n"; + + } + + close(FILE_INPUT); +################### close(FILEF90); + + } + + system("rm -f _____temp08_____"); +