[cig-commits] r20989 - in seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT: FORWARD_ADJOINT ITERATION_UPDATE ITERATION_UPDATE/X01_SRC_SUM_KERNELS ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS ITERATION_UPDATE/X04_SRC_DIRECTION_CG ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS ITERATION_UPDATE/X04_SRC_DIRECTION_SD ITERATION_UPDATE/X05_SRC_UPDATE_MODELS MODEL_VISULIZATION MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT SHARE_FILES SHARE_FILES/HEADER_FILES SOURCE_INVERSION SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT
hejunzhu at geodynamics.org
hejunzhu at geodynamics.org
Mon Nov 5 12:28:19 PST 2012
Author: hejunzhu
Date: 2012-11-05 12:28:17 -0800 (Mon, 05 Nov 2012)
New Revision: 20989
Added:
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XPBS_process_dat.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XSHELL_process_dat.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/XPBS_sum_kernels.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/XPBS_precond_kernels.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XPBS_smooth_kernel.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XSHELL_smooth_kernel.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/XPBS_compute_direction_cg.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/XPBS_compute_direction_lbfgs.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/XPBS_compute_direction_sd.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/XPBS_update_model.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XPBS_single_kernel_vtu.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XSHELL_single_kernel_vtu.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_HORIZON_FILE.m
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_VERTICAL_FILE.m
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XPBS_slice_horiz.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XSHELL_slice_horiz.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XYZ_FILES_HORIZ/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/get_value_parameters.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/sem_model_slice.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XPBS_slice_vert.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XSHELL_slice_vert.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XYZ_FILES_VERT/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/get_value_parameters.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/sem_model_slice.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/CMTSOLUTION_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/EVENTID_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/constants.h
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/precision.h
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/values_from_mesher.h
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/STATIONS_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XPBS_correction.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XSHELL_correction.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/correct_syn_time_moment.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XPBS_gridsearch.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XSHELL_gridsearch.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcombine_gridsearch.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcompile.sh
Removed:
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/CMTSOLUTION_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/EVENTID_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/STATIONS_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat_pbs.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/EVENTID_CENTER/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xpbs_sum_kernels.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xsum_kernels
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xpbs_precond_kernels.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xprecond_kernels
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel_sub.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xsmooth_sem_globe
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompute_direction_cg
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xpbs_compute_direction_cg.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/globe_parameter.mod
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompute_direction_lbfgs
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xpbs_compute_direction_lbfgs.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompute_direction_sd
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xpbs_compute_direction_sd.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/model_update_tiso.mod
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xadd_model_globe
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xpbs_update_model.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XHEADER_FILES/
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu_pbs.sh
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh
Modified:
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/exit_mpi.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/precond_kernels.f90
seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xcompile.sh
Log:
add source correction
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XPBS_process_dat.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XPBS_process_dat.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XPBS_process_dat.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,42 @@
+#!/bin/sh
+#PBS -q tromp
+#PBS -N XPROC_DAT_200604121652A
+#PBS -l nodes=1:ppn=1
+#PBS -l walltime=10:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+opt=2
+tstart=0
+tend=1800
+fmin=25
+fmax=150
+ext=T025_150
+datdir=DATASET_EUROPE/CMTSOLUTION_200604121652A
+syndir=SYN_M13/CMTSOLUTION_200604121652A
+cmtfile=CMTSOLUTION_CENTER/CMTSOLUTION_200604121652A
+
+if [ $opt == 1 ]; then
+ ./PERL_CENTER/process_data.pl -m $cmtfile -s 10.0 -l $tstart/$tend -t $fmin/$fmax -f -i -p -x $ext $datdir/*.sac
+ ./PERL_CENTER/rotate.pl -l $tstart -L $tend $datdir/*.BHE.sac.$ext
+ echo delete N E bandpass component
+ cd $datdir
+ rm *.BHN.sac.$ext
+ rm *.BHE.sac.$ext
+
+elif [ $opt == 2 ]; then
+ ./PERL_CENTER/process_syn.pl -S -m $cmtfile -s 10.0 -l $tstart/$tend -t $fmin/$fmax -f -x $ext $syndir/*.sac
+ ./PERL_CENTER/rotate.pl -l $tstart -L $tend $syndir/*.LHE.sem.sac.$ext
+ ./PERL_CENTER/cut_data_syn.pl -d $syndir $datdir/*BH[ZRT]*.$ext
+ echo delete N E bandpass component
+ cd $syndir
+ rm *.LHN.sem.sac.$ext
+ rm *.LHE.sem.sac.$ext
+fi
+
+echo PROCESSING DATA successfully
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XPBS_process_dat.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XSHELL_process_dat.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XSHELL_process_dat.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XSHELL_process_dat.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,74 @@
+#!/bin/sh
+
+# This script is used to process data and syn
+# It used process_data.pl process_syn.pl
+# Hejun Zhu Jun 07 2010
+
+# INPUT:
+# fmin : minimum period
+# fmax : maximum period
+# tstart: cut start time
+# tend: cut end time
+# cmtid: event id
+# opt: 1=process dat; 2=process syn; 3=cut data and synthetics
+# Bandpass 15-25sec, 20-34sec, 26-56sec, 50-120sec (15-35sec, 50-120sec)
+
+
+# Input
+opt=2
+iter=M13
+fmin=25
+fmax=150
+eventfile=../SHARE_FILES/EVENTID_CENTER/XEVENTID
+tstart=0
+tend=1800
+
+
+# Get names
+datpnm=DATASET_EUROPE
+synpnm="SYN_"$iter
+ext1=`printf "%03i\n" $fmin`
+ext2=`printf "%03i\n" $fmax`
+ext="T"$ext1"_"$ext2
+
+
+# Check files
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+
+
+while read line
+do
+ cmtfile="../SHARE_FILES/CMTSOLUTION_CENTER/$line"
+ cmtfiletag="..\/SHARE_FILES\/CMTSOLUTION_CENTER\/$line"
+ cmtid=`echo $line | awk -F"_" '{print $2}'`
+ proctag="#PBS -N XPROC_DAT_$cmtid"
+ datdir="$datpnm\/CMTSOLUTION_$cmtid"
+ syndir="$synpnm\/$line"
+
+ if [ ! -f $cmtfile ]; then
+ echo WRONG! NO $cmtfile
+ exit
+ fi
+
+ sed -e "s/^#PBS -N.*$/$proctag/g" \
+ -e "s/^cmtfile=.*$/cmtfile=$cmtfiletag/g" \
+ -e "s/^tstart=.*$/tstart=$tstart/g" \
+ -e "s/^tend=.*$/tend=$tend/g" \
+ -e "s/^fmin=.*$/fmin=$fmin/g" \
+ -e "s/^fmax=.*$/fmax=$fmax/g" \
+ -e "s/^ext=.*$/ext=$ext/g" \
+ -e "s/^datdir=.*$/datdir=$datdir/g" \
+ -e "s/^syndir=.*$/syndir=$syndir/g" \
+ -e "s/^opt=.*$/opt=$opt/g" \
+ XPBS_process_dat.sh > XPBS_process_dat.sh.out
+ mv XPBS_process_dat.sh.out XPBS_process_dat.sh
+
+ echo qsub $line
+ qsub XPBS_process_dat.sh
+ sleep 5
+done < $eventfile
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/XSHELL_process_dat.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,15 +0,0 @@
-#!/bin/sh
-
-ntot=0
-for line in XPROC_DAT_*
-do
-
- n=`wc -l $line | awk '{print $1}'`
- ntot=`echo $ntot +1 | bc -l`
- tag="successfully"
- tag1="DONE"
- text=`grep $tag $line`
- text1=`grep $tag1 $line`
- echo $line $text $text1 $n
-done
-echo found $ntot finshed
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,15 @@
+#!/bin/sh
+
+ntot=0
+for line in XPROC_DAT_*
+do
+
+ n=`wc -l $line | awk '{print $1}'`
+ ntot=`echo $ntot +1 | bc -l`
+ tag="successfully"
+ tag1="DONE"
+ text=`grep $tag $line`
+ text1=`grep $tag1 $line`
+ echo $line $text $text1 $n
+done
+echo found $ntot finshed
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcheck_process_dat.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,56 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Thu Nov 18 15:31:44 EST 2010
-
-
-eventfile=EVENTID_CENTER/XEVENTID
-iter=M18
-
-# Check files
-if [ ! -f $eventfile ]; then
- echo WRONG! NO $eventfile
- exit
-fi
-
-if [ ! -d SYN_$iter ]; then
- echo mkdir SYN_$iter
- mkdir SYN_$iter
-fi
-
-
-while read line
-do
- echo $line
- cmtid=`echo $line | awk -F"_" '{print $2}'`
- mefile=MEASUREMENT_CENTER/MEASUREMENT_$cmtid
- dir="SYN_"$iter"/"$line
- if [ ! -d $dir ]; then
- echo mkdir $dir
- mkdir $dir
- fi
- if [ ! -f $mefile ]; then
- echo WRONG! NO $mefile
- exit
- fi
-
- while read name
- do
- if [ ! -f FORWARD_$iter/$line/OUTPUT_FILES/$name.LHZ.sem.sac ]; then
- echo WRONG! NO FORWARD_$iter/$line/OUTPUT_FILES/$name.LHZ.sem.sac
- exit
- fi
- if [ ! -f FORWARD_$iter/$line/OUTPUT_FILES/$name.LHE.sem.sac ]; then
- echo WRONG! NO FORWARD_$iter/$line/OUTPUT_FILES/$name.LHE.sem.sac
- exit
- fi
- if [ ! -f FORWARD_$iter/$line/OUTPUT_FILES/$name.LHN.sem.sac ]; then
- echo WRONG! NO FORWARD_$iter/$line/OUTPUT_FILES/$name.LHN.sem.sac
- exit
- fi
-
-
- cp FORWARD_$iter/$line/OUTPUT_FILES/$name.*.sac SYN_$iter/$line
- done < $mefile
-
-done < $eventfile
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,56 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Thu Nov 18 15:31:44 EST 2010
+
+
+eventfile=../SHARE_FILES/EVENTID_CENTER/XEVENTID
+iter=M18
+
+# Check files
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+
+if [ ! -d SYN_$iter ]; then
+ echo mkdir SYN_$iter
+ mkdir SYN_$iter
+fi
+
+
+while read line
+do
+ echo $line
+ cmtid=`echo $line | awk -F"_" '{print $2}'`
+ mefile=MEASUREMENT_CENTER/MEASUREMENT_$cmtid
+ dir="SYN_"$iter"/"$line
+ if [ ! -d $dir ]; then
+ echo mkdir $dir
+ mkdir $dir
+ fi
+ if [ ! -f $mefile ]; then
+ echo WRONG! NO $mefile
+ exit
+ fi
+
+ while read name
+ do
+ if [ ! -f FORWARD_$iter/$line/OUTPUT_FILES/$name.LHZ.sem.sac ]; then
+ echo WRONG! NO FORWARD_$iter/$line/OUTPUT_FILES/$name.LHZ.sem.sac
+ exit
+ fi
+ if [ ! -f FORWARD_$iter/$line/OUTPUT_FILES/$name.LHE.sem.sac ]; then
+ echo WRONG! NO FORWARD_$iter/$line/OUTPUT_FILES/$name.LHE.sem.sac
+ exit
+ fi
+ if [ ! -f FORWARD_$iter/$line/OUTPUT_FILES/$name.LHN.sem.sac ]; then
+ echo WRONG! NO FORWARD_$iter/$line/OUTPUT_FILES/$name.LHN.sem.sac
+ exit
+ fi
+
+
+ cp FORWARD_$iter/$line/OUTPUT_FILES/$name.*.sac SYN_$iter/$line
+ done < $mefile
+
+done < $eventfile
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xcollect_syn.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,49 +0,0 @@
-#!/bin/sh
-# This script is used to generate a file which contain the same
-# data and synthetics
-# format for MEASUREMENT file is sta.net stlo stla dist az
-# Hejun Zhu, Jun 24, 2010
-
-eventfile=EVENTID_CENTER/XEVENTID
-iter=M00
-
-while read line
-do
- echo $line
- eid=`echo $line | awk -F"_" '{print $NF}'`
- datdir=DATASET_EUROPE/$line
- syndir="SYN_"$iter"/"$line
- mefile="MEASUREMENT_CENTER/MEASUREMENT_"$eid
-
- if [ -f $mefile ]; then
- echo deleting $mefile
- rm $mefile
- fi
- if [ ! -d $datdir ]; then
- echo WRONG! NO $datdir
- exit
- fi
- if [ ! -d $syndir ]; then
- echo WRONG! NO $syndir
- exit
- fi
-
-
- for file1 in $datdir/*BHE.sac; do
- sta=`echo $file1 | awk -F"/" '{print $NF}' | awk -F"." '{print $1}'`
- net=`echo $file1 | awk -F"/" '{print $NF}' | awk -F"." '{print $2}'`
-
- file2=$datdir"/"$sta"."$net".BHE.sac"
-
-
- file4=$syndir"/"$sta"."$net".LHE.sem.sac"
- if [ -f $file4 ] ; then
- #echo found $sta $net for $line
- #echo $sta"."$net $stlo $stla $dist $az >> $mefile
- echo $sta"."$net >> $mefile
- fi
- done
-done < $eventfile
-
-
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,49 @@
+#!/bin/sh
+# This script is used to generate a file which contain the same
+# data and synthetics
+# format for MEASUREMENT file is sta.net stlo stla dist az
+# Hejun Zhu, Jun 24, 2010
+
+eventfile=../SHARE_FILES/EVENTID_CENTER/XEVENTID
+iter=M00
+
+while read line
+do
+ echo $line
+ eid=`echo $line | awk -F"_" '{print $NF}'`
+ datdir=DATASET_EUROPE/$line
+ syndir="SYN_"$iter"/"$line
+ mefile="MEASUREMENT_CENTER/MEASUREMENT_"$eid
+
+ if [ -f $mefile ]; then
+ echo deleting $mefile
+ rm $mefile
+ fi
+ if [ ! -d $datdir ]; then
+ echo WRONG! NO $datdir
+ exit
+ fi
+ if [ ! -d $syndir ]; then
+ echo WRONG! NO $syndir
+ exit
+ fi
+
+
+ for file1 in $datdir/*BHE.sac; do
+ sta=`echo $file1 | awk -F"/" '{print $NF}' | awk -F"." '{print $1}'`
+ net=`echo $file1 | awk -F"/" '{print $NF}' | awk -F"." '{print $2}'`
+
+ file2=$datdir"/"$sta"."$net".BHE.sac"
+
+
+ file4=$syndir"/"$sta"."$net".LHE.sem.sac"
+ if [ -f $file4 ] ; then
+ #echo found $sta $net for $line
+ #echo $sta"."$net $stlo $stla $dist $az >> $mefile
+ echo $sta"."$net >> $mefile
+ fi
+ done
+done < $eventfile
+
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xgen_measurement.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,74 +0,0 @@
-#!/bin/sh
-
-# This script is used to process data and syn
-# It used process_data.pl process_syn.pl
-# Hejun Zhu Jun 07 2010
-
-# INPUT:
-# fmin : minimum period
-# fmax : maximum period
-# tstart: cut start time
-# tend: cut end time
-# cmtid: event id
-# opt: 1=process dat; 2=process syn; 3=cut data and synthetics
-# Bandpass 15-25sec, 20-34sec, 26-56sec, 50-120sec (15-35sec, 50-120sec)
-
-
-# Input
-opt=2
-iter=M13
-fmin=25
-fmax=150
-eventfile=EVENTID_CENTER/XEVENTID_00
-tstart=0
-tend=1800
-
-
-# Get names
-datpnm=DATASET_EUROPE
-synpnm="SYN_"$iter
-ext1=`printf "%03i\n" $fmin`
-ext2=`printf "%03i\n" $fmax`
-ext="T"$ext1"_"$ext2
-
-
-# Check files
-if [ ! -f $eventfile ]; then
- echo WRONG! NO $eventfile
- exit
-fi
-
-
-while read line
-do
- cmtfile="CMTSOLUTION_CENTER/$line"
- cmtfiletag="CMTSOLUTION_CENTER\/$line"
- cmtid=`echo $line | awk -F"_" '{print $2}'`
- proctag="#PBS -N XPROC_DAT_$cmtid"
- datdir="$datpnm\/CMTSOLUTION_$cmtid"
- syndir="$synpnm\/$line"
-
- if [ ! -f $cmtfile ]; then
- echo WRONG! NO $cmtfile
- exit
- fi
-
- sed -e "s/^#PBS -N.*$/$proctag/g" \
- -e "s/^cmtfile=.*$/cmtfile=$cmtfiletag/g" \
- -e "s/^tstart=.*$/tstart=$tstart/g" \
- -e "s/^tend=.*$/tend=$tend/g" \
- -e "s/^fmin=.*$/fmin=$fmin/g" \
- -e "s/^fmax=.*$/fmax=$fmax/g" \
- -e "s/^ext=.*$/ext=$ext/g" \
- -e "s/^datdir=.*$/datdir=$datdir/g" \
- -e "s/^syndir=.*$/syndir=$syndir/g" \
- -e "s/^opt=.*$/opt=$opt/g" \
- xprocess_dat_pbs.sh > xprocess_dat_pbs.sh.out
- mv xprocess_dat_pbs.sh.out xprocess_dat_pbs.sh
-
- echo qsub $line
- qsub xprocess_dat_pbs.sh
- sleep 5
-done < $eventfile
-
-
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat_pbs.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat_pbs.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xprocess_dat_pbs.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,42 +0,0 @@
-#!/bin/sh
-#PBS -q tromp
-#PBS -N XPROC_DAT_200604121652A
-#PBS -l nodes=1:ppn=1
-#PBS -l walltime=10:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o job_src2.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-opt=2
-tstart=0
-tend=1800
-fmin=25
-fmax=150
-ext=T025_150
-datdir=DATASET_EUROPE/CMTSOLUTION_200604121652A
-syndir=SYN_M13/CMTSOLUTION_200604121652A
-cmtfile=CMTSOLUTION_CENTER/CMTSOLUTION_200604121652A
-
-if [ $opt == 1 ]; then
- ./PERL_CENTER/process_data.pl -m $cmtfile -s 10.0 -l $tstart/$tend -t $fmin/$fmax -f -i -p -x $ext $datdir/*.sac
- ./PERL_CENTER/rotate.pl -l $tstart -L $tend $datdir/*.BHE.sac.$ext
- echo delete N E bandpass component
- cd $datdir
- rm *.BHN.sac.$ext
- rm *.BHE.sac.$ext
-
-elif [ $opt == 2 ]; then
- ./PERL_CENTER/process_syn.pl -S -m $cmtfile -s 10.0 -l $tstart/$tend -t $fmin/$fmax -f -x $ext $syndir/*.sac
- ./PERL_CENTER/rotate.pl -l $tstart -L $tend $syndir/*.LHE.sem.sac.$ext
- ./PERL_CENTER/cut_data_syn.pl -d $syndir $datdir/*BH[ZRT]*.$ext
- echo delete N E bandpass component
- cd $syndir
- rm *.LHN.sem.sac.$ext
- rm *.LHE.sem.sac.$ext
-fi
-
-echo PROCESSING DATA successfully
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,141 +0,0 @@
-#!/bin/sh
-
-# This script is used to submit adjoint simulation
-# require adjoint source and station file first
-# Hejun Zhu, Aug 25, 2010
-
-
-eventfile=EVENTID_CENTER/XEVENTID
-iter=M18
-
-#fmin=15
-#fmax=50
-#ext1=`printf "%03i\n" $fmin`
-#ext2=`printf "%03i\n" $fmax`
-#ext="T"$ext1"_"$ext2
-ext="comb"
-
-
-parent="trunk_17365"
-cmtcenter="CMTSOLUTION_CENTER"
-xcopy="COPY_LOCAL/xcopy_local_forward"
-xchange="PERL_CENTER/change_simulation_type.pl"
-
-pnm=ADJOINT_$iter
-
-if [ ! -f $eventfile ]; then
- echo WRONG! NO $eventfile
- exit
-fi
-if [ ! -d $pnm ]; then
- echo mkdir $pnm ...
- mkdir $pnm
-fi
-if [ ! -d $cmtcenter ]; then
- echo WRONG! NO $cmtcenter
- exit
-fi
-if [ ! -f $xcopy ]; then
- echo WRONG! NO $xcopy
- exit
-fi
-if [ ! -f $xchange ]; then
- echo WRONG! NO $xchange
- exit
-fi
-
-while read line
-do
- dir=$pnm"/"$line
- if [ ! -d $dir ]; then
- echo " make dir... "
- mkdir $dir
- fi
- if [ ! -d $dir/DATA ]; then
- echo " make DATA ... "
- mkdir $dir/DATA
- fi
-
-
- adjdir="SYN_"$iter"/"$line"_ADJ_"$ext
- if [ ! -d $adjdir ]; then
- echo WRONG! NO $adjdir
- exit
- fi
-
-
- # only copy useful part of the code to sub directory
- cp -r $parent/DATA/Par_file $dir/DATA
- cp -r $parent/DATA/STATIONS $dir/DATA
- cp -r $parent/DATA/CMTSOLUTION $dir/DATA
- cp -r $parent/OUTPUT_FILES $dir/
- cp -r $parent/SEM $dir/
- cp -r $parent/KERNEL $dir/
- cp $parent/xparallel_adjoint_solver.sh $dir/
- cp $parent/xspecfem3D $dir/
- cp $xcopy $dir/
- cp $xchange $dir/
-
- # distribute adjoint source and stations
- echo distribute adjoint sources and stations
- if [ ! -f $adjdir/STATIONS_ADJOINT ]; then
- echo WRONG! NO $adjdir/STATIONS_ADJOINT
- exit
- fi
- cp $adjdir/*.LH[ZEN].adj $dir/SEM/
- cp $adjdir/STATIONS_ADJOINT $dir/DATA
-
- cd $dir/DATA
- echo " copy CMTSOLUTION... "
- ########sed -e "s/^half duration.*$/half duration: 0.0/g" $line > CMTSOLUTION
- ########mv CMTSOLUTION ../
- cat $cmtcenter/$line > CMTSOLUTION
-
- if [ ! -f Par_file ]; then
- echo WRONG! NO Par_file
- exit
- fi
- echo " change Par_file... "
- path="\/scratch\/hejunzhu"
- sed -e "s/^LOCAL_PATH.*$/LOCAL_PATH = $path/g" \
- Par_file > Par_file_out
- mv Par_file_out Par_file
-
-
- cd ..
- if [ ! -f xparallel_adjoint_solver.sh ]; then
- echo WRONG! NO xparallel_adjoint_solver.sh
- exit
- fi
- echo " changing pbs file "
- tag="#PBS -N $line"
- sed -e "s/^#PBS -N.*$/$tag/g" xparallel_adjoint_solver.sh > xparallel_adjoint_solver_out.sh
- mv xparallel_adjoint_solver_out.sh xparallel_adjoint_solver.sh
-
-
- # check code exist
- if [ ! -f xspecfem3D ] ;then
- echo WRONG! NO xspecfem3D
- exit
- fi
- if [ ! -f xcopy_local_forward ]; then
- echo WRONG! NO xcopy_local_forward
- exit
- fi
- if [ ! -f change_simulation_type.pl ]; then
- echo WRONG! NO change_simulation_type.pl
- exit
- fi
- mimic=`grep USE_ATTENUATION_MIMIC OUTPUT_FILES/values_from_mesher.h | awk -F"=" '{print $NF}'`
- if [ $mimic != ".true." ]; then
- echo WRONG! NEED reompile solver with MIMIC attenuation
- exit
- fi
-
- echo submitting job
- qsub xparallel_adjoint_solver.sh
-
- sleep 5
- cd ../../
-
-done < $eventfile
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,145 @@
+#!/bin/sh
+
+# This script is used to submit adjoint simulation
+# require adjoint source and station file first
+# Hejun Zhu, Aug 25, 2010
+
+
+eventfile=../SHARE_FILES/EVENTID_CENTER/XEVENTID
+iter=M00
+
+#fmin=15
+#fmax=50
+#ext1=`printf "%03i\n" $fmin`
+#ext2=`printf "%03i\n" $fmax`
+#ext="T"$ext1"_"$ext2
+ext="comb"
+
+
+parent="XSRC_SEM"
+cmtcenter="../SHARE_FILES/CMTSOLUTION_CENTER"
+stacenter="../SHARE_FILES/STATION_CENTER"
+xcopy="COPY_LOCAL/xcopy_local_forward"
+xchange="PERL_SRC/change_simulation_type.pl"
+
+pnm=ADJOINT_$iter
+
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+if [ ! -d $pnm ]; then
+ echo mkdir $pnm ...
+ mkdir $pnm
+fi
+if [ ! -d $cmtcenter ]; then
+ echo WRONG! NO $cmtcenter
+ exit
+fi
+if [ ! -f $xcopy ]; then
+ echo WRONG! NO $xcopy
+ exit
+fi
+if [ ! -f $xchange ]; then
+ echo WRONG! NO $xchange
+ exit
+fi
+
+while read line
+do
+ dir=$pnm"/"$line
+ eid=`echo $line | awk -F"_" '{print $NF}'`
+ stafile=STATION_$eid
+
+ if [ ! -d $dir ]; then
+ echo " make dir... "
+ mkdir $dir
+ fi
+ if [ ! -d $dir/DATA ]; then
+ echo " make DATA ... "
+ mkdir $dir/DATA
+ fi
+
+
+ adjdir="SYN_"$iter"/"$line"_ADJ_"$ext
+ if [ ! -d $adjdir ]; then
+ echo WRONG! NO $adjdir
+ exit
+ fi
+
+
+ # only copy useful part of the code to sub directory
+ cp -r $parent/DATA/Par_file $dir/DATA
+ cp -r $parent/DATA/STATIONS $dir/DATA
+ cp -r $parent/DATA/CMTSOLUTION $dir/DATA
+ cp -r $parent/OUTPUT_FILES $dir/
+ cp -r $parent/SEM $dir/
+ cp -r $parent/KERNEL $dir/
+ cp $parent/xparallel_adjoint_solver.sh $dir/
+ cp $parent/xspecfem3D $dir/
+ cp $xcopy $dir/
+ cp $xchange $dir/
+
+ # distribute adjoint source and stations
+ echo distribute adjoint sources and stations
+ if [ ! -f $adjdir/STATIONS_ADJOINT ]; then
+ echo WRONG! NO $adjdir/STATIONS_ADJOINT
+ exit
+ fi
+ cp $adjdir/*.LH[ZEN].adj $dir/SEM/
+ cp $adjdir/STATIONS_ADJOINT $dir/DATA
+
+ cat $cmtcenter/$line > $dir/DATA/CMTSOLUTION
+ cat $stacenter/$stafile > $dir/DATA/STATIONS
+
+ cd $dir/DATA
+
+ if [ ! -f Par_file ]; then
+ echo WRONG! NO Par_file
+ exit
+ fi
+ echo " change Par_file... "
+ path="\/scratch\/hejunzhu"
+ sed -e "s/^LOCAL_PATH.*$/LOCAL_PATH = $path/g" \
+ Par_file > Par_file_out
+ mv Par_file_out Par_file
+
+
+ cd ..
+ if [ ! -f xparallel_adjoint_solver.sh ]; then
+ echo WRONG! NO xparallel_adjoint_solver.sh
+ exit
+ fi
+ echo " changing pbs file "
+ tag="#PBS -N $line"
+ sed -e "s/^#PBS -N.*$/$tag/g" xparallel_adjoint_solver.sh > xparallel_adjoint_solver_out.sh
+ mv xparallel_adjoint_solver_out.sh xparallel_adjoint_solver.sh
+
+
+ # check code exist
+ if [ ! -f xspecfem3D ] ;then
+ echo WRONG! NO xspecfem3D
+ exit
+ fi
+ if [ ! -f xcopy_local_forward ]; then
+ echo WRONG! NO xcopy_local_forward
+ exit
+ fi
+ if [ ! -f change_simulation_type.pl ]; then
+ echo WRONG! NO change_simulation_type.pl
+ exit
+ fi
+ mimic=`grep USE_ATTENUATION_MIMIC OUTPUT_FILES/values_from_mesher.h | awk -F"=" '{print $NF}'`
+ if [ $mimic != ".true." ]; then
+ echo WRONG! NEED reompile solver with MIMIC attenuation
+ exit
+ fi
+
+
+ echo submitting job
+ qsub xparallel_adjoint_solver.sh
+
+ sleep 3
+ cd ../../
+
+done < $eventfile
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_adjoint_simulation.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,109 +0,0 @@
-#!/bin/sh
-# generate and clean code dir for several simulations
-# Input: cmtid: CMTSOLUTION id
-# iter: iteration number
-# opt: 1-generate code
-# 2-clean code
-# 3-clean /scratch/lustre/hejunzhu/*** directory
-# Hejun Zhu, Mar 23, 2010
-
-eventfile="EVENTID_CENTER/XEVENTID"
-iter=M18
-
-parent="XSRC_SEM"
-cmtcenter="CMTSOLUTION_CENTER"
-xcopy="COPY_LOCAL/xcopy_local_forward"
-
-pnm=FORWARD_$iter
-
-if [ ! -f $eventfile ]; then
- echo WRONG! NO $eventfile
- exit
-fi
-if [ ! -d $pnm ]; then
- echo mkdir $pnm ...
- mkdir $pnm
-fi
-if [ ! -d $cmtcenter ]; then
- echo WRONG! NO $cmtcenter
- exit
-fi
-if [ ! -f $xcopy ]; then
- echo WRONG! NO $xcopy
- exit
-fi
-
-
-
-while read line
-do
- echo "*** processing $line ***"
-
- dir=$pnm"/"$line
-
- if [ ! -d $dir ]; then
- echo " make dir... "
- mkdir $dir
- fi
-
- if [ ! -d $dir/DATA ]; then
- echo " make DATA"
- mkdir $dir/DATA
- fi
-
- # only copy useful part of the code to sub directory
- cp -r $parent/DATA/Par_file $dir/DATA/
- cp -r $parent/DATA/STATIONS $dir/DATA/
- cp -r $parent/DATA/CMTSOLUTION $dir/DATA/
- cp -r $parent/OUTPUT_FILES $dir/
- cp $parent/xparallel_forward_solver.sh $dir/
- cp $parent/xspecfem3D $dir/
- cp $xcopy $dir/
-
- cd $dir/DATA
- echo " copy CMTSOLUTION... "
- ########sed -e "s/^half duration.*$/half duration: 0.0/g" $line > CMTSOLUTION
- ########mv CMTSOLUTION ../
- cat $cmtcenter/$line > CMTSOLUTION
-
- if [ ! -f Par_file ]; then
- echo WRONG! NO Par_file
- exit
- fi
- echo " change Par_file... "
- path="\/scratch\/hejunzhu"
- sed -e "s/^LOCAL_PATH.*$/LOCAL_PATH = $path/g" Par_file >Par_file_out
- mv Par_file_out Par_file
-
- cd ..
- if [ ! -f xparallel_forward_solver.sh ]; then
- echo WRONG! NO xparallel_forward_solver.sh
- exit
- fi
- echo " changing pbs file "
- tag="#PBS -N $line"
- sed -e "s/^#PBS -N.*$/$tag/g" xparallel_forward_solver.sh > xparallel_forward_solver_out.sh
- mv xparallel_forward_solver_out.sh xparallel_forward_solver.sh
-
- if [ ! -f xspecfem3D ] ;then
- echo WRONG! NO xspecfem3D
- exit
- fi
- if [ ! -f xcopy_local_forward ]; then
- echo WRONG! NO xcopy_local_forward
- exit
- fi
-
- mimic=`grep USE_ATTENUATION_MIMIC OUTPUT_FILES/values_from_mesher.h | awk -F"=" '{print $NF}'`
- if [ $mimic != ".false." ]; then
- echo WRONG! NEED reompile solver with MIMIC attenuation
- exit
- fi
-
-
- echo submitting job
- qsub xparallel_forward_solver.sh
-
- cd ../../
-
-done < $eventfile
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,117 @@
+#!/bin/sh
+# generate and clean code dir for several simulations
+# Input: cmtid: CMTSOLUTION id
+# iter: iteration number
+# opt: 1-generate code
+# 2-clean code
+# 3-clean /scratch/lustre/hejunzhu/*** directory
+# Hejun Zhu, Mar 23, 2010
+
+eventfile="../SHARE_FILES/EVENTID_CENTER/XEVENTID"
+iter=M00
+
+parent="XSRC_SEM"
+cmtcenter="../SHARE_FILES/CMTSOLUTION_CENTER"
+stacenter="../SHARE_FILES/STATION_CENTER"
+xcopy="COPY_LOCAL/xcopy_local_forward"
+
+pnm=FORWARD_$iter
+
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+if [ ! -d $pnm ]; then
+ echo mkdir $pnm ...
+ mkdir $pnm
+fi
+if [ ! -d $cmtcenter ]; then
+ echo WRONG! NO $cmtcenter
+ exit
+fi
+if [ ! -d $stacenter ]; then
+ echo WRONG! NO $stacenter
+ exit
+fi
+if [ ! -f $xcopy ]; then
+ echo WRONG! NO $xcopy
+ exit
+fi
+
+
+
+while read line
+do
+ echo "*** processing $line ***"
+
+ dir=$pnm"/"$line
+ eid=`echo $line | awk -F"_" '{print $NF}'`
+ stafile=STATION_$eid
+
+ if [ ! -d $dir ]; then
+ echo " make dir... "
+ mkdir $dir
+ fi
+
+ if [ ! -d $dir/DATA ]; then
+ echo " make DATA"
+ mkdir $dir/DATA
+ fi
+
+ # only copy useful part of the code to sub directory
+ cp -r $parent/DATA/Par_file $dir/DATA/
+ cp -r $parent/DATA/STATIONS $dir/DATA/
+ cp -r $parent/DATA/CMTSOLUTION $dir/DATA/
+ cp -r $parent/OUTPUT_FILES $dir/
+ cp $parent/xparallel_forward_solver.sh $dir/
+ cp $parent/xspecfem3D $dir/
+ cp $xcopy $dir/
+
+ cat $cmtcenter/$line > $dir/DATA/CMTSOLUTION
+ cat $stacenter/$stafile > $dir/DATA/STATIONS
+
+ cd $dir/DATA
+
+ if [ ! -f Par_file ]; then
+ echo WRONG! NO Par_file
+ exit
+ fi
+ echo " change Par_file... "
+ path="\/scratch\/hejunzhu"
+ sed -e "s/^LOCAL_PATH.*$/LOCAL_PATH = $path/g" Par_file >Par_file_out
+ mv Par_file_out Par_file
+
+ cd ..
+ if [ ! -f xparallel_forward_solver.sh ]; then
+ echo WRONG! NO xparallel_forward_solver.sh
+ exit
+ fi
+ echo " changing pbs file "
+ tag="#PBS -N $line"
+ sed -e "s/^#PBS -N.*$/$tag/g" xparallel_forward_solver.sh > xparallel_forward_solver_out.sh
+ mv xparallel_forward_solver_out.sh xparallel_forward_solver.sh
+
+ if [ ! -f xspecfem3D ] ;then
+ echo WRONG! NO xspecfem3D
+ exit
+ fi
+ if [ ! -f xcopy_local_forward ]; then
+ echo WRONG! NO xcopy_local_forward
+ exit
+ fi
+
+ mimic=`grep USE_ATTENUATION_MIMIC OUTPUT_FILES/values_from_mesher.h | awk -F"=" '{print $NF}'`
+ if [ $mimic != ".false." ]; then
+ echo WRONG! NEED reompile solver with MIMIC attenuation
+ exit
+ fi
+
+
+ echo submitting job
+ qsub xparallel_forward_solver.sh
+
+ sleep 3
+
+ cd ../../
+
+done < $eventfile
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/xsubmit_forward_simulation.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/XPBS_sum_kernels.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/XPBS_sum_kernels.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/XPBS_sum_kernels.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,44 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XSUM_KERNELS
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o sum_kernels.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter=M00
+
+input_dir=../../FORWARD_ADJOINT/ADJOINT_$iter
+output_dir=../SUMMED_KERNELS_$iter
+eventid=../../SHARE_FILES/EVENTID_CENTER/XEVENTID
+
+
+# checking directories
+if [ ! -d $input_dir ]; then
+ echo WRONG! NO $inputdir
+ exit
+fi
+
+if [ ! -f $eventid ]; then
+ echo WRONG! NO $eventid
+ exit
+fi
+
+# making directories
+if [ ! -d $output_dir ]; then
+ echo MKDIR $output_dir
+ mkdir $output_dir
+fi
+
+
+echo submit summing kernels
+mpiexec -np 100 ./xsum_kernels $input_dir $output_dir $eventid
+echo done successfully
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/XPBS_sum_kernels.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "../XHEADER_FILES/constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(outputname),status='unknown')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-
-! stop all the MPI processes, and exit
-! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
- call MPI_FINALIZE(ier)
- call MPI_ABORT(ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(outputname),status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+
+! stop all the MPI processes, and exit
+! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
+ call MPI_FINALIZE(ier)
+ call MPI_ABORT(ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,93 +0,0 @@
-! This subroutine is used to sum all event kernels to get misfit kernels
-! Last modified: Fri Sep 14 08:50:36 EDT 2012
-
-program sum_kernels
- implicit none
- include 'mpif.h'
- include '../XHEADER_FILES/constants.h'
- include '../XHEADER_FILES/values_from_mesher.h'
-
- integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
- integer,parameter:: NKERNEL=6 !bulk_betah, bulk_betav, bulk_c, eta
-
- integer:: myrank, sizeprocs,ier
- integer:: ios,nevent,ievent,iker
- character(len=350):: eventid,line,kernel_file,input_dir,output_dir
- character(len=150):: event_list(1000), kernel_name(NKERNEL)
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: kernel,total_kernel
-
-
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- call getarg(1,input_dir)
- call getarg(2,output_dir)
- call getarg(3,eventid)
-
-
- if (trim(input_dir) == '' &
- .or. trim(output_dir) == '' &
- .or. trim(eventid) == '' ) then
- call exit_MPI(myrank,'USAGE: xsum_kernels input_dir output_dir eventid')
- end if
-
- if (myrank == 0) then
- write(*,*) 'SUM EVENT KERNELS TO GET MISFIT KENRELS'
- write(*,*) 'INPUT DIRECTION:',input_dir
- write(*,*) 'OUTPUT DIRECTION:',output_dir
- write(*,*) 'INPUT EVENTFILE:',eventid
- end if
-
-
- kernel_name=(/"reg1_bulk_betah_kernel","reg1_bulk_betav_kernel","reg1_bulk_c_kernel","reg1_eta_kernel","reg1_rho_kernel","reg1_hess_kernel"/)
-
- nevent=0
- open(unit=1001,file=trim(eventid),status='old',iostat=ios)
- if ( ios /= 0 ) then
- print*, 'ERROR OPENING', trim(eventid)
- stop
- end if
- do while ( 1 == 1)
- read(1001,'(a)',iostat=ios) line
- if ( ios /=0) exit
- nevent=nevent+1
- event_list(nevent)=line
- end do
- close(1001)
-
-
- do iker=1,NKERNEL
- total_kernel=0.
-
- do ievent=1,nevent
-
- if (myrank==0) write(*,*) 'READING IN EVENT KERNEL:',trim(kernel_name(iker)),' FOR ',trim(event_list(ievent))
-
- write(kernel_file,'(a,i6.6,a)') trim(input_dir)//'/'//trim(event_list(ievent))//'/KERNEL/'//'proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
-
- open(unit=1002,file=trim(kernel_file),status='old',form='unformatted')
- read(1002) kernel(:,:,:,1:NSPEC)
- close(1002)
-
- ! sum ther kernel
- if (iker == 6 ) then ! for hessian , sum the absolute value
- total_kernel(:,:,:,1:NSPEC)=total_kernel(:,:,:,1:NSPEC) + abs(kernel(:,:,:,1:NSPEC))
- else
- total_kernel(:,:,:,1:NSPEC)=total_kernel(:,:,:,1:NSPEC) + kernel(:,:,:,1:NSPEC)
- end if
-
- end do
- if (myrank==0) write(*,*) 'WRITING MISFIT KERNELS:',trim(kernel_name(iker))
- write(kernel_file,'(a,i6.6,a)') trim(output_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
-
- open(1002,file=trim(kernel_file),form='unformatted')
- write(1002) total_kernel(:,:,:,1:NSPEC)
- close(1002)
- end do
-
- if (myrank==0) write(*,*) 'done summing all the kernels'
-
- call MPI_FINALIZE(ier)
-
-end program sum_kernels
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/sum_kernels.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,93 @@
+! This subroutine is used to sum all event kernels to get misfit kernels
+! Last modified: Fri Sep 14 08:50:36 EDT 2012
+
+program sum_kernels
+ implicit none
+ include 'mpif.h'
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+
+ integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
+ integer,parameter:: NKERNEL=6 !bulk_betah, bulk_betav, bulk_c, eta, rho, hess
+
+ integer:: myrank, sizeprocs,ier
+ integer:: ios,nevent,ievent,iker
+ character(len=350):: eventid,line,kernel_file,input_dir,output_dir
+ character(len=150):: event_list(1000), kernel_name(NKERNEL)
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: kernel,total_kernel
+
+
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ call getarg(1,input_dir)
+ call getarg(2,output_dir)
+ call getarg(3,eventid)
+
+
+ if (trim(input_dir) == '' &
+ .or. trim(output_dir) == '' &
+ .or. trim(eventid) == '' ) then
+ call exit_MPI(myrank,'USAGE: xsum_kernels input_dir output_dir eventid')
+ end if
+
+ if (myrank == 0) then
+ write(*,*) 'SUM EVENT KERNELS TO GET MISFIT KENRELS'
+ write(*,*) 'INPUT DIRECTION:',input_dir
+ write(*,*) 'OUTPUT DIRECTION:',output_dir
+ write(*,*) 'INPUT EVENTFILE:',eventid
+ end if
+
+
+ kernel_name=(/"reg1_bulk_betah_kernel","reg1_bulk_betav_kernel","reg1_bulk_c_kernel","reg1_eta_kernel","reg1_rho_kernel","reg1_hess_kernel"/)
+
+ nevent=0
+ open(unit=1001,file=trim(eventid),status='old',iostat=ios)
+ if ( ios /= 0 ) then
+ print*, 'ERROR OPENING', trim(eventid)
+ stop
+ end if
+ do while ( 1 == 1)
+ read(1001,'(a)',iostat=ios) line
+ if ( ios /=0) exit
+ nevent=nevent+1
+ event_list(nevent)=line
+ end do
+ close(1001)
+
+
+ do iker=1,NKERNEL
+ total_kernel=0.
+
+ do ievent=1,nevent
+
+ if (myrank==0) write(*,*) 'READING IN EVENT KERNEL:',trim(kernel_name(iker)),' FOR ',trim(event_list(ievent))
+
+ write(kernel_file,'(a,i6.6,a)') trim(input_dir)//'/'//trim(event_list(ievent))//'/KERNEL/'//'proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+
+ open(unit=1002,file=trim(kernel_file),status='old',form='unformatted')
+ read(1002) kernel(:,:,:,1:NSPEC)
+ close(1002)
+
+ ! sum ther kernel
+ if (iker == 6 ) then ! for hessian , sum the absolute value
+ total_kernel(:,:,:,1:NSPEC)=total_kernel(:,:,:,1:NSPEC) + abs(kernel(:,:,:,1:NSPEC))
+ else
+ total_kernel(:,:,:,1:NSPEC)=total_kernel(:,:,:,1:NSPEC) + kernel(:,:,:,1:NSPEC)
+ end if
+
+ end do
+ if (myrank==0) write(*,*) 'WRITING MISFIT KERNELS:',trim(kernel_name(iker))
+ write(kernel_file,'(a,i6.6,a)') trim(output_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+
+ open(1002,file=trim(kernel_file),form='unformatted')
+ write(1002) total_kernel(:,:,:,1:NSPEC)
+ close(1002)
+ end do
+
+ if (myrank==0) write(*,*) 'done summing all the kernels'
+
+ call MPI_FINALIZE(ier)
+
+end program sum_kernels
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,17 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Fri Sep 14 10:46:40 EDT 2012
-
-
-if [ ! -f ../XHEADER_FILES/constants.h ]; then
- echo WRONG! NO constants.h in XHEADER_FILES
- exit
-fi
-if [ ! -f ../XHEADER_FILES/values_from_mesher.h ]; then
- echo WRONG! values_from_mesher.h in XHEADER_FILES
- exit
-fi
-
-
-mpif90 -O3 -o xsum_kernels sum_kernels.f90 exit_mpi.f90
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,17 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Fri Sep 14 10:46:40 EDT 2012
+
+
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
+ echo WRONG! NO constants.h in SHARE_FILES/HEADER_FILES
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
+ echo WRONG! values_from_mesher.h in SHARE_FILES/HEADER_FILES
+ exit
+fi
+
+
+mpif90 -O3 -o xsum_kernels sum_kernels.f90 exit_mpi.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xpbs_sum_kernels.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xpbs_sum_kernels.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xpbs_sum_kernels.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,44 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XSUM_KERNELS
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o sum_kernels.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter=M00
-
-input_dir=../../MODEL_INVERSION/ADJOINT_$iter
-output_dir=../SUMMED_KERNELS_$iter
-eventid=../EVENTID_CENTER/XEVENTID
-
-
-# checking directories
-if [ ! -d $input_dir ]; then
- echo WRONG! NO $inputdir
- exit
-fi
-
-if [ ! -f $eventid ]; then
- echo WRONG! NO $eventid
- exit
-fi
-
-# making directories
-if [ ! -d $output_dir ]; then
- echo MKDIR $output_dir
- mkdir $output_dir
-fi
-
-
-echo submit summing kernels
-mpiexec -np 100 ./xsum_kernels $input_dir $output_dir $eventid
-echo done successfully
-
-
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X01_SRC_SUM_KERNELS/xsum_kernels
===================================================================
(Binary files differ)
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/XPBS_precond_kernels.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/XPBS_precond_kernels.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/XPBS_precond_kernels.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,29 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XPRECOND_KERNELS
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o precond_kernels.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter=M00
+
+input_dir=../SUMMED_KERNELS_$iter
+
+if [ ! -d $input_dir ]; then
+ echo WRONG! NO $input_dir
+ exit
+fi
+
+
+echo submit precondition kernels
+mpiexec -np 100 ./xprecond_kernels $input_dir
+echo done successfully
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/XPBS_precond_kernels.sh
___________________________________________________________________
Name: svn:executable
+ *
Modified: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -25,7 +25,7 @@
! standard include of the MPI library
include 'mpif.h'
- include "../../SHARE_FILES/constants.h"
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
! identifier for error message file
integer, parameter :: IERROR = 30
Modified: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/precond_kernels.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/precond_kernels.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/precond_kernels.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -5,9 +5,9 @@
program precond_kernels
implicit none
include 'mpif.h'
- include '../../SHARE_FILES/constants.h'
- include '../../SHARE_FILES/values_from_mesher.h'
- include '../../SHARE_FILES/precision.h'
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+ include '../../SHARE_FILES/HEADER_FILES/precision.h'
integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
integer,parameter:: NKERNEL=4 !bulk_betah, bulk_betav, bulk_c, eta
Modified: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -3,11 +3,11 @@
# Princeton University, New Jersey, USA
# Last modified: Tue Jan 25 17:19:32 EST 2011
-if [ ! -f ../../SHARE_FILES/constants.h ]; then
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
echo WRONG! NO constants.h in SHARE_FILES
exit
fi
-if [ ! -f ../../SHARE_FILES/values_from_mesher.h ]; then
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
echo WRONG! values_from_mesher.h in SHARE_FILES
exit
fi
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xpbs_precond_kernels.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xpbs_precond_kernels.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xpbs_precond_kernels.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,29 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XPRECOND_KERNELS
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o precond_kernels.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter=M00
-
-input_dir=../SUMMED_KERNELS_$iter
-
-if [ ! -d $input_dir ]; then
- echo WRONG! NO $input_dir
- exit
-fi
-
-
-echo submit precondition kernels
-mpiexec -np 100 ./xprecond_kernels $input_dir
-echo done successfully
-
-
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X02_SRC_PRECOND_KERNELS/xprecond_kernels
===================================================================
(Binary files differ)
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XPBS_smooth_kernel.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XPBS_smooth_kernel.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XPBS_smooth_kernel.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XSMOOTH_eta_kernel_precond
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter=M18
+sigma_h=50
+sigma_v=5
+topo_path=../EUROPE_TOPOLOGY_FILE
+kernel_path=../SUMMED_KERNEL_$iter
+tag=eta_kernel_precond
+
+output_tag="XTAG_SMOOTH_"$iter"_"$tag
+
+echo submit smoothing $tag kernel
+mpiexec -np 100 ./xsmooth_sem_globe $sigma_h $sigma_v $tag $kernel_path $topo_path > $output_tag
+echo smoothing $tag kernel done successfully
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XSHELL_smooth_kernel.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XSHELL_smooth_kernel.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XSHELL_smooth_kernel.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,30 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Fri Mar 4 13:16:22 EST 2011
+
+
+iter=M00
+sigma_h=50
+sigma_v=5
+
+
+for tag in bulk_c_kernel_precond bulk_betav_kernel_precond bulk_betah_kernel_precond eta_kernel_precond
+do
+ echo $tag
+
+ title="#PBS -N XSMOOTH_$tag"
+
+ sed -e "s/^tag=.*$/tag=$tag/g" \
+ -e "s/^iter=.*$/iter=$iter/g" \
+ -e "s/^sigma_h=.*$/sigma_h=$sigma_h/g" \
+ -e "s/^sigma_v=.*$/sigma_v=$sigma_v/g" \
+ -e "s/^#PBS -N.*$/$title/g" \
+ XPBS_smooth_kernel.sh > XPBS_smooth_kernel.sh.out
+
+ mv XPBS_smooth_kernel.sh.out XPBS_smooth_kernel.sh
+ qsub XPBS_smooth_kernel.sh
+ sleep 3
+done
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/XSHELL_smooth_kernel.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "../constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(outputname),status='unknown')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-
-! stop all the MPI processes, and exit
-! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
- call MPI_FINALIZE(ier)
- call MPI_ABORT(ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(outputname),status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+
+! stop all the MPI processes, and exit
+! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
+ call MPI_FINALIZE(ier)
+ call MPI_ABORT(ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,529 +0,0 @@
-
-!=======================================================================
-!
-! Library to compute the Gauss-Lobatto-Legendre points and weights
-! Based on Gauss-Lobatto routines from M.I.T.
-! Department of Mechanical Engineering
-!
-!=======================================================================
-
- double precision function endw1(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- f3 = zero
- apb = alpha+beta
- if (n == 0) then
- endw1 = zero
- return
- endif
- f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw1 = f1
- return
- endif
- fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw1 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw1 = f3
-
- end function endw1
-
-!
-!=======================================================================
-!
-
- double precision function endw2(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- apb = alpha+beta
- f3 = zero
- if (n == 0) then
- endw2 = zero
- return
- endif
- f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw2 = f1
- return
- endif
- fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw2 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw2 = f3
-
- end function endw2
-
-!
-!=======================================================================
-!
-
- double precision function gammaf (x)
-
- implicit none
-
- double precision, parameter :: pi = 3.141592653589793d0
-
- double precision x
-
- double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
-
- gammaf = one
-
- if (x == -half) gammaf = -two*dsqrt(pi)
- if (x == half) gammaf = dsqrt(pi)
- if (x == one ) gammaf = one
- if (x == two ) gammaf = one
- if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
- if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
- if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
- if (x == 3.d0 ) gammaf = 2.d0
- if (x == 4.d0 ) gammaf = 6.d0
- if (x == 5.d0 ) gammaf = 24.d0
- if (x == 6.d0 ) gammaf = 120.d0
-
- end function gammaf
-
-!
-!=====================================================================
-!
-
- subroutine jacg (xjac,np,alpha,beta)
-
-!=======================================================================
-!
-! computes np Gauss points, which are the zeros of the
-! Jacobi polynomial with parameters alpha and beta
-!
-! .alpha = beta = 0.0 -> Legendre points
-! .alpha = beta = -0.5 -> Chebyshev points
-!
-!=======================================================================
-
- implicit none
-
- integer np
- double precision alpha,beta
- double precision xjac(np)
-
- integer k,j,i,jmin,jm,n
- double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
- double precision p,pd,pm1,pdm1,pm2,pdm2
-
- integer, parameter :: K_MAX_ITER = 10
- double precision, parameter :: zero = 0.d0, eps = 1.0d-12
-
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- xlast = 0.d0
- n = np-1
- dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
- p = 0.d0
- pd = 0.d0
- jmin = 0
- do j=1,np
- if(j == 1) then
- x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- else
- x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- x2 = xlast
- x = (x1+x2)/2.d0
- endif
- do k=1,K_MAX_ITER
- call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
- recsum = 0.d0
- jm = j-1
- do i=1,jm
- recsum = recsum+1.d0/(x-xjac(np-i+1))
- enddo
- delx = -p/(pd-recsum*p)
- x = x+delx
- if(abs(delx) < eps) goto 31
- enddo
- 31 continue
- xjac(np-j+1) = x
- xlast = x
- enddo
- do i=1,np
- xmin = 2.d0
- do j=i,np
- if(xjac(j) < xmin) then
- xmin = xjac(j)
- jmin = j
- endif
- enddo
- if(jmin /= i) then
- swap = xjac(i)
- xjac(i) = xjac(jmin)
- xjac(jmin) = swap
- endif
- enddo
-
- end subroutine jacg
-
-!
-!=====================================================================
-!
-
- subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
-
-!=======================================================================
-!
-! Computes the Jacobi polynomial of degree n and its derivative at x
-!
-!=======================================================================
-
- implicit none
-
- double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
- integer n
-
- double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
- integer k
-
- apb = alp+bet
- poly = 1.d0
- pder = 0.d0
- psave = 0.d0
- pdsave = 0.d0
-
- if (n == 0) return
-
- polyl = poly
- pderl = pder
- poly = (alp-bet+(apb+2.d0)*x)/2.d0
- pder = (apb+2.d0)/2.d0
- if (n == 1) return
-
- do k=2,n
- dk = dble(k)
- a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
- a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
- b3 = (2.d0*dk+apb-2.d0)
- a3 = b3*(b3+1.d0)*(b3+2.d0)
- a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
- polyn = ((a2+a3*x)*poly-a4*polyl)/a1
- pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
- psave = polyl
- pdsave = pderl
- polyl = poly
- poly = polyn
- pderl = pder
- pder = pdern
- enddo
-
- polym1 = polyl
- pderm1 = pderl
- polym2 = psave
- pderm2 = pdsave
-
- end subroutine jacobf
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNDLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the derivative of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P1D,P2D,P3D,FK,P3
- integer k
-
- P1 = 1.d0
- P2 = Z
- P1D = 0.d0
- P2D = 1.d0
- P3D = 1.d0
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
- P1 = P2
- P2 = P3
- P1D = P2D
- P2D = P3D
- enddo
-
- PNDLEG = P3D
-
- end function pndleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P3,FK
- integer k
-
- P1 = 1.d0
- P2 = Z
- P3 = P2
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P1 = P2
- P2 = P3
- enddo
-
- PNLEG = P3
-
- end function pnleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision function pnormj (n,alpha,beta)
-
- implicit none
-
- double precision alpha,beta
- integer n
-
- double precision one,two,dn,const,prod,dindx,frac
- double precision, external :: gammaf
- integer i
-
- one = 1.d0
- two = 2.d0
- dn = dble(n)
- const = alpha+beta+one
-
- if (n <= 1) then
- prod = gammaf(dn+alpha)*gammaf(dn+beta)
- prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
- pnormj = prod * two**const/(two*dn+const)
- return
- endif
-
- prod = gammaf(alpha+one)*gammaf(beta+one)
- prod = prod/(two*(one+const)*gammaf(const+one))
- prod = prod*(one+alpha)*(two+alpha)
- prod = prod*(one+beta)*(two+beta)
-
- do i=3,n
- dindx = dble(i)
- frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
- prod = prod*frac
- enddo
-
- pnormj = prod * two**const/(two*dn+const)
-
- end function pnormj
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgjd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g j d : Generate np Gauss-Jacobi points and weights
-! associated with Jacobi polynomial of degree n = np-1
-!
-! Note : Coefficients alpha and beta must be greater than -1.
-! ----
-!=======================================================================
-
- implicit none
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision z(np),w(np)
- double precision alpha,beta
-
- integer n,np1,np2,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
- double precision, external :: gammaf,pnormj
-
- pd = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- apb = alpha+beta
- p = zero
- pdm1 = zero
-
- if (np <= 0) stop 'minimum number of Gauss points is 1'
-
- if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
-
- if (np == 1) then
- z(1) = (beta-alpha)/(apb+two)
- w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
- return
- endif
-
- call jacg(z,np,alpha,beta)
-
- np1 = n+1
- np2 = n+2
- dnp1 = dble(np1)
- dnp2 = dble(np2)
- fac1 = dnp1+alpha+beta+one
- fac2 = fac1+dnp1
- fac3 = fac2+one
- fnorm = pnormj(np1,alpha,beta)
- rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
- do i=1,np
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
- w(i) = -rcoef/(p*pdm1)
- enddo
-
- end subroutine zwgjd
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgljd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
-! ----------- weights associated with Jacobi polynomials of degree
-! n = np-1.
-!
-! Note : alpha and beta coefficients must be greater than -1.
-! Legendre polynomials are special case of Jacobi polynomials
-! just by setting alpha and beta to 0.
-!
-!=======================================================================
-
- implicit none
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision alpha,beta
- double precision z(np), w(np)
-
- integer n,nm1,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision alpg,betg
- double precision, external :: endw1,endw2
-
- p = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- nm1 = n-1
- pd = zero
-
- if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
-
-! with spectral elements, use at least 3 points
- if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
-
- if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
-
- if (nm1 > 0) then
- alpg = alpha+one
- betg = beta+one
- call zwgjd(z(2),w(2),nm1,alpg,betg)
- endif
-
- z(1) = - one
- z(np) = one
-
- do i=2,np-1
- w(i) = w(i)/(one-z(i)**2)
- enddo
-
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
- w(1) = endw1(n,alpha,beta)/(two*pd)
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
- w(np) = endw2(n,alpha,beta)/(two*pd)
-
- end subroutine zwgljd
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,529 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if (n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*dsqrt(pi)
+ if (x == half) gammaf = dsqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'minimum number of Gauss points is 1'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,645 +0,0 @@
-! smooth_sem_globe
-!
-! this program can be used for smoothing a (summed) event kernel,
-! where it smooths files with a given input kernel name:
-!
-! Usage:
-! ./smooth_sem_globe sigma_h(km) sigma_v(km) kernel_file_name scratch_file_dir scratch_topo_dir
-! e.g.
-! ./smooth_sem_globe 160 10 bulk_c_kernel OUTPUT_SUM/ topo/
-!
-! where:
-! sigma_h - gaussian width for horizontal smoothing (in km)
-! sigma_v - gaussian width for vertical smoothing (in km)
-! kernel_file_name - takes file with this kernel name,
-! e.g. "bulk_c_kernel"
-! scratch_file_dir - directory containing kernel files,
-! e.g. proc***_reg1_bulk_c_kernel.bin
-! topo_dir - directory containing mesh topo files:
-! proc***_solver_data1.bin, proc***_solver_data2.bin
-! outputs:
-! puts the resulting, smoothed kernel files into the same directory as scratch_file_dir/
-! with a file ending "proc***_kernel_smooth.bin"
-
-program smooth_sem_globe
-
-! this is the embarassingly-parallel program that smooths any specfem function (primarily the kernels)
-! that has the dimension of (NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT)
-!
-! notice that it uses the constants_globe.h and precision_globe.h files
-! from the original SPECFEM3D_GLOBE package, and the
-! values_from_mesher_globe.h file from the output of the mesher (or create_header_file),
-! therefore, you need to compile it for your specific case
-!
-! NOTE: smoothing can be different in radial & horizontal directions; mesh is in spherical geometry.
-! algorithm uses vector components in radial/horizontal direction
-
- implicit none
- include 'mpif.h'
- include '../../SHARE_FILES/constants.h'
- include '../../SHARE_FILES/precision.h'
- include '../../SHARE_FILES/values_from_mesher.h'
-
-! ======================================================
- ! USER PARAMETERS
-
- ! taken from values_from_mesher.h:
- ! average size of a spectral element in km = ...
- ! e.g. nproc 12x12, nex 192: element_size = 52.122262
-! real(kind=CUSTOM_REAL),parameter:: element_size = 52.12262
- real(kind=CUSTOM_REAL),parameter:: element_size = 41.69810
-
-! ======================================================
-
- !takes region 1 kernels
- integer, parameter :: NSPEC_MAX = NSPEC_CRUST_MANTLE_ADJOINT
- integer, parameter :: NGLOB_MAX = NGLOB_CRUST_MANTLE
-
- ! only include the neighboring 3 x 3 slices
- integer, parameter :: NSLICES = 3
- integer ,parameter :: NSLICES2 = NSLICES * NSLICES
-
- character(len=256) :: s_sigma_h, s_sigma_v
- character(len=256) :: kernel_file_name, scratch_topo_dir, scratch_file_dir
- integer :: sizeprocs,ier,myrank,ichunk, ixi, ieta, iglob
- integer :: islice(NSLICES2), islice0(NSLICES2), nums
-
- real(kind=CUSTOM_REAL) :: sigma_h, sigma_h2, sigma_h3, sigma_v, sigma_v2, sigma_v3
-
- real(kind=CUSTOM_REAL) :: x0, y0, z0, norm, norm_h, norm_v, element_size_m, max_old, max_new
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor, exp_val
-
- character(len=256) :: ks_file, reg_name
- character(len=256), dimension(NSLICES2) :: x_file, y_file, z_file, j_file, k_file, i_file
- character(len=256), dimension(NSLICES2) :: solver1_file,solver2_file
-
- logical :: global_code
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: kernel, kernel_smooth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: tk, bk, jacobian, xl, yl, zl, xx, yy, zz
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_MAX) :: x, y, z
- real(kind=CUSTOM_REAL), dimension(NSPEC_MAX) :: cx0, cy0, cz0, cx, cy, cz
-
- integer :: i,ii,j,jj,k,kk,ispec,iproc,ispec2,nspec(NSLICES2),nglob(NSLICES2)
-
- ! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll, wxgll
- double precision, dimension(NGLLY) :: yigll, wygll
- double precision, dimension(NGLLZ) :: zigll, wzgll
-
- ! array with all the weights in the cube
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- real(kind=CUSTOM_REAL) :: dist_h,dist_v
- real(kind=CUSTOM_REAL) :: r1,theta1
-
- ! ============ program starts here =====================
-
- ! initialize the MPI communicator and start the NPROCTOT MPI processes
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- if (myrank == 0) print*,"smooth:"
- call mpi_barrier(MPI_COMM_WORLD,ier)
-
- ! arguments
- call getarg(1,s_sigma_h)
- call getarg(2,s_sigma_v)
- call getarg(3,kernel_file_name)
- call getarg(4,scratch_file_dir)
- call getarg(5,scratch_topo_dir)
-
- if ( trim(s_sigma_h) == '' .or. trim(s_sigma_v) == '' &
- .or. trim(kernel_file_name) == '' &
- .or. trim(scratch_file_dir) == '' &
- .or. trim(scratch_topo_dir) == '') then
- call exit_MPI(myrank,'Usage: smooth_sem_globe sigma_h(km) sigma_v(km) kernel_file_name scratch_file_dir scratch_topo_dir')
- endif
-
- ! read in parameter information
- read(s_sigma_h,*) sigma_h
- read(s_sigma_v,*) sigma_v
-
- ! checks if basin code or global code: global code uses nchunks /= 0
- if (NCHUNKS_VAL == 0) then
- global_code = .false.
- call exit_mpi(myrank,'Error nchunks')
- else
- global_code = .true.
- reg_name='_reg1_'
- endif
- if (sizeprocs /= NPROC_XI_VAL*NPROC_ETA_VAL*NCHUNKS_VAL) call exit_mpi(myrank,'Error total number of slices')
-
- ! user output
- if (myrank == 0) then
- print*,"defaults:"
- print*," NPROC_XI , NPROC_ETA: ",NPROC_XI_VAL,NPROC_ETA_VAL
- print*," NCHUNKS : ",NCHUNKS_VAL
- print*," element size on surface(km): ",element_size
- print*," smoothing sigma_h , sigma_v: ",sigma_h,sigma_v
- endif
- ! synchronizes
- call mpi_barrier(MPI_COMM_WORLD,ier)
-
- ! initializes lengths
- element_size_m = element_size * 1000 ! e.g. 9 km on the surface, 36 km at CMB
- if (global_code) element_size_m = element_size_m/R_EARTH
-
- sigma_h = sigma_h * 1000.0 ! m
- if (global_code) sigma_h = sigma_h / R_EARTH ! scale
- sigma_v = sigma_v * 1000.0 ! m
- if (global_code) sigma_v = sigma_v / R_EARTH ! scale
-
- sigma_h2 = 2.0 * sigma_h ** 2 ! factor two for gaussian distribution with standard variance sigma
- sigma_v2 = 2.0 * sigma_v ** 2
-
- ! search radius
- sigma_h3 = 3.0 * sigma_h + element_size_m
- sigma_v3 = 3.0 * sigma_v + element_size_m
-
- ! theoretic normal value
- ! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) )
-
-! note: smoothing is using a gaussian (ellipsoid for sigma_h /= sigma_v),
-! but in spherical coordinates, we use horizontal distance as epicentral distance
-! and vertical distance as radial distance?
-
-! not squared since epicentral distance is taken? values from bk seem to be closer to squared ones...
- !norm_h = sqrt(2.0*PI) * sigma_h
- norm_h = 2.0*PI*sigma_h**2
- norm_v = sqrt(2.0*PI) * sigma_v
- norm = norm_h * norm_v
- !norm = (sqrt(2.0*PI) * sigma) ** 3 ! for sigma_h = sigma_v = sigma
-
-
- ! GLL points weights
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
- enddo
- enddo
- enddo
-
- ! ---- figure out the neighboring 8 or 7 slices: (ichunk,ixi,ieta) index start at 0------
- ichunk = myrank / (NPROC_XI_VAL * NPROC_ETA_VAL)
- ieta = (myrank - ichunk * NPROC_XI_VAL * NPROC_ETA_VAL) / NPROC_XI_VAL
- ixi = myrank - ichunk * NPROC_XI_VAL * NPROC_ETA_VAL - ieta * NPROC_XI_VAL
-
- ! get the neighboring slices:
- call get_all_eight_slices(ichunk,ixi,ieta,&
- islice0(1),islice0(2),islice0(3),islice0(4),islice0(5),islice0(6),islice0(7),islice0(8),&
- NPROC_XI_VAL,NPROC_ETA_VAL)
-
- ! remove the repeated slices (only 8 for corner slices in global case)
- islice(1) = myrank; j = 1
- do i = 1, 8
- if (.not. any(islice(1:i) == islice0(i)) .and. islice0(i) < sizeprocs) then
- j = j + 1
- islice(j) = islice0(i)
- endif
- enddo
- nums = j
-
- if( myrank == 0 ) then
- print *,'slices:',nums
- print *,' ',islice(:)
- print *
- endif
-
- ! read in the topology files of the current and neighboring slices
- do i = 1, nums
- write(k_file(i),'(a,i6.6,a)') &
- trim(scratch_file_dir)//'/proc',islice(i),trim(reg_name)//trim(kernel_file_name)//'.bin'
-
- write(solver1_file(i),'(a,i6.6,a)') &
- trim(scratch_topo_dir)//'/proc',islice(i),trim(reg_name)//'solver_data_1.bin'
- write(solver2_file(i),'(a,i6.6,a)') &
- trim(scratch_topo_dir)//'/proc',islice(i),trim(reg_name)//'solver_data_2.bin'
-
- nspec(i) = NSPEC_MAX
- nglob(i) = NGLOB_MAX
- enddo
-
- ! point locations
- open(11,file=solver2_file(1),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file')
-
- read(11) x(1:nglob(1))
- read(11) y(1:nglob(1))
- read(11) z(1:nglob(1))
- read(11) ibool(:,:,:,1:nspec(1))
- close(11)
-
- ! jacobian
- open(11,file=solver1_file(1),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening solver1 file')
-
- read(11) xix
- read(11) xiy
- read(11) xiz
- read(11) etax
- read(11) etay
- read(11) etaz
- read(11) gammax
- read(11) gammay
- read(11) gammaz
- close(11)
-
- ! get the location of the center of the elements
- do ispec = 1, nspec(1)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool(i,j,k,ispec)
- xl(i,j,k,ispec) = x(iglob)
- yl(i,j,k,ispec) = y(iglob)
- zl(i,j,k,ispec) = z(iglob)
-
- ! build jacobian
- ! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- ! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- jacobian(i,j,k,ispec) = jacobianl
-
-
-
- enddo
- enddo
- enddo
- cx0(ispec) = (xl(1,1,1,ispec) + xl(NGLLX,NGLLY,NGLLZ,ispec))/2.0
- cy0(ispec) = (yl(1,1,1,ispec) + yl(NGLLX,NGLLY,NGLLZ,ispec))/2.0
- cz0(ispec) = (zl(1,1,1,ispec) + zl(NGLLX,NGLLY,NGLLZ,ispec))/2.0
- enddo
-
- if (myrank == 0) write(*,*) 'start looping over elements and points for smoothing ...'
-
- ! smoothed kernel file name
- write(ks_file,'(a,i6.6,a)') trim(scratch_file_dir)//'/proc',myrank, &
- trim(reg_name)//trim(kernel_file_name)//'_smooth.bin'
-
-
- tk = 0.0
- bk = 0.0
- kernel_smooth=0.0
-
- ! loop over all the slices
- do iproc = 1, nums
-
- ! read in the topology, kernel files, calculate center of elements
- ! point locations
- ! given in cartesian coordinates
- open(11,file=solver2_file(iproc),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver2 file')
-
- read(11) x(1:nglob(iproc))
- read(11) y(1:nglob(iproc))
- read(11) z(1:nglob(iproc))
- read(11) ibool(:,:,:,1:nspec(iproc))
- close(11)
-
- open(11,file=solver1_file(iproc),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver1 file')
-
- read(11) xix
- read(11) xiy
- read(11) xiz
- read(11) etax
- read(11) etay
- read(11) etaz
- read(11) gammax
- read(11) gammay
- read(11) gammaz
- close(11)
-
- ! get the location of the center of the elements
- do ispec = 1, nspec(iproc)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- ! build jacobian
- ! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- ! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
- jacobian(i,j,k,ispec) = jacobianl
- enddo
- enddo
- enddo
- enddo
-
- ! kernel file
- open(11,file=k_file(iproc),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening kernel file')
-
- read(11) kernel(:,:,:,1:nspec(iproc))
- close(11)
-
-
- ! get the global maximum value of the original kernel file
- if (iproc == 1) then
- call mpi_reduce(maxval(abs(kernel(:,:,:,1:nspec(iproc)))), max_old, 1, &
- CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- endif
-
- ! calculate element center location
- do ispec2 = 1, nspec(iproc)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool(i,j,k,ispec2)
- xx(i,j,k,ispec2) = x(iglob)
- yy(i,j,k,ispec2) = y(iglob)
- zz(i,j,k,ispec2) = z(iglob)
- enddo
- enddo
- enddo
- cx(ispec2) = (xx(1,1,1,ispec2) + xx(NGLLX,NGLLZ,NGLLY,ispec2))/2.0
- cy(ispec2) = (yy(1,1,1,ispec2) + yy(NGLLX,NGLLZ,NGLLY,ispec2))/2.0
- cz(ispec2) = (zz(1,1,1,ispec2) + zz(NGLLX,NGLLZ,NGLLY,ispec2))/2.0
- enddo
-
- ! loop over elements to be smoothed in the current slice
- do ispec = 1, nspec(1)
-
- ! --- only double loop over the elements in the search radius ---
- do ispec2 = 1, nspec(iproc)
-
- ! calculates horizontal and vertical distance between two element centers
-
- ! vector approximation
- call get_distance_vec(dist_h,dist_v,cx0(ispec),cy0(ispec),cz0(ispec),&
- cx(ispec2),cy(ispec2),cz(ispec2))
-
- ! note: distances and sigmah, sigmav are normalized by R_EARTH
-
- ! checks distance between centers of elements
- if ( dist_h > sigma_h3 .or. abs(dist_v) > sigma_v3 ) cycle
-
- ! integration factors:
- ! uses volume assigned to GLL points
- factor(:,:,:) = jacobian(:,:,:,ispec2) * wgll_cube(:,:,:)
- ! no volume
- !factor(:,:,:) = 1.0_CUSTOM_REAL
-
- ! loop over GLL points of the elements in current slice (ispec)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! reference location
- ! current point (i,j,k,ispec) location, cartesian coordinates
- x0 = xl(i,j,k,ispec)
- y0 = yl(i,j,k,ispec)
- z0 = zl(i,j,k,ispec)
-
- ! calculate weights based on gaussian smoothing
- call smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
- xx(:,:,:,ispec2),yy(:,:,:,ispec2),zz(:,:,:,ispec2))
-
- ! adds GLL integration weights
- exp_val(:,:,:) = exp_val(:,:,:) * factor(:,:,:)
-
- ! adds contribution of element ispec2 to smoothed kernel values
- tk(i,j,k,ispec) = tk(i,j,k,ispec) + sum(exp_val(:,:,:) * kernel(:,:,:,ispec2))
-
- ! normalization, integrated values of gaussian smoothing function
- bk(i,j,k,ispec) = bk(i,j,k,ispec) + sum(exp_val(:,:,:))
-
- ! checks number
- !if( isNaN(tk(i,j,k,ispec)) ) then
- ! print*,'error tk NaN: ',tk(i,j,k,ispec)
- ! print*,'rank:',myrank
- ! print*,'i,j,k,ispec:',i,j,k,ispec
- ! print*,'tk: ',tk(i,j,k,ispec),'bk:',bk(i,j,k,ispec)
- ! print*,'sum exp_val: ',sum(exp_val(:,:,:)),'sum factor:',sum(factor(:,:,:))
- ! print*,'sum kernel:',sum(kernel(:,:,:,ispec2))
- ! call exit_MPI('error NaN')
- !endif
-
- enddo
- enddo
- enddo ! (i,j,k)
- enddo ! (ispec2)
- enddo ! (ispec)
- enddo ! islice
-
- if (myrank == 0) write(*,*) 'Done with integration ...'
-
- ! compute the smoothed kernel values
- do ispec = 1, nspec(1)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! checks the normalization criterion
- ! e.g. sigma_h 160km, sigma_v 40km:
- ! norm (not squared sigma_h ) ~ 0.001
- ! norm ( squared sigma_h) ~ 6.23 * e-5
- if (abs(bk(i,j,k,ispec) - norm) > 1.e-4 ) then
- print *, 'Problem norm here --- ', myrank, ispec, i, j, k, bk(i,j,k,ispec), norm
- !call exit_mpi(myrank, 'Error computing Gaussian function on the grid')
- endif
-
- ! normalizes smoothed kernel values by integral value of gaussian weighting
- kernel_smooth(i,j,k,ispec) = tk(i,j,k,ispec) / bk(i,j,k,ispec)
-
-
- ! checks number
- if( isNaN(kernel_smooth(i,j,k,ispec)) ) then
- print*,'error kernel_smooth NaN: ',kernel_smooth(i,j,k,ispec)
- print*,'rank:',myrank
- print*,'i,j,k,ispec:',i,j,k,ispec
- print*,'tk: ',tk(i,j,k,ispec),'bk:',bk(i,j,k,ispec)
- call exit_MPI('error NaN')
- endif
-
- enddo
- enddo
- enddo
- enddo
- if (myrank == 0) write(*,*) ' norm: ',norm
-
- ! file output
- open(11,file=trim(ks_file),status='unknown',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening smoothed kernel file')
-
- ! Note: output the following instead of kernel_smooth(:,:,:,1:nspec(1)) to create files of the same sizes
- write(11) kernel_smooth(:,:,:,:)
- close(11)
-
- if (myrank == 0) print *,' written:',trim(ks_file)
-
-
-
- ! the maximum value for the smoothed kernel
- call mpi_reduce(maxval(abs(kernel_smooth(:,:,:,1:nspec(1)))), max_new, 1, &
- CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
-
- if (myrank == 0) then
- print *
- print *, 'Maximum data value before smoothing = ', max_old
- print *, 'Maximum data value after smoothing = ', max_new
- print *
- endif
-
-! stop all the MPI processes, and exit
- call MPI_FINALIZE(ier)
-
-end program smooth_sem_globe
-
-!
-! -----------------------------------------------------------------------------
-!
- subroutine smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
- xx_elem,yy_elem,zz_elem)
-
- implicit none
- include "../constants.h"
-
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(out) :: exp_val
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(in) :: xx_elem, yy_elem, zz_elem
- real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,sigma_h2,sigma_v2
- integer,intent(in) :: ispec2
-
- ! local parameters
- integer :: ii,jj,kk
- real(kind=CUSTOM_REAL) :: dist_h,dist_v
- !real(kind=CUSTOM_REAL) :: r0,r1,theta1
-
- ! >>>>>
- ! uniform sigma
- !exp_val(:,:,:) = exp( -((xx(:,:,:,ispec2)-x0)**2+(yy(:,:,:,ispec2)-y0)**2 &
- ! +(zz(:,:,:,ispec2)-z0)**2 )/(2*sigma2) )*factor(:,:,:)
-
- ! from basin code smoothing:
- ! gaussian function
- !exp_val(:,:,:) = exp( -(xx(:,:,:,ispec2)-x0)**2/(sigma_h2) &
- ! -(yy(:,:,:,ispec2)-y0)**2/(sigma_h2) &
- ! -(zz(:,:,:,ispec2)-z0)**2/(sigma_v2) ) * factor(:,:,:)
- ! >>>>>
-
- do kk = 1, NGLLZ
- do jj = 1, NGLLY
- do ii = 1, NGLLX
- ! point in second slice
-
- ! vector approximation:
- call get_distance_vec(dist_h,dist_v,x0,y0,z0, &
- xx_elem(ii,jj,kk),yy_elem(ii,jj,kk),zz_elem(ii,jj,kk))
-
- ! gaussian function
- exp_val(ii,jj,kk) = exp( - (dist_h*dist_h)/sigma_h2 &
- - (dist_v*dist_v)/sigma_v2 ) ! * factor(ii,jj,kk)
-
-
- ! checks number
- !if( isNaN(exp_val(ii,jj,kk)) ) then
- ! print*,'error exp_val NaN: ',exp_val(ii,jj,kk)
- ! print*,'i,j,k:',ii,jj,kk
- ! print*,'dist_h: ',dist_h,'dist_v:',dist_v
- ! print*,'sigma_h2:',sigma_h2,'sigma_v2:',sigma_v2
- ! call exit_MPI('error NaN')
- !endif
-
- enddo
- enddo
- enddo
-
- end subroutine smoothing_weights_vec
-
-
-!
-! -----------------------------------------------------------------------------
-!
-
- subroutine get_distance_vec(dist_h,dist_v,x0,y0,z0,x1,y1,z1)
-
-! returns vector lengths as distances in radial and horizontal direction
-
- implicit none
- include "../constants.h"
-
- real(kind=CUSTOM_REAL),intent(out) :: dist_h,dist_v
- real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,x1,y1,z1
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: r0,r1
- real(kind=CUSTOM_REAL) :: theta,ratio
- !real(kind=CUSTOM_REAL) :: vx,vy,vz,alpha
-
- ! vertical distance
- r0 = sqrt( x0*x0 + y0*y0 + z0*z0 ) ! length of first position vector
- r1 = sqrt( x1*x1 + y1*y1 + z1*z1 )
- dist_v = r1 - r0
- ! only for flat earth with z in depth: dist_v = sqrt( (cz(ispec2)-cz0(ispec))** 2)
-
- ! epicentral distance
- ! (accounting for spherical curvature)
- ! calculates distance of circular segment
- ! angle between r0 and r1 in radian
- ! given by dot-product of two vectors
- ratio = (x0*x1 + y0*y1 + z0*z1)/(r0 * r1)
-
- ! checks boundaries of ratio (due to numerical inaccuracies)
- if( ratio > 1.0_CUSTOM_REAL ) ratio = 1.0_CUSTOM_REAL
- if( ratio < -1.0_CUSTOM_REAL ) ratio = -1.0_CUSTOM_REAL
-
- theta = acos( ratio )
-
- ! segment length at heigth of r1
- dist_h = r1 * theta
-
- ! vector approximation (fast computation): neglects curvature
- ! horizontal distance
- ! length of vector from point 0 to point 1
- ! assuming small earth curvature (since only for neighboring elements)
-
- ! scales r0 to have same length as r1
- !alpha = r1 / r0
- !vx = alpha * x0
- !vy = alpha * y0
- !vz = alpha * z0
-
- ! vector in horizontal between new r0 and r1
- !vx = x1 - vx
- !vy = y1 - vy
- !vz = z1 - vz
-
- ! distance is vector length
- !dist_h = sqrt( vx*vx + vy*vy + vz*vz )
-
- end subroutine get_distance_vec
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,645 @@
+! smooth_sem_globe
+!
+! this program can be used for smoothing a (summed) event kernel,
+! where it smooths files with a given input kernel name:
+!
+! Usage:
+! ./smooth_sem_globe sigma_h(km) sigma_v(km) kernel_file_name scratch_file_dir scratch_topo_dir
+! e.g.
+! ./smooth_sem_globe 160 10 bulk_c_kernel OUTPUT_SUM/ topo/
+!
+! where:
+! sigma_h - gaussian width for horizontal smoothing (in km)
+! sigma_v - gaussian width for vertical smoothing (in km)
+! kernel_file_name - takes file with this kernel name,
+! e.g. "bulk_c_kernel"
+! scratch_file_dir - directory containing kernel files,
+! e.g. proc***_reg1_bulk_c_kernel.bin
+! topo_dir - directory containing mesh topo files:
+! proc***_solver_data1.bin, proc***_solver_data2.bin
+! outputs:
+! puts the resulting, smoothed kernel files into the same directory as scratch_file_dir/
+! with a file ending "proc***_kernel_smooth.bin"
+
+program smooth_sem_globe
+
+! this is the embarassingly-parallel program that smooths any specfem function (primarily the kernels)
+! that has the dimension of (NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT)
+!
+! notice that it uses the constants_globe.h and precision_globe.h files
+! from the original SPECFEM3D_GLOBE package, and the
+! values_from_mesher_globe.h file from the output of the mesher (or create_header_file),
+! therefore, you need to compile it for your specific case
+!
+! NOTE: smoothing can be different in radial & horizontal directions; mesh is in spherical geometry.
+! algorithm uses vector components in radial/horizontal direction
+
+ implicit none
+ include 'mpif.h'
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/precision.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+
+! ======================================================
+ ! USER PARAMETERS
+
+ ! taken from values_from_mesher.h:
+ ! average size of a spectral element in km = ...
+ ! e.g. nproc 12x12, nex 192: element_size = 52.122262
+! real(kind=CUSTOM_REAL),parameter:: element_size = 52.12262
+ real(kind=CUSTOM_REAL),parameter:: element_size = 41.69810
+
+! ======================================================
+
+ !takes region 1 kernels
+ integer, parameter :: NSPEC_MAX = NSPEC_CRUST_MANTLE_ADJOINT
+ integer, parameter :: NGLOB_MAX = NGLOB_CRUST_MANTLE
+
+ ! only include the neighboring 3 x 3 slices
+ integer, parameter :: NSLICES = 3
+ integer ,parameter :: NSLICES2 = NSLICES * NSLICES
+
+ character(len=256) :: s_sigma_h, s_sigma_v
+ character(len=256) :: kernel_file_name, scratch_topo_dir, scratch_file_dir
+ integer :: sizeprocs,ier,myrank,ichunk, ixi, ieta, iglob
+ integer :: islice(NSLICES2), islice0(NSLICES2), nums
+
+ real(kind=CUSTOM_REAL) :: sigma_h, sigma_h2, sigma_h3, sigma_v, sigma_v2, sigma_v3
+
+ real(kind=CUSTOM_REAL) :: x0, y0, z0, norm, norm_h, norm_v, element_size_m, max_old, max_new
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor, exp_val
+
+ character(len=256) :: ks_file, reg_name
+ character(len=256), dimension(NSLICES2) :: x_file, y_file, z_file, j_file, k_file, i_file
+ character(len=256), dimension(NSLICES2) :: solver1_file,solver2_file
+
+ logical :: global_code
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: kernel, kernel_smooth
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: tk, bk, jacobian, xl, yl, zl, xx, yy, zz
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_MAX) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_MAX) :: x, y, z
+ real(kind=CUSTOM_REAL), dimension(NSPEC_MAX) :: cx0, cy0, cz0, cx, cy, cz
+
+ integer :: i,ii,j,jj,k,kk,ispec,iproc,ispec2,nspec(NSLICES2),nglob(NSLICES2)
+
+ ! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll, wxgll
+ double precision, dimension(NGLLY) :: yigll, wygll
+ double precision, dimension(NGLLZ) :: zigll, wzgll
+
+ ! array with all the weights in the cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+ real(kind=CUSTOM_REAL) :: dist_h,dist_v
+ real(kind=CUSTOM_REAL) :: r1,theta1
+
+ ! ============ program starts here =====================
+
+ ! initialize the MPI communicator and start the NPROCTOT MPI processes
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ if (myrank == 0) print*,"smooth:"
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+
+ ! arguments
+ call getarg(1,s_sigma_h)
+ call getarg(2,s_sigma_v)
+ call getarg(3,kernel_file_name)
+ call getarg(4,scratch_file_dir)
+ call getarg(5,scratch_topo_dir)
+
+ if ( trim(s_sigma_h) == '' .or. trim(s_sigma_v) == '' &
+ .or. trim(kernel_file_name) == '' &
+ .or. trim(scratch_file_dir) == '' &
+ .or. trim(scratch_topo_dir) == '') then
+ call exit_MPI(myrank,'Usage: smooth_sem_globe sigma_h(km) sigma_v(km) kernel_file_name scratch_file_dir scratch_topo_dir')
+ endif
+
+ ! read in parameter information
+ read(s_sigma_h,*) sigma_h
+ read(s_sigma_v,*) sigma_v
+
+ ! checks if basin code or global code: global code uses nchunks /= 0
+ if (NCHUNKS_VAL == 0) then
+ global_code = .false.
+ call exit_mpi(myrank,'Error nchunks')
+ else
+ global_code = .true.
+ reg_name='_reg1_'
+ endif
+ if (sizeprocs /= NPROC_XI_VAL*NPROC_ETA_VAL*NCHUNKS_VAL) call exit_mpi(myrank,'Error total number of slices')
+
+ ! user output
+ if (myrank == 0) then
+ print*,"defaults:"
+ print*," NPROC_XI , NPROC_ETA: ",NPROC_XI_VAL,NPROC_ETA_VAL
+ print*," NCHUNKS : ",NCHUNKS_VAL
+ print*," element size on surface(km): ",element_size
+ print*," smoothing sigma_h , sigma_v: ",sigma_h,sigma_v
+ endif
+ ! synchronizes
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+
+ ! initializes lengths
+ element_size_m = element_size * 1000 ! e.g. 9 km on the surface, 36 km at CMB
+ if (global_code) element_size_m = element_size_m/R_EARTH
+
+ sigma_h = sigma_h * 1000.0 ! m
+ if (global_code) sigma_h = sigma_h / R_EARTH ! scale
+ sigma_v = sigma_v * 1000.0 ! m
+ if (global_code) sigma_v = sigma_v / R_EARTH ! scale
+
+ sigma_h2 = 2.0 * sigma_h ** 2 ! factor two for gaussian distribution with standard variance sigma
+ sigma_v2 = 2.0 * sigma_v ** 2
+
+ ! search radius
+ sigma_h3 = 3.0 * sigma_h + element_size_m
+ sigma_v3 = 3.0 * sigma_v + element_size_m
+
+ ! theoretic normal value
+ ! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) )
+
+! note: smoothing is using a gaussian (ellipsoid for sigma_h /= sigma_v),
+! but in spherical coordinates, we use horizontal distance as epicentral distance
+! and vertical distance as radial distance?
+
+! not squared since epicentral distance is taken? values from bk seem to be closer to squared ones...
+ !norm_h = sqrt(2.0*PI) * sigma_h
+ norm_h = 2.0*PI*sigma_h**2
+ norm_v = sqrt(2.0*PI) * sigma_v
+ norm = norm_h * norm_v
+ !norm = (sqrt(2.0*PI) * sigma) ** 3 ! for sigma_h = sigma_v = sigma
+
+
+ ! GLL points weights
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ ! ---- figure out the neighboring 8 or 7 slices: (ichunk,ixi,ieta) index start at 0------
+ ichunk = myrank / (NPROC_XI_VAL * NPROC_ETA_VAL)
+ ieta = (myrank - ichunk * NPROC_XI_VAL * NPROC_ETA_VAL) / NPROC_XI_VAL
+ ixi = myrank - ichunk * NPROC_XI_VAL * NPROC_ETA_VAL - ieta * NPROC_XI_VAL
+
+ ! get the neighboring slices:
+ call get_all_eight_slices(ichunk,ixi,ieta,&
+ islice0(1),islice0(2),islice0(3),islice0(4),islice0(5),islice0(6),islice0(7),islice0(8),&
+ NPROC_XI_VAL,NPROC_ETA_VAL)
+
+ ! remove the repeated slices (only 8 for corner slices in global case)
+ islice(1) = myrank; j = 1
+ do i = 1, 8
+ if (.not. any(islice(1:i) == islice0(i)) .and. islice0(i) < sizeprocs) then
+ j = j + 1
+ islice(j) = islice0(i)
+ endif
+ enddo
+ nums = j
+
+ if( myrank == 0 ) then
+ print *,'slices:',nums
+ print *,' ',islice(:)
+ print *
+ endif
+
+ ! read in the topology files of the current and neighboring slices
+ do i = 1, nums
+ write(k_file(i),'(a,i6.6,a)') &
+ trim(scratch_file_dir)//'/proc',islice(i),trim(reg_name)//trim(kernel_file_name)//'.bin'
+
+ write(solver1_file(i),'(a,i6.6,a)') &
+ trim(scratch_topo_dir)//'/proc',islice(i),trim(reg_name)//'solver_data_1.bin'
+ write(solver2_file(i),'(a,i6.6,a)') &
+ trim(scratch_topo_dir)//'/proc',islice(i),trim(reg_name)//'solver_data_2.bin'
+
+ nspec(i) = NSPEC_MAX
+ nglob(i) = NGLOB_MAX
+ enddo
+
+ ! point locations
+ open(11,file=solver2_file(1),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file')
+
+ read(11) x(1:nglob(1))
+ read(11) y(1:nglob(1))
+ read(11) z(1:nglob(1))
+ read(11) ibool(:,:,:,1:nspec(1))
+ close(11)
+
+ ! jacobian
+ open(11,file=solver1_file(1),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening solver1 file')
+
+ read(11) xix
+ read(11) xiy
+ read(11) xiz
+ read(11) etax
+ read(11) etay
+ read(11) etaz
+ read(11) gammax
+ read(11) gammay
+ read(11) gammaz
+ close(11)
+
+ ! get the location of the center of the elements
+ do ispec = 1, nspec(1)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ xl(i,j,k,ispec) = x(iglob)
+ yl(i,j,k,ispec) = y(iglob)
+ zl(i,j,k,ispec) = z(iglob)
+
+ ! build jacobian
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ ! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ jacobian(i,j,k,ispec) = jacobianl
+
+
+
+ enddo
+ enddo
+ enddo
+ cx0(ispec) = (xl(1,1,1,ispec) + xl(NGLLX,NGLLY,NGLLZ,ispec))/2.0
+ cy0(ispec) = (yl(1,1,1,ispec) + yl(NGLLX,NGLLY,NGLLZ,ispec))/2.0
+ cz0(ispec) = (zl(1,1,1,ispec) + zl(NGLLX,NGLLY,NGLLZ,ispec))/2.0
+ enddo
+
+ if (myrank == 0) write(*,*) 'start looping over elements and points for smoothing ...'
+
+ ! smoothed kernel file name
+ write(ks_file,'(a,i6.6,a)') trim(scratch_file_dir)//'/proc',myrank, &
+ trim(reg_name)//trim(kernel_file_name)//'_smooth.bin'
+
+
+ tk = 0.0
+ bk = 0.0
+ kernel_smooth=0.0
+
+ ! loop over all the slices
+ do iproc = 1, nums
+
+ ! read in the topology, kernel files, calculate center of elements
+ ! point locations
+ ! given in cartesian coordinates
+ open(11,file=solver2_file(iproc),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver2 file')
+
+ read(11) x(1:nglob(iproc))
+ read(11) y(1:nglob(iproc))
+ read(11) z(1:nglob(iproc))
+ read(11) ibool(:,:,:,1:nspec(iproc))
+ close(11)
+
+ open(11,file=solver1_file(iproc),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver1 file')
+
+ read(11) xix
+ read(11) xiy
+ read(11) xiz
+ read(11) etax
+ read(11) etay
+ read(11) etaz
+ read(11) gammax
+ read(11) gammay
+ read(11) gammaz
+ close(11)
+
+ ! get the location of the center of the elements
+ do ispec = 1, nspec(iproc)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! build jacobian
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ ! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+ jacobian(i,j,k,ispec) = jacobianl
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! kernel file
+ open(11,file=k_file(iproc),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening kernel file')
+
+ read(11) kernel(:,:,:,1:nspec(iproc))
+ close(11)
+
+
+ ! get the global maximum value of the original kernel file
+ if (iproc == 1) then
+ call mpi_reduce(maxval(abs(kernel(:,:,:,1:nspec(iproc)))), max_old, 1, &
+ CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ endif
+
+ ! calculate element center location
+ do ispec2 = 1, nspec(iproc)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec2)
+ xx(i,j,k,ispec2) = x(iglob)
+ yy(i,j,k,ispec2) = y(iglob)
+ zz(i,j,k,ispec2) = z(iglob)
+ enddo
+ enddo
+ enddo
+ cx(ispec2) = (xx(1,1,1,ispec2) + xx(NGLLX,NGLLZ,NGLLY,ispec2))/2.0
+ cy(ispec2) = (yy(1,1,1,ispec2) + yy(NGLLX,NGLLZ,NGLLY,ispec2))/2.0
+ cz(ispec2) = (zz(1,1,1,ispec2) + zz(NGLLX,NGLLZ,NGLLY,ispec2))/2.0
+ enddo
+
+ ! loop over elements to be smoothed in the current slice
+ do ispec = 1, nspec(1)
+
+ ! --- only double loop over the elements in the search radius ---
+ do ispec2 = 1, nspec(iproc)
+
+ ! calculates horizontal and vertical distance between two element centers
+
+ ! vector approximation
+ call get_distance_vec(dist_h,dist_v,cx0(ispec),cy0(ispec),cz0(ispec),&
+ cx(ispec2),cy(ispec2),cz(ispec2))
+
+ ! note: distances and sigmah, sigmav are normalized by R_EARTH
+
+ ! checks distance between centers of elements
+ if ( dist_h > sigma_h3 .or. abs(dist_v) > sigma_v3 ) cycle
+
+ ! integration factors:
+ ! uses volume assigned to GLL points
+ factor(:,:,:) = jacobian(:,:,:,ispec2) * wgll_cube(:,:,:)
+ ! no volume
+ !factor(:,:,:) = 1.0_CUSTOM_REAL
+
+ ! loop over GLL points of the elements in current slice (ispec)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! reference location
+ ! current point (i,j,k,ispec) location, cartesian coordinates
+ x0 = xl(i,j,k,ispec)
+ y0 = yl(i,j,k,ispec)
+ z0 = zl(i,j,k,ispec)
+
+ ! calculate weights based on gaussian smoothing
+ call smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
+ xx(:,:,:,ispec2),yy(:,:,:,ispec2),zz(:,:,:,ispec2))
+
+ ! adds GLL integration weights
+ exp_val(:,:,:) = exp_val(:,:,:) * factor(:,:,:)
+
+ ! adds contribution of element ispec2 to smoothed kernel values
+ tk(i,j,k,ispec) = tk(i,j,k,ispec) + sum(exp_val(:,:,:) * kernel(:,:,:,ispec2))
+
+ ! normalization, integrated values of gaussian smoothing function
+ bk(i,j,k,ispec) = bk(i,j,k,ispec) + sum(exp_val(:,:,:))
+
+ ! checks number
+ !if( isNaN(tk(i,j,k,ispec)) ) then
+ ! print*,'error tk NaN: ',tk(i,j,k,ispec)
+ ! print*,'rank:',myrank
+ ! print*,'i,j,k,ispec:',i,j,k,ispec
+ ! print*,'tk: ',tk(i,j,k,ispec),'bk:',bk(i,j,k,ispec)
+ ! print*,'sum exp_val: ',sum(exp_val(:,:,:)),'sum factor:',sum(factor(:,:,:))
+ ! print*,'sum kernel:',sum(kernel(:,:,:,ispec2))
+ ! call exit_MPI('error NaN')
+ !endif
+
+ enddo
+ enddo
+ enddo ! (i,j,k)
+ enddo ! (ispec2)
+ enddo ! (ispec)
+ enddo ! islice
+
+ if (myrank == 0) write(*,*) 'Done with integration ...'
+
+ ! compute the smoothed kernel values
+ do ispec = 1, nspec(1)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! checks the normalization criterion
+ ! e.g. sigma_h 160km, sigma_v 40km:
+ ! norm (not squared sigma_h ) ~ 0.001
+ ! norm ( squared sigma_h) ~ 6.23 * e-5
+ if (abs(bk(i,j,k,ispec) - norm) > 1.e-4 ) then
+ print *, 'Problem norm here --- ', myrank, ispec, i, j, k, bk(i,j,k,ispec), norm
+ !call exit_mpi(myrank, 'Error computing Gaussian function on the grid')
+ endif
+
+ ! normalizes smoothed kernel values by integral value of gaussian weighting
+ kernel_smooth(i,j,k,ispec) = tk(i,j,k,ispec) / bk(i,j,k,ispec)
+
+
+ ! checks number
+ if( isNaN(kernel_smooth(i,j,k,ispec)) ) then
+ print*,'error kernel_smooth NaN: ',kernel_smooth(i,j,k,ispec)
+ print*,'rank:',myrank
+ print*,'i,j,k,ispec:',i,j,k,ispec
+ print*,'tk: ',tk(i,j,k,ispec),'bk:',bk(i,j,k,ispec)
+ call exit_MPI('error NaN')
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+ if (myrank == 0) write(*,*) ' norm: ',norm
+
+ ! file output
+ open(11,file=trim(ks_file),status='unknown',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening smoothed kernel file')
+
+ ! Note: output the following instead of kernel_smooth(:,:,:,1:nspec(1)) to create files of the same sizes
+ write(11) kernel_smooth(:,:,:,:)
+ close(11)
+
+ if (myrank == 0) print *,' written:',trim(ks_file)
+
+
+
+ ! the maximum value for the smoothed kernel
+ call mpi_reduce(maxval(abs(kernel_smooth(:,:,:,1:nspec(1)))), max_new, 1, &
+ CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+
+ if (myrank == 0) then
+ print *
+ print *, 'Maximum data value before smoothing = ', max_old
+ print *, 'Maximum data value after smoothing = ', max_new
+ print *
+ endif
+
+! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+end program smooth_sem_globe
+
+!
+! -----------------------------------------------------------------------------
+!
+ subroutine smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
+ xx_elem,yy_elem,zz_elem)
+
+ implicit none
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(out) :: exp_val
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(in) :: xx_elem, yy_elem, zz_elem
+ real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,sigma_h2,sigma_v2
+ integer,intent(in) :: ispec2
+
+ ! local parameters
+ integer :: ii,jj,kk
+ real(kind=CUSTOM_REAL) :: dist_h,dist_v
+ !real(kind=CUSTOM_REAL) :: r0,r1,theta1
+
+ ! >>>>>
+ ! uniform sigma
+ !exp_val(:,:,:) = exp( -((xx(:,:,:,ispec2)-x0)**2+(yy(:,:,:,ispec2)-y0)**2 &
+ ! +(zz(:,:,:,ispec2)-z0)**2 )/(2*sigma2) )*factor(:,:,:)
+
+ ! from basin code smoothing:
+ ! gaussian function
+ !exp_val(:,:,:) = exp( -(xx(:,:,:,ispec2)-x0)**2/(sigma_h2) &
+ ! -(yy(:,:,:,ispec2)-y0)**2/(sigma_h2) &
+ ! -(zz(:,:,:,ispec2)-z0)**2/(sigma_v2) ) * factor(:,:,:)
+ ! >>>>>
+
+ do kk = 1, NGLLZ
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ ! point in second slice
+
+ ! vector approximation:
+ call get_distance_vec(dist_h,dist_v,x0,y0,z0, &
+ xx_elem(ii,jj,kk),yy_elem(ii,jj,kk),zz_elem(ii,jj,kk))
+
+ ! gaussian function
+ exp_val(ii,jj,kk) = exp( - (dist_h*dist_h)/sigma_h2 &
+ - (dist_v*dist_v)/sigma_v2 ) ! * factor(ii,jj,kk)
+
+
+ ! checks number
+ !if( isNaN(exp_val(ii,jj,kk)) ) then
+ ! print*,'error exp_val NaN: ',exp_val(ii,jj,kk)
+ ! print*,'i,j,k:',ii,jj,kk
+ ! print*,'dist_h: ',dist_h,'dist_v:',dist_v
+ ! print*,'sigma_h2:',sigma_h2,'sigma_v2:',sigma_v2
+ ! call exit_MPI('error NaN')
+ !endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine smoothing_weights_vec
+
+
+!
+! -----------------------------------------------------------------------------
+!
+
+ subroutine get_distance_vec(dist_h,dist_v,x0,y0,z0,x1,y1,z1)
+
+! returns vector lengths as distances in radial and horizontal direction
+
+ implicit none
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ real(kind=CUSTOM_REAL),intent(out) :: dist_h,dist_v
+ real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,x1,y1,z1
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: r0,r1
+ real(kind=CUSTOM_REAL) :: theta,ratio
+ !real(kind=CUSTOM_REAL) :: vx,vy,vz,alpha
+
+ ! vertical distance
+ r0 = sqrt( x0*x0 + y0*y0 + z0*z0 ) ! length of first position vector
+ r1 = sqrt( x1*x1 + y1*y1 + z1*z1 )
+ dist_v = r1 - r0
+ ! only for flat earth with z in depth: dist_v = sqrt( (cz(ispec2)-cz0(ispec))** 2)
+
+ ! epicentral distance
+ ! (accounting for spherical curvature)
+ ! calculates distance of circular segment
+ ! angle between r0 and r1 in radian
+ ! given by dot-product of two vectors
+ ratio = (x0*x1 + y0*y1 + z0*z1)/(r0 * r1)
+
+ ! checks boundaries of ratio (due to numerical inaccuracies)
+ if( ratio > 1.0_CUSTOM_REAL ) ratio = 1.0_CUSTOM_REAL
+ if( ratio < -1.0_CUSTOM_REAL ) ratio = -1.0_CUSTOM_REAL
+
+ theta = acos( ratio )
+
+ ! segment length at heigth of r1
+ dist_h = r1 * theta
+
+ ! vector approximation (fast computation): neglects curvature
+ ! horizontal distance
+ ! length of vector from point 0 to point 1
+ ! assuming small earth curvature (since only for neighboring elements)
+
+ ! scales r0 to have same length as r1
+ !alpha = r1 / r0
+ !vx = alpha * x0
+ !vy = alpha * y0
+ !vz = alpha * z0
+
+ ! vector in horizontal between new r0 and r1
+ !vx = x1 - vx
+ !vy = y1 - vy
+ !vz = z1 - vz
+
+ ! distance is vector length
+ !dist_h = sqrt( vx*vx + vy*vy + vz*vz )
+
+ end subroutine get_distance_vec
+
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,221 +0,0 @@
-
-! --------------------------------------------------------------------------------
-
-subroutine get_all_eight_slices(ichunk,ixi,ieta,&
- ileft,iright,ibot,itop, ilb,ilt,irb,irt,&
- nproc_xi,nproc_eta)
-
- implicit none
-
- integer, intent(IN) :: ichunk,ixi,ieta,nproc_xi,nproc_eta
-
- integer, intent(OUT) :: ileft,iright,ibot,itop,ilb,ilt,irb,irt
- integer :: get_slice_number
-
-
- integer :: ichunk_left, islice_xi_left, islice_eta_left, &
- ichunk_right, islice_xi_right, islice_eta_right, &
- ichunk_bot, islice_xi_bot, islice_eta_bot, &
- ichunk_top, islice_xi_top, islice_eta_top, &
- ileft0,iright0,ibot0,itop0, &
- ichunk_left0, islice_xi_left0, islice_eta_left0, &
- ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- ichunk_top0, islice_xi_top0, islice_eta_top0
-
-
-! get the first 4 immediate slices
- call get_lrbt_slices(ichunk,ixi,ieta, &
- ileft, ichunk_left, islice_xi_left, islice_eta_left, &
- iright, ichunk_right, islice_xi_right, islice_eta_right, &
- ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
- itop, ichunk_top, islice_xi_top, islice_eta_top, &
- nproc_xi,nproc_eta)
-
-! get the 4 diagonal neighboring slices (actually 3 diagonal slices at the corners)
- ilb = get_slice_number(ichunk,ixi-1,ieta-1,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk,ixi-1,ieta+1,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk,ixi+1,ieta-1,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk,ixi+1,ieta+1,nproc_xi,nproc_eta)
-
- if (ixi==0) then
- call get_lrbt_slices(ichunk_left,islice_xi_left,islice_eta_left, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
-
- if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
- ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- else if (ichunk == 2) then
- ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else
- ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- endif
- endif
-
- if (ixi==nproc_xi-1) then
- call get_lrbt_slices(ichunk_right,islice_xi_right,islice_eta_right, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
- if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
- irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- else if (ichunk == 2) then
- irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- else
- irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- endif
- endif
-
- if (ieta==0) then
- call get_lrbt_slices(ichunk_bot,islice_xi_bot,islice_eta_bot, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
- if (ichunk == 1 .or. ichunk == 2) then
- ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- else if (ichunk == 3 .or. ichunk == 4) then
- ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else if (ichunk == 0) then
- ilb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- else
- ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- endif
- endif
-
- if (ieta==nproc_eta-1) then
- call get_lrbt_slices(ichunk_top,islice_xi_top,islice_eta_top, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
-
- if (ichunk == 1 .or. ichunk == 4) then
- ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- else if (ichunk == 2 .or. ichunk == 3) then
- ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else if (ichunk == 0) then
- ilt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- else
- ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- endif
-
- endif
-
-end subroutine get_all_eight_slices
-
-!--------------------------------------------------------------------------------------------
-
-subroutine get_lrbt_slices(ichunk,ixi,ieta, &
- ileft, ichunk_left, islice_xi_left, islice_eta_left, &
- iright, ichunk_right, islice_xi_right, islice_eta_right, &
- ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
- itop, ichunk_top, islice_xi_top, islice_eta_top, &
- nproc_xi,nproc_eta)
-
- implicit none
-
- integer, intent(IN) :: ichunk, ixi, ieta, nproc_xi, nproc_eta
- integer, intent(OUT) :: ileft, ichunk_left, islice_xi_left, islice_eta_left, &
- iright, ichunk_right, islice_xi_right, islice_eta_right, &
- ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
- itop, ichunk_top, islice_xi_top, islice_eta_top
-
- integer, parameter :: NCHUNKS = 6
-
- integer, dimension(NCHUNKS) :: chunk_left,chunk_right,chunk_bot,chunk_top, &
- slice_xi_left,slice_eta_left,slice_xi_right,slice_eta_right, &
- slice_xi_bot,slice_eta_bot,slice_xi_top,slice_eta_top
- integer :: get_slice_number
-
-! set up mapping arrays -- assume chunk/slice number starts from 0
- chunk_left(:) = (/2,6,6,1,6,4/) - 1
- chunk_right(:) = (/4,1,1,6,1,2/) - 1
- chunk_bot(:) = (/5,5,2,5,4,5/) - 1
- chunk_top(:) = (/3,3,4,3,2,3/) - 1
-
- slice_xi_left(:) = (/nproc_xi-1,nproc_xi-1,nproc_xi-1-ieta,nproc_xi-1,ieta,nproc_xi-1/)
- slice_eta_left(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
- slice_xi_right(:) = (/0,0,ieta,0,nproc_xi-1-ieta,0/)
- slice_eta_right(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
-
- slice_xi_bot(:) = (/nproc_xi-1,ixi,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,0/)
- slice_eta_bot(:) = (/nproc_eta-1-ixi,nproc_eta-1,nproc_eta-1,0,0,ixi/)
- slice_xi_top(:) = (/nproc_xi-1,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,ixi,0/)
- slice_eta_top(:) = (/ixi,0,nproc_eta-1,nproc_eta-1,0,nproc_eta-1-ixi /)
-
- ichunk_left = ichunk
- ichunk_right = ichunk
- ichunk_bot = ichunk
- ichunk_top = ichunk
-
- islice_xi_left = ixi-1
- islice_eta_left = ieta
- islice_xi_right = ixi+1
- islice_eta_right = ieta
-
- islice_xi_bot = ixi
- islice_eta_bot = ieta-1
- islice_xi_top = ixi
- islice_eta_top = ieta+1
-
- if (ixi == 0) then
- ichunk_left=chunk_left(ichunk+1)
- islice_xi_left=slice_xi_left(ichunk+1)
- islice_eta_left=slice_eta_left(ichunk+1)
- endif
- if (ixi == nproc_xi - 1) then
- ichunk_right=chunk_right(ichunk+1)
- islice_xi_right=slice_xi_right(ichunk+1)
- islice_eta_right=slice_eta_right(ichunk+1)
- endif
- if (ieta == 0) then
- ichunk_bot=chunk_bot(ichunk+1)
- islice_xi_bot=slice_xi_bot(ichunk+1)
- islice_eta_bot=slice_eta_bot(ichunk+1)
- endif
- if (ieta == nproc_eta - 1) then
- ichunk_top=chunk_top(ichunk+1)
- islice_xi_top=slice_xi_top(ichunk+1)
- islice_eta_top=slice_eta_top(ichunk+1)
- endif
-
- ileft = get_slice_number(ichunk_left,islice_xi_left,islice_eta_left,nproc_xi,nproc_eta)
- iright = get_slice_number(ichunk_right,islice_xi_right,islice_eta_right,nproc_xi,nproc_eta)
- ibot = get_slice_number(ichunk_bot,islice_xi_bot,islice_eta_bot,nproc_xi,nproc_eta)
- itop = get_slice_number(ichunk_top,islice_xi_top,islice_eta_top,nproc_xi,nproc_eta)
-
-end subroutine get_lrbt_slices
-
-! ---------------------------------------------------------------------------------------
-
-integer function get_slice_number(ichunk,ixi,ieta,nproc_xi,nproc_eta)
-
- implicit none
-
- integer :: ichunk, ixi, ieta, nproc_xi, nproc_eta
-
- get_slice_number = ichunk*nproc_xi*nproc_eta+ieta*nproc_xi+ixi
-
- end function get_slice_number
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sub.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,221 @@
+
+! --------------------------------------------------------------------------------
+
+subroutine get_all_eight_slices(ichunk,ixi,ieta,&
+ ileft,iright,ibot,itop, ilb,ilt,irb,irt,&
+ nproc_xi,nproc_eta)
+
+ implicit none
+
+ integer, intent(IN) :: ichunk,ixi,ieta,nproc_xi,nproc_eta
+
+ integer, intent(OUT) :: ileft,iright,ibot,itop,ilb,ilt,irb,irt
+ integer :: get_slice_number
+
+
+ integer :: ichunk_left, islice_xi_left, islice_eta_left, &
+ ichunk_right, islice_xi_right, islice_eta_right, &
+ ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ ichunk_top, islice_xi_top, islice_eta_top, &
+ ileft0,iright0,ibot0,itop0, &
+ ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ ichunk_top0, islice_xi_top0, islice_eta_top0
+
+
+! get the first 4 immediate slices
+ call get_lrbt_slices(ichunk,ixi,ieta, &
+ ileft, ichunk_left, islice_xi_left, islice_eta_left, &
+ iright, ichunk_right, islice_xi_right, islice_eta_right, &
+ ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ itop, ichunk_top, islice_xi_top, islice_eta_top, &
+ nproc_xi,nproc_eta)
+
+! get the 4 diagonal neighboring slices (actually 3 diagonal slices at the corners)
+ ilb = get_slice_number(ichunk,ixi-1,ieta-1,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk,ixi-1,ieta+1,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk,ixi+1,ieta-1,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk,ixi+1,ieta+1,nproc_xi,nproc_eta)
+
+ if (ixi==0) then
+ call get_lrbt_slices(ichunk_left,islice_xi_left,islice_eta_left, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+
+ if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
+ ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ else if (ichunk == 2) then
+ ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ else
+ ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ endif
+ endif
+
+ if (ixi==nproc_xi-1) then
+ call get_lrbt_slices(ichunk_right,islice_xi_right,islice_eta_right, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+ if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
+ irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ else if (ichunk == 2) then
+ irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ else
+ irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ endif
+ endif
+
+ if (ieta==0) then
+ call get_lrbt_slices(ichunk_bot,islice_xi_bot,islice_eta_bot, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+ if (ichunk == 1 .or. ichunk == 2) then
+ ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ else if (ichunk == 3 .or. ichunk == 4) then
+ ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ else if (ichunk == 0) then
+ ilb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ else
+ ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ endif
+ endif
+
+ if (ieta==nproc_eta-1) then
+ call get_lrbt_slices(ichunk_top,islice_xi_top,islice_eta_top, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+
+ if (ichunk == 1 .or. ichunk == 4) then
+ ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ else if (ichunk == 2 .or. ichunk == 3) then
+ ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ else if (ichunk == 0) then
+ ilt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ else
+ ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ endif
+
+ endif
+
+end subroutine get_all_eight_slices
+
+!--------------------------------------------------------------------------------------------
+
+subroutine get_lrbt_slices(ichunk,ixi,ieta, &
+ ileft, ichunk_left, islice_xi_left, islice_eta_left, &
+ iright, ichunk_right, islice_xi_right, islice_eta_right, &
+ ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ itop, ichunk_top, islice_xi_top, islice_eta_top, &
+ nproc_xi,nproc_eta)
+
+ implicit none
+
+ integer, intent(IN) :: ichunk, ixi, ieta, nproc_xi, nproc_eta
+ integer, intent(OUT) :: ileft, ichunk_left, islice_xi_left, islice_eta_left, &
+ iright, ichunk_right, islice_xi_right, islice_eta_right, &
+ ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ itop, ichunk_top, islice_xi_top, islice_eta_top
+
+ integer, parameter :: NCHUNKS = 6
+
+ integer, dimension(NCHUNKS) :: chunk_left,chunk_right,chunk_bot,chunk_top, &
+ slice_xi_left,slice_eta_left,slice_xi_right,slice_eta_right, &
+ slice_xi_bot,slice_eta_bot,slice_xi_top,slice_eta_top
+ integer :: get_slice_number
+
+! set up mapping arrays -- assume chunk/slice number starts from 0
+ chunk_left(:) = (/2,6,6,1,6,4/) - 1
+ chunk_right(:) = (/4,1,1,6,1,2/) - 1
+ chunk_bot(:) = (/5,5,2,5,4,5/) - 1
+ chunk_top(:) = (/3,3,4,3,2,3/) - 1
+
+ slice_xi_left(:) = (/nproc_xi-1,nproc_xi-1,nproc_xi-1-ieta,nproc_xi-1,ieta,nproc_xi-1/)
+ slice_eta_left(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
+ slice_xi_right(:) = (/0,0,ieta,0,nproc_xi-1-ieta,0/)
+ slice_eta_right(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
+
+ slice_xi_bot(:) = (/nproc_xi-1,ixi,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,0/)
+ slice_eta_bot(:) = (/nproc_eta-1-ixi,nproc_eta-1,nproc_eta-1,0,0,ixi/)
+ slice_xi_top(:) = (/nproc_xi-1,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,ixi,0/)
+ slice_eta_top(:) = (/ixi,0,nproc_eta-1,nproc_eta-1,0,nproc_eta-1-ixi /)
+
+ ichunk_left = ichunk
+ ichunk_right = ichunk
+ ichunk_bot = ichunk
+ ichunk_top = ichunk
+
+ islice_xi_left = ixi-1
+ islice_eta_left = ieta
+ islice_xi_right = ixi+1
+ islice_eta_right = ieta
+
+ islice_xi_bot = ixi
+ islice_eta_bot = ieta-1
+ islice_xi_top = ixi
+ islice_eta_top = ieta+1
+
+ if (ixi == 0) then
+ ichunk_left=chunk_left(ichunk+1)
+ islice_xi_left=slice_xi_left(ichunk+1)
+ islice_eta_left=slice_eta_left(ichunk+1)
+ endif
+ if (ixi == nproc_xi - 1) then
+ ichunk_right=chunk_right(ichunk+1)
+ islice_xi_right=slice_xi_right(ichunk+1)
+ islice_eta_right=slice_eta_right(ichunk+1)
+ endif
+ if (ieta == 0) then
+ ichunk_bot=chunk_bot(ichunk+1)
+ islice_xi_bot=slice_xi_bot(ichunk+1)
+ islice_eta_bot=slice_eta_bot(ichunk+1)
+ endif
+ if (ieta == nproc_eta - 1) then
+ ichunk_top=chunk_top(ichunk+1)
+ islice_xi_top=slice_xi_top(ichunk+1)
+ islice_eta_top=slice_eta_top(ichunk+1)
+ endif
+
+ ileft = get_slice_number(ichunk_left,islice_xi_left,islice_eta_left,nproc_xi,nproc_eta)
+ iright = get_slice_number(ichunk_right,islice_xi_right,islice_eta_right,nproc_xi,nproc_eta)
+ ibot = get_slice_number(ichunk_bot,islice_xi_bot,islice_eta_bot,nproc_xi,nproc_eta)
+ itop = get_slice_number(ichunk_top,islice_xi_top,islice_eta_top,nproc_xi,nproc_eta)
+
+end subroutine get_lrbt_slices
+
+! ---------------------------------------------------------------------------------------
+
+integer function get_slice_number(ichunk,ixi,ieta,nproc_xi,nproc_eta)
+
+ implicit none
+
+ integer :: ichunk, ixi, ieta, nproc_xi, nproc_eta
+
+ get_slice_number = ichunk*nproc_xi*nproc_eta+ieta*nproc_xi+ixi
+
+ end function get_slice_number
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,19 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Tue Jan 25 17:19:32 EST 2011
-
-if [ ! -f ../constants.h ]; then
- echo WRONG! NO constants.h
- exit
-fi
-if [ ! -f ../values_from_mesher.h ]; then
- echo WRONG! NO values_from_mesher.h
- exit
-fi
-if [ ! -f ../precision.h ]; then
- echo WRONG! NO precision.h
- exit
-fi
-
-mpif90 -O3 -o xsmooth_sem_globe smooth_sem_globe.f90 smooth_sub.f90 exit_mpi.f90 gll_library.f90
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,19 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
+ echo WRONG! NO constants.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
+ echo WRONG! NO values_from_mesher.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/precision.h ]; then
+ echo WRONG! NO precision.h
+ exit
+fi
+
+mpif90 -O3 -o xsmooth_sem_globe smooth_sem_globe.f90 smooth_sub.f90 exit_mpi.f90 gll_library.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,30 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Fri Mar 4 13:16:22 EST 2011
-
-
-iter=M00
-sigma_h=50
-sigma_v=5
-
-
-for tag in bulk_c_kernel_precond bulk_betav_kernel_precond bulk_betah_kernel_precond eta_kernel_precond
-do
- echo $tag
-
- title="#PBS -N XSMOOTH_$tag"
-
- sed -e "s/^tag=.*$/tag=$tag/g" \
- -e "s/^iter=.*$/iter=$iter/g" \
- -e "s/^sigma_h=.*$/sigma_h=$sigma_h/g" \
- -e "s/^sigma_v=.*$/sigma_v=$sigma_v/g" \
- -e "s/^#PBS -N.*$/$title/g" \
- xpbs_smooth_kernel_sub.sh > xpbs_smooth_kernel_sub.sh.out
-
- mv xpbs_smooth_kernel_sub.sh.out xpbs_smooth_kernel_sub.sh
- qsub xpbs_smooth_kernel_sub.sh
- sleep 5
-done
-
-
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel_sub.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel_sub.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xpbs_smooth_kernel_sub.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,26 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XSMOOTH_eta_kernel_precond
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o job_src2.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter=M18
-sigma_h=50
-sigma_v=5
-topo_path=../EUROPE_TOPOLOGY_FILE
-kernel_path=../SUMMED_KERNEL_$iter
-tag=eta_kernel_precond
-
-output_tag="XTAG_SMOOTH_"$iter"_"$tag
-
-echo submit smoothing $tag kernel
-mpiexec -np 100 ./xsmooth_sem_globe $sigma_h $sigma_v $tag $kernel_path $topo_path > $output_tag
-echo smoothing $tag kernel done successfully
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/xsmooth_sem_globe
===================================================================
(Binary files differ)
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/XPBS_compute_direction_cg.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/XPBS_compute_direction_cg.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/XPBS_compute_direction_cg.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,49 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XCOMPUTE_CG_DIRECTION
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o xcompute_direction_cg.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter_new=M01
+iter_old=M00
+
+xoutput_tag=XTAG_$iter_new
+
+
+direction_0=../DIRECTION_CG_$iter_old
+direction_1=../DIRECTION_CG_$iter_new
+
+gradient_0=../SUMMED_KERNEL_$iter_old
+gradient_1=../SUMMED_KERNEL_$iter_new
+
+if [ ! -d $direction_0 ]; then
+ echo WRONG! NO $direction_0
+ exit
+fi
+if [ ! -d $gradient_0 ]; then
+ echo WRONG! NO $gradient_0
+ exit
+fi
+if [ ! -d $gradient_1 ]; then
+ echo WRONG! NO $gradient_1
+ exit
+fi
+
+if [ ! -d $direction_1 ]; then
+ echo MKDIR $direction_1
+ mkdir $direction_1
+fi
+
+echo submit compute cg direction
+mpiexec -np 100 ./xcompute_direction_cg $direction_0 $direction_1 $gradient_0 $gradient_1 > $xoutput_tag
+echo done successfully
+
+
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,143 +0,0 @@
-program xcompute_direction_cg
- implicit none
-
- include 'mpif.h'
- include '../../SHARE_FILES/constants.h'
- include '../../SHARE_FILES/values_from_mesher.h'
- include '../../SHARE_FILES/precision.h'
-
- integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
- integer,parameter:: NKERNEL=4
- integer:: myrank, sizeprocs,ier
- integer:: iker,ispec,i,j,k
-
- character(len=512):: direction_0_dir, direction_1_dir, gradient_0_dir, gradient_1_dir
- character(len=512):: direction_0_file, direction_1_file, gradient_0_file, gradient_1_file
- character(len=256):: kernel_name(NKERNEL)
-
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: direction_0, direction_1,gradient_0,gradient_1
- real(kind=CUSTOM_REAL)::beta,beta_upper,beta_down,beta_upper_all_tmp,beta_down_all_tmp
- real(kind=CUSTOM_REAL),dimension(NKERNEL)::beta_upper_all,beta_down_all
-
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- call getarg(1,direction_0_dir)
- call getarg(2,direction_1_dir)
- call getarg(3,gradient_0_dir)
- call getarg(4,gradient_1_dir)
-
- if (trim(direction_0_dir) == '' .or. trim(direction_1_dir) == '' &
- .or. trim(gradient_0_dir) == '' .or. trim(gradient_1_dir) == '') then
- call exit_MPI(myrank,'USAGE: xcompute_direction_cg direction_0_dir direction_1_dir gradient_0_dir gradient_1_dir')
- end if
-
- kernel_name=(/"reg1_bulk_betah_kernel_precond_smooth","reg1_bulk_betav_kernel_precond_smooth","reg1_bulk_c_kernel_precond_smooth","reg1_eta_kernel_precond_smooth"/)
-
- do iker = 1,NKERNEL
- write(gradient_0_file,'(a,i6.6,a)') trim(gradient_0_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- write(gradient_1_file,'(a,i6.6,a)') trim(gradient_1_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
-
-
- open(1001,file=trim(gradient_0_file),status='old',form='unformatted',iostat=ier)
- if (myrank == 0) print*, 'reading gradient0:',trim(gradient_0_file)
- if ( ier /=0) then
- print*, 'error opening:',trim(gradient_0_file)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) gradient_0(:,:,:,1:NSPEC)
- close(1001)
-
- open(1001,file=trim(gradient_1_file),status='old',form='unformatted',iostat=ier)
- if (myrank == 0) print*, 'reading gradient1:',trim(gradient_1_file)
- if (ier/=0) then
- print*, 'error opening:',trim(gradient_1_file)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) gradient_1(:,:,:,1:NSPEC)
- close(1001)
-
- beta_upper=sum(gradient_1*(gradient_1-gradient_0))
- beta_down=sum(gradient_0*gradient_0)
-
- call mpi_barrier(MPI_COMM_WORLD,ier)
- call mpi_allreduce(beta_upper,beta_upper_all_tmp,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
- call mpi_allreduce(beta_down,beta_down_all_tmp,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
-
- beta_upper_all(iker)=beta_upper_all_tmp
- beta_down_all(iker)=beta_down_all_tmp
- end do
-
- beta=sum(beta_upper_all)/sum(beta_down_all)
- if (myrank == 0 ) then
- print*,'before zero',myrank,beta
- end if
- if ( beta < 0.0 ) then
- beta=0.0
- end if
-
-
- if (myrank == 0 ) then
- print*,myrank,beta
- end if
-
-
- do iker = 1,NKERNEL
- direction_1=0._CUSTOM_REAL
-
- write(direction_0_file,'(a,i6.6,a)') trim(direction_0_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- write(direction_1_file,'(a,i6.6,a)') trim(direction_1_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- write(gradient_0_file,'(a,i6.6,a)') trim(gradient_0_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- write(gradient_1_file,'(a,i6.6,a)') trim(gradient_1_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
-
- open(1001,file=trim(direction_0_file),status='old',form='unformatted',iostat=ier)
- if ( myrank == 0) print*,'reading direction0:',trim(direction_0_file)
- if (ier /= 0 ) then
- print*, 'error opening:',trim(direction_0_file)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) direction_0(:,:,:,1:NSPEC)
- close(1001)
-
- open(1001,file=trim(gradient_0_file),status='old',form='unformatted',iostat=ier)
- if (myrank == 0) print*, 'reading gradient0:',trim(gradient_0_file)
- if ( ier /=0) then
- print*, 'error opening:',trim(gradient_0_file)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) gradient_0(:,:,:,1:NSPEC)
- close(1001)
-
- open(1001,file=trim(gradient_1_file),status='old',form='unformatted',iostat=ier)
- if (myrank == 0) print*, 'reading gradient1:',trim(gradient_1_file)
- if (ier/=0) then
- print*, 'error opening:',trim(gradient_1_file)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) gradient_1(:,:,:,1:NSPEC)
- close(1001)
-
-
-
-
- do ispec=1,NSPEC
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- direction_1(i,j,k,ispec)=-gradient_1(i,j,k,ispec)+beta*direction_0(i,j,k,ispec)
- end do ! i
- end do ! j
- end do ! k
- end do ! ispec
- open(1001,file=trim(direction_1_file),form='unformatted',action='write')
- if (myrank == 0) print*, 'writing direction1:',direction_1_file
- write(1001) direction_1
- close(1001)
-
- end do ! kernel type
-
- call MPI_FINALIZE(ier)
-
-end program xcompute_direction_cg
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/compute_direction_cg.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,143 @@
+program xcompute_direction_cg
+ implicit none
+
+ include 'mpif.h'
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+ include '../../SHARE_FILES/HEADER_FILES/precision.h'
+
+ integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
+ integer,parameter:: NKERNEL=4
+ integer:: myrank, sizeprocs,ier
+ integer:: iker,ispec,i,j,k
+
+ character(len=512):: direction_0_dir, direction_1_dir, gradient_0_dir, gradient_1_dir
+ character(len=512):: direction_0_file, direction_1_file, gradient_0_file, gradient_1_file
+ character(len=256):: kernel_name(NKERNEL)
+
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: direction_0, direction_1,gradient_0,gradient_1
+ real(kind=CUSTOM_REAL)::beta,beta_upper,beta_down,beta_upper_all_tmp,beta_down_all_tmp
+ real(kind=CUSTOM_REAL),dimension(NKERNEL)::beta_upper_all,beta_down_all
+
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ call getarg(1,direction_0_dir)
+ call getarg(2,direction_1_dir)
+ call getarg(3,gradient_0_dir)
+ call getarg(4,gradient_1_dir)
+
+ if (trim(direction_0_dir) == '' .or. trim(direction_1_dir) == '' &
+ .or. trim(gradient_0_dir) == '' .or. trim(gradient_1_dir) == '') then
+ call exit_MPI(myrank,'USAGE: xcompute_direction_cg direction_0_dir direction_1_dir gradient_0_dir gradient_1_dir')
+ end if
+
+ kernel_name=(/"reg1_bulk_betah_kernel_precond_smooth","reg1_bulk_betav_kernel_precond_smooth","reg1_bulk_c_kernel_precond_smooth","reg1_eta_kernel_precond_smooth"/)
+
+ do iker = 1,NKERNEL
+ write(gradient_0_file,'(a,i6.6,a)') trim(gradient_0_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ write(gradient_1_file,'(a,i6.6,a)') trim(gradient_1_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+
+
+ open(1001,file=trim(gradient_0_file),status='old',form='unformatted',iostat=ier)
+ if (myrank == 0) print*, 'reading gradient0:',trim(gradient_0_file)
+ if ( ier /=0) then
+ print*, 'error opening:',trim(gradient_0_file)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) gradient_0(:,:,:,1:NSPEC)
+ close(1001)
+
+ open(1001,file=trim(gradient_1_file),status='old',form='unformatted',iostat=ier)
+ if (myrank == 0) print*, 'reading gradient1:',trim(gradient_1_file)
+ if (ier/=0) then
+ print*, 'error opening:',trim(gradient_1_file)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) gradient_1(:,:,:,1:NSPEC)
+ close(1001)
+
+ beta_upper=sum(gradient_1*(gradient_1-gradient_0))
+ beta_down=sum(gradient_0*gradient_0)
+
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+ call mpi_allreduce(beta_upper,beta_upper_all_tmp,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+ call mpi_allreduce(beta_down,beta_down_all_tmp,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+
+ beta_upper_all(iker)=beta_upper_all_tmp
+ beta_down_all(iker)=beta_down_all_tmp
+ end do
+
+ beta=sum(beta_upper_all)/sum(beta_down_all)
+ if (myrank == 0 ) then
+ print*,'before zero',myrank,beta
+ end if
+ if ( beta < 0.0 ) then
+ beta=0.0
+ end if
+
+
+ if (myrank == 0 ) then
+ print*,myrank,beta
+ end if
+
+
+ do iker = 1,NKERNEL
+ direction_1=0._CUSTOM_REAL
+
+ write(direction_0_file,'(a,i6.6,a)') trim(direction_0_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ write(direction_1_file,'(a,i6.6,a)') trim(direction_1_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ write(gradient_0_file,'(a,i6.6,a)') trim(gradient_0_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ write(gradient_1_file,'(a,i6.6,a)') trim(gradient_1_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+
+ open(1001,file=trim(direction_0_file),status='old',form='unformatted',iostat=ier)
+ if ( myrank == 0) print*,'reading direction0:',trim(direction_0_file)
+ if (ier /= 0 ) then
+ print*, 'error opening:',trim(direction_0_file)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) direction_0(:,:,:,1:NSPEC)
+ close(1001)
+
+ open(1001,file=trim(gradient_0_file),status='old',form='unformatted',iostat=ier)
+ if (myrank == 0) print*, 'reading gradient0:',trim(gradient_0_file)
+ if ( ier /=0) then
+ print*, 'error opening:',trim(gradient_0_file)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) gradient_0(:,:,:,1:NSPEC)
+ close(1001)
+
+ open(1001,file=trim(gradient_1_file),status='old',form='unformatted',iostat=ier)
+ if (myrank == 0) print*, 'reading gradient1:',trim(gradient_1_file)
+ if (ier/=0) then
+ print*, 'error opening:',trim(gradient_1_file)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) gradient_1(:,:,:,1:NSPEC)
+ close(1001)
+
+
+
+
+ do ispec=1,NSPEC
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ direction_1(i,j,k,ispec)=-gradient_1(i,j,k,ispec)+beta*direction_0(i,j,k,ispec)
+ end do ! i
+ end do ! j
+ end do ! k
+ end do ! ispec
+ open(1001,file=trim(direction_1_file),form='unformatted',action='write')
+ if (myrank == 0) print*, 'writing direction1:',direction_1_file
+ write(1001) direction_1
+ close(1001)
+
+ end do ! kernel type
+
+ call MPI_FINALIZE(ier)
+
+end program xcompute_direction_cg
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "../../SHARE_FILES/constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(outputname),status='unknown')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-
-! stop all the MPI processes, and exit
-! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
- call MPI_FINALIZE(ier)
- call MPI_ABORT(ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(outputname),status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+
+! stop all the MPI processes, and exit
+! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
+ call MPI_FINALIZE(ier)
+ call MPI_ABORT(ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,19 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Tue Jan 25 17:19:32 EST 2011
-
-if [ ! -f ../../SHARE_FILES/constants.h ]; then
- echo WRONG! NO constants.h
- exit
-fi
-if [ ! -f ../../SHARE_FILES/values_from_mesher.h ]; then
- echo WRONG! NO values_from_mesher.h
- exit
-fi
-if [ ! -f ../../SHARE_FILES/precision.h ]; then
- echo WRONG! NO precision.h
- exit
-fi
-
-mpif90 -O3 -o xcompute_direction_cg compute_direction_cg.f90 exit_mpi.f90
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,19 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
+ echo WRONG! NO constants.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
+ echo WRONG! NO values_from_mesher.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/precision.h ]; then
+ echo WRONG! NO precision.h
+ exit
+fi
+
+mpif90 -O3 -o xcompute_direction_cg compute_direction_cg.f90 exit_mpi.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xcompute_direction_cg
===================================================================
(Binary files differ)
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xpbs_compute_direction_cg.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xpbs_compute_direction_cg.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_CG/xpbs_compute_direction_cg.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,49 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XCOMPUTE_CG_DIRECTION
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o xcompute_direction_cg.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter_new=M01
-iter_old=M00
-
-xoutput_tag=XTAG_$iter_new
-
-
-direction_0=../DIRECTION_CG_$iter_old
-direction_1=../DIRECTION_CG_$iter_new
-
-gradient_0=../SUMMED_KERNEL_$iter_old
-gradient_1=../SUMMED_KERNEL_$iter_new
-
-if [ ! -d $direction_0 ]; then
- echo WRONG! NO $direction_0
- exit
-fi
-if [ ! -d $gradient_0 ]; then
- echo WRONG! NO $gradient_0
- exit
-fi
-if [ ! -d $gradient_1 ]; then
- echo WRONG! NO $gradient_1
- exit
-fi
-
-if [ ! -d $direction_1 ]; then
- echo MKDIR $direction_1
- mkdir $direction_1
-fi
-
-echo submit compute cg direction
-mpiexec -np 100 ./xcompute_direction_cg $direction_0 $direction_1 $gradient_0 $gradient_1 > $xoutput_tag
-echo done successfully
-
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/XPBS_compute_direction_lbfgs.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/XPBS_compute_direction_lbfgs.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/XPBS_compute_direction_lbfgs.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,58 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XCOMPUTE_LBFGS_DIRECTION
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter_start=35
+iter_current=36
+
+xoutput_tag=XTAG_$iter_current
+
+
+# check directories
+model_0=../MODEL_M$iter_start
+model_1=../MODEL_M$iter_current
+
+gradient_0=../SUMMED_KERNEL_M$iter_start
+gradient_1=../SUMMED_KERNEL_M$iter_current
+
+direction=../DIRECTION_LBFGS_M$iter_current
+
+if [ ! -d $model_0 ]; then
+ echo WRONG! NO $model_0
+ exit
+fi
+if [ ! -d $model_1 ]; then
+ echo WRONG! NO $model_1
+ exit
+fi
+if [ ! -d $gradient_1 ]; then
+ echo WRONG! NO $gradient_1
+ exit
+fi
+if [ ! -d $gradient_0 ]; then
+ echo WRONG! NO $gradient_0
+ exit
+fi
+
+if [ ! -d $direction ]; then
+ echo MKDIR $direction
+ mkdir $direction
+fi
+
+
+# submit job
+echo submit compute direction lbfgs
+mpiexec -np 100 ./xcompute_direction_lbfgs $iter_start $iter_current > $xoutput_tag
+echo done successfully
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/XPBS_compute_direction_lbfgs.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,278 +0,0 @@
-! This program is used to compute lbfgs update direction
-! Author: Hejun Zhu, hejunzhu at princeton.edu
-! Princeton University, New Jersey, USA
-! Last modified: Tue Aug 21 17:48:28 EDT 2012
-
-module globe_parameter
- include '../../SHARE_FILES/constants.h'
- include '../../SHARE_FILES/values_from_mesher.h'
-
- integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
- integer,parameter:: NGLOB=NGLOB_CRUST_MANTLE
- integer,parameter:: NKERNEL=4
- integer,parameter:: m_store=5 ! stored model step 3<=m_store<=7
-
- integer:: myrank, sizeprocs,ier
- integer::iker,ispec,i,j,k
- character(len=512)::filename,dirname
-
- character(len=256):: kernel_name(NKERNEL)
- character(len=256):: model_name(NKERNEL)
- integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: ibool
-
-end module globe_parameter
-
-program xcompute_direction_lbfgs
- use globe_parameter
- implicit none
-
- include 'mpif.h'
- include '../../SHARE_FILES/precision.h'
-
- integer:: iter_start,iter_current,iter_store,istore
- character(len=128):: s_iter_start,s_iter_current
-
- real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: q_vector,r_vector
- real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: gradient1,gradient0,model1,model0
- real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: gradient_diff,model_diff
- real(kind=CUSTOM_REAL),dimension(128):: p,a
- real(kind=CUSTOM_REAL):: p_tmp,p_sum,a_tmp,a_sum,b_tmp,b_sum
- real(kind=CUSTOM_REAL):: b,p_k_up,p_k_down,p_k_up_sum,p_k_down_sum,p_k
-
-
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- ! read in parameters
- call getarg(1,s_iter_start)
- call getarg(2,s_iter_current)
- read(s_iter_start,*) iter_start
- read(s_iter_current,*) iter_current
- if (myrank ==0) print*, 'starting iteration for this period band:',iter_start
- if (myrank ==0) print*, 'current iteration:',iter_current
-
- iter_store = iter_current-m_store
- if ( iter_store <= iter_start ) then
- iter_store = iter_start
- end if
- if (myrank==0) print*, 'stored iteration:',iter_store
-
-
- kernel_name=(/"reg1_bulk_betah_kernel_precond_smooth","reg1_bulk_betav_kernel_precond_smooth","reg1_eta_kernel_precond_smooth","reg1_bulk_c_kernel_precond_smooth"/)
- model_name=(/"reg1_vsh","reg1_vsv","reg1_eta","reg1_bulk"/)
-
- ! initialize arrays
- a(:)=0.0
- p(:)=0.0
- gradient1(:)=0.0
- gradient0(:)=0.0
- model1(:)=0.0
- model0(:)=0.0
- gradient_diff(:)=0.0
- model_diff(:)=0.0
- q_vector(:)=0.0
- r_vector(:)=0.0
-
- call get_ibool
- call get_gradient(iter_current,q_vector)
-
- if (myrank == 0) then
- print*,'************************************************'
- print*,'*******starting backward store *****************'
- print*,'************************************************'
- end if
-
- do istore=iter_current-1,iter_store,-1
- call get_gradient(istore+1,gradient1)
- call get_gradient(istore,gradient0)
- call get_model(istore+1,model1)
- call get_model(istore,model0)
- gradient_diff=gradient1-gradient0
- model_diff=model1-model0
-
- p_tmp=sum(gradient_diff*model_diff)
- call mpi_barrier(MPI_COMM_WORLD,ier)
- call mpi_allreduce(p_tmp,p_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
- p(istore)=1.0/p_sum
-
- a_tmp=sum(model_diff*q_vector)
- call mpi_barrier(MPI_COMM_WORLD,ier)
- call mpi_allreduce(a_tmp,a_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
- a(istore)=p(istore)*a_sum
-
- if (myrank == 0) print*,'a,p:',a(istore),p(istore)
- q_vector=q_vector-a(istore)*gradient_diff
- end do
-
- p_k_up=sum(gradient_diff*model_diff)
- p_k_down=sum(gradient_diff*gradient_diff)
- call mpi_barrier(MPI_COMM_WORLD,ier)
- call mpi_allreduce(p_k_up,p_k_up_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
- call mpi_allreduce(p_k_down,p_k_down_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
- p_k=p_k_up_sum/p_k_down_sum
-
- if ( myrank == 0) print*,'p_k:',p_k
- r_vector=p_k*q_vector
- !r_vector=1.0*q_vector
-
- if (myrank == 0) then
- print*,'******************************************'
- print*,'********starting forward store ***********'
- print*,'******************************************'
- end if
-
- do istore=iter_store,iter_current-1,1
- call get_gradient(istore+1,gradient1)
- call get_gradient(istore,gradient0)
- call get_model(istore+1,model1)
- call get_model(istore,model0)
-
- gradient_diff=gradient1-gradient0
- model_diff=model1-model0
-
- b_tmp=sum(gradient_diff*r_vector)
- call mpi_barrier(MPI_COMM_WORLD,ier)
- call mpi_allreduce(b_tmp,b_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
- b=p(istore)*b_sum
-
- if (myrank==0) print*,'a,b:',a(istore),b
-
- r_vector=r_vector+model_diff*(a(istore)-b)
-
- end do
- r_vector=-1.0*r_vector
-
- call write_gradient(iter_current,r_vector)
-
- call MPI_FINALIZE(ier)
-end program xcompute_direction_lbfgs
-
-
-
-subroutine get_ibool
- use globe_parameter
- implicit none
-
- real(kind=CUSTOM_REAL),dimension(NGLOB)::tmp
-
- write(dirname,'(a)') '/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE'
- write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_reg1_solver_data_2.bin'
- open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file')
- read(1001) tmp(1:NGLOB)
- read(1001) tmp(1:NGLOB)
- read(1001) tmp(1:NGLOB)
- read(1001) ibool(:,:,:,1:NSPEC)
- close(1001)
-end subroutine get_ibool
-
-
-subroutine get_gradient(iter,gradient)
- use globe_parameter
- implicit none
- integer::iter,iglob
- real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB)::gradient
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC)::vector
- real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLOB)::vector_gll
-
- do iker=1,NKERNEL
- write(dirname,'(a,i2.2)') '/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/SUMMED_KERNEL_M',iter
- write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier)
- if ( myrank == 0) print*,'reading gradient:',trim(filename)
- if (ier /= 0 ) then
- print*,'error reading:',trim(filename)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) vector(:,:,:,1:NSPEC)
- close(1001)
- do ispec=1,NSPEC
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob=ibool(i,j,k,ispec)
- vector_gll(iker,iglob)=vector(i,j,k,ispec)
- end do
- end do
- end do
- end do
- end do
- gradient(1:NGLOB)=vector_gll(1,1:NGLOB)
- gradient(NGLOB+1:2*NGLOB)=vector_gll(2,1:NGLOB)
- gradient(2*NGLOB+1:3*NGLOB)=vector_gll(3,1:NGLOB)
- gradient(3*NGLOB+1:4*NGLOB)=vector_gll(4,1:NGLOB)
-end subroutine get_gradient
-
-
-subroutine get_model(iter,model)
- use globe_parameter
- implicit none
- integer::iter,iglob
- real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: model
- real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLOB):: vector_gll
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: vector
-
- do iker=1,NKERNEL
- write(dirname,'(a,i2.2)') '/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/MODEL_M',iter
- write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_'//trim(model_name(iker))//'.bin'
- open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier)
- if ( myrank == 0) print*,'reading model:',trim(filename)
- if ( ier /=0) then
- print*,'error reading:',trim(filename)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) vector(:,:,:,1:NSPEC)
- close(1001)
- do ispec=1,NSPEC
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob=ibool(i,j,k,ispec)
- vector_gll(iker,iglob)=vector(i,j,k,ispec)
- end do
- end do
- end do
- end do
- end do
- model(1:NGLOB)=log(vector_gll(1,1:NGLOB))
- model(NGLOB+1:2*NGLOB)=log(vector_gll(2,1:NGLOB))
- model(2*NGLOB+1:3*NGLOB)=log(vector_gll(3,1:NGLOB))
- model(3*NGLOB+1:4*NGLOB)=log(vector_gll(4,1:NGLOB))
-end subroutine get_model
-
-
-subroutine write_gradient(iter,gradient)
- use globe_parameter
- implicit none
-
- integer::iter,iglob
- real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB)::gradient
- real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLLX,NGLLY,NGLLZ,NSPEC)::vector
- real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLOB)::vector_gll
-
- vector_gll(1,1:NGLOB)=gradient(1:NGLOB)
- vector_gll(2,1:NGLOB)=gradient(NGLOB+1:2*NGLOB)
- vector_gll(3,1:NGLOB)=gradient(2*NGLOB+1:3*NGLOB)
- vector_gll(4,1:NGLOB)=gradient(3*NGLOB+1:4*NGLOB)
-
- do iker=1,NKERNEL
- do ispec=1,NSPEC
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob=ibool(i,j,k,ispec)
- vector(iker,i,j,k,ispec)=vector_gll(iker,iglob)
- end do
- end do
- end do
- end do
-
- write(dirname,'(a,i2.2)') '/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/DIRECTION_LBFGS_M',iter
- write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- open(1001,file=trim(filename),form='unformatted',action='write')
- if ( myrank == 0) print*,'writing direct:',filename
- write(1001) vector(iker,:,:,:,1:NSPEC)
- close(1001)
- end do
-end subroutine write_gradient
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,278 @@
+! This program is used to compute lbfgs update direction
+! Author: Hejun Zhu, hejunzhu at princeton.edu
+! Princeton University, New Jersey, USA
+! Last modified: Tue Aug 21 17:48:28 EDT 2012
+
+module globe_parameter
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+
+ integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
+ integer,parameter:: NGLOB=NGLOB_CRUST_MANTLE
+ integer,parameter:: NKERNEL=4
+ integer,parameter:: m_store=5 ! stored model step 3<=m_store<=7
+
+ integer:: myrank, sizeprocs,ier
+ integer::iker,ispec,i,j,k
+ character(len=512)::filename,dirname
+
+ character(len=256):: kernel_name(NKERNEL)
+ character(len=256):: model_name(NKERNEL)
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: ibool
+
+end module globe_parameter
+
+program xcompute_direction_lbfgs
+ use globe_parameter
+ implicit none
+
+ include 'mpif.h'
+ include '../../SHARE_FILES/HEADER_FILES/precision.h'
+
+ integer:: iter_start,iter_current,iter_store,istore
+ character(len=128):: s_iter_start,s_iter_current
+
+ real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: q_vector,r_vector
+ real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: gradient1,gradient0,model1,model0
+ real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: gradient_diff,model_diff
+ real(kind=CUSTOM_REAL),dimension(128):: p,a
+ real(kind=CUSTOM_REAL):: p_tmp,p_sum,a_tmp,a_sum,b_tmp,b_sum
+ real(kind=CUSTOM_REAL):: b,p_k_up,p_k_down,p_k_up_sum,p_k_down_sum,p_k
+
+
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ ! read in parameters
+ call getarg(1,s_iter_start)
+ call getarg(2,s_iter_current)
+ read(s_iter_start,*) iter_start
+ read(s_iter_current,*) iter_current
+ if (myrank ==0) print*, 'starting iteration for this period band:',iter_start
+ if (myrank ==0) print*, 'current iteration:',iter_current
+
+ iter_store = iter_current-m_store
+ if ( iter_store <= iter_start ) then
+ iter_store = iter_start
+ end if
+ if (myrank==0) print*, 'stored iteration:',iter_store
+
+
+ kernel_name=(/"reg1_bulk_betah_kernel_precond_smooth","reg1_bulk_betav_kernel_precond_smooth","reg1_eta_kernel_precond_smooth","reg1_bulk_c_kernel_precond_smooth"/)
+ model_name=(/"reg1_vsh","reg1_vsv","reg1_eta","reg1_bulk"/)
+
+ ! initialize arrays
+ a(:)=0.0
+ p(:)=0.0
+ gradient1(:)=0.0
+ gradient0(:)=0.0
+ model1(:)=0.0
+ model0(:)=0.0
+ gradient_diff(:)=0.0
+ model_diff(:)=0.0
+ q_vector(:)=0.0
+ r_vector(:)=0.0
+
+ call get_ibool
+ call get_gradient(iter_current,q_vector)
+
+ if (myrank == 0) then
+ print*,'************************************************'
+ print*,'*******starting backward store *****************'
+ print*,'************************************************'
+ end if
+
+ do istore=iter_current-1,iter_store,-1
+ call get_gradient(istore+1,gradient1)
+ call get_gradient(istore,gradient0)
+ call get_model(istore+1,model1)
+ call get_model(istore,model0)
+ gradient_diff=gradient1-gradient0
+ model_diff=model1-model0
+
+ p_tmp=sum(gradient_diff*model_diff)
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+ call mpi_allreduce(p_tmp,p_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+ p(istore)=1.0/p_sum
+
+ a_tmp=sum(model_diff*q_vector)
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+ call mpi_allreduce(a_tmp,a_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+ a(istore)=p(istore)*a_sum
+
+ if (myrank == 0) print*,'a,p:',a(istore),p(istore)
+ q_vector=q_vector-a(istore)*gradient_diff
+ end do
+
+ p_k_up=sum(gradient_diff*model_diff)
+ p_k_down=sum(gradient_diff*gradient_diff)
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+ call mpi_allreduce(p_k_up,p_k_up_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+ call mpi_allreduce(p_k_down,p_k_down_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+ p_k=p_k_up_sum/p_k_down_sum
+
+ if ( myrank == 0) print*,'p_k:',p_k
+ r_vector=p_k*q_vector
+ !r_vector=1.0*q_vector
+
+ if (myrank == 0) then
+ print*,'******************************************'
+ print*,'********starting forward store ***********'
+ print*,'******************************************'
+ end if
+
+ do istore=iter_store,iter_current-1,1
+ call get_gradient(istore+1,gradient1)
+ call get_gradient(istore,gradient0)
+ call get_model(istore+1,model1)
+ call get_model(istore,model0)
+
+ gradient_diff=gradient1-gradient0
+ model_diff=model1-model0
+
+ b_tmp=sum(gradient_diff*r_vector)
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+ call mpi_allreduce(b_tmp,b_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,MPI_COMM_WORLD,ier)
+ b=p(istore)*b_sum
+
+ if (myrank==0) print*,'a,b:',a(istore),b
+
+ r_vector=r_vector+model_diff*(a(istore)-b)
+
+ end do
+ r_vector=-1.0*r_vector
+
+ call write_gradient(iter_current,r_vector)
+
+ call MPI_FINALIZE(ier)
+end program xcompute_direction_lbfgs
+
+
+
+subroutine get_ibool
+ use globe_parameter
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NGLOB)::tmp
+
+ write(dirname,'(a)') '/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE'
+ write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_reg1_solver_data_2.bin'
+ open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file')
+ read(1001) tmp(1:NGLOB)
+ read(1001) tmp(1:NGLOB)
+ read(1001) tmp(1:NGLOB)
+ read(1001) ibool(:,:,:,1:NSPEC)
+ close(1001)
+end subroutine get_ibool
+
+
+subroutine get_gradient(iter,gradient)
+ use globe_parameter
+ implicit none
+ integer::iter,iglob
+ real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB)::gradient
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC)::vector
+ real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLOB)::vector_gll
+
+ do iker=1,NKERNEL
+ write(dirname,'(a,i2.2)') '../SUMMED_KERNEL_M',iter
+ write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier)
+ if ( myrank == 0) print*,'reading gradient:',trim(filename)
+ if (ier /= 0 ) then
+ print*,'error reading:',trim(filename)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) vector(:,:,:,1:NSPEC)
+ close(1001)
+ do ispec=1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob=ibool(i,j,k,ispec)
+ vector_gll(iker,iglob)=vector(i,j,k,ispec)
+ end do
+ end do
+ end do
+ end do
+ end do
+ gradient(1:NGLOB)=vector_gll(1,1:NGLOB)
+ gradient(NGLOB+1:2*NGLOB)=vector_gll(2,1:NGLOB)
+ gradient(2*NGLOB+1:3*NGLOB)=vector_gll(3,1:NGLOB)
+ gradient(3*NGLOB+1:4*NGLOB)=vector_gll(4,1:NGLOB)
+end subroutine get_gradient
+
+
+subroutine get_model(iter,model)
+ use globe_parameter
+ implicit none
+ integer::iter,iglob
+ real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB):: model
+ real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLOB):: vector_gll
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: vector
+
+ do iker=1,NKERNEL
+ write(dirname,'(a,i2.2)') '../MODEL_M',iter
+ write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_'//trim(model_name(iker))//'.bin'
+ open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier)
+ if ( myrank == 0) print*,'reading model:',trim(filename)
+ if ( ier /=0) then
+ print*,'error reading:',trim(filename)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) vector(:,:,:,1:NSPEC)
+ close(1001)
+ do ispec=1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob=ibool(i,j,k,ispec)
+ vector_gll(iker,iglob)=vector(i,j,k,ispec)
+ end do
+ end do
+ end do
+ end do
+ end do
+ model(1:NGLOB)=log(vector_gll(1,1:NGLOB))
+ model(NGLOB+1:2*NGLOB)=log(vector_gll(2,1:NGLOB))
+ model(2*NGLOB+1:3*NGLOB)=log(vector_gll(3,1:NGLOB))
+ model(3*NGLOB+1:4*NGLOB)=log(vector_gll(4,1:NGLOB))
+end subroutine get_model
+
+
+subroutine write_gradient(iter,gradient)
+ use globe_parameter
+ implicit none
+
+ integer::iter,iglob
+ real(kind=CUSTOM_REAL),dimension(NKERNEL*NGLOB)::gradient
+ real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLLX,NGLLY,NGLLZ,NSPEC)::vector
+ real(kind=CUSTOM_REAL),dimension(NKERNEL,NGLOB)::vector_gll
+
+ vector_gll(1,1:NGLOB)=gradient(1:NGLOB)
+ vector_gll(2,1:NGLOB)=gradient(NGLOB+1:2*NGLOB)
+ vector_gll(3,1:NGLOB)=gradient(2*NGLOB+1:3*NGLOB)
+ vector_gll(4,1:NGLOB)=gradient(3*NGLOB+1:4*NGLOB)
+
+ do iker=1,NKERNEL
+ do ispec=1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob=ibool(i,j,k,ispec)
+ vector(iker,i,j,k,ispec)=vector_gll(iker,iglob)
+ end do
+ end do
+ end do
+ end do
+
+ write(dirname,'(a,i2.2)') '../DIRECTION_LBFGS_M',iter
+ write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ open(1001,file=trim(filename),form='unformatted',action='write')
+ if ( myrank == 0) print*,'writing direct:',filename
+ write(1001) vector(iker,:,:,:,1:NSPEC)
+ close(1001)
+ end do
+end subroutine write_gradient
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "../../SHARE_FILES/constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(outputname),status='unknown')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-
-! stop all the MPI processes, and exit
-! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
- call MPI_FINALIZE(ier)
- call MPI_ABORT(ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(outputname),status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+
+! stop all the MPI processes, and exit
+! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
+ call MPI_FINALIZE(ier)
+ call MPI_ABORT(ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/globe_parameter.mod
===================================================================
(Binary files differ)
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,19 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Tue Jan 25 17:19:32 EST 2011
-
-if [ ! -f ../../SHARE_FILES/constants.h ]; then
- echo WRONG! NO constants.h
- exit
-fi
-if [ ! -f ../../SHARE_FILES/values_from_mesher.h ]; then
- echo WRONG! NO values_from_mesher.h
- exit
-fi
-if [ ! -f ../../SHARE_FILES/precision.h ]; then
- echo WRONG! NO precision.h
- exit
-fi
-
-mpif90 -O3 -o xcompute_direction_lbfgs compute_direction_lbfgs.f90 exit_mpi.f90
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,19 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
+ echo WRONG! NO constants.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
+ echo WRONG! NO values_from_mesher.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/precision.h ]; then
+ echo WRONG! NO precision.h
+ exit
+fi
+
+mpif90 -O3 -o xcompute_direction_lbfgs compute_direction_lbfgs.f90 exit_mpi.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xcompute_direction_lbfgs
===================================================================
(Binary files differ)
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xpbs_compute_direction_lbfgs.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xpbs_compute_direction_lbfgs.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/xpbs_compute_direction_lbfgs.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,58 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XCOMPUTE_LBFGS_DIRECTION
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o job_src2.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter_start=35
-iter_current=36
-
-xoutput_tag=XTAG_$iter_current
-
-
-# check directories
-model_0=../MODEL_M$iter_start
-model_1=../MODEL_M$iter_current
-
-gradient_0=../SUMMED_KERNEL_M$iter_start
-gradient_1=../SUMMED_KERNEL_M$iter_current
-
-direction=../DIRECTION_LBFGS_M$iter_current
-
-if [ ! -d $model_0 ]; then
- echo WRONG! NO $model_0
- exit
-fi
-if [ ! -d $model_1 ]; then
- echo WRONG! NO $model_1
- exit
-fi
-if [ ! -d $gradient_1 ]; then
- echo WRONG! NO $gradient_1
- exit
-fi
-if [ ! -d $gradient_0 ]; then
- echo WRONG! NO $gradient_0
- exit
-fi
-
-if [ ! -d $direction ]; then
- echo MKDIR $direction
- mkdir $direction
-fi
-
-
-# submit job
-echo submit compute direction lbfgs
-mpiexec -np 100 ./xcompute_direction_lbfgs $iter_start $iter_current > $xoutput_tag
-echo done successfully
-
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/XPBS_compute_direction_sd.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/XPBS_compute_direction_sd.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/XPBS_compute_direction_sd.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,37 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XCOMPUTE_CG_DIRECTION
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o xcompute_direction_sd.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter=M00
+
+xoutput_tag=XTAG_$iter
+
+direction_dir=../DIRECTION_SD_$iter
+gradient_dir=../SUMMED_KERNEL_$iter
+
+
+if [ ! -d $gradient_dir ]; then
+ echo WRONG! NO $gradient_dir
+ exit
+fi
+
+if [ ! -d $direction_dir ]; then
+ echo MKDIR $direction_dir
+ mkdir $direction_dir
+fi
+
+echo submit compute sd direction
+mpiexec -np 100 ./xcompute_direction_sd $direction $gradient > $xoutput_tag
+echo done successfully
+
+
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-program xcompute_direction_sd
- implicit none
-
- include 'mpif.h'
- include '../../SHARE_FILES/constants.h'
- include '../../SHARE_FILES/values_from_mesher.h'
- include '../../SHARE_FILES/precision.h'
-
- integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
- integer,parameter:: NKERNEL=4
- integer:: myrank, sizeprocs,ier
- integer:: iker,ispec,i,j,k
-
- character(len=512):: direction_dir, gradient_dir
- character(len=512):: direction_file, gradient_file
- character(len=256):: kernel_name(NKERNEL)
-
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: direction,gradient
-
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- call getarg(1,direction_dir)
- call getarg(2,gradient_dir)
-
- if (trim(direction_dir) == ''.or. trim(gradient_dir) == '') then
- call exit_MPI(myrank,'USAGE: xcompute_direction_sd direction_dir gradient_dir')
- end if
-
-
- kernel_name=(/"reg1_bulk_betah_kernel_precond_smooth","reg1_bulk_betav_kernel_precond_smooth","reg1_bulk_c_kernel_precond_smooth","reg1_eta_kernel_precond_smooth"/)
-
- do iker = 1,NKERNEL
- direction=0._CUSTOM_REAL
-
- write(direction_file,'(a,i6.6,a)') trim(direction_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
- write(gradient_file,'(a,i6.6,a)') trim(gradient_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
-
-
- open(1001,file=trim(gradient_file),status='old',form='unformatted',iostat=ier)
- if (myrank == 0) print*, 'reading gradient1:',trim(gradient_file)
- if (ier/=0) then
- print*, 'error opening:',trim(gradient_file)
- call exit_mpi(myrank,'file not found')
- end if
- read(1001) gradient(:,:,:,1:NSPEC)
- close(1001)
-
- direction=-gradient
-
- open(1001,file=trim(direction_file),form='unformatted',action='write')
- if (myrank == 0) print*, 'writing direction1:',direction_file
- write(1001) direction
- close(1001)
-
- end do ! kernel type
-
-call MPI_FINALIZE(ier)
-
-end program xcompute_direction_sd
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/compute_direction_sd.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+program xcompute_direction_sd
+ implicit none
+
+ include 'mpif.h'
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+ include '../../SHARE_FILES/HEADER_FILES/precision.h'
+
+ integer,parameter:: NSPEC=NSPEC_CRUST_MANTLE
+ integer,parameter:: NKERNEL=4
+ integer:: myrank, sizeprocs,ier
+ integer:: iker,ispec,i,j,k
+
+ character(len=512):: direction_dir, gradient_dir
+ character(len=512):: direction_file, gradient_file
+ character(len=256):: kernel_name(NKERNEL)
+
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC):: direction,gradient
+
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ call getarg(1,direction_dir)
+ call getarg(2,gradient_dir)
+
+ if (trim(direction_dir) == ''.or. trim(gradient_dir) == '') then
+ call exit_MPI(myrank,'USAGE: xcompute_direction_sd direction_dir gradient_dir')
+ end if
+
+
+ kernel_name=(/"reg1_bulk_betah_kernel_precond_smooth","reg1_bulk_betav_kernel_precond_smooth","reg1_bulk_c_kernel_precond_smooth","reg1_eta_kernel_precond_smooth"/)
+
+ do iker = 1,NKERNEL
+ direction=0._CUSTOM_REAL
+
+ write(direction_file,'(a,i6.6,a)') trim(direction_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+ write(gradient_file,'(a,i6.6,a)') trim(gradient_dir)//'/proc',myrank,'_'//trim(kernel_name(iker))//'.bin'
+
+
+ open(1001,file=trim(gradient_file),status='old',form='unformatted',iostat=ier)
+ if (myrank == 0) print*, 'reading gradient1:',trim(gradient_file)
+ if (ier/=0) then
+ print*, 'error opening:',trim(gradient_file)
+ call exit_mpi(myrank,'file not found')
+ end if
+ read(1001) gradient(:,:,:,1:NSPEC)
+ close(1001)
+
+ direction=-gradient
+
+ open(1001,file=trim(direction_file),form='unformatted',action='write')
+ if (myrank == 0) print*, 'writing direction1:',direction_file
+ write(1001) direction
+ close(1001)
+
+ end do ! kernel type
+
+call MPI_FINALIZE(ier)
+
+end program xcompute_direction_sd
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "../../SHARE_FILES/constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(outputname),status='unknown')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-
-! stop all the MPI processes, and exit
-! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
- call MPI_FINALIZE(ier)
- call MPI_ABORT(ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(outputname),status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+
+! stop all the MPI processes, and exit
+! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
+ call MPI_FINALIZE(ier)
+ call MPI_ABORT(ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,19 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Tue Jan 25 17:19:32 EST 2011
-
-if [ ! -f ../../SHARE_FILES/constants.h ]; then
- echo WRONG! NO constants.h in SHARE_FILES
- exit
-fi
-if [ ! -f ../../SHARE_FILES/values_from_mesher.h ]; then
- echo WRONG! NO values_from_mesher.h in SHARE_FILES
- exit
-fi
-if [ ! -f ../../SHARE_FILES/precision.h ]; then
- echo WRONG! NO precision.h in SHARE_FILES
- exit
-fi
-
-mpif90 -O3 -o xcompute_direction_sd compute_direction_sd.f90 exit_mpi.f90
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,19 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
+ echo WRONG! NO constants.h in SHARE_FILES
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
+ echo WRONG! NO values_from_mesher.h in SHARE_FILES
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/precision.h ]; then
+ echo WRONG! NO precision.h in SHARE_FILES
+ exit
+fi
+
+mpif90 -O3 -o xcompute_direction_sd compute_direction_sd.f90 exit_mpi.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xcompute_direction_sd
===================================================================
(Binary files differ)
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xpbs_compute_direction_sd.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xpbs_compute_direction_sd.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_SD/xpbs_compute_direction_sd.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,37 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XCOMPUTE_CG_DIRECTION
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o xcompute_direction_sd.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter=M00
-
-xoutput_tag=XTAG_$iter
-
-direction_dir=../DIRECTION_SD_$iter
-gradient_dir=../SUMMED_KERNEL_$iter
-
-
-if [ ! -d $gradient_dir ]; then
- echo WRONG! NO $gradient_dir
- exit
-fi
-
-if [ ! -d $direction_dir ]; then
- echo MKDIR $direction_dir
- mkdir $direction_dir
-fi
-
-echo submit compute sd direction
-mpiexec -np 100 ./xcompute_direction_sd $direction $gradient > $xoutput_tag
-echo done successfully
-
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/XPBS_update_model.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/XPBS_update_model.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/XPBS_update_model.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,43 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XUPDATE_MODEL
+#PBS -l nodes=13:ppn=8
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+iter_old=M17
+iter_new=M18
+step_len=0.01
+
+xoutput_tag=XTAG_$iter_new
+
+
+input_model=../MODEL_$iter_old
+input_kernel=../DIRECTION_CG_$iter_old
+output_model=../MODEL_$iter_new
+
+if [ ! -d $input_model ]; then
+ echo WRONG! NO $input_model
+ exit
+fi
+if [ ! -d $input_kernel ]; then
+ echo WRONG! NO $input_kernel
+ exit
+fi
+if [ ! -d $output_model ]; then
+ echo MKDIR $output_model
+ mkdir $output_model
+fi
+
+echo submit updata model
+mpiexec -np 100 ./xadd_model_globe $step_len $input_model $input_kernel $output_model > $xoutput_tag
+echo done successfully
+
+
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,1135 +0,0 @@
-! add_model_globe_tiso
-!
-! this program can be used to update TRANSVERSE ISOTROPIC model files
-! based on smoothed event kernels.
-! the kernels are given for tranverse isotropic parameters (bulk_c,bulk_betav,bulk_betah,eta).
-!
-! the algorithm uses a steepest descent method with a step length
-! determined by the given maximum update percentage.
-!
-! input:
-! - step_fac : step length to update the models, f.e. 0.03 for plusminus 3%
-!
-! setup:
-!
-!- INPUT_MODEL/ contains:
-! proc000***_reg1_vsv.bin &
-! proc000***_reg1_vsh.bin &
-! proc000***_reg1_vpv.bin &
-! proc000***_reg1_vph.bin &
-! proc000***_reg1_eta.bin &
-! proc000***_reg1_rho.bin
-!
-!- INPUT_GRADIENT/ contains:
-! proc000***_reg1_bulk_c_kernel_smooth.bin &
-! proc000***_reg1_bulk_betav_kernel_smooth.bin &
-! proc000***_reg1_bulk_betah_kernel_smooth.bin &
-! proc000***_reg1_eta_kernel_smooth.bin
-!
-!- topo/ contains:
-! proc000***_reg1_solver_data_1.bin
-!
-! new models are stored in
-!- OUTPUT_MODEL/ as
-! proc000***_reg1_vpv_new.bin &
-! proc000***_reg1_vph_new.bin &
-! proc000***_reg1_vsv_new.bin &
-! proc000***_reg1_vsh_new.bin &
-! proc000***_reg1_eta_new.bin &
-! proc000***_reg1_rho_new.bin
-!
-! USAGE: ./add_model_globe_tiso 0.3
-
-module model_update_tiso
-
- include 'mpif.h'
- include '../XHEADER_FILES/constants.h'
- include '../XHEADER_FILES/precision.h'
- include '../XHEADER_FILES/values_from_mesher.h'
-
- ! ======================================================
-
- ! density scaling factor with shear perturbations
- ! see e.g. Montagner & Anderson (1989), Panning & Romanowicz (2006)
- real(kind=CUSTOM_REAL),parameter :: RHO_SCALING = 0.33_CUSTOM_REAL
-
- ! constraint on eta model
- real(kind=CUSTOM_REAL),parameter :: LIMIT_ETA_MIN = 0.5_CUSTOM_REAL
- real(kind=CUSTOM_REAL),parameter :: LIMIT_ETA_MAX = 1.5_CUSTOM_REAL
-
- ! ======================================================
-
- integer, parameter :: NSPEC = NSPEC_CRUST_MANTLE
- integer, parameter :: NGLOB = NGLOB_CRUST_MANTLE
-
- ! transverse isotropic model files
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- model_vpv,model_vph,model_vsv,model_vsh,model_eta,model_rho
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- model_vpv_new,model_vph_new,model_vsv_new,model_vsh_new,model_eta_new,model_rho_new
-
- ! model updates
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- model_dbulk,model_dbetah,model_dbetav,model_deta
-
- ! kernels
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- kernel_bulk,kernel_betav,kernel_betah,kernel_eta
-
- ! volume
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: x, y, z
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
- integer, dimension(NSPEC) :: idoubling
-
- ! gradient vector norm ( v^T * v )
- real(kind=CUSTOM_REAL) :: norm_bulk,norm_betav,norm_betah,norm_eta
- real(kind=CUSTOM_REAL) :: norm_bulk_sum,norm_betav_sum, &
- norm_betah_sum,norm_eta_sum
-
- ! model update length
- real(kind=CUSTOM_REAL) :: step_fac,step_length
-
- real(kind=CUSTOM_REAL) :: min_vpv,min_vph,min_vsv,min_vsh, &
- max_vpv,max_vph,max_vsv,max_vsh,min_eta,max_eta,min_bulk,max_bulk, &
- min_rho,max_rho,max,minmax(4)
-
- real(kind=CUSTOM_REAL) :: betav1,betah1,betav0,betah0,rho1,rho0, &
- betaiso1,betaiso0,eta1,eta0,alphav1,alphav0,alphah1,alphah0
- real(kind=CUSTOM_REAL) :: dbetaiso,dbulk
-
- integer :: nfile, myrank, sizeprocs, ier
- integer :: i, j, k,ispec, iglob, ishell, n, it, j1, ib, npts_sem, ios
- character(len=256) :: sline, m_file, fname
- character(len=256) :: input_model,input_kernel,output_model
-
-end module model_update_tiso
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-program add_model
-
- use model_update_tiso
-
- implicit none
-
- ! ============ program starts here =====================
-
- ! initializes arrays
- call initialize()
-
- ! reads in parameters needed
- call read_parameters()
-
- ! reads in current transverse isotropic model files: vpv.. & vsv.. & eta & rho
- call read_model()
-
- ! reads in smoothed kernels: bulk, betav, betah, eta
- call read_kernels()
-
- ! computes volume element associated with points, calculates kernel integral for statistics
- call compute_volume()
-
- ! calculates gradient
- ! steepest descent method
- call get_gradient()
-
- ! compute new model in terms of alpha, beta, eta and rho
- ! (see also Carl's Latex notes)
-
- ! model update:
- ! transverse isotropic update only in layer Moho to 220 (where SPECFEM3D_GLOBE considers TISO)
- ! everywhere else uses an isotropic update
- do ispec = 1, NSPEC
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! initial model values
- eta0 = model_eta(i,j,k,ispec)
- betav0 = model_vsv(i,j,k,ispec)
- betah0 = model_vsh(i,j,k,ispec)
- rho0 = model_rho(i,j,k,ispec)
- alphav0 = model_vpv(i,j,k,ispec)
- alphah0 = model_vph(i,j,k,ispec)
-
- eta1 = 0._CUSTOM_REAL
- betav1 = 0._CUSTOM_REAL
- betah1 = 0._CUSTOM_REAL
- rho1 = 0._CUSTOM_REAL
- alphav1 = 0._CUSTOM_REAL
- alphah1 = 0._CUSTOM_REAL
-
- ! do not use transverse isotropy except if element is between d220 and Moho
- if(.not. ( idoubling(ispec)== IFLAG_670_220 .or.idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO) ) then
-
- ! isotropic model update
-
- ! no eta perturbation, since eta = 1 in isotropic media
- eta1 = eta0
-
- ! shear values
- ! isotropic kernel K_beta = K_betav + K_betah
- ! with same scaling step_length the model update dbeta_iso = dbetav + dbetah
- ! note:
- ! this step length can be twice as big as that given by the input
- dbetaiso = model_dbetav(i,j,k,ispec) + model_dbetah(i,j,k,ispec)
- betav1 = betav0 * exp( dbetaiso )
- betah1 = betah0 * exp( dbetaiso )
- ! note: betah is probably not really used in isotropic layers
- ! (see SPECFEM3D_GLOBE/get_model.f90)
-
- ! density: uses scaling relation with isotropic shear perturbations
- ! dln rho = RHO_SCALING * dln betaiso
- rho1 = rho0 * exp( RHO_SCALING * dbetaiso )
-
- ! alpha values
- dbulk = model_dbulk(i,j,k,ispec)
- alphav1 = sqrt( alphav0**2 * exp(2.0*dbulk) + FOUR_THIRDS * betav0**2 * ( &
- exp(2.0*dbetaiso) - exp(2.0*dbulk) ) )
- alphah1 = sqrt( alphah0**2 * exp(2.0*dbulk) + FOUR_THIRDS * betah0**2 * ( &
- exp(2.0*dbetaiso) - exp(2.0*dbulk) ) )
- ! note: alphah probably not used in SPECFEM3D_GLOBE
-
- else
-
- ! transverse isotropic model update
-
- ! eta value : limits updated values for eta range constraint
- eta1 = eta0 * exp( model_deta(i,j,k,ispec) )
- if( eta1 < LIMIT_ETA_MIN ) eta1 = LIMIT_ETA_MIN
- if( eta1 > LIMIT_ETA_MAX ) eta1 = LIMIT_ETA_MAX
-
- ! shear values
- betav1 = betav0 * exp( model_dbetav(i,j,k,ispec) )
- betah1 = betah0 * exp( model_dbetah(i,j,k,ispec) )
-
- ! density: uses scaling relation with Voigt average of shear perturbations
- betaiso0 = sqrt( ( 2.0 * betav0**2 + betah0**2 ) / 3.0 )
- betaiso1 = sqrt( ( 2.0 * betav1**2 + betah1**2 ) / 3.0 )
- dbetaiso = log( betaiso1 / betaiso0 )
- rho1 = rho0 * exp( RHO_SCALING * dbetaiso )
-
- ! alpha values
- dbulk = model_dbulk(i,j,k,ispec)
- alphav1 = sqrt( alphav0**2 * exp(2.0*dbulk) &
- + FOUR_THIRDS * betav0**2 * ( &
- exp(2.0*model_dbetav(i,j,k,ispec)) - exp(2.0*dbulk) ) )
- alphah1 = sqrt( alphah0**2 * exp(2.0*dbulk) &
- + FOUR_THIRDS * betah0**2 * ( &
- exp(2.0*model_dbetah(i,j,k,ispec)) - exp(2.0*dbulk) ) )
-
- endif
-
-
- ! stores new model values
- model_vpv_new(i,j,k,ispec) = alphav1
- model_vph_new(i,j,k,ispec) = alphah1
- model_vsv_new(i,j,k,ispec) = betav1
- model_vsh_new(i,j,k,ispec) = betah1
- model_eta_new(i,j,k,ispec) = eta1
- model_rho_new(i,j,k,ispec) = rho1
-
- enddo
- enddo
- enddo
- enddo
-
- ! stores new model in files
- call store_new_model()
-
- ! stores relative model perturbations
- call store_perturbations()
-
- ! stop all the MPI processes, and exit
- call MPI_FINALIZE(ier)
-
-end program add_model
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine initialize()
-
-! initializes arrays
-
- use model_update_tiso
- implicit none
-
- ! initialize the MPI communicator and start the NPROCTOT MPI processes
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- if( sizeprocs /= nchunks_val*nproc_xi_val*nproc_eta_val ) then
- print*,'sizeprocs:',sizeprocs,nchunks_val,nproc_xi_val,nproc_eta_val
- call exit_mpi(myrank,'error number sizeprocs')
- endif
-
- ! model
- model_vpv = 0.0_CUSTOM_REAL
- model_vph = 0.0_CUSTOM_REAL
- model_vsv = 0.0_CUSTOM_REAL
- model_vsh = 0.0_CUSTOM_REAL
- model_eta = 0.0_CUSTOM_REAL
- model_rho = 0.0_CUSTOM_REAL
-
- model_vpv_new = 0.0_CUSTOM_REAL
- model_vph_new = 0.0_CUSTOM_REAL
- model_vsv_new = 0.0_CUSTOM_REAL
- model_vsh_new = 0.0_CUSTOM_REAL
- model_eta_new = 0.0_CUSTOM_REAL
- model_rho_new = 0.0_CUSTOM_REAL
-
- ! model updates
- model_dbulk = 0.0_CUSTOM_REAL
- model_dbetah = 0.0_CUSTOM_REAL
- model_dbetav = 0.0_CUSTOM_REAL
- model_deta = 0.0_CUSTOM_REAL
-
- ! gradients
- kernel_bulk = 0.0_CUSTOM_REAL
- kernel_betav = 0.0_CUSTOM_REAL
- kernel_betah = 0.0_CUSTOM_REAL
- kernel_eta = 0.0_CUSTOM_REAL
-
-end subroutine initialize
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine read_parameters()
-
-! reads in parameters needed
-
- use model_update_tiso
- implicit none
- character(len=150) :: s_step_fac
-
- ! subjective step length to multiply to the gradient
- !step_fac = 0.03
-
- call getarg(1,s_step_fac)
-!> Hejun Zhu
- call getarg(2,input_model)
- call getarg(3,input_kernel)
- call getarg(4,output_model)
-!< Hejun Zhu
-
-
-!> Hejun Zhu
-! if (trim(s_step_fac) == '') then
-! call exit_MPI(myrank,'Usage: add_model_globe_tiso step_factor')
-! endif
- if (trim(s_step_fac) == '' .or. trim(input_model) == '' &
- .or. trim(input_kernel) == ''.or. trim(output_model) == '') then
- call exit_MPI(myrank, 'Usage: add model_globe_tiso step_factor input_model input_kernel output_model')
- endif
-!< Hejun Zhu
-
-
- ! read in parameter information
- read(s_step_fac,*) step_fac
- !if( abs(step_fac) < 1.e-10) then
- ! print*,'error: step factor ',step_fac
- ! call exit_MPI(myrank,'error step factor')
- !endif
-
- if (myrank == 0) then
- print*,'defaults'
- print*,' NPROC_XI , NPROC_ETA: ',nproc_xi_val,nproc_eta_val
- print*,' NCHUNKS: ',nchunks_val
- print*
- print*,'model update for vsv,vsh,vpv,vph,eta,rho:'
- print*,' step_fac = ',step_fac
- print*,' input model dir = ', trim(input_model)
- print*,' input gradient dir=', trim(input_kernel)
- print*,' output model dir= ', trim(output_model)
- print*
-
- endif
-
-
-end subroutine read_parameters
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine read_model()
-
-! reads in current transverse isotropic model: vpv.. & vsv.. & eta & rho
-
- use model_update_tiso
- implicit none
-
- ! vpv model
- write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vpv.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) model_vpv(:,:,:,1:nspec)
- close(12)
-
- ! vph model
- write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vph.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) model_vph(:,:,:,1:nspec)
- close(12)
-
- ! vsv model
- write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vsv.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) model_vsv(:,:,:,1:nspec)
- close(12)
-
- ! vsh model
- write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vsh.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) model_vsh(:,:,:,1:nspec)
- close(12)
-
- ! eta model
- write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_eta.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) model_eta(:,:,:,1:nspec)
- close(12)
-
- ! rho model
- write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_rho.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) model_rho(:,:,:,1:nspec)
- close(12)
-
- ! statistics
- call mpi_reduce(minval(model_vpv),min_vpv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_vpv),max_vpv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_vph),min_vph,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_vph),max_vph,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_vsv),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_vsv),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_vsh),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_vsh),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_eta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_eta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_rho),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_rho),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- if( myrank == 0 ) then
- print*,'initial models:'
- print*,' vpv min/max: ',min_vpv,max_vpv
- print*,' vph min/max: ',min_vph,max_vph
- print*,' vsv min/max: ',min_vsv,max_vsv
- print*,' vsh min/max: ',min_vsh,max_vsh
- print*,' eta min/max: ',min_eta,max_eta
- print*,' rho min/max: ',min_rho,max_rho
- print*
- endif
-
-end subroutine read_model
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine read_kernels()
-
-! reads in smoothed kernels: bulk, betav, betah, eta
-
- use model_update_tiso
- implicit none
-
- ! bulk kernel
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_c_kernel_precond_smooth.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) kernel_bulk(:,:,:,1:nspec)
- close(12)
-
- ! betav kernel
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_betav_kernel_precond_smooth.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) kernel_betav(:,:,:,1:nspec)
- close(12)
-
- ! betah kernel
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_betah_kernel_precond_smooth.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) kernel_betah(:,:,:,1:nspec)
- close(12)
-
- ! eta kernel
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_eta_kernel_precond_smooth.bin'
- open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(12) kernel_eta(:,:,:,1:nspec)
- close(12)
-
-
- ! statistics
- call mpi_reduce(minval(kernel_bulk),min_bulk,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(kernel_bulk),max_bulk,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(kernel_betah),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(kernel_betah),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(kernel_betav),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(kernel_betav),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(kernel_eta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(kernel_eta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- if( myrank == 0 ) then
- print*,'initial kernels:'
- print*,' bulk min/max : ',min_bulk,max_bulk
- print*,' betav min/max: ',min_vsv,max_vsv
- print*,' betah min/max: ',min_vsh,max_vsh
- print*,' eta min/max : ',min_eta,max_eta
- print*
- endif
-
-end subroutine read_kernels
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine compute_volume()
-
-! computes volume element associated with points
-
- use model_update_tiso
- implicit none
- ! jacobian
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: jacobian
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl, &
- jacobianl,volumel
- ! integration values
- real(kind=CUSTOM_REAL) :: integral_bulk_sum,integral_betav_sum, &
- integral_betah_sum,integral_eta_sum
- real(kind=CUSTOM_REAL) :: integral_bulk,integral_betav,&
- integral_betah,integral_eta
- real(kind=CUSTOM_REAL) :: volume_glob,volume_glob_sum
- ! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll, wxgll
- double precision, dimension(NGLLY) :: yigll, wygll
- double precision, dimension(NGLLZ) :: zigll, wzgll
- ! array with all the weights in the cube
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- ! GLL points
- wgll_cube = 0.0d0
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
- enddo
- enddo
- enddo
-
- ! global addressing
- write(m_file,'(a,i6.6,a)') &
- '/tigress-hsm/hejunzhu/2011EUROPE_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE/proc',myrank,'_reg1_solver_data_2.bin'
- open(11,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(11) x(1:nglob)
- read(11) y(1:nglob)
- read(11) z(1:nglob)
- read(11) ibool(:,:,:,1:nspec)
- read(11) idoubling(1:nspec)
- close(11)
-
- ! builds jacobian
- write(m_file,'(a,i6.6,a)') &
- '/tigress-hsm/hejunzhu/2011EUROPE_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE/proc',myrank,'_reg1_solver_data_1.bin'
- open(11,file=trim(m_file),status='old',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',trim(m_file)
- call exit_mpi(myrank,'file not found')
- endif
- read(11) xix
- read(11) xiy
- read(11) xiz
- read(11) etax
- read(11) etay
- read(11) etaz
- read(11) gammax
- read(11) gammay
- read(11) gammaz
- close(11)
-
- jacobian = 0.0
- do ispec = 1, NSPEC
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- ! gets derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- ! computes the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
- jacobian(i,j,k,ispec) = jacobianl
-
- !if( abs(jacobianl) < 1.e-8 ) then
- ! print*,'rank ',myrank,'jacobian: ',jacobianl,i,j,k,wgll_cube(i,j,k)
- !endif
-
- enddo
- enddo
- enddo
- enddo
-
- ! volume associated with global point
- volume_glob = 0.0
- integral_bulk = 0._CUSTOM_REAL
- integral_betav = 0._CUSTOM_REAL
- integral_betah = 0._CUSTOM_REAL
- integral_eta = 0._CUSTOM_REAL
- norm_bulk = 0._CUSTOM_REAL
- norm_betav = 0._CUSTOM_REAL
- norm_betah = 0._CUSTOM_REAL
- norm_eta = 0._CUSTOM_REAL
- do ispec = 1, NSPEC
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool(i,j,k,ispec)
- if( iglob == 0 ) then
- print*,'iglob zero',i,j,k,ispec
- print*
- print*,'ibool:',ispec
- print*,ibool(:,:,:,ispec)
- print*
- call exit_MPI(myrank,'error ibool')
- endif
-
- ! volume associated with GLL point
- volumel = jacobian(i,j,k,ispec)*wgll_cube(i,j,k)
- volume_glob = volume_glob + volumel
-
- ! kernel integration: for each element
- integral_bulk = integral_bulk &
- + volumel * kernel_bulk(i,j,k,ispec)
-
- integral_betav = integral_betav &
- + volumel * kernel_betav(i,j,k,ispec)
-
- integral_betah = integral_betah &
- + volumel * kernel_betah(i,j,k,ispec)
-
- integral_eta = integral_eta &
- + volumel * kernel_eta(i,j,k,ispec)
-
- ! gradient vector norm sqrt( v^T * v )
- norm_bulk = norm_bulk + kernel_bulk(i,j,k,ispec)*kernel_bulk(i,j,k,ispec)
- norm_betav = norm_betav + kernel_betav(i,j,k,ispec)*kernel_betav(i,j,k,ispec)
- norm_betah = norm_betah + kernel_betah(i,j,k,ispec)*kernel_betah(i,j,k,ispec)
- norm_eta = norm_eta + kernel_eta(i,j,k,ispec)*kernel_eta(i,j,k,ispec)
-
- ! checks number
- if( isNaN(integral_bulk) ) then
- print*,'error NaN: ',integral_bulk
- print*,'rank:',myrank
- print*,'i,j,k,ispec:',i,j,k,ispec
- print*,'volumel: ',volumel,'kernel_bulk:',kernel_bulk(i,j,k,ispec)
- call exit_MPI(myrank,'error NaN')
- endif
-
- enddo
- enddo
- enddo
- enddo
-
- ! statistics
- ! kernel integration: for whole volume
- call mpi_reduce(integral_bulk,integral_bulk_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(integral_betav,integral_betav_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(integral_betah,integral_betah_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(integral_eta,integral_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(volume_glob,volume_glob_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
-
- if( myrank == 0 ) then
- print*,'integral kernels:'
- print*,' bulk : ',integral_bulk_sum
- print*,' betav : ',integral_betav_sum
- print*,' betah : ',integral_betah_sum
- print*,' eta : ',integral_eta_sum
- print*
- print*,' total volume:',volume_glob_sum
- print*
- endif
-
- ! norms: for whole volume
- call mpi_reduce(norm_bulk,norm_bulk_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(norm_betav,norm_betav_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(norm_betah,norm_betah_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(norm_eta,norm_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
-
- norm_bulk = sqrt(norm_bulk_sum)
- norm_betav = sqrt(norm_betav_sum)
- norm_betah = sqrt(norm_betah_sum)
- norm_eta = sqrt(norm_eta_sum)
-
- if( myrank == 0 ) then
- print*,'norm kernels:'
- print*,' bulk : ',norm_bulk
- print*,' betav : ',norm_betav
- print*,' betah : ',norm_betah
- print*,' eta : ',norm_eta
- print*
- endif
-
-end subroutine compute_volume
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine get_gradient()
-
-! calculates gradient by steepest descent method
-
- use model_update_tiso
- implicit none
- ! local parameters
- ! ------------------------------------------------------------------------
- ! sets maximum update in this depth range
- logical,parameter :: use_depth_maximum = .false.
- ! normalized radii
- real(kind=CUSTOM_REAL),parameter :: R_top = (6371.0 - 50.0 ) / R_EARTH_KM ! shallow depth
- real(kind=CUSTOM_REAL),parameter :: R_bottom = (6371.0 - 600.0 ) / R_EARTH_KM ! deep depth
- real(kind=CUSTOM_REAL):: r,depth_max
- ! ------------------------------------------------------------------------
-
- ! initializes kernel maximum
- max = 0._CUSTOM_REAL
-
- ! gradient in negative direction for steepest descent
- do ispec = 1, NSPEC
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! for bulk
- model_dbulk(i,j,k,ispec) = kernel_bulk(i,j,k,ispec) ! no negative sign, in conjugate direction subroutine
-
- ! for shear
- model_dbetav(i,j,k,ispec) = kernel_betav(i,j,k,ispec)
- model_dbetah(i,j,k,ispec) = kernel_betah(i,j,k,ispec)
-
- ! for eta
- model_deta(i,j,k,ispec) = kernel_eta(i,j,k,ispec)
-
- ! determines maximum kernel betav value within given radius
- if( use_depth_maximum ) then
- ! get radius of point
- iglob = ibool(i,j,k,ispec)
- r = sqrt( x(iglob)*x(iglob) + y(iglob)*y(iglob) + z(iglob)*z(iglob) )
-
- ! stores maximum kernel betav value in this depth slice, since betav is most likely dominating
- if( r < R_top .and. r > R_bottom ) then
- ! kernel betav value
- max_vsv = abs( kernel_betav(i,j,k,ispec) )
- if( max < max_vsv ) then
- max = max_vsv
- depth_max = r
- endif
- endif
- endif
-
- enddo
- enddo
- enddo
- enddo
-
-!> Hejun Zhu
- ! stores model_dbulk, ... arrays
-! call store_kernel_updates()
-!< Hejun Zhu
-
- ! statistics
- call mpi_reduce(minval(model_dbulk),min_bulk,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_dbulk),max_bulk,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_dbetav),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_dbetav),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_dbetah),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_dbetah),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_deta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_deta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- if( myrank == 0 ) then
- print*,'initial gradients:'
- print*,' bulk min/max : ',min_bulk,max_bulk
- print*,' betav min/max: ',min_vsv,max_vsv
- print*,' betah min/max: ',min_vsh,max_vsh
- print*,' eta min/max : ',min_eta,max_eta
- print*
- endif
-
- ! determines maximum kernel betav value within given radius
- if( use_depth_maximum ) then
- ! maximum of all processes stored in max_vsv
- call mpi_reduce(max,max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- max = max_vsv
- depth_max = 6371.0 *( 1.0 - depth_max )
- endif
-
- ! determines step length
- ! based on maximum gradient value (either vsv or vsh)
- if( myrank == 0 ) then
-
- ! determines maximum kernel betav value within given radius
- if( use_depth_maximum ) then
- print*,' using depth maximum between 50km and 100km: ',max
- print*,' approximate depth maximum: ',depth_max
- print*
- else
- ! maximum gradient values
- minmax(1) = abs(min_vsv)
- minmax(2) = abs(max_vsv)
- minmax(3) = abs(min_vsh)
- minmax(4) = abs(max_vsh)
-
- ! maximum value of all kernel maxima
- max = maxval(minmax)
- print*,' using maximum: ',max
- print*
- endif
-
- ! chooses step length such that it becomes the desired, given step factor as inputted
- step_length = step_fac/max
-
- print*,' step length : ',step_length
- print*
-
- endif
- call mpi_bcast(step_length,1,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
-
-
- ! gradient length sqrt( v^T * v )
- norm_bulk = sum( model_dbulk * model_dbulk )
- norm_betav = sum( model_dbetav * model_dbetav )
- norm_betah = sum( model_dbetah * model_dbetah )
- norm_eta = sum( model_deta * model_deta )
-
- call mpi_reduce(norm_bulk,norm_bulk_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(norm_betav,norm_betav_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(norm_betah,norm_betah_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(norm_eta,norm_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
-
- norm_bulk = sqrt(norm_bulk_sum)
- norm_betav = sqrt(norm_betav_sum)
- norm_betah = sqrt(norm_betah_sum)
- norm_eta = sqrt(norm_eta_sum)
-
- if( myrank == 0 ) then
- print*,'norm model updates:'
- print*,' bulk : ',norm_bulk
- print*,' betav: ',norm_betav
- print*,' betah: ',norm_betah
- print*,' eta : ',norm_eta
- print*
- endif
-
- ! multiply model updates by a subjective factor that will change the step
- model_dbulk(:,:,:,:) = step_length * model_dbulk(:,:,:,:)
- model_dbetav(:,:,:,:) = step_length * model_dbetav(:,:,:,:)
- model_dbetah(:,:,:,:) = step_length * model_dbetah(:,:,:,:)
- model_deta(:,:,:,:) = step_length * model_deta(:,:,:,:)
-
-
- ! statistics
- call mpi_reduce(minval(model_dbulk),min_bulk,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_dbulk),max_bulk,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_dbetav),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_dbetav),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_dbetah),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_dbetah),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- call mpi_reduce(minval(model_deta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(maxval(model_deta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- if( myrank == 0 ) then
- print*,'scaled gradients:'
- print*,' bulk min/max : ',min_bulk,max_bulk
- print*,' betav min/max: ',min_vsv,max_vsv
- print*,' betah min/max: ',min_vsh,max_vsh
- print*,' eta min/max : ',min_eta,max_eta
- print*
- endif
-
-end subroutine get_gradient
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine store_kernel_updates()
-
-! file output for new model
-
- use model_update_tiso
- implicit none
-
- ! kernel updates
- fname = 'dbulk_c'
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_dbulk
- close(12)
-
- fname = 'dbetav'
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_dbetav
- close(12)
-
- fname = 'dbetah'
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_dbetah
- close(12)
-
- fname = 'deta'
- write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_deta
- close(12)
-
-end subroutine store_kernel_updates
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine store_new_model()
-
-! file output for new model
-
- use model_update_tiso
- implicit none
-
- ! vpv model
- call mpi_reduce(maxval(model_vpv_new),max_vpv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(model_vpv_new),min_vpv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- fname = 'vpv'
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_vpv_new
- close(12)
-
- ! vph model
- call mpi_reduce(maxval(model_vph_new),max_vph,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(model_vph_new),min_vph,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- fname = 'vph'
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_vph_new
- close(12)
-
- ! vsv model
- call mpi_reduce(maxval(model_vsv_new),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(model_vsv_new),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- fname = 'vsv'
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_vsv_new
- close(12)
-
- ! vsh model
- call mpi_reduce(maxval(model_vsh_new),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(model_vsh_new),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- fname = 'vsh'
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_vsh_new
- close(12)
-
- ! eta model
- call mpi_reduce(maxval(model_eta_new),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(model_eta_new),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- fname = 'eta'
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_eta_new
- close(12)
-
- ! rho model
- call mpi_reduce(maxval(model_rho_new),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(model_rho_new),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
- fname = 'rho'
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) model_rho_new
- close(12)
-
-
- if( myrank == 0 ) then
- print*,'new models:'
- print*,' vpv min/max: ',min_vpv,max_vpv
- print*,' vph min/max: ',min_vph,max_vph
- print*,' vsv min/max: ',min_vsv,max_vsv
- print*,' vsh min/max: ',min_vsh,max_vsh
- print*,' eta min/max: ',min_eta,max_eta
- print*,' rho min/max: ',min_rho,max_rho
- print*
- endif
-
-
-end subroutine store_new_model
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine store_perturbations()
-
-! file output for new model
-
- use model_update_tiso
- implicit none
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: total_model
-
- ! vpv relative perturbations
- ! logarithmic perturbation: log( v_new) - log( v_old) = log( v_new / v_old )
- total_model = 0.0_CUSTOM_REAL
- where( model_vpv /= 0.0 ) total_model = log( model_vpv_new / model_vpv)
- ! or
- ! linear approximation: (v_new - v_old) / v_old
- !where( model_vpv /= 0.0 ) total_model = ( model_vpv_new - model_vpv) / model_vpv
-
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvpvvpv.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) total_model
- close(12)
- call mpi_reduce(maxval(total_model),max_vpv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(total_model),min_vpv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
-
- ! vph relative perturbations
- total_model = 0.0_CUSTOM_REAL
- where( model_vph /= 0.0 ) total_model = log( model_vph_new / model_vph)
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvphvph.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) total_model
- close(12)
- call mpi_reduce(maxval(total_model),max_vph,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(total_model),min_vph,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
-
- ! vsv relative perturbations
- total_model = 0.0_CUSTOM_REAL
- where( model_vsv /= 0.0 ) total_model = log( model_vsv_new / model_vsv)
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvsvvsv.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) total_model
- close(12)
- call mpi_reduce(maxval(total_model),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(total_model),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
-
- ! vsh relative perturbations
- total_model = 0.0_CUSTOM_REAL
- where( model_vsh /= 0.0 ) total_model = log( model_vsh_new / model_vsh)
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvshvsh.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) total_model
- close(12)
- call mpi_reduce(maxval(total_model),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(total_model),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
-
- ! eta relative perturbations
- total_model = 0.0_CUSTOM_REAL
- where( model_eta /= 0.0 ) total_model = log( model_eta_new / model_eta)
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_detaeta.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) total_model
- close(12)
- call mpi_reduce(maxval(total_model),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(total_model),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
-
- ! rho relative model perturbations
- total_model = 0.0_CUSTOM_REAL
- where( model_rho /= 0.0 ) total_model = log( model_rho_new / model_rho)
- write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_drhorho.bin'
- open(12,file=trim(m_file),form='unformatted',action='write')
- write(12) total_model
- close(12)
- call mpi_reduce(maxval(total_model),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call mpi_reduce(minval(total_model),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
-
- if( myrank == 0 ) then
- print*,'relative update:'
- print*,' dvpv/vpv min/max: ',min_vpv,max_vpv
- print*,' dvph/vph min/max: ',min_vph,max_vph
- print*,' dvsv/vsv min/max: ',min_vsv,max_vsv
- print*,' dvsh/vsh min/max: ',min_vsh,max_vsh
- print*,' deta/eta min/max: ',min_eta,max_eta
- print*,' drho/rho min/max: ',min_rho,max_rho
- print*
- endif
-
-end subroutine store_perturbations
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,1135 @@
+! add_model_globe_tiso
+!
+! this program can be used to update TRANSVERSE ISOTROPIC model files
+! based on smoothed event kernels.
+! the kernels are given for tranverse isotropic parameters (bulk_c,bulk_betav,bulk_betah,eta).
+!
+! the algorithm uses a steepest descent method with a step length
+! determined by the given maximum update percentage.
+!
+! input:
+! - step_fac : step length to update the models, f.e. 0.03 for plusminus 3%
+!
+! setup:
+!
+!- INPUT_MODEL/ contains:
+! proc000***_reg1_vsv.bin &
+! proc000***_reg1_vsh.bin &
+! proc000***_reg1_vpv.bin &
+! proc000***_reg1_vph.bin &
+! proc000***_reg1_eta.bin &
+! proc000***_reg1_rho.bin
+!
+!- INPUT_GRADIENT/ contains:
+! proc000***_reg1_bulk_c_kernel_smooth.bin &
+! proc000***_reg1_bulk_betav_kernel_smooth.bin &
+! proc000***_reg1_bulk_betah_kernel_smooth.bin &
+! proc000***_reg1_eta_kernel_smooth.bin
+!
+!- topo/ contains:
+! proc000***_reg1_solver_data_1.bin
+!
+! new models are stored in
+!- OUTPUT_MODEL/ as
+! proc000***_reg1_vpv_new.bin &
+! proc000***_reg1_vph_new.bin &
+! proc000***_reg1_vsv_new.bin &
+! proc000***_reg1_vsh_new.bin &
+! proc000***_reg1_eta_new.bin &
+! proc000***_reg1_rho_new.bin
+!
+! USAGE: ./add_model_globe_tiso 0.3
+
+module model_update_tiso
+
+ include 'mpif.h'
+ include '../../SHARE_FILES/HEADER_FILES/constants.h'
+ include '../../SHARE_FILES/HEADER_FILES/precision.h'
+ include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+
+ ! ======================================================
+
+ ! density scaling factor with shear perturbations
+ ! see e.g. Montagner & Anderson (1989), Panning & Romanowicz (2006)
+ real(kind=CUSTOM_REAL),parameter :: RHO_SCALING = 0.33_CUSTOM_REAL
+
+ ! constraint on eta model
+ real(kind=CUSTOM_REAL),parameter :: LIMIT_ETA_MIN = 0.5_CUSTOM_REAL
+ real(kind=CUSTOM_REAL),parameter :: LIMIT_ETA_MAX = 1.5_CUSTOM_REAL
+
+ ! ======================================================
+
+ integer, parameter :: NSPEC = NSPEC_CRUST_MANTLE
+ integer, parameter :: NGLOB = NGLOB_CRUST_MANTLE
+
+ ! transverse isotropic model files
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ model_vpv,model_vph,model_vsv,model_vsh,model_eta,model_rho
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ model_vpv_new,model_vph_new,model_vsv_new,model_vsh_new,model_eta_new,model_rho_new
+
+ ! model updates
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ model_dbulk,model_dbetah,model_dbetav,model_deta
+
+ ! kernels
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ kernel_bulk,kernel_betav,kernel_betah,kernel_eta
+
+ ! volume
+ real(kind=CUSTOM_REAL), dimension(NGLOB) :: x, y, z
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ integer, dimension(NSPEC) :: idoubling
+
+ ! gradient vector norm ( v^T * v )
+ real(kind=CUSTOM_REAL) :: norm_bulk,norm_betav,norm_betah,norm_eta
+ real(kind=CUSTOM_REAL) :: norm_bulk_sum,norm_betav_sum, &
+ norm_betah_sum,norm_eta_sum
+
+ ! model update length
+ real(kind=CUSTOM_REAL) :: step_fac,step_length
+
+ real(kind=CUSTOM_REAL) :: min_vpv,min_vph,min_vsv,min_vsh, &
+ max_vpv,max_vph,max_vsv,max_vsh,min_eta,max_eta,min_bulk,max_bulk, &
+ min_rho,max_rho,max,minmax(4)
+
+ real(kind=CUSTOM_REAL) :: betav1,betah1,betav0,betah0,rho1,rho0, &
+ betaiso1,betaiso0,eta1,eta0,alphav1,alphav0,alphah1,alphah0
+ real(kind=CUSTOM_REAL) :: dbetaiso,dbulk
+
+ integer :: nfile, myrank, sizeprocs, ier
+ integer :: i, j, k,ispec, iglob, ishell, n, it, j1, ib, npts_sem, ios
+ character(len=256) :: sline, m_file, fname
+ character(len=256) :: input_model,input_kernel,output_model
+
+end module model_update_tiso
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+program add_model
+
+ use model_update_tiso
+
+ implicit none
+
+ ! ============ program starts here =====================
+
+ ! initializes arrays
+ call initialize()
+
+ ! reads in parameters needed
+ call read_parameters()
+
+ ! reads in current transverse isotropic model files: vpv.. & vsv.. & eta & rho
+ call read_model()
+
+ ! reads in smoothed kernels: bulk, betav, betah, eta
+ call read_kernels()
+
+ ! computes volume element associated with points, calculates kernel integral for statistics
+ call compute_volume()
+
+ ! calculates gradient
+ ! steepest descent method
+ call get_gradient()
+
+ ! compute new model in terms of alpha, beta, eta and rho
+ ! (see also Carl's Latex notes)
+
+ ! model update:
+ ! transverse isotropic update only in layer Moho to 220 (where SPECFEM3D_GLOBE considers TISO)
+ ! everywhere else uses an isotropic update
+ do ispec = 1, NSPEC
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! initial model values
+ eta0 = model_eta(i,j,k,ispec)
+ betav0 = model_vsv(i,j,k,ispec)
+ betah0 = model_vsh(i,j,k,ispec)
+ rho0 = model_rho(i,j,k,ispec)
+ alphav0 = model_vpv(i,j,k,ispec)
+ alphah0 = model_vph(i,j,k,ispec)
+
+ eta1 = 0._CUSTOM_REAL
+ betav1 = 0._CUSTOM_REAL
+ betah1 = 0._CUSTOM_REAL
+ rho1 = 0._CUSTOM_REAL
+ alphav1 = 0._CUSTOM_REAL
+ alphah1 = 0._CUSTOM_REAL
+
+ ! do not use transverse isotropy except if element is between d220 and Moho
+ if(.not. ( idoubling(ispec)== IFLAG_670_220 .or.idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO) ) then
+
+ ! isotropic model update
+
+ ! no eta perturbation, since eta = 1 in isotropic media
+ eta1 = eta0
+
+ ! shear values
+ ! isotropic kernel K_beta = K_betav + K_betah
+ ! with same scaling step_length the model update dbeta_iso = dbetav + dbetah
+ ! note:
+ ! this step length can be twice as big as that given by the input
+ dbetaiso = model_dbetav(i,j,k,ispec) + model_dbetah(i,j,k,ispec)
+ betav1 = betav0 * exp( dbetaiso )
+ betah1 = betah0 * exp( dbetaiso )
+ ! note: betah is probably not really used in isotropic layers
+ ! (see SPECFEM3D_GLOBE/get_model.f90)
+
+ ! density: uses scaling relation with isotropic shear perturbations
+ ! dln rho = RHO_SCALING * dln betaiso
+ rho1 = rho0 * exp( RHO_SCALING * dbetaiso )
+
+ ! alpha values
+ dbulk = model_dbulk(i,j,k,ispec)
+ alphav1 = sqrt( alphav0**2 * exp(2.0*dbulk) + FOUR_THIRDS * betav0**2 * ( &
+ exp(2.0*dbetaiso) - exp(2.0*dbulk) ) )
+ alphah1 = sqrt( alphah0**2 * exp(2.0*dbulk) + FOUR_THIRDS * betah0**2 * ( &
+ exp(2.0*dbetaiso) - exp(2.0*dbulk) ) )
+ ! note: alphah probably not used in SPECFEM3D_GLOBE
+
+ else
+
+ ! transverse isotropic model update
+
+ ! eta value : limits updated values for eta range constraint
+ eta1 = eta0 * exp( model_deta(i,j,k,ispec) )
+ if( eta1 < LIMIT_ETA_MIN ) eta1 = LIMIT_ETA_MIN
+ if( eta1 > LIMIT_ETA_MAX ) eta1 = LIMIT_ETA_MAX
+
+ ! shear values
+ betav1 = betav0 * exp( model_dbetav(i,j,k,ispec) )
+ betah1 = betah0 * exp( model_dbetah(i,j,k,ispec) )
+
+ ! density: uses scaling relation with Voigt average of shear perturbations
+ betaiso0 = sqrt( ( 2.0 * betav0**2 + betah0**2 ) / 3.0 )
+ betaiso1 = sqrt( ( 2.0 * betav1**2 + betah1**2 ) / 3.0 )
+ dbetaiso = log( betaiso1 / betaiso0 )
+ rho1 = rho0 * exp( RHO_SCALING * dbetaiso )
+
+ ! alpha values
+ dbulk = model_dbulk(i,j,k,ispec)
+ alphav1 = sqrt( alphav0**2 * exp(2.0*dbulk) &
+ + FOUR_THIRDS * betav0**2 * ( &
+ exp(2.0*model_dbetav(i,j,k,ispec)) - exp(2.0*dbulk) ) )
+ alphah1 = sqrt( alphah0**2 * exp(2.0*dbulk) &
+ + FOUR_THIRDS * betah0**2 * ( &
+ exp(2.0*model_dbetah(i,j,k,ispec)) - exp(2.0*dbulk) ) )
+
+ endif
+
+
+ ! stores new model values
+ model_vpv_new(i,j,k,ispec) = alphav1
+ model_vph_new(i,j,k,ispec) = alphah1
+ model_vsv_new(i,j,k,ispec) = betav1
+ model_vsh_new(i,j,k,ispec) = betah1
+ model_eta_new(i,j,k,ispec) = eta1
+ model_rho_new(i,j,k,ispec) = rho1
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! stores new model in files
+ call store_new_model()
+
+ ! stores relative model perturbations
+ call store_perturbations()
+
+ ! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+end program add_model
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine initialize()
+
+! initializes arrays
+
+ use model_update_tiso
+ implicit none
+
+ ! initialize the MPI communicator and start the NPROCTOT MPI processes
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ if( sizeprocs /= nchunks_val*nproc_xi_val*nproc_eta_val ) then
+ print*,'sizeprocs:',sizeprocs,nchunks_val,nproc_xi_val,nproc_eta_val
+ call exit_mpi(myrank,'error number sizeprocs')
+ endif
+
+ ! model
+ model_vpv = 0.0_CUSTOM_REAL
+ model_vph = 0.0_CUSTOM_REAL
+ model_vsv = 0.0_CUSTOM_REAL
+ model_vsh = 0.0_CUSTOM_REAL
+ model_eta = 0.0_CUSTOM_REAL
+ model_rho = 0.0_CUSTOM_REAL
+
+ model_vpv_new = 0.0_CUSTOM_REAL
+ model_vph_new = 0.0_CUSTOM_REAL
+ model_vsv_new = 0.0_CUSTOM_REAL
+ model_vsh_new = 0.0_CUSTOM_REAL
+ model_eta_new = 0.0_CUSTOM_REAL
+ model_rho_new = 0.0_CUSTOM_REAL
+
+ ! model updates
+ model_dbulk = 0.0_CUSTOM_REAL
+ model_dbetah = 0.0_CUSTOM_REAL
+ model_dbetav = 0.0_CUSTOM_REAL
+ model_deta = 0.0_CUSTOM_REAL
+
+ ! gradients
+ kernel_bulk = 0.0_CUSTOM_REAL
+ kernel_betav = 0.0_CUSTOM_REAL
+ kernel_betah = 0.0_CUSTOM_REAL
+ kernel_eta = 0.0_CUSTOM_REAL
+
+end subroutine initialize
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine read_parameters()
+
+! reads in parameters needed
+
+ use model_update_tiso
+ implicit none
+ character(len=150) :: s_step_fac
+
+ ! subjective step length to multiply to the gradient
+ !step_fac = 0.03
+
+ call getarg(1,s_step_fac)
+!> Hejun Zhu
+ call getarg(2,input_model)
+ call getarg(3,input_kernel)
+ call getarg(4,output_model)
+!< Hejun Zhu
+
+
+!> Hejun Zhu
+! if (trim(s_step_fac) == '') then
+! call exit_MPI(myrank,'Usage: add_model_globe_tiso step_factor')
+! endif
+ if (trim(s_step_fac) == '' .or. trim(input_model) == '' &
+ .or. trim(input_kernel) == ''.or. trim(output_model) == '') then
+ call exit_MPI(myrank, 'Usage: add model_globe_tiso step_factor input_model input_kernel output_model')
+ endif
+!< Hejun Zhu
+
+
+ ! read in parameter information
+ read(s_step_fac,*) step_fac
+ !if( abs(step_fac) < 1.e-10) then
+ ! print*,'error: step factor ',step_fac
+ ! call exit_MPI(myrank,'error step factor')
+ !endif
+
+ if (myrank == 0) then
+ print*,'defaults'
+ print*,' NPROC_XI , NPROC_ETA: ',nproc_xi_val,nproc_eta_val
+ print*,' NCHUNKS: ',nchunks_val
+ print*
+ print*,'model update for vsv,vsh,vpv,vph,eta,rho:'
+ print*,' step_fac = ',step_fac
+ print*,' input model dir = ', trim(input_model)
+ print*,' input gradient dir=', trim(input_kernel)
+ print*,' output model dir= ', trim(output_model)
+ print*
+
+ endif
+
+
+end subroutine read_parameters
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine read_model()
+
+! reads in current transverse isotropic model: vpv.. & vsv.. & eta & rho
+
+ use model_update_tiso
+ implicit none
+
+ ! vpv model
+ write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vpv.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) model_vpv(:,:,:,1:nspec)
+ close(12)
+
+ ! vph model
+ write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vph.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) model_vph(:,:,:,1:nspec)
+ close(12)
+
+ ! vsv model
+ write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vsv.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) model_vsv(:,:,:,1:nspec)
+ close(12)
+
+ ! vsh model
+ write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vsh.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) model_vsh(:,:,:,1:nspec)
+ close(12)
+
+ ! eta model
+ write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_eta.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) model_eta(:,:,:,1:nspec)
+ close(12)
+
+ ! rho model
+ write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_rho.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) model_rho(:,:,:,1:nspec)
+ close(12)
+
+ ! statistics
+ call mpi_reduce(minval(model_vpv),min_vpv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_vpv),max_vpv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_vph),min_vph,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_vph),max_vph,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_vsv),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_vsv),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_vsh),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_vsh),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_eta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_eta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_rho),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_rho),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ if( myrank == 0 ) then
+ print*,'initial models:'
+ print*,' vpv min/max: ',min_vpv,max_vpv
+ print*,' vph min/max: ',min_vph,max_vph
+ print*,' vsv min/max: ',min_vsv,max_vsv
+ print*,' vsh min/max: ',min_vsh,max_vsh
+ print*,' eta min/max: ',min_eta,max_eta
+ print*,' rho min/max: ',min_rho,max_rho
+ print*
+ endif
+
+end subroutine read_model
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine read_kernels()
+
+! reads in smoothed kernels: bulk, betav, betah, eta
+
+ use model_update_tiso
+ implicit none
+
+ ! bulk kernel
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_c_kernel_precond_smooth.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) kernel_bulk(:,:,:,1:nspec)
+ close(12)
+
+ ! betav kernel
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_betav_kernel_precond_smooth.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) kernel_betav(:,:,:,1:nspec)
+ close(12)
+
+ ! betah kernel
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_betah_kernel_precond_smooth.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) kernel_betah(:,:,:,1:nspec)
+ close(12)
+
+ ! eta kernel
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_eta_kernel_precond_smooth.bin'
+ open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(12) kernel_eta(:,:,:,1:nspec)
+ close(12)
+
+
+ ! statistics
+ call mpi_reduce(minval(kernel_bulk),min_bulk,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(kernel_bulk),max_bulk,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(kernel_betah),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(kernel_betah),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(kernel_betav),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(kernel_betav),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(kernel_eta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(kernel_eta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ if( myrank == 0 ) then
+ print*,'initial kernels:'
+ print*,' bulk min/max : ',min_bulk,max_bulk
+ print*,' betav min/max: ',min_vsv,max_vsv
+ print*,' betah min/max: ',min_vsh,max_vsh
+ print*,' eta min/max : ',min_eta,max_eta
+ print*
+ endif
+
+end subroutine read_kernels
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_volume()
+
+! computes volume element associated with points
+
+ use model_update_tiso
+ implicit none
+ ! jacobian
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: jacobian
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl, &
+ jacobianl,volumel
+ ! integration values
+ real(kind=CUSTOM_REAL) :: integral_bulk_sum,integral_betav_sum, &
+ integral_betah_sum,integral_eta_sum
+ real(kind=CUSTOM_REAL) :: integral_bulk,integral_betav,&
+ integral_betah,integral_eta
+ real(kind=CUSTOM_REAL) :: volume_glob,volume_glob_sum
+ ! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll, wxgll
+ double precision, dimension(NGLLY) :: yigll, wygll
+ double precision, dimension(NGLLZ) :: zigll, wzgll
+ ! array with all the weights in the cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+ ! GLL points
+ wgll_cube = 0.0d0
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ ! global addressing
+ write(m_file,'(a,i6.6,a)') &
+ '/tigress-hsm/hejunzhu/2011EUROPE_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE/proc',myrank,'_reg1_solver_data_2.bin'
+ open(11,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(11) x(1:nglob)
+ read(11) y(1:nglob)
+ read(11) z(1:nglob)
+ read(11) ibool(:,:,:,1:nspec)
+ read(11) idoubling(1:nspec)
+ close(11)
+
+ ! builds jacobian
+ write(m_file,'(a,i6.6,a)') &
+ '/tigress-hsm/hejunzhu/2011EUROPE_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE/proc',myrank,'_reg1_solver_data_1.bin'
+ open(11,file=trim(m_file),status='old',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',trim(m_file)
+ call exit_mpi(myrank,'file not found')
+ endif
+ read(11) xix
+ read(11) xiy
+ read(11) xiz
+ read(11) etax
+ read(11) etay
+ read(11) etaz
+ read(11) gammax
+ read(11) gammay
+ read(11) gammaz
+ close(11)
+
+ jacobian = 0.0
+ do ispec = 1, NSPEC
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! gets derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ ! computes the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+ jacobian(i,j,k,ispec) = jacobianl
+
+ !if( abs(jacobianl) < 1.e-8 ) then
+ ! print*,'rank ',myrank,'jacobian: ',jacobianl,i,j,k,wgll_cube(i,j,k)
+ !endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! volume associated with global point
+ volume_glob = 0.0
+ integral_bulk = 0._CUSTOM_REAL
+ integral_betav = 0._CUSTOM_REAL
+ integral_betah = 0._CUSTOM_REAL
+ integral_eta = 0._CUSTOM_REAL
+ norm_bulk = 0._CUSTOM_REAL
+ norm_betav = 0._CUSTOM_REAL
+ norm_betah = 0._CUSTOM_REAL
+ norm_eta = 0._CUSTOM_REAL
+ do ispec = 1, NSPEC
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob == 0 ) then
+ print*,'iglob zero',i,j,k,ispec
+ print*
+ print*,'ibool:',ispec
+ print*,ibool(:,:,:,ispec)
+ print*
+ call exit_MPI(myrank,'error ibool')
+ endif
+
+ ! volume associated with GLL point
+ volumel = jacobian(i,j,k,ispec)*wgll_cube(i,j,k)
+ volume_glob = volume_glob + volumel
+
+ ! kernel integration: for each element
+ integral_bulk = integral_bulk &
+ + volumel * kernel_bulk(i,j,k,ispec)
+
+ integral_betav = integral_betav &
+ + volumel * kernel_betav(i,j,k,ispec)
+
+ integral_betah = integral_betah &
+ + volumel * kernel_betah(i,j,k,ispec)
+
+ integral_eta = integral_eta &
+ + volumel * kernel_eta(i,j,k,ispec)
+
+ ! gradient vector norm sqrt( v^T * v )
+ norm_bulk = norm_bulk + kernel_bulk(i,j,k,ispec)*kernel_bulk(i,j,k,ispec)
+ norm_betav = norm_betav + kernel_betav(i,j,k,ispec)*kernel_betav(i,j,k,ispec)
+ norm_betah = norm_betah + kernel_betah(i,j,k,ispec)*kernel_betah(i,j,k,ispec)
+ norm_eta = norm_eta + kernel_eta(i,j,k,ispec)*kernel_eta(i,j,k,ispec)
+
+ ! checks number
+ if( isNaN(integral_bulk) ) then
+ print*,'error NaN: ',integral_bulk
+ print*,'rank:',myrank
+ print*,'i,j,k,ispec:',i,j,k,ispec
+ print*,'volumel: ',volumel,'kernel_bulk:',kernel_bulk(i,j,k,ispec)
+ call exit_MPI(myrank,'error NaN')
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! statistics
+ ! kernel integration: for whole volume
+ call mpi_reduce(integral_bulk,integral_bulk_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(integral_betav,integral_betav_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(integral_betah,integral_betah_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(integral_eta,integral_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(volume_glob,volume_glob_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ if( myrank == 0 ) then
+ print*,'integral kernels:'
+ print*,' bulk : ',integral_bulk_sum
+ print*,' betav : ',integral_betav_sum
+ print*,' betah : ',integral_betah_sum
+ print*,' eta : ',integral_eta_sum
+ print*
+ print*,' total volume:',volume_glob_sum
+ print*
+ endif
+
+ ! norms: for whole volume
+ call mpi_reduce(norm_bulk,norm_bulk_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(norm_betav,norm_betav_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(norm_betah,norm_betah_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(norm_eta,norm_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ norm_bulk = sqrt(norm_bulk_sum)
+ norm_betav = sqrt(norm_betav_sum)
+ norm_betah = sqrt(norm_betah_sum)
+ norm_eta = sqrt(norm_eta_sum)
+
+ if( myrank == 0 ) then
+ print*,'norm kernels:'
+ print*,' bulk : ',norm_bulk
+ print*,' betav : ',norm_betav
+ print*,' betah : ',norm_betah
+ print*,' eta : ',norm_eta
+ print*
+ endif
+
+end subroutine compute_volume
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine get_gradient()
+
+! calculates gradient by steepest descent method
+
+ use model_update_tiso
+ implicit none
+ ! local parameters
+ ! ------------------------------------------------------------------------
+ ! sets maximum update in this depth range
+ logical,parameter :: use_depth_maximum = .false.
+ ! normalized radii
+ real(kind=CUSTOM_REAL),parameter :: R_top = (6371.0 - 50.0 ) / R_EARTH_KM ! shallow depth
+ real(kind=CUSTOM_REAL),parameter :: R_bottom = (6371.0 - 600.0 ) / R_EARTH_KM ! deep depth
+ real(kind=CUSTOM_REAL):: r,depth_max
+ ! ------------------------------------------------------------------------
+
+ ! initializes kernel maximum
+ max = 0._CUSTOM_REAL
+
+ ! gradient in negative direction for steepest descent
+ do ispec = 1, NSPEC
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! for bulk
+ model_dbulk(i,j,k,ispec) = kernel_bulk(i,j,k,ispec) ! no negative sign, in conjugate direction subroutine
+
+ ! for shear
+ model_dbetav(i,j,k,ispec) = kernel_betav(i,j,k,ispec)
+ model_dbetah(i,j,k,ispec) = kernel_betah(i,j,k,ispec)
+
+ ! for eta
+ model_deta(i,j,k,ispec) = kernel_eta(i,j,k,ispec)
+
+ ! determines maximum kernel betav value within given radius
+ if( use_depth_maximum ) then
+ ! get radius of point
+ iglob = ibool(i,j,k,ispec)
+ r = sqrt( x(iglob)*x(iglob) + y(iglob)*y(iglob) + z(iglob)*z(iglob) )
+
+ ! stores maximum kernel betav value in this depth slice, since betav is most likely dominating
+ if( r < R_top .and. r > R_bottom ) then
+ ! kernel betav value
+ max_vsv = abs( kernel_betav(i,j,k,ispec) )
+ if( max < max_vsv ) then
+ max = max_vsv
+ depth_max = r
+ endif
+ endif
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+!> Hejun Zhu
+ ! stores model_dbulk, ... arrays
+! call store_kernel_updates()
+!< Hejun Zhu
+
+ ! statistics
+ call mpi_reduce(minval(model_dbulk),min_bulk,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_dbulk),max_bulk,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_dbetav),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_dbetav),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_dbetah),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_dbetah),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_deta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_deta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ if( myrank == 0 ) then
+ print*,'initial gradients:'
+ print*,' bulk min/max : ',min_bulk,max_bulk
+ print*,' betav min/max: ',min_vsv,max_vsv
+ print*,' betah min/max: ',min_vsh,max_vsh
+ print*,' eta min/max : ',min_eta,max_eta
+ print*
+ endif
+
+ ! determines maximum kernel betav value within given radius
+ if( use_depth_maximum ) then
+ ! maximum of all processes stored in max_vsv
+ call mpi_reduce(max,max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ max = max_vsv
+ depth_max = 6371.0 *( 1.0 - depth_max )
+ endif
+
+ ! determines step length
+ ! based on maximum gradient value (either vsv or vsh)
+ if( myrank == 0 ) then
+
+ ! determines maximum kernel betav value within given radius
+ if( use_depth_maximum ) then
+ print*,' using depth maximum between 50km and 100km: ',max
+ print*,' approximate depth maximum: ',depth_max
+ print*
+ else
+ ! maximum gradient values
+ minmax(1) = abs(min_vsv)
+ minmax(2) = abs(max_vsv)
+ minmax(3) = abs(min_vsh)
+ minmax(4) = abs(max_vsh)
+
+ ! maximum value of all kernel maxima
+ max = maxval(minmax)
+ print*,' using maximum: ',max
+ print*
+ endif
+
+ ! chooses step length such that it becomes the desired, given step factor as inputted
+ step_length = step_fac/max
+
+ print*,' step length : ',step_length
+ print*
+
+ endif
+ call mpi_bcast(step_length,1,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+
+ ! gradient length sqrt( v^T * v )
+ norm_bulk = sum( model_dbulk * model_dbulk )
+ norm_betav = sum( model_dbetav * model_dbetav )
+ norm_betah = sum( model_dbetah * model_dbetah )
+ norm_eta = sum( model_deta * model_deta )
+
+ call mpi_reduce(norm_bulk,norm_bulk_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(norm_betav,norm_betav_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(norm_betah,norm_betah_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(norm_eta,norm_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ norm_bulk = sqrt(norm_bulk_sum)
+ norm_betav = sqrt(norm_betav_sum)
+ norm_betah = sqrt(norm_betah_sum)
+ norm_eta = sqrt(norm_eta_sum)
+
+ if( myrank == 0 ) then
+ print*,'norm model updates:'
+ print*,' bulk : ',norm_bulk
+ print*,' betav: ',norm_betav
+ print*,' betah: ',norm_betah
+ print*,' eta : ',norm_eta
+ print*
+ endif
+
+ ! multiply model updates by a subjective factor that will change the step
+ model_dbulk(:,:,:,:) = step_length * model_dbulk(:,:,:,:)
+ model_dbetav(:,:,:,:) = step_length * model_dbetav(:,:,:,:)
+ model_dbetah(:,:,:,:) = step_length * model_dbetah(:,:,:,:)
+ model_deta(:,:,:,:) = step_length * model_deta(:,:,:,:)
+
+
+ ! statistics
+ call mpi_reduce(minval(model_dbulk),min_bulk,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_dbulk),max_bulk,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_dbetav),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_dbetav),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_dbetah),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_dbetah),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ call mpi_reduce(minval(model_deta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(maxval(model_deta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ if( myrank == 0 ) then
+ print*,'scaled gradients:'
+ print*,' bulk min/max : ',min_bulk,max_bulk
+ print*,' betav min/max: ',min_vsv,max_vsv
+ print*,' betah min/max: ',min_vsh,max_vsh
+ print*,' eta min/max : ',min_eta,max_eta
+ print*
+ endif
+
+end subroutine get_gradient
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine store_kernel_updates()
+
+! file output for new model
+
+ use model_update_tiso
+ implicit none
+
+ ! kernel updates
+ fname = 'dbulk_c'
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_dbulk
+ close(12)
+
+ fname = 'dbetav'
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_dbetav
+ close(12)
+
+ fname = 'dbetah'
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_dbetah
+ close(12)
+
+ fname = 'deta'
+ write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_deta
+ close(12)
+
+end subroutine store_kernel_updates
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine store_new_model()
+
+! file output for new model
+
+ use model_update_tiso
+ implicit none
+
+ ! vpv model
+ call mpi_reduce(maxval(model_vpv_new),max_vpv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(model_vpv_new),min_vpv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ fname = 'vpv'
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_vpv_new
+ close(12)
+
+ ! vph model
+ call mpi_reduce(maxval(model_vph_new),max_vph,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(model_vph_new),min_vph,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ fname = 'vph'
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_vph_new
+ close(12)
+
+ ! vsv model
+ call mpi_reduce(maxval(model_vsv_new),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(model_vsv_new),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ fname = 'vsv'
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_vsv_new
+ close(12)
+
+ ! vsh model
+ call mpi_reduce(maxval(model_vsh_new),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(model_vsh_new),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ fname = 'vsh'
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_vsh_new
+ close(12)
+
+ ! eta model
+ call mpi_reduce(maxval(model_eta_new),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(model_eta_new),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ fname = 'eta'
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_eta_new
+ close(12)
+
+ ! rho model
+ call mpi_reduce(maxval(model_rho_new),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(model_rho_new),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ fname = 'rho'
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_'//trim(fname)//'.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) model_rho_new
+ close(12)
+
+
+ if( myrank == 0 ) then
+ print*,'new models:'
+ print*,' vpv min/max: ',min_vpv,max_vpv
+ print*,' vph min/max: ',min_vph,max_vph
+ print*,' vsv min/max: ',min_vsv,max_vsv
+ print*,' vsh min/max: ',min_vsh,max_vsh
+ print*,' eta min/max: ',min_eta,max_eta
+ print*,' rho min/max: ',min_rho,max_rho
+ print*
+ endif
+
+
+end subroutine store_new_model
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine store_perturbations()
+
+! file output for new model
+
+ use model_update_tiso
+ implicit none
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: total_model
+
+ ! vpv relative perturbations
+ ! logarithmic perturbation: log( v_new) - log( v_old) = log( v_new / v_old )
+ total_model = 0.0_CUSTOM_REAL
+ where( model_vpv /= 0.0 ) total_model = log( model_vpv_new / model_vpv)
+ ! or
+ ! linear approximation: (v_new - v_old) / v_old
+ !where( model_vpv /= 0.0 ) total_model = ( model_vpv_new - model_vpv) / model_vpv
+
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvpvvpv.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) total_model
+ close(12)
+ call mpi_reduce(maxval(total_model),max_vpv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(total_model),min_vpv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ ! vph relative perturbations
+ total_model = 0.0_CUSTOM_REAL
+ where( model_vph /= 0.0 ) total_model = log( model_vph_new / model_vph)
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvphvph.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) total_model
+ close(12)
+ call mpi_reduce(maxval(total_model),max_vph,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(total_model),min_vph,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ ! vsv relative perturbations
+ total_model = 0.0_CUSTOM_REAL
+ where( model_vsv /= 0.0 ) total_model = log( model_vsv_new / model_vsv)
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvsvvsv.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) total_model
+ close(12)
+ call mpi_reduce(maxval(total_model),max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(total_model),min_vsv,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ ! vsh relative perturbations
+ total_model = 0.0_CUSTOM_REAL
+ where( model_vsh /= 0.0 ) total_model = log( model_vsh_new / model_vsh)
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_dvshvsh.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) total_model
+ close(12)
+ call mpi_reduce(maxval(total_model),max_vsh,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(total_model),min_vsh,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ ! eta relative perturbations
+ total_model = 0.0_CUSTOM_REAL
+ where( model_eta /= 0.0 ) total_model = log( model_eta_new / model_eta)
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_detaeta.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) total_model
+ close(12)
+ call mpi_reduce(maxval(total_model),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(total_model),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ ! rho relative model perturbations
+ total_model = 0.0_CUSTOM_REAL
+ where( model_rho /= 0.0 ) total_model = log( model_rho_new / model_rho)
+ write(m_file,'(a,i6.6,a)') trim(output_model)//'/proc',myrank,'_reg1_drhorho.bin'
+ open(12,file=trim(m_file),form='unformatted',action='write')
+ write(12) total_model
+ close(12)
+ call mpi_reduce(maxval(total_model),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call mpi_reduce(minval(total_model),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ if( myrank == 0 ) then
+ print*,'relative update:'
+ print*,' dvpv/vpv min/max: ',min_vpv,max_vpv
+ print*,' dvph/vph min/max: ',min_vph,max_vph
+ print*,' dvsv/vsv min/max: ',min_vsv,max_vsv
+ print*,' dvsh/vsh min/max: ',min_vsh,max_vsh
+ print*,' deta/eta min/max: ',min_eta,max_eta
+ print*,' drho/rho min/max: ',min_rho,max_rho
+ print*
+ endif
+
+end subroutine store_perturbations
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,61 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "../XHEADER_FILES/constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(outputname),status='unknown')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-
-! stop all the MPI processes, and exit
-! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
- call MPI_FINALIZE(ier)
- call MPI_ABORT(ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 6
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ write(outputname,"('OUTPUT_FILES/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(outputname),status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+
+! stop all the MPI processes, and exit
+! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT
+ call MPI_FINALIZE(ier)
+ call MPI_ABORT(ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,529 +0,0 @@
-
-!=======================================================================
-!
-! Library to compute the Gauss-Lobatto-Legendre points and weights
-! Based on Gauss-Lobatto routines from M.I.T.
-! Department of Mechanical Engineering
-!
-!=======================================================================
-
- double precision function endw1(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- f3 = zero
- apb = alpha+beta
- if (n == 0) then
- endw1 = zero
- return
- endif
- f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw1 = f1
- return
- endif
- fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw1 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw1 = f3
-
- end function endw1
-
-!
-!=======================================================================
-!
-
- double precision function endw2(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- apb = alpha+beta
- f3 = zero
- if (n == 0) then
- endw2 = zero
- return
- endif
- f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw2 = f1
- return
- endif
- fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw2 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw2 = f3
-
- end function endw2
-
-!
-!=======================================================================
-!
-
- double precision function gammaf (x)
-
- implicit none
-
- double precision, parameter :: pi = 3.141592653589793d0
-
- double precision x
-
- double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
-
- gammaf = one
-
- if (x == -half) gammaf = -two*dsqrt(pi)
- if (x == half) gammaf = dsqrt(pi)
- if (x == one ) gammaf = one
- if (x == two ) gammaf = one
- if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
- if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
- if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
- if (x == 3.d0 ) gammaf = 2.d0
- if (x == 4.d0 ) gammaf = 6.d0
- if (x == 5.d0 ) gammaf = 24.d0
- if (x == 6.d0 ) gammaf = 120.d0
-
- end function gammaf
-
-!
-!=====================================================================
-!
-
- subroutine jacg (xjac,np,alpha,beta)
-
-!=======================================================================
-!
-! computes np Gauss points, which are the zeros of the
-! Jacobi polynomial with parameters alpha and beta
-!
-! .alpha = beta = 0.0 -> Legendre points
-! .alpha = beta = -0.5 -> Chebyshev points
-!
-!=======================================================================
-
- implicit none
-
- integer np
- double precision alpha,beta
- double precision xjac(np)
-
- integer k,j,i,jmin,jm,n
- double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
- double precision p,pd,pm1,pdm1,pm2,pdm2
-
- integer, parameter :: K_MAX_ITER = 10
- double precision, parameter :: zero = 0.d0, eps = 1.0d-12
-
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- xlast = 0.d0
- n = np-1
- dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
- p = 0.d0
- pd = 0.d0
- jmin = 0
- do j=1,np
- if(j == 1) then
- x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- else
- x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- x2 = xlast
- x = (x1+x2)/2.d0
- endif
- do k=1,K_MAX_ITER
- call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
- recsum = 0.d0
- jm = j-1
- do i=1,jm
- recsum = recsum+1.d0/(x-xjac(np-i+1))
- enddo
- delx = -p/(pd-recsum*p)
- x = x+delx
- if(abs(delx) < eps) goto 31
- enddo
- 31 continue
- xjac(np-j+1) = x
- xlast = x
- enddo
- do i=1,np
- xmin = 2.d0
- do j=i,np
- if(xjac(j) < xmin) then
- xmin = xjac(j)
- jmin = j
- endif
- enddo
- if(jmin /= i) then
- swap = xjac(i)
- xjac(i) = xjac(jmin)
- xjac(jmin) = swap
- endif
- enddo
-
- end subroutine jacg
-
-!
-!=====================================================================
-!
-
- subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
-
-!=======================================================================
-!
-! Computes the Jacobi polynomial of degree n and its derivative at x
-!
-!=======================================================================
-
- implicit none
-
- double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
- integer n
-
- double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
- integer k
-
- apb = alp+bet
- poly = 1.d0
- pder = 0.d0
- psave = 0.d0
- pdsave = 0.d0
-
- if (n == 0) return
-
- polyl = poly
- pderl = pder
- poly = (alp-bet+(apb+2.d0)*x)/2.d0
- pder = (apb+2.d0)/2.d0
- if (n == 1) return
-
- do k=2,n
- dk = dble(k)
- a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
- a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
- b3 = (2.d0*dk+apb-2.d0)
- a3 = b3*(b3+1.d0)*(b3+2.d0)
- a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
- polyn = ((a2+a3*x)*poly-a4*polyl)/a1
- pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
- psave = polyl
- pdsave = pderl
- polyl = poly
- poly = polyn
- pderl = pder
- pder = pdern
- enddo
-
- polym1 = polyl
- pderm1 = pderl
- polym2 = psave
- pderm2 = pdsave
-
- end subroutine jacobf
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNDLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the derivative of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P1D,P2D,P3D,FK,P3
- integer k
-
- P1 = 1.d0
- P2 = Z
- P1D = 0.d0
- P2D = 1.d0
- P3D = 1.d0
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
- P1 = P2
- P2 = P3
- P1D = P2D
- P2D = P3D
- enddo
-
- PNDLEG = P3D
-
- end function pndleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P3,FK
- integer k
-
- P1 = 1.d0
- P2 = Z
- P3 = P2
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P1 = P2
- P2 = P3
- enddo
-
- PNLEG = P3
-
- end function pnleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision function pnormj (n,alpha,beta)
-
- implicit none
-
- double precision alpha,beta
- integer n
-
- double precision one,two,dn,const,prod,dindx,frac
- double precision, external :: gammaf
- integer i
-
- one = 1.d0
- two = 2.d0
- dn = dble(n)
- const = alpha+beta+one
-
- if (n <= 1) then
- prod = gammaf(dn+alpha)*gammaf(dn+beta)
- prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
- pnormj = prod * two**const/(two*dn+const)
- return
- endif
-
- prod = gammaf(alpha+one)*gammaf(beta+one)
- prod = prod/(two*(one+const)*gammaf(const+one))
- prod = prod*(one+alpha)*(two+alpha)
- prod = prod*(one+beta)*(two+beta)
-
- do i=3,n
- dindx = dble(i)
- frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
- prod = prod*frac
- enddo
-
- pnormj = prod * two**const/(two*dn+const)
-
- end function pnormj
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgjd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g j d : Generate np Gauss-Jacobi points and weights
-! associated with Jacobi polynomial of degree n = np-1
-!
-! Note : Coefficients alpha and beta must be greater than -1.
-! ----
-!=======================================================================
-
- implicit none
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision z(np),w(np)
- double precision alpha,beta
-
- integer n,np1,np2,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
- double precision, external :: gammaf,pnormj
-
- pd = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- apb = alpha+beta
- p = zero
- pdm1 = zero
-
- if (np <= 0) stop 'minimum number of Gauss points is 1'
-
- if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
-
- if (np == 1) then
- z(1) = (beta-alpha)/(apb+two)
- w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
- return
- endif
-
- call jacg(z,np,alpha,beta)
-
- np1 = n+1
- np2 = n+2
- dnp1 = dble(np1)
- dnp2 = dble(np2)
- fac1 = dnp1+alpha+beta+one
- fac2 = fac1+dnp1
- fac3 = fac2+one
- fnorm = pnormj(np1,alpha,beta)
- rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
- do i=1,np
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
- w(i) = -rcoef/(p*pdm1)
- enddo
-
- end subroutine zwgjd
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgljd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
-! ----------- weights associated with Jacobi polynomials of degree
-! n = np-1.
-!
-! Note : alpha and beta coefficients must be greater than -1.
-! Legendre polynomials are special case of Jacobi polynomials
-! just by setting alpha and beta to 0.
-!
-!=======================================================================
-
- implicit none
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision alpha,beta
- double precision z(np), w(np)
-
- integer n,nm1,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision alpg,betg
- double precision, external :: endw1,endw2
-
- p = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- nm1 = n-1
- pd = zero
-
- if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
-
-! with spectral elements, use at least 3 points
- if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
-
- if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
-
- if (nm1 > 0) then
- alpg = alpha+one
- betg = beta+one
- call zwgjd(z(2),w(2),nm1,alpg,betg)
- endif
-
- z(1) = - one
- z(np) = one
-
- do i=2,np-1
- w(i) = w(i)/(one-z(i)**2)
- enddo
-
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
- w(1) = endw1(n,alpha,beta)/(two*pd)
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
- w(np) = endw2(n,alpha,beta)/(two*pd)
-
- end subroutine zwgljd
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,529 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if (n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*dsqrt(pi)
+ if (x == half) gammaf = dsqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'minimum number of Gauss points is 1'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/model_update_tiso.mod
===================================================================
(Binary files differ)
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xadd_model_globe
===================================================================
(Binary files differ)
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,19 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Tue Jan 25 17:19:32 EST 2011
-
-if [ ! -f ../XHEADER_FILES/constants.h ]; then
- echo WRONG! NO constants.h
- exit
-fi
-if [ ! -f ../XHEADER_FILES/values_from_mesher.h ]; then
- echo WRONG! NO values_from_mesher.h
- exit
-fi
-if [ ! -f ../XHEADER_FILES/precision.h ]; then
- echo WRONG! NO precision.h
- exit
-fi
-
-mpif90 -O3 -o xadd_model_globe add_model_globe.f90 exit_mpi.f90 gll_library.f90
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,19 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/constants.h ]; then
+ echo WRONG! NO constants.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/values_from_mesher.h ]; then
+ echo WRONG! NO values_from_mesher.h
+ exit
+fi
+if [ ! -f ../../SHARE_FILES/HEADER_FILES/precision.h ]; then
+ echo WRONG! NO precision.h
+ exit
+fi
+
+mpif90 -O3 -o xadd_model_globe add_model_globe.f90 exit_mpi.f90 gll_library.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xpbs_update_model.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xpbs_update_model.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/xpbs_update_model.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,53 +0,0 @@
-#!/bin/sh
-
-#PBS -q tromp
-#PBS -N XUPDATE_MODEL
-#PBS -l nodes=13:ppn=8
-#PBS -l walltime=15:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o job_src2.log
-
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-iter_old=M17
-iter_new=M18
-step_len=0.01
-method=CG
-
-
-xoutput_tag=XTAG_$iter_new
-
-
-input_model=../MODEL_$iter_old
-output_model=../MODEL_$iter_new
-
-if [ $method == SD ]; then
- input_kernel=../DIRECTION_SD_$iter_old
-elif [ $method == CG ]; then
- input_kernel=../DIRECTION_CG_$iter_old
-elif [ $method == LBFGS ]; then
- input_kernel=../DIRECTION_LBFGS_$iter_old
-fi
-
-
-if [ ! -d $input_model ]; then
- echo WRONG! NO $input_model
- exit
-fi
-if [ ! -d $input_kernel ]; then
- echo WRONG! NO $input_kernel
- exit
-fi
-if [ ! -d $output_model ]; then
- echo MKDIR $output_model
- mkdir $output_model
-fi
-
-echo submit updata model
-mpiexec -np 100 ./xadd_model_globe $step_len $input_model $input_kernel $output_model > $xoutput_tag
-echo done successfully
-
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XPBS_single_kernel_vtu.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XPBS_single_kernel_vtu.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XPBS_single_kernel_vtu.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,25 @@
+#!/bin/sh
+#PBS -q tromp
+#PBS -N XCOMBINE_KERNEL_200704090832A
+#PBS -l nodes=1:ppn=1
+#PBS -l walltime=5:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+slicefile=XSLICE_FILE
+topo_path=EUROPE_TOPOLOGY_FILE
+local_path=../MODEL_INVERSION/ADJOINT_M18/CMTSOLUTION_200704090832A/KERNEL/
+out_path=VTU_SINGLE_KERNEL_M18/CMTSOLUTION_200704090832A
+
+#for tag in bulk_c_kernel bulk_betav_kernel bulk_betah_kernel eta_kernel rho_kernel hess_kernel
+for tag in bulk_betav_kernel
+do
+ ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
+done
+
+echo combine kernels successfully
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XSHELL_single_kernel_vtu.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XSHELL_single_kernel_vtu.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XSHELL_single_kernel_vtu.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,74 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Sat Jan 22 18:47:49 EST 2011
+
+
+eventfile=../SHARE_FILES/EVENTID_CENTER/XEVENTID
+iter=M18
+slicefile=XSLICE_FILE
+
+savedir=VTU_SINGLE_KERNEL_$iter
+topo_path1=EUROPE_TOPOLOGY_FILE
+topo_path2="EUROPE_TOPOLOGY_FILE"
+
+
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+if [ ! -f $slicefile ]; then
+ echo WRONG! NO $slicefile
+ exit
+fi
+if [ ! -f xcombine_vol_data ]; then
+ echo WRONG! NO xcombine_vol_data
+ exit
+fi
+if [ ! -d $savedir ]; then
+ echo MKDIR $savedir
+ mkdir $savedir
+fi
+if [ ! -d $topo_path1 ]; then
+ echo WRONG !NO $topo_path 1
+ exit
+fi
+
+
+while read line
+do
+ cmtid=`echo $line | awk -F"_" '{print $2}'`
+ local_path1=../FORWARD_ADJOINT/ADJOINT_$iter/$line/KERNEL/
+ local_path2="..\/FORWARD_ADJOINT\/ADJOINT_$iter\/$line\/KERNEL\/"
+
+ out_path1=VTU_SINGLE_KERNEL_$iter/$line
+ out_path2="VTU_SINGLE_KERNEL_$iter\/$line"
+
+ proctag="#PBS -N XCOMBINE_KERNEL_$cmtid"
+
+ if [ ! -d $out_path1 ] ;then
+ echo MKDIR $out_path1
+ mkdir $out_path1
+ fi
+
+ if [ ! -d $local_path1 ]; then
+ echo WRONG! NO $local_path1
+ exit
+ fi
+
+
+ sed -e "s/^#PBS -N.*$/$proctag/g" \
+ -e "s/^slicefile=.*$/slicefile=$slicefile/g" \
+ -e "s/^topo_path=.*$/topo_path=$topo_path2/g" \
+ -e "s/^local_path=.*$/local_path=$local_path2/g" \
+ -e "s/^out_path=.*$/out_path=$out_path2/g" \
+ XPBS_single_kernel_vtu.sh > XPBS_single_kernel_vtu.sh.out
+ mv XPBS_single_kernel_vtu.sh.out XPBS_single_kernel_vtu.sh
+
+ echo qsub $line
+ qsub XPBS_single_kernel_vtu.sh
+ sleep 3
+
+done < $eventfile
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/XSHELL_single_kernel_vtu.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,31 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Mon Mar 7 15:56:47 EST 2011
-
-iter=M00
-
-model=MODEL_$iter
-dest=../MODEL_INVERSION/XSRC_SEM/DATA/GLL/
-
-if [ ! -d $model ]; then
- echo WRONG! NO $model
- exit
-fi
-if [ ! -d $dest ]; then
- echo WRONG! NO $dest
- exit
-fi
-
-echo copy vpv from $model ...
-cp $model/proc*_reg1_vpv.bin $dest
-echo copy vph from $model ...
-cp $model/proc*_reg1_vph.bin $dest
-echo copy vsv from $model ...
-cp $model/proc*_reg1_vsv.bin $dest
-echo copy vsh from $model ...
-cp $model/proc*_reg1_vsh.bin $dest
-echo copy rho from $model ...
-cp $model/proc*_reg1_rho.bin $dest
-echo copy eta from $model ...
-cp $model/proc*_reg1_eta.bin $dest
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,31 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Mon Mar 7 15:56:47 EST 2011
+
+iter=M00
+
+model=MODEL_$iter
+dest=../FORWARD_ADJOINT/XSRC_SEM/DATA/GLL/
+
+if [ ! -d $model ]; then
+ echo WRONG! NO $model
+ exit
+fi
+if [ ! -d $dest ]; then
+ echo WRONG! NO $dest
+ exit
+fi
+
+echo copy vpv from $model ...
+cp $model/proc*_reg1_vpv.bin $dest
+echo copy vph from $model ...
+cp $model/proc*_reg1_vph.bin $dest
+echo copy vsv from $model ...
+cp $model/proc*_reg1_vsv.bin $dest
+echo copy vsh from $model ...
+cp $model/proc*_reg1_vsh.bin $dest
+echo copy rho from $model ...
+cp $model/proc*_reg1_rho.bin $dest
+echo copy eta from $model ...
+cp $model/proc*_reg1_eta.bin $dest
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xcopy_model_to_mesher.sh
___________________________________________________________________
Name: svn:executable
+ *
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,74 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Sat Jan 22 18:47:49 EST 2011
-
-
-eventfile=EVENTID_CENTER/XEVENTID
-iter=M18
-slicefile=XSLICE_FILE
-
-savedir=VTU_SINGLE_KERNEL_$iter
-topo_path1=EUROPE_TOPOLOGY_FILE
-topo_path2="EUROPE_TOPOLOGY_FILE"
-
-
-if [ ! -f $eventfile ]; then
- echo WRONG! NO $eventfile
- exit
-fi
-if [ ! -f $slicefile ]; then
- echo WRONG! NO $slicefile
- exit
-fi
-if [ ! -f xcombine_vol_data ]; then
- echo WRONG! NO xcombine_vol_data
- exit
-fi
-if [ ! -d $savedir ]; then
- echo MKDIR $savedir
- mkdir $savedir
-fi
-if [ ! -d $topo_path1 ]; then
- echo WRONG !NO $topo_path 1
- exit
-fi
-
-
-while read line
-do
- cmtid=`echo $line | awk -F"_" '{print $2}'`
- local_path1=../MODEL_INVERSION/ADJOINT_$iter/$line/KERNEL/
- local_path2="..\/MODEL_INVERSION\/ADJOINT_$iter\/$line\/KERNEL\/"
-
- out_path1=VTU_SINGLE_KERNEL_$iter/$line
- out_path2="VTU_SINGLE_KERNEL_$iter\/$line"
-
- proctag="#PBS -N XCOMBINE_KERNEL_$cmtid"
-
- if [ ! -d $out_path1 ] ;then
- echo MKDIR $out_path1
- mkdir $out_path1
- fi
-
- if [ ! -d $local_path1 ]; then
- echo WRONG! NO $local_path1
- exit
- fi
-
-
- sed -e "s/^#PBS -N.*$/$proctag/g" \
- -e "s/^slicefile=.*$/slicefile=$slicefile/g" \
- -e "s/^topo_path=.*$/topo_path=$topo_path2/g" \
- -e "s/^local_path=.*$/local_path=$local_path2/g" \
- -e "s/^out_path=.*$/out_path=$out_path2/g" \
- xgen_single_kernel_vtu_pbs.sh > xgen_single_kernel_vtu_pbs.sh.out
- mv xgen_single_kernel_vtu_pbs.sh.out xgen_single_kernel_vtu_pbs.sh
-
- echo qsub $line
- qsub xgen_single_kernel_vtu_pbs.sh
- sleep 5
-
-done < $eventfile
-
-
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu_pbs.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu_pbs.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_single_kernel_vtu_pbs.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,25 +0,0 @@
-#!/bin/sh
-#PBS -q tromp
-#PBS -N XCOMBINE_KERNEL_200704090832A
-#PBS -l nodes=1:ppn=1
-#PBS -l walltime=5:00:00
-#PBS -j oe
-#PBS -k oe
-#PBS -o job_src2.log
-
-echo $PBS_O_WORKDIR
-cd $PBS_O_WORKDIR
-
-slicefile=XSLICE_FILE
-topo_path=EUROPE_TOPOLOGY_FILE
-local_path=../MODEL_INVERSION/ADJOINT_M18/CMTSOLUTION_200704090832A/KERNEL/
-out_path=VTU_SINGLE_KERNEL_M18/CMTSOLUTION_200704090832A
-
-#for tag in bulk_c_kernel bulk_betav_kernel bulk_betah_kernel eta_kernel rho_kernel hess_kernel
-for tag in bulk_betav_kernel
-do
- ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
-done
-
-echo combine kernels successfully
-
Deleted: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh 2012-11-05 20:04:29 UTC (rev 20988)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -1,77 +0,0 @@
-#!/bin/sh
-# Author: Hejun Zhu, hejunzhu at princeton.edu
-# Princeton University, New Jersey, USA
-# Last modified: Fri Sep 14 15:08:23 EDT 2012
-
-
-# This script is used to generate vtu file from bin file
-
-iter=M00
-vtu=KERNEL
-if [ $vtu == DIRECTION ]; then
- method=CG
-fi
-
-
-topo_path=EUROPE_TOPOLOGY_FILE
-slicefile=XSLIEC_FILE
-
-
-
-if [ $vtu == KERNEL ]; then
- local_path=SUMMED_KERNEL_$iter
- out_path=VTU_SUMMED_KERNEL_$iter
-elif [ $vtu == DIRECTION ]; then
- if [ $method == SD ]; then
- local_path=DIRECTION_SD_$iter
- output_path=VTU_DIRECTION_SD_$iter
- elif [ $method == CG ]; then
- local_path=DIRECTION_CG_$iter
- output_path=VTU_DIRECTION_CG_$iter
- elif [ $method == LBFGS ]; then
- local_path=DIRECTION_LBFGS_$iter
- output_path=VTU_DIRECTION_LBFGS_$iter
- else
- echo WRONG! NO $method
- fi
-elif [ $vtu == MODEL ]; then
- local_path=MODEL_$iter
- output_path=VTU_MODEL_$iter
-elif [ $vtu == MODEL_PERT ]; then
- local_path=MODEL_$iter"_PERT_STW"
- output_path=VTU_MODEL_$iter"_PERT_STW"
-else
- echo WRONG! NO $vtu
- exit
-fi
-
-if [ $vtu == KERNEL ]; then
- for tag in bulk_betav_kernel_precond_smooth bulk_betah_kernel_precond_smooth bulk_c_kernel_precond_smooth eta_kernel_precond_smooth
- do
- ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
- done
-elif [ $vtu == DIRECTION ]; then
- for tag in bulk_c_kernel_precond bulk_betav_kernel_precond bulk_betah_kernel_precond eta_kernel_precond rho_kernel_precond hess_kernel_precond
- do
- ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
- done
-elif [ $vtu == MODEL ]; then
- for tag in vpv vph vsv vsh eta rho
- do
-
- ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
- done
-elif [ $vtu == MODEL_PERT ]; then
- for tag in dvsh dvpv dvph deta drho
- do
- ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
- done
-
-else
- echo WRONG! NO $vtu
- exit
-fi
-
-
-
-
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/xgen_vtu_file.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,77 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Fri Sep 14 15:08:23 EDT 2012
+
+
+# This script is used to generate vtu file from bin file
+
+iter=M00
+vtu=KERNEL
+if [ $vtu == DIRECTION ]; then
+ method=CG
+fi
+
+
+topo_path=EUROPE_TOPOLOGY_FILE
+slicefile=XSLIEC_FILE
+
+
+
+if [ $vtu == KERNEL ]; then
+ local_path=SUMMED_KERNEL_$iter
+ out_path=VTU_SUMMED_KERNEL_$iter
+elif [ $vtu == DIRECTION ]; then
+ if [ $method == SD ]; then
+ local_path=DIRECTION_SD_$iter
+ output_path=VTU_DIRECTION_SD_$iter
+ elif [ $method == CG ]; then
+ local_path=DIRECTION_CG_$iter
+ output_path=VTU_DIRECTION_CG_$iter
+ elif [ $method == LBFGS ]; then
+ local_path=DIRECTION_LBFGS_$iter
+ output_path=VTU_DIRECTION_LBFGS_$iter
+ else
+ echo WRONG! NO $method
+ fi
+elif [ $vtu == MODEL ]; then
+ local_path=MODEL_$iter
+ output_path=VTU_MODEL_$iter
+elif [ $vtu == MODEL_PERT ]; then
+ local_path=MODEL_$iter"_PERT_STW"
+ output_path=VTU_MODEL_$iter"_PERT_STW"
+else
+ echo WRONG! NO $vtu
+ exit
+fi
+
+if [ $vtu == KERNEL ]; then
+ for tag in bulk_betav_kernel_precond_smooth bulk_betah_kernel_precond_smooth bulk_c_kernel_precond_smooth eta_kernel_precond_smooth
+ do
+ ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
+ done
+elif [ $vtu == DIRECTION ]; then
+ for tag in bulk_c_kernel_precond bulk_betav_kernel_precond bulk_betah_kernel_precond eta_kernel_precond rho_kernel_precond hess_kernel_precond
+ do
+ ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
+ done
+elif [ $vtu == MODEL ]; then
+ for tag in vpv vph vsv vsh eta rho
+ do
+
+ ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
+ done
+elif [ $vtu == MODEL_PERT ]; then
+ for tag in dvsh dvpv dvph deta drho
+ do
+ ./xcombine_vol_data $slicefile $tag $topo_path $local_path $out_path 0 1
+ done
+
+else
+ echo WRONG! NO $vtu
+ exit
+fi
+
+
+
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_HORIZON_FILE.m
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_HORIZON_FILE.m (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_HORIZON_FILE.m 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,37 @@
+clear all
+close all
+
+depth=400; % input depth km
+
+rnew=1.0-depth/6371.0;
+
+fnm_output=['XYZ_FILE_HORIZ/DEPTH_SLICE_',num2str(depth,'%3.3i'),'.xyz'];
+
+
+nglob=921600; %total number of GLL points
+fnm_input='SURFACE_GLL_POINTS.xyz';
+
+fid_input=fopen(fnm_input,'r');
+fid_output=fopen(fnm_output,'w');
+
+
+for i = 1:nglob
+ i
+ array=fscanf(fid_input,'%f',2);
+ lon=array(1);
+ lat=array(2);
+
+
+ phi=lon*pi/180.0;
+ theta=(90.0-lat)*pi/180.0;
+
+ xnew=rnew*sin(theta)*cos(phi);
+ ynew=rnew*sin(theta)*sin(phi);
+ znew=rnew*cos(theta);
+
+ fprintf(fid_output,'%f %f %f\n',xnew,ynew,znew);
+
+end
+
+fclose(fid_input);
+fclose(fid_output);
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_HORIZON_FILE.m
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_VERTICAL_FILE.m
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_VERTICAL_FILE.m (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_VERTICAL_FILE.m 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,88 @@
+clear all
+close all
+% cross section A, Carpathian-Adriatic slab, lon1=5(7.5),lat1=38(39); lon2=45(42.5),lat2=48(48);
+% cross section B, Hellenic arc, lon1=29, lat1=30; lon2=10, lat2=65;
+% cross section C, Eifle Hotspot, lon1=-5, lat1=49; lon2=30, lat2=47.5;
+% cross section D, Calabria arc, lon1=-5, lat1=39; lon2=30,lat2=37;
+% cross section E, Alps, lon1=10, lat1=30; lat2=10.1, lat2=65;
+% cross section F, Apennies, lon1=-5(0),lat1=34(37); lon2=35(35), lat2=49(49);
+% cross section G, Scandiawia, lon1=10, lat1=68; lon2=15; lat2=48.
+
+
+% cross section A, Carpathian-Adriatic slab, lon1=15,lat1=42.1 ; lon2=35,lat2=47.1;
+% cross section B, Hellenic arc, lon1=29, lat1=32.5; lon2=19, lat2=52.5;
+% cross section C, Alps, lon1=10, lat1=35; lat2=10.1, lat2=50;
+% cross section D, Scandiawia, lon1=11, lat1=65; lon2=14.5; lat2=50.
+% cross section E, Eifle Hotspot, lon1=0, lat1=50.5 ; lon2=20, lat2=47.5 ;
+% cross section F, Calabria arc, lon1=0, lat1=39.5; lon2=20,lat2=38.5;
+% cross section G, Apennies, lon1=0,lat1=32 ; lon2=20, lat2=47;
+% cross section H, Iaptus ocean, lon1=-10, lat1=61; lon2=10, lat2=48;
+% cross section SEIS, lon1=20.74,lat1=37.63; lon2=34.65, lat2=67.9;
+% cross section SINGLE, lon1=38.4273, lat1=38.3134; lon2=-6.6734, lat2=70.9573;
+% cross section CALA, lon1=0; lat1=38.8; lon2=20; lat2=38.8
+
+% comparison between EU30 and Wortel & Spakman
+% cross section APEN, lon1=10; lat1=35.5; lon2=30; lat2=51
+% cross section APENNEW, lon1=0; lat1=38.2; lon2=20; lat2=41.2
+% cross section SCAN, lon1=9.5; lat1=50; lon2=18; lat2=60
+% cross section Turkey, 1, lon1=27, lat1=35; lon2=27, lat2=42
+% cross section Turkey, 2, lon1=31, lat1=35; lon2=31, lat2=42
+% cross section Turkey, 3, lon1=40, lat1=35; lon2=40, lat2=42
+% cross section Turkey 4, lon1=26, lat1=39; lon2=44, lat2=39
+% cross section Turkey 5, lon1=26, lat1=37; lon2=44, lat2=37
+% cross section ICE1, lon1=-25; lat1=64.5; lon2=-12.5, lat2=64.5
+% cross section ICE2, lon1=-21, lat1=63; lon2=-12.5, lat2=66.5
+% cross section APLINE1, lon1=3.5,lat1=46; lon2=17.5,lat2=42.5
+% cross section APLINE2, lon1=6.4,lat1=51.5;lon2=12.2,lat2=43.5
+% cross section APLINE3, lon1=11,lat1=43.5;lon2=19,lat2=51
+
+% cross section Iapetus, lon1=-3,lat1=59; lon2=8;lat2=48;
+% cross section Tornquist, lon1=6.5,lat1=49; lon2=20,lat2=61;
+% cross section England, lon1=1.5;lat1=48; lon2=-7,lat2=59;
+
+lon1=1.5;
+lat1=48;
+
+lon2=-7;
+lat2=59;
+
+fnm='XYZ_FILE_VERT/VERT_SLICE_England.xyz';
+
+
+fid=fopen(fnm,'w');
+rtop=1;
+rbot=0.80; % 1200km depth
+
+%npt1=800;
+%npt2=500;
+
+npt1=300;
+npt2=200;
+
+
+dr=(rtop-rbot)/npt2;
+
+[ylat,xlon]=gcwaypts(lat2,lon2,lat1,lon1,npt1); %generate points along great circle
+
+for i = 1:npt1
+
+ phi=xlon(i)*pi/180.0;
+ theta=(90.0-ylat(i))*pi/180.0;
+
+ for j = 1:npt2
+ r=rtop-(j-1)*dr;
+
+ x=r*sin(theta)*cos(phi);
+ y=r*sin(theta)*sin(phi);
+ z=r*cos(theta);
+
+ fprintf(fid,'%f %f %f\n',x,y,z);
+
+ end
+end
+fclose(fid);
+% cross section Alpine 1, lon1=3.5, lat1=46; lon2=16, lat2=43
+% cross section Alpine 2, lon1=7.5, lat1=50.2; lon2=12.5, lat2=43;
+% cross section Alpine 3, lon1=10.5, lat1=43; lon2=16.5, lat2=49
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_GEN_XYZ_HORIZ_VERT/xgen_XYZ_VERTICAL_FILE.m
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XPBS_slice_horiz.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XPBS_slice_horiz.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XPBS_slice_horiz.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,27 @@
+#!/bin/sh
+
+
+#PBS -q tromp
+#PBS -N XSLICE
+#PBS -l nodes=12:ppn=8+1:ppn=4
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+
+depthslice=XYZ_FILE_HORIZ/DEPTH_SLICE_075.xyz
+topo_path=/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE
+model_path=/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/MODEL_M42_PERT_STW
+tag=dQmu
+gmtout=/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/XSRC_MODEL_SLICE_HORIZ/MODEL_M42_PERT_STW/DEPTH_SLICE_075_dQmu.xyz
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+echo submit slicing
+mpiexec -np 100 ./xsem_model_slice $depthslice $topo_path $model_path $tag $gmtout
+echo done successfully
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XPBS_slice_horiz.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XSHELL_slice_horiz.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XSHELL_slice_horiz.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XSHELL_slice_horiz.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,71 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 20:58:19 EST 2011
+
+iter=M42_PERT_STW
+
+topo_path="\/scratch\/lustre\/hejunzhu\/2012SHEAR_ATTENUATION_ITERATION_UPDATE\/EUROPE_TOPOLOGY_FILE"
+topo_path1=/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE
+
+model_path="\/scratch\/lustre\/hejunzhu\/2012SHEAR_ATTENUATION_ITERATION_UPDATE\/MODEL_$iter"
+model_path1=/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/MODEL_$iter
+
+out_path="\/scratch\/lustre\/hejunzhu\/2012SHEAR_ATTENUATION_ITERATION_UPDATE\/XSRC_MODEL_SLICE_HORIZ\/MODEL_$iter"
+out_path1=/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/XSRC_MODEL_SLICE_HORIZ/MODEL_$iter
+
+
+if [ ! -f xsem_model_slice ]; then
+ echo WRONG! NO xsem_model_slice
+ exit
+fi
+
+if [ ! -d $topo_path1 ]; then
+ echo WRONG !NO $topo_path1
+ exit
+fi
+
+if [ ! -d $model_path1 ]; then
+ echo WRONG! NO $model_path1
+ exit
+fi
+
+
+if [ ! -d $out_path1 ] ;then
+ echo MKDIR $out_path1
+ mkdir $out_path1
+fi
+
+#for depth in 005 025 050 075 125 175 225 275 325 375 425 475 525 575 625 675
+for depth in 075
+do
+ depthslice="XYZ_FILE_HORIZ\/DEPTH_SLICE_$depth.xyz"
+ depthslice1="XYZ_FILE_HORIZ/DEPTH_SLICE_$depth.xyz"
+ if [ ! -f $depthslice1 ]; then
+ echo WRONG! NO $depthslice1
+ exit
+ fi
+
+ #for tag in dvsh_vsv dbulk dpossion
+ #for tag in dvsh dvsh_vsv dbulk dpossion
+ #for tag in dvp_vs
+ for tag in dvsv dQmu
+ do
+ gmtout="\/scratch\/lustre\/hejunzhu\/2012SHEAR_ATTENUATION_ITERATION_UPDATE\/XSRC_MODEL_SLICE_HORIZ\/MODEL_$iter\/DEPTH_SLICE_"$depth"_"$tag".xyz"
+
+ echo $depth $tag
+
+ sed -e "s/^depthslice=.*$/depthslice=$depthslice/g"\
+ -e "s/^topo_path=.*$/topo_path=$topo_path/g"\
+ -e "s/^model_path=.*$/model_path=$model_path/g"\
+ -e "s/^tag=.*$/tag=$tag/g"\
+ -e "s/^gmtout=.*$/gmtout=$gmtout/g"\
+ xgen_slice_pbs.sh > xgen_slice_pbs.sh.out
+ mv xgen_slice_pbs.sh.out xgen_slice_pbs.sh
+ qsub xgen_slice_pbs.sh
+ sleep 5
+
+ done
+done
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/XSHELL_slice_horiz.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,107 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+ character(len=150) OUTPUT_FILES
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ write(outputname,"('/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+! close output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+
+! stop all the MPI processes, and exit
+! note: MPI_ABORT does not return, and does exit the
+! program with an error code of 30
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+
+! otherwise: there is no standard behaviour to exit with an error code in fortran,
+! however most compilers do recognize this as an error code stop statement;
+! to check stop code in terminal: > echo $?
+ stop 30
+
+ ! or just exit with message:
+ !stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
+
+! version without rank number printed in the error message
+ subroutine exit_MPI_without_rank(error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ character(len=*) error_msg
+
+ integer ier
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI...'
+
+! stop all the MPI processes, and exit
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI_without_rank
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/get_value_parameters.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/get_value_parameters.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/get_value_parameters.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,101 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine get_value_string(value_to_get, name, default_value)
+
+ implicit none
+
+ character(len=*) value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_string
+
+!--------------------
+
+! dummy subroutine to avoid warnings about variable not used in other subroutines
+ subroutine unused_string(s)
+
+ character(len=*) s
+
+ if (len(s) == 1) continue
+
+ end subroutine unused_string
+
+!--------------------
+
+!
+! unused routines:
+!
+
+! subroutine get_value_integer(value_to_get, name, default_value)
+!
+! implicit none
+!
+! integer value_to_get, default_value
+! character(len=*) name
+!
+! call unused_string(name)
+!
+! value_to_get = default_value
+!
+! end subroutine get_value_integer
+!
+!!--------------------
+!
+! subroutine get_value_double_precision(value_to_get, name, default_value)
+!
+! implicit none
+!
+! double precision value_to_get, default_value
+! character(len=*) name
+!
+! call unused_string(name)
+!
+! value_to_get = default_value
+!
+! end subroutine get_value_double_precision
+!
+!!--------------------
+!
+! subroutine get_value_logical(value_to_get, name, default_value)
+!
+! implicit none
+!
+! logical value_to_get, default_value
+! character(len=*) name
+!
+! call unused_string(name)
+!
+! value_to_get = default_value
+!
+! end subroutine get_value_logical
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,122 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, single precision call
+
+ implicit none
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ xmesh = dble(x)
+ ymesh = dble(y)
+ zmesh = dble(z)
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh))
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = sngl(datan2(ymesh,xmesh))
+
+ r = sngl(dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh))
+
+ else
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ endif
+
+ end subroutine xyz_2_rthetaphi
+
+!-------------------------------------------------------------
+
+ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, double precision call
+
+ implicit none
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ double precision x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ end subroutine xyz_2_rthetaphi_dble
+
+!-------------------------------------------------------------
+
+ subroutine rthetaphi_2_xyz(x,y,z,r,theta,phi)
+
+! convert r theta phi to x y z
+
+ implicit none
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+
+ x = r * sin(theta) * cos(phi)
+ y = r * sin(theta) * sin(phi)
+ z = r * cos(theta)
+
+ end subroutine rthetaphi_2_xyz
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/sem_model_slice.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/sem_model_slice.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/sem_model_slice.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,183 @@
+program sem_model_slice
+implicit none
+
+include 'mpif.h'
+include '../../SHARE_FILES/HEADER_FILES/constants.h'
+include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+include '../../SHARE_FILES/HEADER_FILES/precision.h'
+
+integer,parameter:: NUM_NODES=99 ! for recent mesher 100 processors
+integer,parameter:: iregion=1 ! for region one
+integer,parameter:: NMAXPTS=10000000
+real(kind=CUSTOM_REAL):: R_CUT_RANGE=0.00785d0 ! dr=0.00785 ~ 50 km depth
+
+integer::iproc,ipt,npts
+character(len=150):: xyz_infile,topo_dir,model_dir,filename,gmt_outfile
+character(len=256):: prname_topo, prname_file
+character(len=256):: topo_file, data_file
+real(kind=CUSTOM_REAL),dimension(NMAXPTS):: x,y,z
+real(kind=CUSTOM_REAL),dimension(NMAXPTS):: xfound,yfound,zfound,vfound
+real(kind=CUSTOM_REAL),dimension(NMAXPTS)::distmin,dist, distall, v, vall
+integer,dimension(NMAXPTS):: ispec_found,ix_found,iy_found,iz_found
+real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE):: xstore, ystore, zstore
+integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE):: ibool
+real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE):: vstore
+integer:: ier,sizeprocs,myrank,ios
+integer:: i,j,k,ispec,iglob
+real(kind=CUSTOM_REAL):: r,theta,phi,lat,lon,dep, xmesh,ymesh,zmesh
+real(kind=CUSTOM_REAL),dimension(2,NMAXPTS):: in,out
+real(kind=CUSTOM_REAL):: R_CUT, r1
+
+call MPI_INIT(ier)
+call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+! read input file
+call getarg(1,xyz_infile)
+call getarg(2,topo_dir)
+call getarg(3,model_dir)
+call getarg(4,filename)
+call getarg(5,gmt_outfile)
+
+! read interpolate points
+if ( myrank == 0) then
+ write(*,*) "INPUT FILE:", trim(xyz_infile)
+ write(*,*) "TOPOLOGY FILE:", trim(topo_dir)
+ write(*,*) "MODEL DIR:", trim(model_dir)
+ write(*,*) "VALUE NAME:", trim(filename)
+ write(*,*) "OUTPUT:", trim(gmt_outfile)
+end if
+
+
+open(1001,file=trim(xyz_infile),status='old',iostat=ios)
+i=0
+do while (1==1)
+ i=i+1
+ read(1001,*,iostat=ios) xmesh,ymesh,zmesh
+ R_CUT=sqrt(xmesh**2+ymesh**2+zmesh**2)
+ if (ios /= 0) exit
+ x(i)=xmesh
+ y(i)=ymesh
+ z(i)=zmesh
+end do
+close(1001)
+npts=i-1
+
+!end if
+!call MPI_BCAST(npts,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+!call MPI_BCAST(x,NMAXPTS,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+!call MPI_BCAST(y,NMAXPTS,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+!call MPI_BCAST(z,NMAXPTS,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+
+if ( myrank == 0 ) then
+ write(*,*) 'Total number of points = ', npts
+ if (npts>NMAXPTS .or. npts < 0) call exit_MPI(myrank,'Npts error...')
+end if
+
+
+write(prname_topo,'(a,i6.6,a,i1,a)') trim(topo_dir)//'/proc',myrank,'_reg',iregion,'_'
+write(prname_file,'(a,i6.6,a,i1,a)') trim(model_dir)//'/proc',myrank,'_reg',iregion,'_'
+
+! read value file
+data_file = trim(prname_file) // trim(filename) // '.bin'
+open(unit = 27,file = trim(data_file),status='old',action='read', iostat = ios,form ='unformatted')
+if (ios /= 0) call exit_MPI(myrank,'Error reading value file')
+read(27) vstore(:,:,:,1:NSPEC_CRUST_MANTLE)
+close(27)
+
+if (myrank ==0) write(*,*) 'DONE READING',trim(data_file)
+
+! read topology
+topo_file = trim(prname_topo) // 'solver_data_2' // '.bin'
+open(unit = 28,file = trim(topo_file),status='old',action='read', iostat = ios, form='unformatted')
+if (ios /= 0) call exit_MPI(myrank,'Error reading topology file')
+xstore(:) = 0.0
+ystore(:) = 0.0
+zstore(:) = 0.0
+ibool(:,:,:,:) = -1
+read(28) xstore(1:NGLOB_CRUST_MANTLE)
+read(28) ystore(1:NGLOB_CRUST_MANTLE)
+read(28) zstore(1:NGLOB_CRUST_MANTLE)
+read(28) ibool(:,:,:,1:NSPEC_CRUST_MANTLE)
+close(28)
+
+if (myrank == 0) write(*,*) 'DONE READING',trim(topo_file)
+
+distmin(1:npts)=HUGEVAL
+
+do ispec=1,NSPEC_CRUST_MANTLE
+
+ if (myrank == 0) write(*,*) 'ispec=',ispec
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob=ibool(i,j,k,ispec)
+
+
+ r1=sqrt((xstore(iglob))**2+(ystore(iglob))**2+(zstore(iglob))**2)
+
+ if ( abs(r1-R_CUT) < R_CUT_RANGE ) then
+ dist(1:npts) = dsqrt((x(1:npts)-dble(xstore(iglob)))**2 &
+ +(y(1:npts)-dble(ystore(iglob)))**2 &
+ +(z(1:npts)-dble(zstore(iglob)))**2)
+
+ do ipt=1,npts
+ if (dist(ipt) < distmin(ipt)) then
+ distmin(ipt)=dist(ipt)
+ ispec_found(ipt)=ispec
+ ix_found(ipt)=i
+ iy_found(ipt)=j
+ iz_found(ipt)=k
+ vfound(ipt)=vstore(i,j,k,ispec)
+ end if
+ end do ! ipt loop
+ end if ! radius within in a range
+
+ end do ! i loop
+ end do ! j loop
+ end do ! k loop
+end do ! ispec loop
+
+call MPI_BARRIER(MPI_COMM_WORLD,ier)
+if (myrank == 0) print*,'Done looping over global points'
+
+do i = 1,npts
+ in(1,i)=distmin(i)
+ in(2,i)=myrank
+end do
+call MPI_REDUCE(in,out,npts,CUSTOM_MPI_2REAL,MPI_MINLOC,0,MPI_COMM_WORLD,ier)
+
+call MPI_BCAST(out,2*npts,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+v(1:npts)=0
+dist(1:npts)=0.
+
+do i=1,npts
+ if (myrank == nint(out(2,i))) then
+ v(i)=vfound(i)
+ dist(i)=distmin(i)
+ end if
+end do
+
+call MPI_REDUCE(v,vall,npts,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+call MPI_REDUCE(dist,distall,npts,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+if (myrank == 0) then
+ open(1002, file=gmt_outfile,status='unknown')
+ do i = 1,npts
+ xmesh=x(i); ymesh=y(i); zmesh=z(i)
+ call xyz_2_rthetaphi(xmesh,ymesh,zmesh,r,theta,phi)
+ lat=90.0 - theta*180.0/PI
+ lon=phi*180.0/PI
+ dep=(1.0-r)*R_EARTH_KM
+! write(1002,*) lon,lat,dep,vall(i),distall(i)
+ write(1002,*) lon,lat,r,vall(i),distall(i)
+ end do
+ close(1002)
+end if
+
+202 FORMAT (5(F12.9,2X))
+call MPI_FINALIZE(ier)
+end program sem_model_slice
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,7 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+
+mpif90 -O3 -o xsem_model_slice sem_model_slice.f90 rthetaphi_xyz.f90 exit_mpi.f90 get_value_parameters.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XPBS_slice_vert.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XPBS_slice_vert.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XPBS_slice_vert.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+#PBS -q tromp
+#PBS -N XSLICE
+#PBS -l nodes=12:ppn=8+1:ppn=4
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+#PBS -o job_src2.log
+
+
+depthslice=XYZ_FILE/VERT_SLICE_England.xyz
+topo_path=/scratch/lustre/hejunzhu/2011EUROPE_SHOW_MODEL/EUROPE_TOPOLOGY_FILE_NO_TOPO_ELL
+model_path=/scratch/lustre/hejunzhu/2011EUROPE_SHOW_MODEL/MODEL_M30_PERT_STW
+tag=dvsv
+gmtout=/scratch/lustre/hejunzhu/2011EUROPE_SHOW_MODEL/XSRC_MODEL_SLICE_VERT/MODEL_M30_PERT_STW/VERT_SLICE_England_dvsv.xyz
+
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+echo submit slicing
+mpiexec -np 100 ./xsem_model_slice $depthslice $topo_path $model_path $tag $gmtout
+echo done successfully
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XPBS_slice_vert.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XSHELL_slice_vert.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XSHELL_slice_vert.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XSHELL_slice_vert.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,80 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 20:58:19 EST 2011
+
+iter=M30_PERT_STW
+
+topo_path="\/scratch\/lustre\/hejunzhu\/2011EUROPE_SHOW_MODEL\/EUROPE_TOPOLOGY_FILE_NO_TOPO_ELL"
+topo_path1=/scratch/lustre/hejunzhu/2011EUROPE_SHOW_MODEL/EUROPE_TOPOLOGY_FILE_NO_TOPO_ELL
+
+model_path="\/scratch\/lustre\/hejunzhu\/2011EUROPE_SHOW_MODEL\/MODEL_$iter"
+model_path1=/scratch/lustre/hejunzhu/2011EUROPE_SHOW_MODEL/MODEL_$iter
+
+#model_path="\/scratch\/lustre\/hejunzhu\/2011EUROPE_ITERATION_UPDATE\/MODEL_$iter"
+#model_path1=/scratch/lustre/hejunzhu/2011EUROPE_ITERATION_UPDATE/MODEL_$iter
+
+out_path="\/scratch\/lustre\/hejunzhu\/2011EUROPE_SHOW_MODEL\/XSRC_MODEL_SLICE_VERT\/MODEL_$iter"
+out_path1=/scratch/lustre/hejunzhu/2011EUROPE_SHOW_MODEL/XSRC_MODEL_SLICE_VERT/MODEL_$iter
+
+
+
+if [ ! -f xsem_model_slice ]; then
+ echo WRONG! NO xsem_model_slice
+ exit
+fi
+
+if [ ! -d $topo_path1 ]; then
+ echo WRONG !NO $topo_path1
+ exit
+fi
+
+if [ ! -d $model_path1 ]; then
+ echo WRONG! NO $model_path1
+ exit
+fi
+
+
+if [ ! -d $out_path1 ] ;then
+ echo MKDIR $out_path1
+ mkdir $out_path1
+fi
+
+
+#for sliceid in A B C D E F G H
+#for sliceid in SINGLE
+for sliceid in England
+do
+ echo submitting slice $sliceid
+
+ depthslice="XYZ_FILE\/VERT_SLICE_$sliceid.xyz"
+ depthslice1="XYZ_FILE/VERT_SLICE_$sliceid.xyz"
+
+
+ if [ ! -f $depthslice1 ]; then
+ echo WRONG! NO $depthslice1
+ exit
+ fi
+
+ #for tag in dvsh_vsv
+ #for tag in dvsv dvsh dvsh_vsv
+ #for tag in dvsh_vsv dvs dvp #dvsh dbulk # dvp
+ for tag in dvsv
+ do
+ gmtout="\/scratch\/lustre\/hejunzhu\/2011EUROPE_SHOW_MODEL\/XSRC_MODEL_SLICE_VERT\/MODEL_$iter\/VERT_SLICE_"$sliceid"_"$tag".xyz"
+
+
+ sed -e "s/^depthslice=.*$/depthslice=$depthslice/g"\
+ -e "s/^topo_path=.*$/topo_path=$topo_path/g"\
+ -e "s/^model_path=.*$/model_path=$model_path/g"\
+ -e "s/^tag=.*$/tag=$tag/g"\
+ -e "s/^gmtout=.*$/gmtout=$gmtout/g"\
+ xgen_slice_pbs.sh > xgen_slice_pbs.sh.out
+ mv xgen_slice_pbs.sh.out xgen_slice_pbs.sh
+ qsub xgen_slice_pbs.sh
+ sleep 5
+
+ done
+
+done
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/XSHELL_slice_vert.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,107 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+ character(len=150) OUTPUT_FILES
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ write(outputname,"('/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+! close output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+
+! stop all the MPI processes, and exit
+! note: MPI_ABORT does not return, and does exit the
+! program with an error code of 30
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+
+! otherwise: there is no standard behaviour to exit with an error code in fortran,
+! however most compilers do recognize this as an error code stop statement;
+! to check stop code in terminal: > echo $?
+ stop 30
+
+ ! or just exit with message:
+ !stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
+
+! version without rank number printed in the error message
+ subroutine exit_MPI_without_rank(error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ character(len=*) error_msg
+
+ integer ier
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI...'
+
+! stop all the MPI processes, and exit
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI_without_rank
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/get_value_parameters.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/get_value_parameters.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/get_value_parameters.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,101 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine get_value_string(value_to_get, name, default_value)
+
+ implicit none
+
+ character(len=*) value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_string
+
+!--------------------
+
+! dummy subroutine to avoid warnings about variable not used in other subroutines
+ subroutine unused_string(s)
+
+ character(len=*) s
+
+ if (len(s) == 1) continue
+
+ end subroutine unused_string
+
+!--------------------
+
+!
+! unused routines:
+!
+
+! subroutine get_value_integer(value_to_get, name, default_value)
+!
+! implicit none
+!
+! integer value_to_get, default_value
+! character(len=*) name
+!
+! call unused_string(name)
+!
+! value_to_get = default_value
+!
+! end subroutine get_value_integer
+!
+!!--------------------
+!
+! subroutine get_value_double_precision(value_to_get, name, default_value)
+!
+! implicit none
+!
+! double precision value_to_get, default_value
+! character(len=*) name
+!
+! call unused_string(name)
+!
+! value_to_get = default_value
+!
+! end subroutine get_value_double_precision
+!
+!!--------------------
+!
+! subroutine get_value_logical(value_to_get, name, default_value)
+!
+! implicit none
+!
+! logical value_to_get, default_value
+! character(len=*) name
+!
+! call unused_string(name)
+!
+! value_to_get = default_value
+!
+! end subroutine get_value_logical
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,122 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, single precision call
+
+ implicit none
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ xmesh = dble(x)
+ ymesh = dble(y)
+ zmesh = dble(z)
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh))
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = sngl(datan2(ymesh,xmesh))
+
+ r = sngl(dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh))
+
+ else
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ endif
+
+ end subroutine xyz_2_rthetaphi
+
+!-------------------------------------------------------------
+
+ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, double precision call
+
+ implicit none
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ double precision x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ end subroutine xyz_2_rthetaphi_dble
+
+!-------------------------------------------------------------
+
+ subroutine rthetaphi_2_xyz(x,y,z,r,theta,phi)
+
+! convert r theta phi to x y z
+
+ implicit none
+
+ include "../../SHARE_FILES/HEADER_FILES/constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+
+ x = r * sin(theta) * cos(phi)
+ y = r * sin(theta) * sin(phi)
+ z = r * cos(theta)
+
+ end subroutine rthetaphi_2_xyz
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/sem_model_slice.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/sem_model_slice.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/sem_model_slice.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,191 @@
+program sem_model_slice
+implicit none
+
+include 'mpif.h'
+include '../../SHARE_FILES/HEADER_FILES/constants.h'
+include '../../SHARE_FILES/HEADER_FILES/values_from_mesher.h'
+include '../../SHARE_FILES/HEADER_FILES/precision.h'
+
+integer,parameter:: NUM_NODES=99 ! for recent mesher 100 processors
+integer,parameter:: iregion=1 ! for region one
+integer,parameter:: NMAXPTS=10000000
+real(kind=CUSTOM_REAL):: R_CUT_RANGE=0.00785d0 ! dr=0.00785 ~ 50 km depth
+
+integer::iproc,ipt,npts
+character(len=150):: xyz_infile,topo_dir,model_dir,filename,gmt_outfile
+character(len=256):: prname_topo, prname_file
+character(len=256):: topo_file, data_file
+real(kind=CUSTOM_REAL),dimension(NMAXPTS):: x,y,z
+real(kind=CUSTOM_REAL),dimension(NMAXPTS):: xfound,yfound,zfound,vfound
+real(kind=CUSTOM_REAL),dimension(NMAXPTS)::distmin,dist, distall, v, vall
+integer,dimension(NMAXPTS):: ispec_found,ix_found,iy_found,iz_found
+real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE):: xstore, ystore, zstore
+integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE):: ibool
+real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE):: vstore
+integer:: ier,sizeprocs,myrank,ios
+integer:: i,j,k,ispec,iglob
+real(kind=CUSTOM_REAL):: r,theta,phi,lat,lon,dep, xmesh,ymesh,zmesh,rnew
+real(kind=CUSTOM_REAL),dimension(2,NMAXPTS):: in,out
+real(kind=CUSTOM_REAL):: R_CUT, r1
+
+call MPI_INIT(ier)
+call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+! read input file
+call getarg(1,xyz_infile)
+call getarg(2,topo_dir)
+call getarg(3,model_dir)
+call getarg(4,filename)
+call getarg(5,gmt_outfile)
+
+! read interpolate points
+if ( myrank == 0) then
+ write(*,*) "INPUT FILE:", trim(xyz_infile)
+ write(*,*) "TOPOLOGY FILE:", trim(topo_dir)
+ write(*,*) "MODEL DIR:", trim(model_dir)
+ write(*,*) "VALUE NAME:", trim(filename)
+ write(*,*) "OUTPUT:", trim(gmt_outfile)
+end if
+
+
+open(1001,file=trim(xyz_infile),status='old',iostat=ios)
+i=0
+do while (1==1)
+ i=i+1
+ read(1001,*,iostat=ios) xmesh,ymesh,zmesh
+ R_CUT=sqrt(xmesh**2+ymesh**2+zmesh**2)
+ if (ios /= 0) exit
+ x(i)=xmesh
+ y(i)=ymesh
+ z(i)=zmesh
+end do
+close(1001)
+npts=i-1
+
+!end if
+!call MPI_BCAST(npts,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+!call MPI_BCAST(x,NMAXPTS,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+!call MPI_BCAST(y,NMAXPTS,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+!call MPI_BCAST(z,NMAXPTS,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+
+if ( myrank == 0 ) then
+ write(*,*) 'Total number of points = ', npts
+ if (npts>NMAXPTS .or. npts < 0) call exit_MPI(myrank,'Npts error...')
+end if
+
+
+write(prname_topo,'(a,i6.6,a,i1,a)') trim(topo_dir)//'/proc',myrank,'_reg',iregion,'_'
+write(prname_file,'(a,i6.6,a,i1,a)') trim(model_dir)//'/proc',myrank,'_reg',iregion,'_'
+
+! read value file
+data_file = trim(prname_file) // trim(filename) // '.bin'
+open(unit = 27,file = trim(data_file),status='old',action='read', iostat = ios,form ='unformatted')
+if (ios /= 0) call exit_MPI(myrank,'Error reading value file')
+read(27) vstore(:,:,:,1:NSPEC_CRUST_MANTLE)
+close(27)
+
+if (myrank ==0) write(*,*) 'DONE READING',trim(data_file)
+
+! read topology
+topo_file = trim(prname_topo) // 'solver_data_2' // '.bin'
+open(unit = 28,file = trim(topo_file),status='old',action='read', iostat = ios, form='unformatted')
+if (ios /= 0) call exit_MPI(myrank,'Error reading topology file')
+xstore(:) = 0.0
+ystore(:) = 0.0
+zstore(:) = 0.0
+ibool(:,:,:,:) = -1
+read(28) xstore(1:NGLOB_CRUST_MANTLE)
+read(28) ystore(1:NGLOB_CRUST_MANTLE)
+read(28) zstore(1:NGLOB_CRUST_MANTLE)
+read(28) ibool(:,:,:,1:NSPEC_CRUST_MANTLE)
+close(28)
+
+if (myrank == 0) write(*,*) 'DONE READING',trim(topo_file)
+
+distmin(1:npts)=HUGEVAL
+
+do ispec=1,NSPEC_CRUST_MANTLE
+
+ if (myrank == 0) write(*,*) 'ispec=',ispec
+
+ do k = 1,NGLLZ,1
+ do j = 1,NGLLY,1
+ do i = 1,NGLLX,1
+ iglob=ibool(i,j,k,ispec)
+
+
+ r1=sqrt((xstore(iglob))**2+(ystore(iglob))**2+(zstore(iglob))**2)
+
+ if ( r1 > 0.7 ) then
+ dist(1:npts) = dsqrt((x(1:npts)-dble(xstore(iglob)))**2 &
+ +(y(1:npts)-dble(ystore(iglob)))**2 &
+ +(z(1:npts)-dble(zstore(iglob)))**2)
+
+ do ipt=1,npts
+ if (dist(ipt) < distmin(ipt)) then
+ distmin(ipt)=dist(ipt)
+ ispec_found(ipt)=ispec
+ ix_found(ipt)=i
+ iy_found(ipt)=j
+ iz_found(ipt)=k
+ vfound(ipt)=vstore(i,j,k,ispec)
+ end if
+ end do ! ipt loop
+ end if ! radius within in a range
+
+ end do ! i loop
+ end do ! j loop
+ end do ! k loop
+end do ! ispec loop
+
+call MPI_BARRIER(MPI_COMM_WORLD,ier)
+if (myrank == 0) print*,'Done looping over global points'
+
+do i = 1,npts
+ in(1,i)=distmin(i)
+ in(2,i)=myrank
+end do
+call MPI_REDUCE(in,out,npts,CUSTOM_MPI_2REAL,MPI_MINLOC,0,MPI_COMM_WORLD,ier)
+
+call MPI_BCAST(out,2*npts,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+v(1:npts)=0
+dist(1:npts)=0.
+
+do i=1,npts
+ if (myrank == nint(out(2,i))) then
+ v(i)=vfound(i)
+ dist(i)=distmin(i)
+ end if
+end do
+
+call MPI_REDUCE(v,vall,npts,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+call MPI_REDUCE(dist,distall,npts,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+if (myrank == 0) then
+ open(1002, file=gmt_outfile,status='unknown')
+ do i = 1,npts
+ xmesh=x(i); ymesh=y(i); zmesh=z(i)
+ call xyz_2_rthetaphi(xmesh,ymesh,zmesh,r,theta,phi)
+ lat=90.0 - theta*180.0/PI
+ lon=phi*180.0/PI
+ dep=(1.0-r)*R_EARTH_KM
+
+ !strech along radial direction (0.8->0.7)
+ ! rnew=(r-0.1*(1-r)/(1.0-0.8))*6371
+ rnew=r*6371.0
+ !
+
+
+! write(1002,*) lon,lat,dep,vall(i),distall(i)
+ write(1002,*) lon,lat,rnew,vall(i),distall(i)
+! write(1002,*) xmesh,ymesh,zmesh,vall(i),distall(i)
+ end do
+ close(1002)
+end if
+
+202 FORMAT (5(F12.9,2X))
+call MPI_FINALIZE(ier)
+end program sem_model_slice
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,7 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Tue Jan 25 17:19:32 EST 2011
+
+
+mpif90 -O3 -o xsem_model_slice sem_model_slice.f90 rthetaphi_xyz.f90 exit_mpi.f90 get_value_parameters.f90
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/constants.h
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/constants.h (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/constants.h 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,583 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! constants.h. Generated from constants.h.in by configure.
+
+!
+!--- user can modify parameters below
+!
+
+!
+! solver in single or double precision depending on the machine (4 or 8 bytes)
+!
+! ALSO CHANGE FILE precision.h ACCORDINGLY
+!
+ integer, parameter :: SIZE_REAL = 4, SIZE_DOUBLE = 8
+
+! usually the size of integer and logical variables is the same as regular single-precision real variable
+ integer, parameter :: SIZE_INTEGER = SIZE_REAL
+ integer, parameter :: SIZE_LOGICAL = SIZE_REAL
+
+! set to SIZE_REAL to run in single precision
+! set to SIZE_DOUBLE to run in double precision (increases memory size by 2)
+ integer, parameter :: CUSTOM_REAL = SIZE_REAL
+
+! if files on a local path on each node are also seen as global with same path
+! set to .true. typically on a shared-memory machine with a common file system
+! set to .false. typically on a cluster of nodes with local disks
+! if running on a cluster of nodes with local disks, also customize global path
+! to local files in create_serial_name_database.f90 ("20 format ...")
+! Flag is used only when one checks the mesh with the serial codes
+! ("xcheck_buffers_1D" etc.), ignore it if you do not plan to use them
+ logical, parameter :: LOCAL_PATH_IS_ALSO_GLOBAL = .true.
+
+! input, output and main MPI I/O files
+ integer, parameter :: ISTANDARD_OUTPUT = 6
+ integer, parameter :: IIN = 40,IOUT = 41,IOUT_SAC = 903
+ integer, parameter :: IIN_NOISE = 43,IOUT_NOISE = 44
+! local file unit for output of buffers
+ integer, parameter :: IOUT_BUFFERS = 35
+! uncomment this to write messages to a text file
+ integer, parameter :: IMAIN = 42
+! uncomment this to write messages to the screen (slows down the code)
+! integer, parameter :: IMAIN = ISTANDARD_OUTPUT
+! I/O unit for source and receiver vtk file
+ integer, parameter :: IOVTK = 98
+
+
+! R_EARTH is the radius of the bottom of the oceans (radius of Earth in m)
+ double precision, parameter :: R_EARTH = 6371000.d0
+! uncomment line below for PREM with oceans
+! double precision, parameter :: R_EARTH = 6368000.d0
+
+! average density in the full Earth to normalize equation
+ double precision, parameter :: RHOAV = 5514.3d0
+
+! for topography/bathymetry model
+
+!!--- ETOPO5 5-minute model, smoothed Harvard version
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 4320,NY_BATHY = 2160
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 5
+!! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo5_smoothed_Harvard.dat'
+
+!--- ETOPO4 4-minute model created by subsampling and smoothing etopo-2
+! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 5400,NY_BATHY = 2700
+! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 4
+! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo4_smoothed_window_7.dat'
+
+!!--- ETOPO2 2-minute model, not implemented yet
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 10800,NY_BATHY = 5400
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 2
+!! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo2_smoothed_window7.dat'
+
+!!--- ETOPO1 1-minute model, implemented now, but data file must be created first
+!! size of topography and bathymetry file
+ integer, parameter :: NX_BATHY = 21600,NY_BATHY = 10800
+!! resolution of topography file in minutes
+ integer, parameter :: RESOLUTION_TOPO_FILE = 1
+!! pathname of the topography file (un-smoothed)
+ character (len=*), parameter :: PATHNAME_TOPO_FILE = '/scratch/lustre/hejunzhu/DATA/Global_topo/ETOPO1.xyz'
+
+! Use GLL points to capture TOPOGRAPHY and ELLIPTICITY (experimental feature)
+ logical,parameter :: USE_GLL = .false.
+
+! maximum depth of the oceans in trenches and height of topo in mountains
+! to avoid taking into account spurious oscillations in global model ETOPO
+ logical, parameter :: USE_MAXIMUM_HEIGHT_TOPO = .false.
+ integer, parameter :: MAXIMUM_HEIGHT_TOPO = +20000
+ logical, parameter :: USE_MAXIMUM_DEPTH_OCEANS = .false.
+ integer, parameter :: MAXIMUM_DEPTH_OCEANS = -20000
+
+! minimum thickness in meters to include the effect of the oceans and topo
+ double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 100.d0
+
+!-- crustal models
+ integer, parameter :: ICRUST_CRUST2 = 1
+ integer, parameter :: ICRUST_CRUSTMAPS = 2
+!> Hejun Zhu
+ integer, parameter :: ICRUST_EPCRUST=3
+!< Hejun Zhu
+
+
+! increase smoothing for critical regions (increases mesh stability)
+ logical, parameter :: SMOOTH_CRUST = .true.
+
+! use sedimentary layers in crustal model
+ logical, parameter :: INCLUDE_SEDIMENTS_CRUST = .true.
+ double precision, parameter :: MINIMUM_SEDIMENT_THICKNESS = 2.d0 ! minimim thickness in km
+
+!-- uncomment for using Crust2.0 (used when CRUSTAL flag is set for simulation)
+! integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_CRUST2
+!!-- uncomment for using General Crustmaps instead
+!! integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_CRUSTMAPS
+!> Hejun Zhu
+ integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_EPCRUST
+!< Hejun Zhu
+
+
+! number of GLL points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! flag to exclude elements that are too far from target in source detection
+ logical, parameter :: USE_DISTANCE_CRITERION = .true.
+
+! flag to display detailed information about location of stations
+ logical, parameter :: DISPLAY_DETAILS_STATIONS = .false.
+
+! maximum length of station and network name for receivers
+ integer, parameter :: MAX_LENGTH_STATION_NAME = 32
+ integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual. This source decay rate to mimic an equivalent triangle
+! was found by trial and error
+ double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
+
+! maximum number of sources to locate simultaneously
+ integer, parameter :: NSOURCES_SUBSET_MAX = 1000
+
+! distance threshold (in km) above which we consider that a receiver
+! is located outside the mesh and therefore excluded from the station list
+ double precision, parameter :: THRESHOLD_EXCLUDE_STATION = 50.d0
+
+! the first doubling is implemented right below the Moho
+! it seems optimal to implement the three other doublings at these depths
+! in the mantle
+ double precision, parameter :: DEPTH_SECOND_DOUBLING_OPTIMAL = 1650000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_THIRD_DOUBLING_OPTIMAL = 3860000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_FOURTH_DOUBLING_OPTIMAL = 5000000.d0
+
+! Boundary Mesh -- save Moho, 400, 670 km discontinuity topology files (in
+! the mesher) and use them for the computation of boundary kernel (in the solver)
+ logical, parameter :: SAVE_BOUNDARY_MESH = .false.
+
+! this parameter must be set to .true. to compute anisotropic kernels
+! in crust and mantle (related to the 21 Cij in geographical coordinates)
+! default is .false. to compute isotropic kernels (related to alpha and beta)
+ logical, parameter :: ANISOTROPIC_KL = .true.
+
+! output only transverse isotropic kernels (alpha_v,alpha_h,beta_v,beta_h,eta,rho)
+! rather than fully anisotropic kernels in case ANISOTROPIC_KL is set to .true.
+ logical, parameter :: SAVE_TRANSVERSE_KL = .true.
+
+! print date and time estimate of end of run in another country,
+! in addition to local time.
+! For instance: the code runs at Caltech in California but the person
+! running the code is connected remotely from France, which has 9 hours more.
+! The time difference with that remote location can be positive or negative
+ logical, parameter :: ADD_TIME_ESTIMATE_ELSEWHERE = .false.
+ integer, parameter :: HOURS_TIME_DIFFERENCE = +9
+ integer, parameter :: MINUTES_TIME_DIFFERENCE = +0
+
+!
+!--- debugging flags
+!
+
+! flags to actually assemble with MPI or not
+! and to actually match fluid and solid regions of the Earth or not
+! should always be set to true except when debugging code
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_SLICES = .true.
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_CHUNKS = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_CMB = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_ICB = .true.
+
+! flag to turn off the conversion of geographic to geocentric coordinates for
+! the seismic source and the stations; i.e. assume a perfect sphere, which
+! can be useful for benchmarks of a spherical Earth with fictitious sources and stations
+ logical, parameter :: ASSUME_PERFECT_SPHERE = .false.
+
+!------------------------------------------------------
+!----------- do not modify anything below -------------
+!------------------------------------------------------
+
+! on some processors (e.g. Pentiums) it is necessary to suppress underflows
+! by using a small initial field instead of zero
+ logical, parameter :: FIX_UNDERFLOW_PROBLEM = .true.
+
+! some useful constants
+ double precision, parameter :: PI = 3.141592653589793d0
+ double precision, parameter :: TWO_PI = 2.d0 * PI
+ double precision, parameter :: PI_OVER_FOUR = PI / 4.d0
+
+! to convert angles from degrees to radians
+ double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+! dimension of the boundaries of the slices
+ integer, parameter :: NDIM2D = 2
+
+! number of nodes for 2D and 3D shape functions for hexahedra with 27 nodes
+ integer, parameter :: NGNOD = 27, NGNOD2D = 9
+
+! Deville routines optimized for NGLLX = NGLLY = NGLLZ = 5
+ integer, parameter :: m1 = NGLLX, m2 = NGLLX * NGLLY
+
+! gravitational constant
+ double precision, parameter :: GRAV = 6.6723d-11
+
+! a few useful constants
+ double precision, parameter :: ZERO = 0.d0,ONE = 1.d0,TWO = 2.d0,HALF = 0.5d0
+
+ real(kind=CUSTOM_REAL), parameter :: &
+ ONE_THIRD = 1._CUSTOM_REAL/3._CUSTOM_REAL, &
+ TWO_THIRDS = 2._CUSTOM_REAL/3._CUSTOM_REAL, &
+ FOUR_THIRDS = 4._CUSTOM_REAL/3._CUSTOM_REAL
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! very large real value declared independently of the machine
+ real(kind=CUSTOM_REAL), parameter :: HUGEVAL_SNGL = 1.e+30_CUSTOM_REAL
+
+! very large integer value
+ integer, parameter :: HUGEINT = 100000000
+
+! normalized radius of free surface
+ double precision, parameter :: R_UNIT_SPHERE = ONE
+
+! same radius in km
+ double precision, parameter :: R_EARTH_KM = R_EARTH / 1000.d0
+
+! fixed thickness of 3 km for PREM oceans
+ double precision, parameter :: THICKNESS_OCEANS_PREM = 3000.d0 / R_EARTH
+
+! shortest radius at which crust is implemented (80 km depth)
+! to be constistent with the D80 discontinuity, we impose the crust only above it
+ double precision, parameter :: R_DEEPEST_CRUST = (R_EARTH - 80000.d0) / R_EARTH
+
+! maximum number of chunks (full sphere)
+ integer, parameter :: NCHUNKS_MAX = 6
+
+! define block type based upon chunk number (between 1 and 6)
+! do not change this numbering, chunk AB must be number 1 for central cube
+ integer, parameter :: CHUNK_AB = 1
+ integer, parameter :: CHUNK_AC = 2
+ integer, parameter :: CHUNK_BC = 3
+ integer, parameter :: CHUNK_AC_ANTIPODE = 4
+ integer, parameter :: CHUNK_BC_ANTIPODE = 5
+ integer, parameter :: CHUNK_AB_ANTIPODE = 6
+
+! maximum number of regions in the mesh
+ integer, parameter :: MAX_NUM_REGIONS = 3
+
+! define flag for regions of the global Earth mesh
+ integer, parameter :: IREGION_CRUST_MANTLE = 1
+ integer, parameter :: IREGION_OUTER_CORE = 2
+ integer, parameter :: IREGION_INNER_CORE = 3
+
+! define flag for elements
+ integer, parameter :: IFLAG_CRUST = 1
+
+ integer, parameter :: IFLAG_80_MOHO = 2
+ integer, parameter :: IFLAG_220_80 = 3
+ integer, parameter :: IFLAG_670_220 = 4
+ integer, parameter :: IFLAG_MANTLE_NORMAL = 5
+
+ integer, parameter :: IFLAG_OUTER_CORE_NORMAL = 6
+
+ integer, parameter :: IFLAG_INNER_CORE_NORMAL = 7
+ integer, parameter :: IFLAG_MIDDLE_CENTRAL_CUBE = 8
+ integer, parameter :: IFLAG_BOTTOM_CENTRAL_CUBE = 9
+ integer, parameter :: IFLAG_TOP_CENTRAL_CUBE = 10
+ integer, parameter :: IFLAG_IN_FICTITIOUS_CUBE = 11
+
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK_1L = 6
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK_1L = 6
+
+! dummy flag used for mesh display purposes only
+ integer, parameter :: IFLAG_DUMMY = 100
+
+! max number of layers that are used in the radial direction to build the full mesh
+ integer, parameter :: MAX_NUMBER_OF_MESH_LAYERS = 15
+
+! define number of spectral elements and points in basic symmetric mesh doubling superbrick
+ integer, parameter :: NSPEC_DOUBLING_SUPERBRICK = 32
+ integer, parameter :: NGLOB_DOUBLING_SUPERBRICK = 67
+ integer, parameter :: NSPEC_SUPERBRICK_1L = 28
+ integer, parameter :: NGLOB_SUPERBRICK_1L = 58
+ integer, parameter :: NGNOD_EIGHT_CORNERS = 8
+
+! define flag for reference 1D Earth model
+ integer, parameter :: REFERENCE_MODEL_PREM = 1
+ integer, parameter :: REFERENCE_MODEL_IASP91 = 2
+ integer, parameter :: REFERENCE_MODEL_1066A = 3
+ integer, parameter :: REFERENCE_MODEL_AK135 = 4
+ integer, parameter :: REFERENCE_MODEL_1DREF = 5
+ integer, parameter :: REFERENCE_MODEL_JP1D = 6
+ integer, parameter :: REFERENCE_MODEL_SEA1D = 7
+
+! define flag for 3D Earth model
+ integer, parameter :: THREE_D_MODEL_S20RTS = 1
+ integer, parameter :: THREE_D_MODEL_S362ANI = 2
+ integer, parameter :: THREE_D_MODEL_S362WMANI = 3
+ integer, parameter :: THREE_D_MODEL_S362ANI_PREM = 4
+ integer, parameter :: THREE_D_MODEL_S29EA = 5
+ integer, parameter :: THREE_D_MODEL_SEA99_JP3D = 6
+ integer, parameter :: THREE_D_MODEL_SEA99 = 7
+ integer, parameter :: THREE_D_MODEL_JP3D = 8
+ integer, parameter :: THREE_D_MODEL_PPM = 9 ! format for point profile models
+ integer, parameter :: THREE_D_MODEL_GLL = 10 ! format for iterations with GLL mesh
+ integer, parameter :: THREE_D_MODEL_S40RTS = 11
+ integer, parameter :: THREE_D_MODEL_GAPP2 = 12
+
+! define flag for regions of the global Earth for attenuation
+ integer, parameter :: NUM_REGIONS_ATTENUATION = 5
+
+ integer, parameter :: IREGION_ATTENUATION_INNER_CORE = 1
+ integer, parameter :: IREGION_ATTENUATION_CMB_670 = 2
+ integer, parameter :: IREGION_ATTENUATION_670_220 = 3
+ integer, parameter :: IREGION_ATTENUATION_220_80 = 4
+ integer, parameter :: IREGION_ATTENUATION_80_SURFACE = 5
+ integer, parameter :: IREGION_ATTENUATION_UNDEFINED = 6
+
+! number of standard linear solids for attenuation
+ integer, parameter :: N_SLS = 3
+
+! computation of standard linear solids in meshfem3D
+! ATTENUATION_COMP_RESOLUTION: Number of Digits after decimal
+! ATTENUATION_COMP_MAXIMUM: Maximum Q Value
+ integer, parameter :: ATTENUATION_COMP_RESOLUTION = 1
+ integer, parameter :: ATTENUATION_COMP_MAXIMUM = 5000
+
+! for lookup table for attenuation every 100 m in radial direction of Earth model
+ integer, parameter :: NRAD_ATTENUATION = 70000
+ double precision, parameter :: TABLE_ATTENUATION = R_EARTH_KM * 10.0d0
+
+! for determination of the attenuation period range
+! if this is set to .true. then the hardcoded values will be used
+! otherwise they are computed automatically from the Number of elements
+! This *may* be a useful parameter for Benchmarking against older versions
+ logical, parameter :: ATTENUATION_RANGE_PREDEFINED = .false.
+
+! flag for the four edges of each slice and for the bottom edge
+ integer, parameter :: XI_MIN = 1
+ integer, parameter :: XI_MAX = 2
+ integer, parameter :: ETA_MIN = 3
+ integer, parameter :: ETA_MAX = 4
+ integer, parameter :: BOTTOM = 5
+
+! flags to select the right corner in each slice
+ integer, parameter :: ILOWERLOWER = 1
+ integer, parameter :: ILOWERUPPER = 2
+ integer, parameter :: IUPPERLOWER = 3
+ integer, parameter :: IUPPERUPPER = 4
+
+! number of points in each AVS or OpenDX quadrangular cell for movies
+ integer, parameter :: NGNOD2D_AVS_DX = 4
+
+! number of faces a given slice can share with other slices
+! this is at most 2, except when there is only once slice per chunk
+! in which case it is 4
+ integer, parameter :: NUMFACES_SHARED = 2 !!!!! DK DK removed support for one slice only, was 4
+
+! number of corners a given slice can share with other slices
+! this is at most 1, except when there is only once slice per chunk
+! in which case it is 4
+ integer, parameter :: NUMCORNERS_SHARED = 1 !!!!!! DK DK removed support for one slice only, was 4
+
+! number of slaves per corner
+ integer, parameter :: NUMSLAVES = 2
+
+! number of layers in PREM
+ integer, parameter :: NR = 640
+
+! smallest real number on many machines = 1.1754944E-38
+! largest real number on many machines = 3.4028235E+38
+! small negligible initial value to avoid very slow underflow trapping
+! but not too small to avoid trapping on velocity and acceleration in Newmark
+ real(kind=CUSTOM_REAL), parameter :: VERYSMALLVAL = 1.E-24_CUSTOM_REAL
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=CUSTOM_REAL), parameter :: STABILITY_THRESHOLD = 1.E+25_CUSTOM_REAL
+
+! geometrical tolerance for boundary detection
+ double precision, parameter :: SMALLVAL = 0.00001d0
+
+! small tolerance for conversion from x y z to r theta phi
+ double precision, parameter :: SMALL_VAL_ANGLE = 1.d-10
+
+! geometry tolerance parameter to calculate number of independent grid points
+! sensitive to actual size of model, assumes reference sphere of radius 1
+! this is an absolute value for normalized coordinates in the Earth
+ double precision, parameter :: SMALLVALTOL = 1.d-10
+
+! do not use tags for MPI messages, use dummy tag instead
+ integer, parameter :: itag = 0,itag2 = 0
+
+! for the Gauss-Lobatto-Legendre points and weights
+ double precision, parameter :: GAUSSALPHA = 0.d0,GAUSSBETA = 0.d0
+
+! number of lines per source in CMTSOLUTION file
+ integer, parameter :: NLINES_PER_CMTSOLUTION_SOURCE = 13
+
+! number of iterations to solve the non linear system for xi and eta
+ integer, parameter :: NUM_ITER = 4
+
+! number of hours per day for rotation rate of the Earth
+ double precision, parameter :: HOURS_PER_DAY = 24.d0
+
+! for lookup table for gravity every 100 m in radial direction of Earth model
+ integer, parameter :: NRAD_GRAVITY = 70000
+
+!!!!!!!!!!!!!! parameters added for the thread-safe version of the code
+! number of layers in DATA/1066a/1066a.dat
+ integer, parameter :: NR_1066A = 160
+
+! number of layers in DATA/ak135/ak135.dat
+ integer, parameter :: NR_AK135 = 136
+
+! number of layers in DATA/s362ani/REF
+ integer, parameter :: NR_REF = 750
+
+! number of layers in DATA/Lebedev_sea99 1D model
+ integer, parameter :: NR_SEA1D = 163
+
+! three_d_mantle_model_constants
+ integer, parameter :: NK_20 = 20,NS_20 = 20,NS_40 = 40, ND = 1
+
+! heterogen_mantle_model_constants
+ integer, parameter :: N_R = 256,N_THETA = 256,N_PHI = 256
+
+! Japan 3D model (Zhao, 1994) constants
+ integer, parameter :: MPA=42,MRA=48,MHA=21,MPB=42,MRB=48,MHB=18
+ integer, parameter :: MKA=2101,MKB=2101
+
+!QRFSI12 constants
+ integer,parameter :: NKQ=8,MAXL_Q=12
+ integer,parameter :: NSQ=(MAXL_Q+1)**2,NDEPTHS_REFQ=913
+
+! The meaningful range of Zhao et al.'s model (1994) is as follows:
+! latitude : 32 - 45 N
+! longitude: 130-145 E
+! depth : 0 - 500 km
+! The deepest Moho beneath Japan is 40 km
+ double precision,parameter :: LAT_MAX = 45.d0
+ double precision,parameter :: LAT_MIN = 32.d0
+ double precision,parameter :: LON_MAX = 145.d0
+ double precision,parameter :: LON_MIN = 130.d0
+ double precision,parameter :: DEP_MAX = 500.d0
+
+! crustal_model_constants
+! crustal model parameters for crust2.0
+ integer, parameter :: NKEYS_CRUST = 359
+ integer, parameter :: NLAYERS_CRUST = 8
+ integer, parameter :: NCAP_CRUST = 180
+
+! General Crustmaps parameters
+ integer, parameter :: CRUSTMAP_RESOLUTION = 4 !means 1/4 degrees
+ integer, parameter :: NLAYERS_CRUSTMAP = 5
+
+!> Hejun Zhu, parameters for EPCRUST , from Molinari et al's model(2010)
+! latitude : 9.0N - 89.5N
+! longitude: 56.0W - 70.0E
+ character(len=*), parameter:: PATHNAME_EPCRUST='DATA/EPCRUST_EXTEND/EPcrust_0_5.txt'
+ integer, parameter :: EPCRUST_NLON=253, EPCRUST_NLAT=162, EPCRUST_NLAYER=3
+ double precision, parameter:: EPCRUST_LON_MIN=-56.0d0
+ double precision, parameter:: EPCRUST_LON_MAX=70.0d0
+ double precision, parameter:: EPCRUST_LAT_MIN=9.0d0
+ double precision, parameter:: EPCRUST_LAT_MAX=89.5d0
+ double precision, parameter:: EPCRUST_SAMPLE=0.5d0
+ logical, parameter:: flag_smooth_epcrust=.true.
+ integer, parameter:: NTHETA_EP=4, NPHI_EP=20
+ double precision, parameter:: cap_degree_EP=0.2d0
+!< Hejun Zhu
+
+
+!!!!!!!!!!!!!! end of parameters added for the thread-safe version of the code
+
+! for the stretching of crustal elements in the case of 3D models
+! (values are chosen for 3D models to have RMOHO_FICTICIOUS at 35 km
+! and RMIDDLE_CRUST to become 15 km with stretching function stretch_tab)
+ double precision, parameter :: MAX_RATIO_CRUST_STRETCHING = 0.75d0
+! double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = 5000.d0 ! moho up to 35km
+ double precision, parameter :: R80_STRETCH_ADJUSTEMENT = -40000.d0 ! r80 down to 120km
+
+! adapted regional moho stretching
+! 1 chunk simulations, 3-layer crust
+ logical, parameter :: REGIONAL_MOHO_MESH = .true.
+ logical, parameter :: REGIONAL_MOHO_MESH_EUROPE = .true. ! used only for fixing time step
+ logical, parameter :: REGIONAL_MOHO_MESH_ASIA = .false. ! used only for fixing time step
+ logical, parameter :: HONOR_DEEP_MOHO = .false.
+! uncomment for e.g. Europe case, where deep moho is rare
+ double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = -15000.d0 ! moho mesh boundary down to 55km
+! uncomment for deep moho cases, e.g. Asia case (Himalayan moho)
+!! double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = -20000.d0 ! moho mesh boundary down to 60km
+
+
+! to suppress the crustal layers
+! (replaced by an extension of the mantle: R_EARTH is not modified, but no more crustal doubling)
+ logical, parameter :: SUPPRESS_CRUSTAL_MESH = .false.
+
+! to inflate the central cube (set to 0.d0 for a non-inflated cube)
+ double precision, parameter :: CENTRAL_CUBE_INFLATE_FACTOR = 0.41d0
+
+! to add a fourth doubling at the bottom of the outer core
+ logical, parameter :: ADD_4TH_DOUBLING = .false.
+
+! parameters to cut the doubling brick
+
+! this to cut the superbrick: 3 possibilities, 4 cases max / possibility
+! three possibilities: (cut in xi and eta) or (cut in xi) or (cut in eta)
+! case 1: (ximin and etamin) or ximin or etamin
+! case 2: (ximin and etamax) or ximax or etamax
+! case 3: ximax and etamin
+! case 4: ximax and etamax
+ integer, parameter :: NB_CUT_CASE = 4
+
+! corner 1: ximin and etamin
+! corner 2: ximax and etamin
+! corner 3: ximax and etamax
+! corner 4: ximin and etamax
+ integer, parameter :: NB_SQUARE_CORNERS = 4
+
+! two possibilities: xi or eta
+! face 1: ximin or etamin
+! face 2: ximax or etamax
+ integer, parameter :: NB_SQUARE_EDGES_ONEDIR = 2
+
+! this for the geometry of the basic doubling brick
+ integer, parameter :: NSPEC_DOUBLING_BASICBRICK = 8
+ integer, parameter :: NGLOB_DOUBLING_BASICBRICK = 27
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/precision.h
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/precision.h (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/precision.h 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,39 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! precision.h. Generated from precision.h.in by configure.
+
+!
+! solver in single or double precision depending on the machine
+!
+! set to MPI_REAL to run in single precision
+! set to MPI_DOUBLE_PRECISION to run in double precision
+!
+! ALSO CHANGE FILE constants.h ACCORDINGLY
+!
+ integer, parameter :: CUSTOM_MPI_TYPE = MPI_REAL
+ integer, parameter :: CUSTOM_MPI_2REAL = MPI_2REAL
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/values_from_mesher.h
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/values_from_mesher.h (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SHARE_FILES/HEADER_FILES/values_from_mesher.h 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,189 @@
+
+ !
+ ! this is the parameter file for static compilation of the solver
+ !
+ ! mesh statistics:
+ ! ---------------
+ !
+ !
+ ! number of chunks = 1
+ !
+ ! these statistics do not include the central cube
+ !
+ ! number of processors = 100
+ !
+ ! maximum number of points per region = 475797
+ !
+ ! on NEC SX, make sure "loopcnt=" parameter
+ ! in Makefile is greater than max vector length = 1427391
+ !
+ ! total elements per slice = 7821
+ ! total points per slice = 528135
+ !
+ ! total for full 6-chunk mesh:
+ ! ---------------------------
+ !
+ ! exact total number of spectral elements in entire mesh =
+ ! 4692600.00000000
+ ! approximate total number of points in entire mesh =
+ ! 316881000.000000
+ ! approximate total number of degrees of freedom in entire mesh =
+ ! 892096200.000000
+ !
+ ! position of the mesh chunk at the surface:
+ ! -----------------------------------------
+ !
+ ! angular size in first direction in degrees = 68.00000
+ ! angular size in second direction in degrees = 68.00000
+ !
+ ! longitude of center in degrees = 7.000000
+ ! latitude of center in degrees = 52.00000
+ !
+ ! angle of rotation of the first chunk = 45.00000
+ !
+ ! corner 1
+ ! longitude in degrees = 6.99999999999999
+ ! latitude in degrees = 8.40726023480213
+ !
+ ! corner 2
+ ! longitude in degrees = 64.1611658328499
+ ! latitude in degrees = 34.9449365466497
+ !
+ ! corner 3
+ ! longitude in degrees = -50.1611658328499
+ ! latitude in degrees = 34.9449365466497
+ !
+ ! corner 4
+ ! longitude in degrees = -173.000000000000
+ ! latitude in degrees = 84.3892903527184
+ !
+ ! resolution of the mesh at the surface:
+ ! -------------------------------------
+ !
+ ! spectral elements along a great circle = 960
+ ! GLL points along a great circle = 3840
+ ! average distance between points in degrees = 9.3750000E-02
+ ! average distance between points in km = 10.42452
+ ! average size of a spectral element in km = 41.69810
+ !
+ ! number of time steps = 10600
+ !
+ ! number of seismic sources = 1
+ !
+
+ ! approximate static memory needed by the solver:
+ ! ----------------------------------------------
+ !
+ ! size of static arrays per slice = 0.260327711701393 GB
+ !
+ ! (should be below and typically equal to 80% or 90%
+ ! of the memory installed per core)
+ ! (if significantly more, the job will not run by lack of memory)
+ ! (if significantly less, you waste a significant amount of memory)
+ !
+ ! size of static arrays for all slices = 26.0327711701393 GB
+ ! = 2.542262809583917E-002 TB
+ !
+
+ integer, parameter :: NEX_XI_VAL = 240
+ integer, parameter :: NEX_ETA_VAL = 240
+
+ integer, parameter :: NSPEC_CRUST_MANTLE = 7092
+ integer, parameter :: NSPEC_OUTER_CORE = 684
+ integer, parameter :: NSPEC_INNER_CORE = 45
+
+ integer, parameter :: NGLOB_CRUST_MANTLE = 475797
+ integer, parameter :: NGLOB_OUTER_CORE = 48789
+ integer, parameter :: NGLOB_INNER_CORE = 3549
+
+ integer, parameter :: NSPECMAX_ANISO_IC = 1
+
+ integer, parameter :: NSPECMAX_ISO_MANTLE = 7092
+ integer, parameter :: NSPECMAX_TISO_MANTLE = 7092
+ integer, parameter :: NSPECMAX_ANISO_MANTLE = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_ATTENUAT = 7092
+ integer, parameter :: NSPEC_INNER_CORE_ATTENUATION = 45
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STR_OR_ATT = 7092
+ integer, parameter :: NSPEC_INNER_CORE_STR_OR_ATT = 45
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STR_AND_ATT = 7092
+ integer, parameter :: NSPEC_INNER_CORE_STR_AND_ATT = 45
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STRAIN_ONLY = 7092
+ integer, parameter :: NSPEC_INNER_CORE_STRAIN_ONLY = 45
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_ADJOINT = 7092
+ integer, parameter :: NSPEC_OUTER_CORE_ADJOINT = 684
+ integer, parameter :: NSPEC_INNER_CORE_ADJOINT = 45
+ integer, parameter :: NGLOB_CRUST_MANTLE_ADJOINT = 475797
+ integer, parameter :: NGLOB_OUTER_CORE_ADJOINT = 48789
+ integer, parameter :: NGLOB_INNER_CORE_ADJOINT = 3549
+ integer, parameter :: NSPEC_OUTER_CORE_ROT_ADJOINT = 684
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STACEY = 7092
+ integer, parameter :: NSPEC_OUTER_CORE_STACEY = 684
+
+ integer, parameter :: NGLOB_CRUST_MANTLE_OCEANS = 475797
+
+ logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .true.
+
+ logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.
+
+ logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.
+
+ logical, parameter :: ATTENUATION_VAL = .true.
+
+ logical, parameter :: ATTENUATION_3D_VAL = .false.
+
+ logical, parameter :: ELLIPTICITY_VAL = .true.
+
+ logical, parameter :: GRAVITY_VAL = .true.
+
+ logical, parameter :: OCEANS_VAL = .true.
+
+ logical, parameter :: ROTATION_VAL = .true.
+ integer, parameter :: NSPEC_OUTER_CORE_ROTATION = 684
+
+ integer, parameter :: NGLOB1D_RADIAL_CM = 189
+ integer, parameter :: NGLOB1D_RADIAL_OC = 133
+ integer, parameter :: NGLOB1D_RADIAL_IC = 21
+ integer, parameter :: NGLOB2DMAX_XMIN_XMAX_CM = 10274
+ integer, parameter :: NGLOB2DMAX_XMIN_XMAX_OC = 2862
+ integer, parameter :: NGLOB2DMAX_XMIN_XMAX_IC = 314
+ integer, parameter :: NGLOB2DMAX_YMIN_YMAX_CM = 10274
+ integer, parameter :: NGLOB2DMAX_YMIN_YMAX_OC = 2862
+ integer, parameter :: NGLOB2DMAX_YMIN_YMAX_IC = 314
+ integer, parameter :: NPROC_XI_VAL = 10
+ integer, parameter :: NPROC_ETA_VAL = 10
+ integer, parameter :: NCHUNKS_VAL = 1
+ integer, parameter :: NPROCTOT_VAL = 100
+ integer, parameter :: NGLOB2DMAX_XY_VAL = 10274
+ integer, parameter :: NUMMSGS_FACES_VAL = 10
+ integer, parameter :: NCORNERSCHUNKS_VAL = 1
+ integer, parameter :: ATT1 = 5
+ integer, parameter :: ATT2 = 5
+ integer, parameter :: ATT3 = 5
+ integer, parameter :: ATT4 = 7092
+ integer, parameter :: ATT5 = 45
+ integer, parameter :: NSPEC2DMAX_XMIN_XMAX_CM = 522
+ integer, parameter :: NSPEC2DMAX_YMIN_YMAX_CM = 522
+ integer, parameter :: NSPEC2D_BOTTOM_CM = 36
+ integer, parameter :: NSPEC2D_TOP_CM = 576
+ integer, parameter :: NSPEC2DMAX_XMIN_XMAX_IC = 15
+ integer, parameter :: NSPEC2DMAX_YMIN_YMAX_IC = 15
+ integer, parameter :: NSPEC2D_BOTTOM_IC = 9
+ integer, parameter :: NSPEC2D_TOP_IC = 9
+ integer, parameter :: NSPEC2DMAX_XMIN_XMAX_OC = 141
+ integer, parameter :: NSPEC2DMAX_YMIN_YMAX_OC = 144
+ integer, parameter :: NSPEC2D_BOTTOM_OC = 9
+ integer, parameter :: NSPEC2D_TOP_OC = 36
+ integer, parameter :: NSPEC2D_MOHO = 1
+ integer, parameter :: NSPEC2D_400 = 1
+ integer, parameter :: NSPEC2D_670 = 1
+ integer, parameter :: NSPEC2D_CMB = 1
+ integer, parameter :: NSPEC2D_ICB = 1
+ logical, parameter :: USE_DEVILLE_PRODUCTS_VAL = .true.
+ logical, parameter :: USE_ATTENUATION_MIMIC = .true.
+ logical, parameter :: COMPUTE_AND_STORE_STRAIN = .true.
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XPBS_correction.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XPBS_correction.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XPBS_correction.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,15 @@
+#!/bin/sh
+#PBS -q tromp
+#PBS -N XXCORRECT_201105192015A
+#PBS -l nodes=1:ppn=1
+#PBS -l walltime=15:00:00
+#PBS -j oe
+#PBS -k oe
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+
+input=XCORRECT_INPUT_M42/CORRECT_201105192015A
+
+./xcorrect_syn_time_moment < $input
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XPBS_correction.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XSHELL_correction.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XSHELL_correction.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XSHELL_correction.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,105 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: #!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Sun Jun 3 17:19:13 EDT 2012
+
+eventfile=../../SHARE_FILES/EVENTID_CENTER/XEVENTID
+iter1=M42
+iter2=M43
+
+ext1=T015_040
+ext2=T030_100
+
+
+dirold=../SYN_$iter1
+dirnew=../SYN_$iter2
+dirinput=XCORRECT_INPUT_$iter1
+
+# check directories
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+if [ ! -d $dirold ]; then
+ echo WRONG! NO $dirold
+ exit
+fi
+if [ ! -d $dirinput ]; then
+ echo MKDIR $dirinput
+ mkdir $dirinput
+fi
+if [ ! -d $dirnew ]; then
+ echo MKDIR $dirnew
+ mkdir $dirnew
+fi
+
+while read line
+do
+ echo running correction for $line...
+ cmtid=`echo $line | awk -F"_" '{print $NF}'`
+ minmax=../SRC_GRIDSEARCH_INITIALTIME_MOMENT/XGRIDSEARCH_OUTPUT_$iter1/XMINMAX_$cmtid
+ input=$dirinput/CORRECT_$cmtid
+ synold=$dirold/CMTSOLUTION_$cmtid
+ synnew=$dirnew/CMTSOLUTION_$cmtid
+
+ tag="#PBS -N XXCORRECT_$cmtid"
+ input_tag="$dirinput\/CORRECT_$cmtid"
+
+ # check directories
+ if [ ! -f $minmax ]; then
+ echo WRONG! NO $minmax
+ exit
+ fi
+ if [ -f $input ]; then
+ echo $input exist, rm it
+ rm $input
+ fi
+ if [ ! -d $synold ]; then
+ echo WRONG! NO $synold
+ exit
+ fi
+ if [ ! -d $synnew ]; then
+ echo NO $synnew, make it
+ mkdir $synnew
+ fi
+ if [ -f xtmp ]; then
+ echo xtmp exist, rm it
+ rm xtmp
+ fi
+
+ dt0=`cat $minmax | awk '{print $1}'`
+ dm0=`cat $minmax | awk '{print $2}'`
+
+ ls $synold/*.$ext1 > xtmp
+ ls $synold/*.$ext2 >> xtmp
+
+ nfile=`wc -l xtmp | awk '{print $1}'`
+
+ echo "$dt0 $dm0 " > $input
+ echo $nfile >> $input
+ while read line
+ do
+ name=`echo $line | awk -F"/" '{print $NF}'`
+ name_new=$synnew/$name
+ echo $line >> $input
+ echo $name_new >> $input
+ done < xtmp
+
+ rm xtmp
+
+
+ sed -e "s/^#PBS -N.*$/$tag/g" \
+ -e "s/^input=.*$/input=$input_tag/g" \
+ XPBS_correction.sh > XPBS_correction.sh.out
+ mv XPBS_correction.sh.out XPBS_correction.sh
+
+ echo RUNNING CORRECTION FOR EVENTID $cmtid
+ qsub XPBS_correction.sh
+ sleep 3
+
+
+done < $eventfile
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/XSHELL_correction.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/correct_syn_time_moment.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/correct_syn_time_moment.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/correct_syn_time_moment.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,80 @@
+program xcorrect_syn
+
+implicit none
+
+integer,parameter:: NDIM=80000
+real:: dt0,dm0
+integer:: nfile,i,j
+character(len=250):: oldsyn_fnm,newsyn_fnm
+real,dimension(NDIM):: oldsyn,newsyn,syn_t
+integer:: npt,nerr,nerr1
+real:: b,dt,b_new
+real:: evla,evlo,stla,stlo,evdp
+character*8:: kstnm,knetwk,kcmpnm
+integer::ishift
+
+write(*,*) 'read input file'
+read(*,*) dt0, dm0
+read(*,*) nfile
+
+write(*,*) 'correct initial time:',dt0
+write(*,*) 'correct scale moment:',dm0
+write(*,*) 'total number of files:',nfile
+
+do i = 1,nfile
+
+ oldsyn=0.0
+ newsyn=0.0
+ syn_t=0.0
+
+ read(*,'(a)') oldsyn_fnm
+ read(*,'(a)') newsyn_fnm
+
+ write(*,*) 'old syn:',oldsyn_fnm
+ write(*,*) 'new syn:',newsyn_fnm
+
+ call rsac1(oldsyn_fnm,oldsyn,npt,b,dt,NDIM,nerr)
+ if (nerr.ne.0) stop 'error reading sac file'
+
+ call getfhv('evla',evla,nerr)
+ call getfhv('evlo',evlo,nerr)
+ call getfhv('stla',stla,nerr)
+ call getfhv('stlo',stlo,nerr)
+ call getfhv('evdp',evdp,nerr)
+ call getkhv('kstnm',kstnm,nerr)
+ call getkhv('kcmpnm',kcmpnm,nerr)
+ call getkhv('knetwk',knetwk,nerr)
+
+
+ ! shift and apply scale moment correction for seismograms
+ ishift=nint(abs(dt0)/dt)
+ if (dt0 > 0.0 ) then
+ newsyn(1+ishift:npt+ishift)=dm0*oldsyn(1:npt)
+ else
+ newsyn(1:npt)=dm0*oldsyn(1+ishift:npt+ishift)
+ end if
+
+ do j =1,npt
+ syn_t(j)=b+(j-1)*dt
+ end do
+! call newhdr()
+ call setfhv('b',b,nerr1)
+ call setfhv('delta',dt,nerr1)
+ call setnhv('npts',npt,nerr1)
+ call setfhv('evla',evla,nerr1)
+ call setfhv('evlo',evlo,nerr1)
+ call setfhv('stla',stla,nerr1)
+ call setfhv('stlo',stlo,nerr1)
+ call setfhv('evdp',evdp,nerr1)
+ call setkhv('kstnm',trim(kstnm),nerr1)
+ call setkhv('kcmpnm',trim(kcmpnm),nerr1)
+ call setkhv('knetwk',trim(knetwk),nerr1)
+
+ ! write new seismograms
+ call wsac0(newsyn_fnm,syn_t(1:npt),newsyn(1:npt),nerr1)
+ if (nerr1.ne.0) stop 'Error reading sac file'
+
+end do
+write(*,*) "SUCESSIVEFULLY"
+
+end program xcorrect_syn
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,13 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Mon Jan 24 20:34:14 EST 2011
+
+if [ -f xcorrect_syn_time_moment ]; then
+ echo RM xcorrect_syn_time_moment
+ rm xcorrect_syn_time_moment
+fi
+
+
+gfortran -o xcorrect_syn_time_moment -O3 correct_syn_time_moment.f90 -L/home/hejunzhu/BIN/sac-101.4/lib -lsacio
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_CORRECT_INITIALTIME_MOMENT/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XPBS_gridsearch.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XPBS_gridsearch.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XPBS_gridsearch.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,15 @@
+#!/bin/sh
+#PBS -q tromp
+#PBS -N XOUTPUT_GRID_201105192015A
+#PBS -l nodes=1:ppn=1
+#PBS -l walltime=30:00:00
+#PBS -j oe
+#PBS -k oe
+
+echo $PBS_O_WORKDIR
+cd $PBS_O_WORKDIR
+
+
+input=XGRIDSEARCH_INPUT_M42/PAR_201105192015A
+
+./xgridsearch_time_moment < $input
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XPBS_gridsearch.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XSHELL_gridsearch.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XSHELL_gridsearch.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XSHELL_gridsearch.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,110 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Mon Jun 4 16:25:38 EDT 2012
+
+
+# input parameters
+iter1=M42
+iter2=M43
+
+mstart=0.2
+mend=1.8
+dm=0.01
+
+tstart=-5
+tend=5
+dt=0.1
+
+fact_am=0.857
+fact_tt=0.143
+linesearch_mbest=0.02
+
+body_bandpass=T015_040
+surf_bandpass=T040_100
+
+criteria=phase_amplitude
+
+eventfile=../../SHARE_FILES/EVENTID_CENTER/XEVENTID
+dir1=../../SHARE_FILES/CMTSOLUTION_CENTER_$iter1
+dir2=../../SHARE_FILES/CMTSOLUTION_CENTER_$iter2
+
+# check directories and files
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+
+if [ ! -d $dir1 ]; then
+ echo wrong! no $dir1
+ exit
+fi
+
+if [ ! -d $dir2 ]; then
+ echo mkdir $dir2
+ mkdir $dir2
+fi
+
+if [ ! -d XGRIDSEARCH_OUTPUT_$iter1 ];then
+ echo MKDIR XGRIDSEARCH_OUTPUT_$iter1
+ mkdir XGRIDSEARCH_OUTPUT_$iter1
+fi
+
+while read line
+do
+
+ cmtid=`echo $line | awk -F"_" '{print $NF}'`
+ grd_tag="#PBS -N XOUTPUT_GRID_$cmtid"
+ parinput=XGRIDSEARCH_INPUT_$iter1/PAR_$cmtid
+ parinput_tag="XGRIDSEARCH_INPUT_"$iter1"\/PAR_"$cmtid
+
+
+ cmtorig="../../SHARE_FILES/CMTSOLUTION_CENTER_$iter1/CMTSOLUTION_$cmtid"
+ cmtnew="../../SHARE_FILES/CMTSOLUTION_CENTER_$iter2/CMTSOLUTION_$cmtid"
+ gridinput="XGRIDSEARCH_INPUT_$iter1/GRIDSEARCH_"$cmtid
+ gridoutput1="XGRIDSEARCH_OUTPUT_$iter1/XMINMAX_$cmtid"
+ gridoutput2="XGRIDSEARCH_OUTPUT_$iter1/XMISFITFUNCTION_$cmtid"
+
+
+ if [ -f $parinput ] ;then
+ echo $parinput exist, delete it
+ rm $parinput
+ fi
+
+ if [ ! -f $cmtorig ]; then
+ echo WRONG! NO $cmtorig
+ exit
+ fi
+
+ if [ ! -f $gridinput ]; then
+ echo WRONG! NO $gridinput
+ exit
+ fi
+
+ echo GERENATING... $parinput
+ echo $cmtorig > $parinput
+ echo $cmtnew >> $parinput
+ echo $gridinput >> $parinput
+ echo $gridoutput1 >> $parinput
+ echo $gridoutput2 >> $parinput
+ echo "$mstart $mend $dm" >> $parinput
+ echo "$tstart $tend $dt" >> $parinput
+ echo "$fact_am" >> $parinput
+ echo "$fact_tt" >> $parinput
+ echo "$linesearch_mbest" >> $parinput
+ echo "$body_bandpass" >> $parinput
+ echo "$surf_bandpass" >> $parinput
+ echo "$criteria" >> $parinput
+
+
+ sed -e "s/^#PBS -N.*$/$grd_tag/g" \
+ -e "s/^input=.*$/input=$parinput_tag/g" \
+ XPBS_gridsearch.sh > XPBS_gridsearch.sh.out
+ mv XPBS_gridsearch.sh.out XPBS_gridsearch.sh
+
+
+ echo RUNNING GRIDSEARCH FOR EVENT $cmtid
+ qsub XPBS_gridsearch.sh
+ sleep 3
+
+done < $eventfile
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/XSHELL_gridsearch.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,406 @@
+program xgrid_search_time_moment
+
+ implicit none
+
+ integer,parameter:: NDIM=80000
+
+ character(len=256) :: cmt_file, new_cmt_file
+ character(len=256) :: output_minmax, output_misfit
+ character(len=256) :: flexwin_out_file
+ character(len=256) :: data_file, syn_file
+ character(len=150) :: string,bandpass,cmp
+ character(len=150) :: body_bandpass,surf_bandpass,criteria
+ real ,dimension(:),allocatable :: misfit,t0,m0
+ real,dimension(NDIM):: data,syn,syn_m0
+ real,dimension(NDIM):: data_win,syn_win
+ real :: tshift, dlnA, cc_max
+ real::s_m0,e_m0,d_m0,s_t0,e_t0,d_t0,t00,m00,m0_best,t0_best,maxmisfit,t_cmt,t_cmt_new
+ integer:: i,j,k,n_m0,n_t0,n_total,i_total,cc_shift
+ real:: misfit_tmp,b,b2,dt,dt2,tstart,tend,tstart0,tend0,weight
+ integer:: nf,nwin,nerr,ios,lstr,npts,npts2
+ integer:: is,ie,ishift,isd,ied,iss,iee,imina(1),imin
+ integer:: bd_z,bd_r,bd_t,sw_z,sw_r,sw_t
+ real:: deltaT,deltaA,fact_am,fact_tt,deltaT0
+ real:: linesearch_mbest
+ integer:: istart,iend
+
+ !----------------------------------------------------------------
+ !- read in input parameters
+ !----------------------------------------------------------------
+ read(*,'(a)') cmt_file ! read in old cmt file
+ read(*,'(a)') new_cmt_file ! read in new cmt file
+ read(*,'(a)') flexwin_out_file ! read in measurement window selected from flexwin
+ read(*,'(a)') output_minmax ! output selected original time and scale moment
+ read(*,'(a)') output_misfit ! output 2D misfit function for delta_t0 and delta_M0
+ read(*,*) s_m0,e_m0,d_m0 ! starting, end and spacing for scale moment searching
+ read(*,*) s_t0,e_t0,d_t0 ! starting, end and spacing for original time searching
+ read(*,*) fact_am ! weighting for amplitude misfit function
+ read(*,*) fact_tt ! weighting for original time misfit function
+ read(*,*) linesearch_mbest ! perturbation for scale moment pick
+ read(*,'(a)') body_bandpass ! extension for body wave bandpass, e.g.,T015_040
+ read(*,'(a)') surf_bandpass ! extension for surface wave bandpass, e.g.,T040_100
+ read(*,'(a)') criteria ! misfit function, waveform, phase_amplitude
+
+ !---------------------------------------------------------
+ !- setup searching space
+ !---------------------------------------------------------
+ n_m0=nint((e_m0-s_m0)/d_m0)+1
+ n_t0=nint((e_t0-s_t0)/d_t0)+1
+ n_total=n_m0*n_t0
+
+ allocate(misfit(n_total))
+ allocate(t0(n_total))
+ allocate(m0(n_total))
+ misfit=0.0
+ t0=0.0
+ m0=0.0
+
+ i_total=0
+ do i=1,n_m0
+ do j=1,n_t0
+ i_total=i_total+1
+ t0(i_total)=s_t0+d_t0*(j-1)
+ m0(i_total)=s_m0+d_m0*(i-1)
+ end do
+ end do
+
+ if ( i_total /= n_total ) stop 'i_total not equal n_total, check input paramters'
+ write(*,*) i_total,n_total
+
+
+ !------------------------------------------------------------
+ !- read in measurement window from flexwin and calculate misfit function
+ !------------------------------------------------------------
+ open(1001,file=trim(flexwin_out_file),status='old')
+ read(1001,*) nf,bd_z,bd_r,bd_t,sw_z,sw_r,sw_t
+ do j=1,nf
+ write(*,*) j,nf
+ read(1001,'(a)') data_file
+ read(1001,'(a)') syn_file
+
+ call rsac1(data_file,data,npts,b,dt,NDIM,nerr)
+ if (nerr.ne.0) stop 'error reading data'
+
+ call rsac1(syn_file,syn,npts2,b2,dt2,NDIM,nerr)
+ if (nerr.ne.0) stop 'error reading synthetics'
+
+ lstr=len_trim(syn_file)
+ bandpass=syn_file(lstr-7:lstr)
+ cmp=syn_file(lstr-19:lstr-17)
+
+ ! decide weight factors
+ if ( trim(bandpass) .eq. trim(body_bandpass) .and. trim(cmp) .eq. 'LHZ' ) then
+ if ( bd_z .ne. 0 ) then
+ weight=1.0/bd_z
+ else
+ weight=1.0
+ end if
+ else if ( trim(bandpass) .eq. trim(body_bandpass) .and. trim(cmp) .eq. 'LHR' ) then
+ if ( bd_r .ne. 0 ) then
+ weight=1.0/bd_r
+ else
+ weight=1.0
+ end if
+ else if ( trim(bandpass) .eq. trim(body_bandpass) .and. trim(cmp) .eq. 'LHT' ) then
+ if ( bd_t .ne. 0 ) then
+ weight=1.0/bd_t
+ else
+ weight=1.0
+ end if
+ else if ( trim(bandpass) .eq. trim(surf_bandpass) .and. trim(cmp) .eq. 'LHZ' ) then
+ if ( sw_z .ne. 0 ) then
+ weight=1.0/sw_z
+ else
+ weight=1.0
+ end if
+ else if ( trim(bandpass) .eq. trim(surf_bandpass) .and. trim(cmp) .eq. 'LHR' ) then
+ if ( sw_r .ne. 0 ) then
+ weight=1.0/sw_r
+ else
+ weight=1.0
+ end if
+ else if ( trim(bandpass) .eq. trim(surf_bandpass) .and. trim(cmp) .eq. 'LHT' ) then
+ if ( sw_t .ne. 0) then
+ weight=1.0/sw_t
+ else
+ weight=1.0
+ end if
+ else
+ stop 'wrong bandpass and component, check input parameters'
+ end if
+
+
+ read(1001,*) nwin
+ do k=1,nwin
+ read(1001,*) tstart,tend
+ is=max(floor((tstart-b)/dt),1)
+ ie=min(ceiling((tend-b)/dt),npts)
+
+ data_win(:)=0.0
+ syn_win(:)=0.0
+ data_win(is:ie)=data(is:ie)
+ syn_win(is:ie)=syn(is:ie)
+ call xcorr_calc(data_win,syn_win,npts,is,ie,cc_shift,cc_max)
+ deltaT0=cc_shift*dt
+
+
+ do i=1,n_total
+
+ t00=t0(i)
+ m00=m0(i)
+ ishift=nint(t00/dt)
+
+ isd=is
+ ied=ie
+
+ iss=isd-ishift
+ iee=ied-ishift
+
+
+ if ( trim(criteria) .eq. 'waveform' ) then
+ ! full waveform misfit function
+ misfit_tmp=weight*sum((m00*syn(iss:iee)-data(isd:ied))**2)/sum(sqrt(syn(iss:iee)**2)*sqrt(data(isd:ied)**2))
+ else if (trim(criteria) .eq. 'phase_amplitude' ) then
+ ! phase and amplitude misfit function
+ deltaT=deltaT0-t00
+ syn_m0=syn*m00
+ deltaA=0.5*log(sum(data(isd:ied)*data(isd:ied))/sum(syn_m0(iss:iee)*syn_m0(iss:iee)))
+
+ misfit_tmp=weight*(fact_tt*(deltaT**2)+fact_am*(deltaA**2))
+ else
+ stop 'wrong criteria for misfit function, check input parameters'
+ end if
+
+ ! total misfit function
+ misfit(i)=misfit(i)+misfit_tmp
+
+ end do
+ end do
+ end do
+ close(1001)
+
+
+ !------------------------------------------------------------
+ !- select minimum misfit function and write out new cmt file
+ !------------------------------------------------------------
+ imina=minloc(misfit(1:n_total))
+ imin=imina(1)
+ m0_best=m0(imin)
+ t0_best=t0(imin)
+
+ maxmisfit=maxval(misfit(1:n_total))
+
+ open(1004,file=trim(cmt_file),status='old',iostat=ios)
+ if (ios/=0) stop 'Error openning CMT file'
+ do while (ios == 0)
+ read(1004,'(a)',iostat=ios) string
+ lstr=len_trim(string)
+ if (string(1:10) == 'time shift') then
+ read(string(12:lstr),*) t_cmt
+ end if
+ end do
+ close(1004)
+
+ t_cmt_new=t_cmt+t0_best
+
+ ! several criteria to negelect selected parameters
+ ! 1. if number of window smaller than 10
+ ! 2. if new original time is smaller than 0.0
+ ! 3. for scale moment, only use perturbation linesearch_mbest since its large covariance
+ if (nf < 10 ) then
+ t0_best=0.0
+ m0_best=1.0
+ end if
+
+ if ( t_cmt_new < 0.0 ) then
+ t0_best=0.0
+ m0_best=1.0
+ end if
+ m0_best=1.0+(m0_best-1.0)*linesearch_mbest
+
+
+
+ write(*,*) 'DONE'
+ write(*,*) 'FIND BEST T0:',t0_best
+ write(*,*) 'FIND BEST M0:',m0_best
+ write(*,*) 'MIN MISFIT:',misfit(imin)
+
+
+
+ open(1002,file=trim(output_minmax),status='unknown')
+ write(1002,*) t0_best,m0_best,misfit(imin)
+ close(1002)
+ open(1003,file=trim(output_misfit),status='unknown')
+ do i = 1,n_total
+ write(1003,*) t0(i),m0(i),misfit(i)/maxmisfit
+ end do
+ close(1003)
+
+ call write_new_cmtsolution(cmt_file,trim(new_cmt_file),t0_best,m0_best)
+
+ write(*,*) 'SUCESSIVEFULLY'
+
+ deallocate(misfit)
+ deallocate(t0)
+ deallocate(m0)
+
+end program xgrid_search_time_moment
+
+
+subroutine xcorr_calc(d,s,npts,i1,i2,ishift,cc_max)
+
+ ! inputs:
+ ! s(npts) = synthetic
+ ! d(npts) = data (or observed)
+ ! i1, i2 = start and stop indexes of window within s and d
+
+ real, dimension(*), intent(in) :: s,d
+ integer, intent(in) :: npts, i1, i2
+
+ ! outputs:
+ ! ishift = index lag (d-s) for max cross correlation
+ ! cc_max = maximum of cross correlation (normalised by sqrt(synthetic*data))
+ integer, intent(out) :: ishift
+ real, intent(out) :: cc_max
+
+ ! local variables
+ integer :: nlen
+ integer :: i_left, i_right, i, j, id_left, id_right
+ real :: cc, norm, norm_s, fout
+
+ ! initialise shift and cross correlation to zero
+ ishift = 0
+ cc_max = 0.0
+
+ if (i1.lt.1 .or. i1.gt.i2 .or. i2.gt.npts) then
+ write(*,*) 'Error with window limits: i1, i2, npts ', i1, i2, npts
+ return
+ endif
+
+ ! length of window (number of points, including ends)
+ nlen = i2 - i1 + 1
+
+ ! power of synthetic signal in window
+ norm_s = sqrt(sum(s(i1:i2)*s(i1:i2)))
+
+ ! left and right limits of index (time) shift search
+ ! NOTE: This looks OUTSIDE the time window of interest to compute TSHIFT and CC.
+ ! If fout=0.5, then it looks outside by a time of 0.5*(window width).
+ ! Perhaps fout should be a parameter, or it should be tied to the max
+ ! allowable time-shift specified by the user.
+ ! However, it does not matter as much if the data and synthetics are
+ ! zeroed outside the windows, as currently done in calc_criteria.
+ fout = 0.5
+ i_left = -1*int(fout*nlen)
+ i_right = int(fout*nlen)
+
+
+ ! i is the index to shift to be applied to DATA (d)
+ do i = i_left, i_right
+
+ ! normalization factor varies as you take different windows of d
+ id_left = max(1,i1+i) ! left index for data window
+ id_right = min(npts,i2+i) ! right index for data window
+ norm = norm_s * sqrt(sum(d(id_left:id_right)*(d(id_left:id_right))))
+
+ ! cc as a function of i
+ cc = 0.
+ do j = i1, i2 ! loop over full window length
+ if((j+i).ge.1 .and. (j+i).le.npts) cc = cc + s(j)*d(j+i) ! d is shifted by i
+ enddo
+ cc = cc/norm
+
+ ! keeping cc-max only
+ if (cc .gt. cc_max) then
+ cc_max = cc
+ ishift = i
+ endif
+ enddo
+
+ ! EXAMPLE: consider the following indexing:
+ ! Two records are from 1 to 100, window is i1=20 to i2=41.
+ ! --> nlen = 22, i_left = -11, i_right = 11
+ ! i i1+i i2+i id_left id_right
+ ! -11 9 30 9 30
+ ! -5 15 36 15 36
+ ! 0 20 41 20 41 <== ORIGINAL WINDOW
+ ! 5 25 46 25 46
+ ! 10 31 52 31 52
+
+end subroutine xcorr_calc
+
+
+subroutine write_new_cmtsolution(cmt_file,new_cmt_file,t0_best,m0_best)
+
+ character(len=*),intent(in):: cmt_file,new_cmt_file
+ real,intent(in):: t0_best,m0_best
+ integer,parameter:: IOCMT=1009
+
+ character(len=150):: pde_time,event_name,str_tshift,str_hdur,str_lat,str_lon,str_dep
+ real:: t_cmt, t_cmt_new
+ real,dimension(6):: moment_tensor,moment_tensor_new
+ integer:: ios,lstr
+ character(len=150) :: string
+
+ ! read basic information
+ open(IOCMT,file=trim(cmt_file),status='old')
+ read(IOCMT,'(a)') pde_time
+ read(IOCMT,'(a)') event_name
+ read(IOCMT,'(a)') str_tshift
+ read(IOCMT,'(a)') str_hdur
+ read(IOCMT,'(a)') str_lat
+ read(IOCMT,'(a)') str_lon
+ read(IOCMT,'(a)') str_dep
+ close(IOCMT)
+
+ ! read tshift and moment tensor
+ open(IOCMT,file=trim(cmt_file),status='old',iostat=ios)
+ if (ios /= 0) stop 'Error opening CMT file'
+ do while (ios==0)
+ read(IOCMT,'(a)',iostat=ios) string
+ lstr=len_trim(string)
+
+ if (string(1:10) == 'time shift') then
+ read(string(12:lstr),*) t_cmt
+ else if (string(1:3) == 'Mrr') then
+ read(string(5:lstr),*) moment_tensor(1)
+ else if (string(1:3) == 'Mtt') then
+ read(string(5:lstr),*) moment_tensor(2)
+ else if (string(1:3) == 'Mpp') then
+ read(string(5:lstr),*) moment_tensor(3)
+ else if (string(1:3) == 'Mrt') then
+ read(string(5:lstr),*) moment_tensor(4)
+ else if (string(1:3) == 'Mrp') then
+ read(string(5:lstr),*) moment_tensor(5)
+ else if (string(1:3) == 'Mtp') then
+ read(string(5:lstr),*) moment_tensor(6)
+ end if
+ end do
+ close(IOCMT)
+
+ ! calculate new t0 and Mij
+ !t_cmt_new=t_cmt
+ t_cmt_new=t_cmt+t0_best
+ moment_tensor_new(:)=moment_tensor(:)*m0_best
+
+ ! write out new CMTSOLUTION
+ open(IOCMT,file=trim(new_cmt_file),status='unknown')
+ write(IOCMT,'(a)') trim(pde_time)
+ write(IOCMT,'(a)') trim(event_name)
+ write(IOCMT,'(a,f12.4)') 'time shift:',t_cmt_new
+ write(IOCMT,'(a)') trim(str_hdur)
+ write(IOCMT,'(a)') trim(str_lat)
+ write(IOCMT,'(a)') trim(str_lon)
+ write(IOCMT,'(a)') trim(str_dep)
+
+ write(IOCMT,'(a,g19.6)') 'Mrr:',moment_tensor_new(1)
+ write(IOCMT,'(a,g19.6)') 'Mtt:',moment_tensor_new(2)
+ write(IOCMT,'(a,g19.6)') 'Mpp:',moment_tensor_new(3)
+ write(IOCMT,'(a,g19.6)') 'Mrt:',moment_tensor_new(4)
+ write(IOCMT,'(a,g19.6)') 'Mrp:',moment_tensor_new(5)
+ write(IOCMT,'(a,g19.6)') 'Mtp:',moment_tensor_new(6)
+ close(IOCMT)
+
+end subroutine write_new_cmtsolution
+
+
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcombine_gridsearch.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcombine_gridsearch.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcombine_gridsearch.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,69 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Thu Sep 6 07:09:24 EDT 2012
+
+
+iter=M42
+
+ext1=T015_040
+ext2=T030_100
+
+eventfile=../EVENTID_CENTER/XEVENTID
+
+meadir=XMEASUREMENT_INPUT_$iter
+grddir=XGRIDSEARCH_INPUT_$iter
+
+if [ ! -d $meadir ]; then
+ echo WRONG! NO $meadir
+ exit
+fi
+if [ ! -d $grddir ]; then
+ echo MKDIR $grddir
+ mkdir $grddir
+fi
+if [ ! -f $eventfile ]; then
+ echo WRONG! NO $eventfile
+ exit
+fi
+
+while read line
+do
+ echo $line
+ cmtid=`echo $line | awk -F"_" '{print $NF}'`
+ m1=$meadir/MEASUREMENT_$cmtid'_'$ext1
+ m2=$meadir/MEASUREMENT_$cmtid'_'$ext2
+ ofile=$grddir/GRIDSEARCH_$cmtid
+ if [ ! -f $m1 ]; then
+ echo WRONG! NO $m1
+ exit
+ fi
+ if [ ! -f $m2 ]; then
+ echo WRONG! NO $m2
+ exit
+ fi
+ if [ -f $ofile ]; then
+ echo DELETE $ofile
+ rm $ofile
+ fi
+
+ n1=`sed -n '5p' $m1`
+ n2=`sed -n '5p' $m2`
+
+ bd_z=`sed -n '1p' $m1 | awk '{print $2}'`
+ bd_r=`sed -n '1p' $m1 | awk '{print $3}'`
+ bd_t=`sed -n '1p' $m1 | awk '{print $4}'`
+ sw_z=`sed -n '1p' $m2 | awk '{print $2}'`
+ sw_r=`sed -n '1p' $m2 | awk '{print $3}'`
+ sw_t=`sed -n '1p' $m2 | awk '{print $4}'`
+
+ ntotal=`echo $n1 + $n2 | bc -l`
+
+ echo $ntotal $bd_z $bd_r $bd_t $sw_z $sw_r $sw_t > $ofile
+ awk 'FNR>5' $m1 >> $ofile
+ awk 'FNR>5' $m2 >> $ofile
+
+
+done < $eventfile
+
+
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcombine_gridsearch.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcompile.sh
===================================================================
--- seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcompile.sh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcompile.sh 2012-11-05 20:28:17 UTC (rev 20989)
@@ -0,0 +1,13 @@
+#!/bin/sh
+# Author: Hejun Zhu, hejunzhu at princeton.edu
+# Princeton University, New Jersey, USA
+# Last modified: Wed Sep 12 11:17:06 EDT 2012
+
+
+if [ -f xgridsearch_time_moment ]; then
+ echo RM xgridsearch_time_moment
+ rm xgridsearch_time_moment
+fi
+
+gfortran -o xgridsearch_time_moment -O3 gridsearch_time_moment.f90 -L/home/hejunzhu/BIN/sac-101.4/lib -lsacio
+#gfortran -o xgridsearch_time_moment -O3 gridsearch_time_moment.f90 -L${SACHOME}/lib -lsacio
Property changes on: seismo/3D/ADJOINT_TOMO/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/xcompile.sh
___________________________________________________________________
Name: svn:executable
+ *
More information about the CIG-COMMITS
mailing list